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.

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)

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,25 +469,67 @@
 	   (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-
+  (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*))))
+
+    (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 (compile-thunk expr) (compile `(lambda () ,expr)))
-
 (define (ref-int32-LE a i)
   (int32 (+ (ash (aref a (+ i 0)) 0)
 	    (ash (aref a (+ i 1)) 8)

femtolisp/system.lsp

@@ -3,26 +3,18 @@
 ; by Jeff Bezanson (C) 2009
 ; Distributed under the BSD License
 
-(set! *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))))))
+(if (not (bound? '*syntax-environment*))
+    (define *syntax-environment* (table)))
 
+(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)))))

femtolisp/todo

@@ -159,6 +159,7 @@ bugs:
   . 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 @@ new evaluator todo:
 * 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