shithub: femtolisp

Download patch

ref: 642d1e1bd4dadfade218128bcf3eb6980fe7d501
parent: 2c304edf4228b21e8b12ea737c14a8aa4791b997
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Fri Jul 17 22:16:18 EDT 2009

rewriting some primitives to take advantage of the full language; they
  do not need to be written in terms of the base language any more
moving handling of internal define and multiple-body-lambda to the
  compiler where it belongs. macroexpand now only handles syntax.


--- a/femtolisp/aliases.scm
+++ b/femtolisp/aliases.scm
@@ -1,6 +1,8 @@
 ; definitions of standard scheme procedures in terms of
 ; femtolisp procedures
 
+(define top-level-bound? bound?)
+
 (define vector-ref aref)
 (define vector-set! aset!)
 (define vector-length length)
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -418,6 +418,12 @@
 		  (else      (emit g b))))
 	      (emit g (if tail? :tcall :call) nargs)))))))
 
+(define (expand-define form body)
+  (if (symbol? form)
+      `(set! ,form ,(car body))
+      `(set! ,(car form)
+	     (lambda ,(cdr form) ,@body . ,(car form)))))
+
 (define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
 
 (define (compile-in g env tail? x)
@@ -449,6 +455,8 @@
 		     (emit g :ret))
 	   (set!     (compile-in g env #f (caddr x))
 		     (compile-sym g env (cadr x) [:seta :setc :setg]))
+	   (define   (compile-in g env tail?
+				 (expand-define (cadr x) (cddr x))))
 	   (trycatch (compile-in g env #f `(lambda () ,(cadr x)))
 		     (unless (1arg-lambda? (caddr x))
 			     (error "trycatch: second form must be a 1-argument lambda"))
@@ -461,24 +469,66 @@
 	   (apply compile-f- env f let?)
 	   ff))
 
-(define (compile-f- env f . let?)
-  (let ((g    (make-code-emitter))
-	(args (cadr f)))
-    (cond ((not (null? let?))      (emit g :let))
-	  ((length> args MAX_ARGS) (emit g (if (null? (lastcdr args))
-					       :largc :lvargc)
-					 (length args)))
-	  ((null? (lastcdr args))  (emit g :argc  (length args)))
-	  (else  (emit g :vargc (if (atom? args) 0 (length args)))))
-    (compile-in g (cons (to-proper args) env) #t (caddr f))
-    (emit g :ret)
-    (values (function (encode-byte-code (bcode:code g))
-		      (const-to-idx-vec g) (lastcdr f))
-	    (aref g 3))))
+(define get-defined-vars
+  (letrec ((get-defined-vars-
+	    (lambda (expr)
+	      (cond ((atom? expr) ())
+		    ((and (eq? (car expr) 'define)
+			  (pair? (cdr expr)))
+		     (or (and (symbol? (cadr expr))
+			      (list (cadr expr)))
+			 (and (pair? (cadr expr))
+			      (symbol? (caadr expr))
+			      (list (caadr expr)))
+			 ()))
+		    ((eq? (car expr) 'begin)
+		     (apply append (map get-defined-vars- (cdr expr))))
+		    (else ())))))
+    (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
 
-(define (compile f) (compile-f () f))
+(define compile-f-
+  (let ((*defines-processed-token* (gensym)))
+    ; to eval a top-level expression we need to avoid internal define
+    (set-top-level-value!
+     'compile-thunk
+     (lambda (expr)
+       (compile `(lambda () ,expr . ,*defines-processed-token*))))
 
-(define (compile-thunk expr) (compile `(lambda () ,expr)))
+    (lambda (env f . let?)
+      ; convert lambda to one body expression and process internal defines
+      (define (lambda-body e)
+	(let ((B (if (pair? (cddr e))
+		     (if (pair? (cdddr e))
+			 (cons 'begin (cddr e))
+			 (caddr e))
+		     #f)))
+	  (let ((V (get-defined-vars B)))
+	    (if (null? V)
+		B
+		(cons (list* 'lambda V B *defines-processed-token*)
+		      (map (lambda (x) #f) V))))))
+      
+      (let ((g    (make-code-emitter))
+	    (args (cadr f))
+	    (name (if (eq? (lastcdr f) *defines-processed-token*)
+		      'lambda
+		      (lastcdr f))))
+	(cond ((not (null? let?))      (emit g :let))
+	      ((length> args MAX_ARGS) (emit g (if (null? (lastcdr args))
+						   :largc :lvargc)
+					     (length args)))
+	      ((null? (lastcdr args))  (emit g :argc  (length args)))
+	      (else  (emit g :vargc (if (atom? args) 0 (length args)))))
+	(compile-in g (cons (to-proper args) env) #t
+		    (if (eq? (lastcdr f) *defines-processed-token*)
+			(caddr f)
+			(lambda-body f)))
+	(emit g :ret)
+	(values (function (encode-byte-code (bcode:code g))
+			  (const-to-idx-vec g) name)
+		(aref g 3))))))
+
+(define (compile f) (compile-f () f))
 
 (define (ref-int32-LE a i)
   (int32 (+ (ash (aref a (+ i 0)) 0)
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -1,1 +1,1 @@
-(zero? #function("7000r1~`W;" [] zero?) vector.map #function("8000r2c0e1\x7f31u42;" [#function("8000vc0e1~31u42;" [#function(":000v`\x80azc0qw2~;" [#function(":000r1\x80~i20i21~[31\\;" [])]) vector.alloc]) length] vector.map) vector->list #function("9000r1c0e1~31_u43;" [#function(":000va~c0qw2\x7f;" [#function("8000r1i10\x80~z[\x81Ko01;" [])]) length] vector->list) values #function("9000s0~F16602~NA650~M;\x80~K;" [] #4=[(values) ()]) untrace #function("8000r1c0e1~31u42;" [#function("9000ve0~316@0e1\x80e2~31b2[42;^;" [traced? set-top-level-value! function:vals]) top-level-value] untrace) traced? #function("8000r1e0~31e0\x8031>;" [function:code] [#function("\xb9000s0e0c1~K312c2~x2;" [println x #.apply]) ()]) trace #function("8000r1c0e1~31u322c2;" [#function("8000vc0e130u42;" [#function("?000ve0\x8031@6a0e1i10e2c3~c4c5c6c7i10L2~L3L2c8c7\x80L2~L3L3L33142;^;" [traced? set-top-level-value! eval lambda begin println cons quote apply]) gensym]) top-level-value ok] trace) to-proper #function("8000r1~A640~;~?660~L1;~Me0~N31K;" [to-proper] to-proper) table.values #function("9000r1e0c1_~43;" [table.foldl #function("7000r3\x7fg2K;" [])] table.values) table.pairs #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~\x7fKg2K;" [])] table.pairs) table.keys #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~g2K;" [])] table.keys) table.invert #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80\x7f~43;" [put!])]) table] table.invert) table.foreach #function("9000r2e0c1q_\x7f43;" [table.foldl #function("8000r3\x80~\x7f322];" [])] table.foreach) table.clone #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80~\x7f43;" [put!])]) table] table.clone) symbol-syntax #function("9000r1e0e1~^43;" [get *syntax-environment*] symbol-syntax) string.trim #function("9000r3c0^^u43;" [#function("8000vc0qm02c1qm12c2e3\x8031u42;" [#function(";000r4g2g3X16?02e0\x7fe1~g232326A0\x80~\x7fe2~g232g344;g2;" [string.find string.char string.inc] trim-start) #function("<000r3e0g2`3216D02e1\x7fe2~e3~g23232326?0\x81~\x7fe3~g23243;g2;" [> string.find string.char string.dec] trim-end) #function("<000ve0i10\x80i10i11`~34\x81i10i12~3343;" [string.sub]) length])] string.trim) string.tail #function(";000r2e0~e1~`\x7f3342;" [string.sub string.inc] string.tail) string.rpad #function("<000r3e0~e1g2\x7fe2~31z3242;" [string string.rep string.count] string.rpad) string.rep #function(";000r2\x7fb4X6`0e0\x7f`32650c1;\x7faW680e2~41;\x7fb2W690e2~~42;e2~~~43;e3\x7f316@0e2~e4~\x7faz3242;e4e2~~32\x7fb2U242;" [<= "" string odd? string.rep] string.rep) string.map #function("9000r2c0e130e2\x7f31u43;" [#function("8000vc0`u322e1~41;" [#function(";000v^~\x81X6S02e0\x80i10e1i11~3231322e2i11~32m05\x0b/;" [io.putc string.char string.inc]) io.tostring!]) buffer length] string.map) string.lpad #function(";000r3e0e1g2\x7fe2~31z32~42;" [string string.rep string.count] string.lpad) string.join #function("8000r2~A650c0;c1e230u42;" ["" #function("8000ve0~\x80M322e1c2q\x80N322e3~41;" [io.write for-each #function("8000r1e0\x80i11322e0\x80~42;" [io.write]) io.tostring!]) buffer] string.join) simple-sort #function("8000r1~A17602~NA640~;c0~Mu42;" [#function("9000vc0e1c2q\x80N32u42;" [#function(":000ve0e1~M31\x80L1e1~N3143;" [nconc simple-sort]) separate #function("7000r1~\x80X;" [])])] simple-sort) set-syntax! #function("9000r2e0e1~\x7f43;" [put! *syntax-environment*]) separate #function(":000r2\x80~\x7f__44;" [] #0=[#function(";000r4\x7fA680g2g3K;~\x7fM316@0\x80~\x7fN\x7fMg2Kg344;\x80~\x7fNg2\x7fMg3K44;" [] #0#) ()]) self-evaluating? #function("8000r1~?16602~C@17K02e0~3116A02~C16:02~e1~31<;" [constant? top-level-value] self-evaluating?) reverse! #function("8000r1c0_u42;" [#function("9000v^\x80F6C02\x80N\x80~\x80m02P2o005\x1c/2~;" [])] reverse!) reverse #function("9000r1e0e1_~43;" [foldl cons] reverse) revappend #function("8000r2e0e1~31\x7f42;" [nconc reverse] revappend) repl #function("9000r0c0^^u43;" [#function("6000vc0m02c1qm12\x7f302e240;" [#function("8000r0e0c1312e2e3312c4c5c6tu42;" [princ "> " i
\ No newline at end of file
+(zero? #function("7000r1~`W;" [] zero?) vector.map #function("8000r2c0e1\x7f31u42;" [#function("8000vc0e1~31u42;" [#function(":000v`\x80azc0qw2~;" [#function(":000r1\x80~i20i21~[31\\;" [])]) vector.alloc]) length] vector.map) vector->list #function("9000r1c0e1~31_u43;" [#function(":000va~c0qw2\x7f;" [#function("8000r1i10\x80~z[\x81Ko01;" [])]) length] vector->list) values #function("9000s0~F16602~NA650~M;\x80~K;" [] #5=[(*values*) ()]) untrace #function("8000r1c0e1~31u42;" [#function("9000ve0~316@0e1\x80e2~31b2[42;^;" [traced? set-top-level-value! function:vals]) top-level-value] untrace) traced? #function("8000r1e0~31e0\x8031>;" [function:code] [#function("\xb9000s0e0c1~K312c2~x2;" [println x #.apply]) ()]) trace #function("8000r1c0e1~31u322c2;" [#function("8000vc0e130u42;" [#function("?000ve0\x8031@6a0e1i10e2c3~c4c5c6c7i10L2~L3L2c8c7\x80L2~L3L3L33142;^;" [traced? set-top-level-value! eval lambda begin println cons quote apply]) gensym]) top-level-value ok] trace) to-proper #function("8000r1~A640~;~?660~L1;~Me0~N31K;" [to-proper] to-proper) table.values #function("9000r1e0c1_~43;" [table.foldl #function("7000r3\x7fg2K;" [])] table.values) table.pairs #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~\x7fKg2K;" [])] table.pairs) table.keys #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~g2K;" [])] table.keys) table.invert #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80\x7f~43;" [put!])]) table] table.invert) table.foreach #function("9000r2e0c1q_\x7f43;" [table.foldl #function("8000r3\x80~\x7f322];" [])] table.foreach) table.clone #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80~\x7f43;" [put!])]) table] table.clone) symbol-syntax #function("9000r1e0e1~^43;" [get *syntax-environment*] symbol-syntax) string.trim #function("9000r3c0^^u43;" [#function("8000vc0qm02c1qm12c2e3\x8031u42;" [#function(";000r4g2g3X16?02e0\x7fe1~g232326A0\x80~\x7fe2~g232g344;g2;" [string.find string.char string.inc] trim-start) #function("<000r3e0g2`3216D02e1\x7fe2~e3~g23232326?0\x81~\x7fe3~g23243;g2;" [> string.find string.char string.dec] trim-end) #function("<000ve0i10\x80i10i11`~34\x81i10i12~3343;" [string.sub]) length])] string.trim) string.tail #function(";000r2e0~e1~`\x7f3342;" [string.sub string.inc] string.tail) string.rpad #function("<000r3e0~e1g2\x7fe2~31z3242;" [string string.rep string.count] string.rpad) string.rep #function(";000r2\x7fb4X6`0e0\x7f`32650c1;\x7faW680e2~41;\x7fb2W690e2~~42;e2~~~43;e3\x7f316@0e2~e4~\x7faz3242;e4e2~~32\x7fb2U242;" [<= "" string odd? string.rep] string.rep) string.map #function("9000r2c0e130e2\x7f31u43;" [#function("8000vc0`u322e1~41;" [#function(";000v^~\x81X6S02e0\x80i10e1i11~3231322e2i11~32m05\x0b/;" [io.putc string.char string.inc]) io.tostring!]) buffer length] string.map) string.lpad #function(";000r3e0e1g2\x7fe2~31z32~42;" [string string.rep string.count] string.lpad) string.join #function("8000r2~A650c0;c1e230u42;" ["" #function("8000ve0~\x80M322e1c2q\x80N322e3~41;" [io.write for-each #function("8000r1e0\x80i11322e0\x80~42;" [io.write]) io.tostring!]) buffer] string.join) simple-sort #function("8000r1~A17602~NA640~;c0~Mu42;" [#function("9000vc0e1c2q\x80N32u42;" [#function(":000ve0e1~M31\x80L1e1~N3143;" [nconc simple-sort]) separate #function("7000r1~\x80X;" [])])] simple-sort) set-syntax! #function("9000r2e0e1~\x7f43;" [put! *syntax-environment*] set-syntax!) separate #function(":000r2\x80~\x7f__44;" [] #0=[#function(";000r4\x7fA680g2g3K;~\x7fM316@0\x80~\x7fN\x7fMg2Kg344;\x80~\x7fNg2\x7fMg3K44;" [] #0#) ()]) self-evaluating? #function("8000r1~?16602~C@17K02e0~3116A02~C16:02~e1~31<;" [constant? top-level-value] self-evaluating?) reverse! #function("8000r1c0_u42;" [#function("9000v^\x80F6C02\x80N\x80~\x80m02P2o005\x1c/2~;" [])] reverse!) reverse #function("9000r1e0e1_~43;" [foldl cons] reverse) revappend #function("8000r2e0e1~31\x7f42;" [nconc reverse] revappend) repl #function("9000r0c0^^u43;" [#function("6000vc0m02c1qm12\x7f302e240;" [#function("8000r0e0c1312e2e3312c4c5c6tu42;"
\ No newline at end of file
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -3,26 +3,18 @@
 ; by Jeff Bezanson (C) 2009
 ; Distributed under the BSD License
 
-(set! *syntax-environment* (table))
+(if (not (bound? '*syntax-environment*))
+    (define *syntax-environment* (table)))
 
-(set! set-syntax!
-      (lambda (s v) (put! *syntax-environment* s v)))
-
-(set-syntax! 'define-macro
-             (lambda (form . body)
-               (list 'set-syntax! (list 'quote (car form))
-                     (cons 'lambda (cons (cdr form) body)))))
-
-(define-macro (define form . body)
-  (if (symbol? form)
-      (list 'set! form (car body))
-      (list 'set! (car form)
-	    (list* 'lambda (cdr form) (append body (car form))))))
-
+(define (set-syntax! s v) (put! *syntax-environment* s v))
 (define (symbol-syntax s) (get *syntax-environment* s #f))
 
+(define-macro (define-macro form . body)
+  `(set-syntax! ',(car form)
+		(lambda ,(cdr form) ,@body)))
+
 (define-macro (label name fn)
-  (list (list 'lambda (list name) (list 'set! name fn)) #f))
+  `((lambda (,name) (set! ,name ,fn)) #f))
 
 (define (map f lst . lsts)
   (define (map1 f lst acc)
@@ -42,28 +34,27 @@
       (mapn f (cons lst lsts))))
 
 (define-macro (let binds . body)
-  ((lambda (lname)
-     (begin
-       (if (symbol? binds)
-	   (begin (set! lname binds)
-		  (set! binds (car body))
-		  (set! body (cdr body))))
-       ((lambda (thelambda theargs)
-	  (cons (if lname
-		    (list 'label lname thelambda)
-		    thelambda)
-		theargs))
-	(cons 'lambda
-	      (cons (map (lambda (c) (if (pair? c) (car c) c)) binds)
-		    body))
-	(map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
-   #f))
+  (let (lname)
+    (if (symbol? binds)
+	(begin (set! lname binds)
+	       (set! binds (car body))
+	       (set! body (cdr body))))
+    (let ((thelambda
+	   `(lambda ,(map (lambda (c) (if (pair? c) (car c) c))
+			  binds)
+	      ,@body))
+	  (theargs
+	   (map (lambda (c) (if (pair? c) (cadr c) #f)) binds)))
+      (cons (if lname
+		`(label ,lname ,thelambda)
+		thelambda)
+	    theargs))))
 
 (define-macro (letrec binds . body)
-  (cons (cons 'lambda (cons (map car binds)
-			    (nconc (map (lambda (b) (cons 'set! b)) binds)
-				   body)))
-	(map (lambda (x) #f) binds)))
+  `((lambda ,(map car binds)
+      ,.(map (lambda (b) `(set! ,@b)) binds)
+      ,@body)
+    ,.(map (lambda (x) #f) binds)))
 
 (define-macro (cond . clauses)
   (define (cond-clauses->if lst)
@@ -390,7 +381,7 @@
 	  (else            `(memv ,key ',v))))
   (let ((g (gensym)))
     `(let ((,g ,key))
-       (cond ,@(map (lambda (clause)
+       (cond ,.(map (lambda (clause)
 		      (cons (vals->cond g (car clause))
 			    (cdr clause)))
 		    clauses)))))
@@ -411,8 +402,8 @@
 			     ,@(cdr test-spec))
 			   (begin
 			     ,@commands
-			     (,loop ,@steps))))))
-       (,loop ,@inits))))
+			     (,loop ,.steps))))))
+       (,loop ,.inits))))
 
 ; SRFI 8
 (define-macro (receive formals expr . body)
@@ -618,23 +609,6 @@
 
 ; toplevel --------------------------------------------------------------------
 
-(define get-defined-vars
-  (letrec ((get-defined-vars-
-	    (lambda (expr)
-	      (cond ((atom? expr) ())
-		    ((and (eq? (car expr) 'define)
-			  (pair? (cdr expr)))
-		     (or (and (symbol? (cadr expr))
-			      (list (cadr expr)))
-			 (and (pair? (cadr expr))
-			      (symbol? (caadr expr))
-			      (list (caadr expr)))
-			 ()))
-		    ((eq? (car expr) 'begin)
-		     (apply append (map get-defined-vars- (cdr expr))))
-		    (else ())))))
-    (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
-
 (define (macrocall? e) (and (symbol? (car e))
 			    (get *syntax-environment* (car e) #f)))
 
@@ -645,21 +619,6 @@
 	    e))))
 
 (define (macroexpand e)
-  (define (expand-lambda e env)
-    (let ((B (if (pair? (cddr e))
-		 (if (pair? (cdddr e))
-		     (cons 'begin (cddr e))
-		     (caddr e))
-		 #f)))
-      (let ((V  (get-defined-vars B))
-	    (Be (macroexpand-in B env)))
-	(list* 'lambda
-	       (cadr e)
-	       (if (null? V)
-		   Be
-		   (cons (list 'lambda V Be)
-			 (map (lambda (x) #f) V)))
-	       (lastcdr e)))))
   (define (macroexpand-in e env)
     (if (atom? e) e
 	(let ((f (assq (car e) env)))
@@ -669,7 +628,15 @@
 		(if f
 		    (macroexpand-in (apply f (cdr e)) env)
 		    (cond ((eq (car e) 'quote)  e)
-			  ((eq (car e) 'lambda) (expand-lambda e env))
+			  ((eq (car e) 'lambda)
+			   `(lambda ,(cadr e)
+			      ,.(map (lambda (x) (macroexpand-in x env))
+				     (cddr e))
+			      . ,(lastcdr e)))
+			  ((eq (car e) 'define)
+			   `(define ,(cadr e)
+			      ,.(map (lambda (x) (macroexpand-in x env))
+				     (cddr e))))
 			  ((eq (car e) 'let-syntax)
 			   (let ((binds (cadr e))
 				 (body  `((lambda () ,@(cddr e)))))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -159,6 +159,7 @@
   . write a function to evaluate directly from list to list, use it for
     Nth arg and for user function rest args
   . modify vararg builtins accordingly
+- filter should be stable. right now it reverses.
 
 
 femtoLisp3...with symbolic C interface
@@ -1040,6 +1041,8 @@
 * maxstack calculation, make Stack growable
   * stack traces and better debugging support
   - make maxstack calculation robust against invalid bytecode
+* improve internal define
+- try removing MAX_ARGS trickery
 - let eversion
 * lambda lifting
 * let optimization