refactor into modules

kekkonen.scm

@@ -11,6 +11,8 @@
 (import (chicken file))
 (import breadline)
 (import ncurses)
+(import util)
+(import lisp)
 
 (define (lift fn parser)
   (bind parser (compose result fn)))
@@ -19,18 +21,6 @@
   (satisfies (lambda (y)
 	       (not (eqv? x y)))))
 
-(define (curry fn a)
-  (lambda (b)
-    (fn a b)))
-
-(define (applied fn)
-  (curry apply fn))
-
-(define-syntax thunk
-  (syntax-rules ()
-    ((_ exp ...)
-     (lambda () exp ...))))
-
 (define parse-whitespace
   (one-or-more (is #\space)))
 
@@ -319,111 +309,6 @@
 	(cons (get-container source) (get-contents (get-container source)))
 	(error "Tried to determine visible objects for object without a container."))))
 
-(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
-		   (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 (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 (eval a))
-				(eb (eval b)))
-			    (equal? ea eb)))
-		   (_ (lisp-exit "malformed eq expression")))))
-	(set . ,(lambda function-args
-		  (match function-args
-		    ((a b) (let ((ea (eval a))
-				 (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))
-			    (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)
   (display (set-text '(bold) (get-name room)))

lisp.scm

@@ -0,0 +1,111 @@
+(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)))
+	  (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 (eval a))
+				  (eb (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 body))
+
+    (call/cc (lambda (lisp-exit)
+	       (cons #t (lisp body (list (list)) (compose lisp-exit (curry cons #f))))))))

util.scm

@@ -0,0 +1,14 @@
+(module util (curry applied thunk)
+  (import scheme)
+
+  (define (curry fn a)
+  (lambda (b)
+    (fn a b)))
+
+  (define (applied fn)
+    (curry apply fn))
+  
+  (define-syntax thunk
+    (syntax-rules ()
+      ((_ exp ...)
+       (lambda () exp ...)))))