nya

kekkonen.scm

@@ -328,94 +328,95 @@
 	      result
 	      (loop (cdr ln)))))))
 
-(define (lisp body environments exit)
-  
-  (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)))
-			       (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))))
-  
-  (lisp-eval body))
-
-(define lisp-builtins
-  `((test . ,(lambda function-args
-	       (show "test function called")))
-    (if . ,(lambda function-args
-	     (match function-args
-		  ((e x y) (if e
-			       x
-			       y))
-		  (_ (exit "malformed if expression")))))
-    (quote . ,(lambda function-args
-		(match function-args
-		  ((v) v)
-		  (_ (exit "malformed quote expression")))))
-    (cons . ,(lambda function-args
-	       (match function-args
-		 ((a b) (cons a b))
-		 (_ (exit "malformed cons expression")))))
-    (car . ,(lambda function-args
-	      (match function-args
-		((a) (if (atom? a)
-			 (exit "tried to take car of atom")
-			 (car a)))
-		(_ (exit "malformed car expression")))))
-    (cdr . ,(lambda function-args
-	      (match 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? a))
-		 (_ (exit "malformed atom expression")))))
-    (eq . ,(lambda function-args
-	     (match function-args
-	       ((a b) (equal? a b))
-	       (_ (exit "malformed eval expression")))))
-    (set . ,(lambda function-args
-	      (match function-args
-		((a b) (if (symbol? a)
-			   (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)
-	     (cons #t (lisp body (list lisp-builtins) (compose exit (curry cons #f)))))))
+
+  (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 (cadr function))
+		   (function-body (cddr function)))
+	       (lisp function-body (cons (if (= (length function-arguments) (length argument-values))
+					      (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) (let ((ln (map lisp-eval body)))
+			    (lisp-apply (car ln) (cdr ln))))
+	    (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
+		   (show "test function called")))
+	(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 a b))
+		     (_ (lisp-exit "malformed cons expression")))))
+	(car . ,(lambda function-args
+		  (match function-args
+		    ((a) (if (atom? a)
+			     (lisp-exit "tried to take car of atom")
+			     (car a)))
+		    (_ (lisp-exit "malformed car expression")))))
+	(cdr . ,(lambda function-args
+		  (match function-args
+		    ((a) (if (atom? a)
+			     (lisp-exit "tried to take cdr of atom")
+			     (cdr a)))
+		    (_ (lisp-exit "malformed cdr expression")))))
+	(atom . ,(lambda function-args
+		   (match function-args
+		     ((a) (atom? a))
+		     (_ (lisp-exit "malformed atom expression")))))
+	(eq . ,(lambda function-args
+		 (match function-args
+		   ((a b) (equal? a b))
+		   (_ (lisp-exit "malformed eq expression")))))
+	(set . ,(lambda function-args
+		  (match function-args
+		    ((a 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))
+			    (cons args (cons exp exps))
+			    (lisp-exit "malformed lambda expression"))
+			(_ (lisp-exit "malformed lambda expression"))))))))
+    
+    (lisp-eval body))
+
+  (call/cc (lambda (lisp-exit)
+	     (cons #t (lisp body (list) (compose lisp-exit (curry cons #f)))))))
 
 (define (print-room-description room)
   (newline)