grass interpreter in CL

Grass.lisp

(defpackage :grass 
  (:use :common-lisp
	:split-sequence
	:babel
	:ppcre
	:babel-streams)
  (:export :grass-eval
	   :str-to-grass))

(in-package grass)

(defmacro with-grass-char (code env &body body)
  (let ((type (gensym "type"))
	(_ (gensym "_")))
    `(destructuring-bind ( (((,type ,_ ,code) . ,_) ,_) . ,_) ,env
       (declare (ignore ,_))
       (if (and (eq ,type 'prim) (integerp ,code))	   
	   (progn ,@body)
	   (error "Wrong application of grass-char")))))

(defun grass-char (code)
  `(((prim ,(lambda (env)
		  (with-grass-char code env
		    (if (= code code)
			'( ((:abs 1 ((2 1)))) ((nil nil)) ) ;church-true
			'( ((:abs 1 nil))     nil ))))      ;church-false
	 ,code)) nil))

(defvar *output* nil)

(defconstant +env0+ `((((:prim ,(lambda (env)
				      (with-grass-char code env
					(progn (write-byte code *output*) (first env)))) "out")) nil)
		     (((:prim ,(lambda (env)
				      (with-grass-char code env
					(grass-char (mod (1+ code) 256)))) "succ")) nil)
		     ,(grass-char 119)
		     (((:prim ,(lambda (env) 
				      (let ((c (read-char t nil nil)))
					(if c
					    (grass-char (char-code c))
					    (first env)))) "in")) nil)))

(defconstant +cstack0+ '((((:app 0 0)) nil) (nil nil)))

(defun grass-eval (code &key (encoding :cp932))
  (princ
   (with-output-to-sequence (*output* :return-as 'string :external-format encoding)
     (grass-eval* (str-to-grass code) +env0+ +cstack0+)))
  nil)

(defun grass-eval* (code &optional (env +env0+) (cstack +cstack0+))
  (multiple-value-bind (c e d) (grass-> code env cstack)
    (if (and (null c) (null d))
	'done
	(grass-eval* c e d))))
	
(defun grass-> (code env cstack)
  (if code
      (destructuring-bind ((type x y) . rest) code
	(ecase type
	  (:app (values (first #1=(nth x env)) 
		       (cons (nth y env) (second #1#))
		       (cons (list rest env) cstack)))
	  (:abs (values rest
		       (cons (if (= 1 x)
				 `( ,y                 ,env)
				 `( ((:abs ,(1- x) ,y)) ,env))
			     env)
		       cstack))
	  (:prim (values rest
			(cons (funcall x env) env)
			cstack))))
      (destructuring-bind ((code* env*) . cstack*) cstack
	(values code*
		(cons (first env) env*)
		cstack*))))

; reader-section
(defun str-to-grass (str)
  (mapcan #'str-to-grass*
	  (split-sequence #\v (map 'string #'normalize-grass-char (remove-if-not (lambda (x) (member x '(#\w #\W #\v #\ｗ #\Ｗ #\ｖ))) str)))))
 	     
(defun str-to-grass* (str)
  (if (zerop (length str))
      nil
      (ecase (char str 0)
	(#\w (register-groups-bind (n apps) ("(w+)(.*)" str)
	       (list (list :abs (length n) (str-to-grass* apps)))))
	(#\W (register-groups-bind (m n rest) ("(W+)(w+)(.*)" str)
	       (cons (list :app (1- (length m)) (1- (length n))) (str-to-grass* rest)))))))

(defun normalize-grass-char (ch)
  (ecase ch
    (#\ｗ #\w)
    (#\Ｗ #\W)
    (#\ｖ #\v)
    ((#\w #\W #\v) ch)))