fully working meta-circular evaluator

kekkonen.scm

@@ -10,6 +10,7 @@
 (import ansi-escape-sequences)
 (import (chicken file))
 (import breadline)
+(import ncurses)
 
 (define (lift fn parser)
   (bind parser (compose result fn)))
@@ -258,7 +259,7 @@
 
 (define (set-hidden object value)
   (database-set object 'hidden value))
-
+ 
 (define (get-hidden object)
   (database-get object 'hidden #f))
 
@@ -328,15 +329,27 @@
 	      (loop (cdr ln)))))))
 
 (define (lisp body environments exit)
-  (define (lisp-eval body)
-    (cond ((atom? body) body)
-	  ((symbol? body) (reference body))
-	  ((list? body) (let ((ln (map lisp-eval body)))
-			  (apply (car ln) (cdr ln))))
-	  (else (exit "Unknown value type in evaluation."))))
   
   (define (reference symbol)
     (cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string symbol))))))
+				 
+  (define (lisp-apply function args)
+    (cond ((procedure? function)
+	   (apply function args))
+	  ((list? function)
+	   (let ((function-arguments (cadr function))
+		 (function-body (cddr function)))
+	     (lisp function-body (cons (if (= (length function-arguments) (length argument-values))
+					   (map cons function-arguments args)
+					   (exit "Wrong number of arguments to function")) environments) exit)))
+	  (else (exit "attempt to call atom"))))
+  
+  (define (lisp-eval body)
+    (cond ((symbol? body) (reference body))
+	  ((atom? body) body)
+	  ((list? body) (let ((ln (map lisp-eval body)))
+			  (lisp-apply (car ln) (cdr ln))))
+	  (else (exit "Unknown value type in evaluation."))))
   
   (define (bind name value)
     (set! environments (cons (let loop ((environment (car environments)))
@@ -344,66 +357,61 @@
 				   (list (cons name value))
 				   (if (eq? name (caar environment))
 				       (cons (cons name value) (cdr environment))
-				       (loop (cdr environment)))))
+				       (cons (car environment) (loop (cdr environment))))))
 			     (cdr environments))))
-				 
-  (define (lisp-apply function args)
-    (cond ((function? function)
-	   (apply function args))
-	  ((list? function)
-	   (let ((function-arguments (car function))
-		 (function-body (cddr function)))
-	     (lisp function-body (cons (if (= (length function-argumentsq) (length argument-values))
-					   (map cons function-arguments args)
-					   (exit "Wrong number of arguments to function")) environments) exit)))
-	  (_ (exit "attempt to call atom")))))
+  
+  (lisp-eval body))
 
 (define lisp-builtins
-  `((test . ,(lambda (function-args)
+  `((test . ,(lambda function-args
 	       (show "test function called")))
-    (if . ,(lambda (function-args)
+    (if . ,(lambda function-args
 	     (match function-args
-		  ((e x y) (if (lisp-eval e)
-			       (lisp-eval x)
-			       (lisp-eval y)))
+		  ((e x y) (if e
+			       x
+			       y))
 		  (_ (exit "malformed if expression")))))
-    (quote . ,(lambda (function-args)
+    (quote . ,(lambda function-args
 		(match function-args
 		  ((v) v)
 		  (_ (exit "malformed quote expression")))))
-    (cons . ,(lambda (function-args)
+    (cons . ,(lambda function-args
 	       (match function-args
-		 ((a b) (cons (eval a) (eval b)))
+		 ((a b) (cons a b))
 		 (_ (exit "malformed cons expression")))))
-    (car . ,(lambda (function-args)
+    (car . ,(lambda function-args
 	      (match function-args
-		((a) (let ((ae (eval a)))
-		       (if (atom? ae)
-			   (exit "tried to take car of atom")
-			   (car (eval a)))))
+		((a) (if (atom? a)
+			 (exit "tried to take car of atom")
+			 (car a)))
 		(_ (exit "malformed car expression")))))
-    (cdr . ,(lambda (function-args)
+    (cdr . ,(lambda function-args
 	      (match function-args
-		((a) (cdr (eval a))))))
-    (atom . ,(lambda (function-args)
+		((a) (if (atom? a)
+			 (exit "tried to take cdr of atom")
+			 (cdr a)))
+		(_ (exit "malformed cdr expression")))))
+    (atom . ,(lambda function-args
 	       (match function-args
-		 ((a) (atom? (eval a)))
+		 ((a) (atom? a))
 		 (_ (exit "malformed atom expression")))))
-    (eq . ,(lambda (function-args)
+    (eq . ,(lambda function-args
 	     (match function-args
-	       ((a b) (equal? (eval a) (eval b)))
+	       ((a b) (equal? a b))
 	       (_ (exit "malformed eval expression")))))
-    (set . ,(lambda (function-args)
+    (set . ,(lambda function-args
 	      (match function-args
 		((a b) (if (symbol? a)
-			   (bind a b))))))
-    (lambda . ,(lambda (function-args)
-		 match function-args
-		 ((args exp . exps)
-		  (if (and (list? args) (every symbol? args))
-		      (cons args (cons exp exps))
-		      (exit "malformed lambda expression"))
-		  (_ (exit "malformed lambda expression")))))))
+			   (bind a b)
+			   (exit "tried to bind to non-symbol")))
+		(_ (exit "malformed set expression")))))
+    (lambda . ,(lambda function-args
+		 (match function-args
+		   ((args exp . exps)
+		    (if (and (list? args) (every symbol? args))
+			(cons args (cons exp exps))
+			(exit "malformed lambda expression"))
+		    (_ (exit "malformed lambda expression"))))))))
 
 (define (run-lisp body)
   (call/cc (lambda (exit)