kekkonen/lisp.scm

(module lisp (run-lisp)
  (import scheme)
  (import chicken.base)
  (import matchable)
  (import srfi-1)
  (import util)

  (define (any-or fn ln thunk)
    (let loop ((ln ln))
      (if (null? ln)
	  (thunk)
	  (let ((result (fn (car ln))))
	    (if result
		result
		(loop (cdr ln)))))))

  (define (run-lisp body)

    (define (lisp body environments lisp-exit)
      
      (define (reference symbol)
	(cdr (any-or (curry assoc symbol) (cons lisp-builtins environments) (thunk (lisp-exit (string-append "Undefined reference: " (symbol->string symbol)))))))
      
      (define (lisp-apply function args)
	(cond ((procedure? function)
	       (apply function args))
	      ((list? function)
	       (let ((function-arguments (car function))
		     (function-body (cdr function)))
		 (lisp function-body (cons (if (= (length function-arguments) (length args))
					       (map cons function-arguments args)
					       (lisp-exit "Wrong number of arguments to function")) environments) lisp-exit)))
	      (else (lisp-exit "attempt to call atom"))))
      
      (define (lisp-eval body)
	(cond ((symbol? body) (reference body))
	      ((atom? body) body)
	      ((list? body) (lisp-apply (lisp-eval (car body)) (cdr body)))
	      (else (lisp-exit "Unknown value type in evaluation."))))
      
      (define (bind name value)
	(set! environments (cons (let loop ((environment (car environments)))
				   (if (null? environment)
				       (list (cons name value))
				       (if (eq? name (caar environment))
					   (cons (cons name value) (cdr environment))
					   (cons (car environment) (loop (cdr environment))))))
				 (cdr environments))))
      
      (define lisp-builtins
	`((test . ,(lambda function-args
		     (display "test function called")
		     (newline)))
	  (begin . ,(lambda function-args
		      (mapn lisp-eval function-args)))
	  (if . ,(lambda function-args
		   (match function-args
		     ((e x y) (if (lisp-eval e)
				  (lisp-eval x)
				  (lisp-eval y)))
		     (_ (lisp-exit "malformed if expression")))))
	  (quote . ,(lambda function-args
		      (match function-args
			((v) v)
			(_ (lisp-exit "malformed quote expression")))))
	  (cons . ,(lambda function-args
		     (match function-args
		       ((a b) (cons (lisp-eval a) (lisp-eval b)))
		       (_ (lisp-exit "malformed cons expression")))))
	  (car . ,(lambda function-args
		    (match function-args
		      ((a) (let ((e (lisp-eval a)))
			     (if (atom? e)
				 (lisp-exit "tried to take car of atom")
				 (car e))))
		      (_ (lisp-exit "malformed car expression")))))
	  (cdr . ,(lambda function-args
		    (match function-args
		      ((a) (let ((e (lisp-eval a)))
			     (if (atom? e)
				 (lisp-exit "tried to take cdr of atom")
				 (cdr e))))
		      (_ (lisp-exit "malformed cdr expression")))))
	  (atom . ,(lambda function-args
		     (match function-args
		       ((a) (let ((e (lisp-eval a)))
			      (atom? e)))
		       (_ (lisp-exit "malformed atom expression")))))
	  (eq . ,(lambda function-args
		   (match function-args
		     ((a b) (let ((ea (lisp-eval a))
				  (eb (lisp-eval b)))
			      (equal? ea eb)))
		     (_ (lisp-exit "malformed eq expression")))))
	  (set . ,(lambda function-args
		    (match function-args
		      ((a b) (let ((eb (eval b)))
			       (if (symbol? a)
				   (bind a b)
				   (lisp-exit "tried to bind to non-symbol"))))
		      (_ (lisp-exit "malformed set expression")))))
	  (lambda . ,(lambda function-args
		       (match function-args
			 ((args exp . exps)
			  (if (and (list? args) (every symbol? args))
			      (append (list args exp) exps)
			      (lisp-exit "malformed lambda expression")))
			 (_ (lisp-exit "malformed lambda expression")))))))
      
      (lisp-eval (cons 'begin body)))

    (call/cc (lambda (lisp-exit)
	       (cons #t (lisp body (list (list)) (compose lisp-exit (curry cons #f))))))))