* Complete Elisp translator work.

lang/elisp/ChangeLog

@@ -1,3 +1,85 @@
+2002-02-08  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* STATUS: New file.
+
+	* README: Updated.
+
+	* interface.scm (translate-elisp): New exported procedure.
+	(elisp-function): Symbol var is `obj', not `symbol'.
+	
+	* internals/lambda.scm, primitives/fns.scm: Fix confusion between
+	interactive-spec and interactive-specification.
+	
+	* internals/lambda.scm (transform-lambda), primitives/syntax.scm
+	(defmacro): Bind unspecified optional and rest arguments to #nil,
+	not #f.
+
+	* internals/null.scm (->nil, lambda->nil): New, exported.
+	(null): Use ->nil.
+
+	* primitives/features.scm (featurep), primitives/fns.scm
+	(fboundp, subrp): Use ->nil.
+
+	* internals/lists.scm (cons, setcdr, memq, member, assq, assoc):
+	Simplified.
+	(car, cdr): Return #nil rather than #f.
+
+	* primitives/load.scm (current-load-list), primitives/pure.scm
+	(purify-flag): Set to #nil, not #f.
+
+	* primitives/match.scm (string-match): Return #nil rather than #f.
+
+	* primitives/numbers.scm (integerp, numberp),
+	primitives/strings.scm (string-lessp, stringp): Use lambda->nil.
+
+	* primitives/symprop.scm (boundp): Use ->nil.
+	(symbolp, local-variable-if-set-p): Return #nil rather than #f.
+
+	* primitives/syntax.scm (prog1, prog2): Mangle variable names
+	further to lessen possibility of conflicts.
+	(if, and, or, cond): Return #nil rather than #f.
+	(cond): Return #t rather than t (which is undefined).
+	(let, let*): Bind uninitialized variables to #nil, not #f.
+	
+	* transform.scm: Resolve inconsistency in usage of `map', and add
+	an explanatory note.  Also cleaned up use of subsidiary
+	transformation functions.  Also use cons-source wherever possible.
+	(transform-datum, transform-quote): New.
+	(transform-quasiquote): Renamed from `transform-inside-qq'.
+	(transform-application): Apply `transform-quote' to application
+	args.
+	(cars->nil): Removed.
+	
+	* internals/null.scm (null), primitives/lists.scm (cons, car, cdr,
+	setcdr, memq, member, assq, assoc, nth): Update to take into
+	account new libguile support for Elisp nil value.
+
+2002-02-06  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* example.el (time): New macro, for performance measurement.
+	Accompanying comment compares results for Guile and Emacs.
+	
+	* transform.scm (scheme): New macro.
+	(transformer): New implementation of `scheme' escape that doesn't
+	rely on (lang elisp base) importing Guile bindings.
+
+	* base.scm: No longer import anything from (guile).
+	(load-emacs): Add scheme form to ensure that keywords
+	read option is set correctly.
+
+	* primitives/syntax.scm (defmacro, let, let*): Unquote uses of
+	`@bind' in transformed code.
+	(if): Unquote uses of `nil-cond' in transformed code.
+
+	* internals/lambda.scm (transform-lambda): Unquote use of `@bind'
+	in transformed code.
+
+	* transform.scm (transformer-macro): Don't quote `list' in
+	transformed code.
+	(transform-application): Don't quote `@fop' in transformed code.
+	(transformer): No need to treat `@bind' and `@fop' as special
+	cases in input to the transformer.
+
 2002-02-04  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* primitives/syntax.scm (parse-formals, transform-lambda,

lang/elisp/README

@@ -45,8 +45,7 @@ and try to bootstrap a complete Emacs environment:
 
 * Status
 
-Please note that this is work in progress; the translator is
+Please see the STATUS file for the full position.
-incomplete and not yet widely tested.
 
 ** Trying to load a complete Emacs environment.
 
@@ -163,12 +162,23 @@ transform Elisp variable references after all.
 
 *** Truth value stuff
 
-Lots of stuff to do with providing the special self-evaluating `nil'
+Following extensive discussions on the Guile mailing list between
-and `t' symbols, and macros that convert between Scheme and Elisp
+September 2001 and January 2002, we decided to go with Jim Blandy's
-truth values, and so on.
+proposal.  See devel/translation/lisp-and-scheme.text for details.
 
-I'm hoping that most of this will go away, but I need to show that
+- The Elisp nil value is a new immediate SCM_MAKIFLAG, eq?-distinct
-it's feasible first.
+from both #f and '() (and of course any other Scheme value).  It can
+be accessed via the (guile) binding `%nil', and prints as `#nil'.
+
+- All Elisp primitives treat #nil, #f and '() as identical.
+
+- Scheme truth-testing primitives have been modified so that they
+treat #nil the same as #f.
+
+- Scheme list-manipulating primitives have been modified so that they
+treat #nil the same as '().
+
+- The Elisp t value is the same as #t.
 
 ** Emacs editing primitives
 
@@ -191,8 +201,9 @@ that Ken Raeburn has been doing on the Emacs codebase.
 
 Elisp is close enough to Scheme that it's convenient to coopt the
 existing Guile reader rather than to write a new one from scratch, but
-there are a few syntactic differences that will require adding Elisp
+there are a few syntactic differences that will require changes in
-support to the reader.
+reading and printing.  None of the following changes has yet been
+implemented.
 
 - Character syntax is `?a' rather than `#\a'.  (Not done.  More
   precisely, `?a' in Elisp isn't character syntax but an alternative
@@ -204,12 +215,10 @@ support to the reader.
 
   and so on.)
 
-- `nil' and `t' should be read (I think) as #f and #t.  (Done.)
+- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'.
 
-- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'.  (Not done.)
+- When in an Elisp environment, #nil and #t should print as `nil' and
-
+  `t'.
-Correspondingly, when printing, #f and '() should be written as
-`nil'.  (Not done.)
 
 ** The Elisp evaluation module (lang elisp base)
 
@@ -272,36 +281,6 @@ worry about adding unexec support to Guile!)  For the output that
 currently results from calling `(load-emacs)', see above in the Status
 section.
 
-* nil, #f and '()
-
-For Jim Blandy's notes on this, see the reference at the bottom of
-this file.  Currently I'm investigating a different approach, which is
-better IMO than Jim's proposal because it avoids requiring multiple
-false values in the Scheme world.
-
-According to my approach...
-
-- `nil' and `t' are read (when in Elisp mode) as #f and #t.
-
-- `(if x ...)', `(while x ...)' etc. are translated to something
-  like `(if (and x (not (null? x))) ...)'.
-
-- Functions which interpret an argument as a list --
-  `cons', `setcdr', `memq', etc. -- either convert #f to '(), or
-  handle the #f case specially.
-
-- `eq' treats #f and '() as the same.
-
-- Optionally, functions which produce '() values -- i.e. the reader
-  and `cdr' -- could convert those immediately to #f.  This shouldn't
-  affect the validity of any Elisp code, but it alters the balance of
-  #f and '() values swimming around in that code and so affects what
-  happens if two such values are returned to the Scheme world and then
-  compared.  However, since you can never completely solve this
-  problem (unless you are prepared to convert arbitrarily deep
-  structures on entry to the Elisp world, which would kill performance),
-  I'm inclined not to try to solve it at all.
-
 * Resources
 
 ** Ken Raeburn's Guile Emacs page
@@ -316,6 +295,9 @@ http://gemacs.sourceforge.net
 
 http://sanpietro.red-bean.com/guile/guile/old/3114.html
 
+Also now stored as guile-core/devel/translation/lisp-and-scheme.text
+in Guile CVS.
+
 ** Mikael Djurfeldt's notes on translation
 
-See file guile-cvs/devel/translation/langtools.text in Guile CVS.
+See file guile-core/devel/translation/langtools.text in Guile CVS.

lang/elisp/STATUS

@@ -0,0 +1,35 @@
+                                                        -*-text-*-
+
+I've now finished my currently planned work on the Emacs Lisp
+translator in guile-core CVS.
+
+It works well enough for experimentation and playing around with --
+see the README file for details of what it _can_ do -- but has two
+serious restrictions:
+
+- Most Emacs Lisp primitives are not yet implemented.  In particular,
+  there are no buffer-related primitives.
+
+- Performance compares badly with Emacs.  Using a handful of
+  completely unscientific tests, I found that Guile was between 2 and
+  20 times slower than Emacs.  (See the comment in
+  lang/elisp/example.el for details of tests and results.)
+
+Interestingly, both these restrictions point in the same direction:
+the way forward is to define the primitives by compiling a
+preprocessed version of the Emacs source code, not by trying to
+implement them in Scheme.  (Which, of course, is what Ken Raeburn's
+project is already trying to do.)
+
+Given this conclusion, I expect that most of the translator's Scheme
+code will eventually become obsolete, replaced by bits of Emacs C
+code.  Until then, though, it should have a role:
+
+- as a guide to the Guile Emacs project on how to interface to the
+  Elisp support in libguile (notably, usage of `@fop' and `@bind')
+
+- as a proof of concept and fun thing to experiment with
+
+- as a working translator that could help us develop our picture of
+  how we want to integrate translator usage in general with the rest
+  of Guile.

lang/elisp/base.scm

@@ -1,13 +1,12 @@
 (define-module (lang elisp base)
 
-  ;; Be pure.  Nothing in this module requires most of the standard
+  ;; Be pure.  Nothing in this module requires symbols that map to the
-  ;; Guile builtins, and it creates a problem if this module has
+  ;; standard Guile builtins, and it creates a problem if this module
-  ;; access to them, as @bind can dynamically change their values.
+  ;; has access to them, as @bind can dynamically change their values.
+  ;; Transformer output always uses the values of builtin procedures
+  ;; and macros directly.
   #:pure
 
-  ;; But we do need a few builtins - import them here.
-  #:use-module ((guile) #:select (@fop @bind nil-cond))
-
   ;; {Elisp Primitives}
   ;;
   ;; In other words, Scheme definitions of elisp primitives.  This
@@ -34,13 +33,10 @@
   ;; Now switch into Emacs Lisp syntax.
   #:use-syntax (lang elisp transform))
 
-;(use-modules (lang elisp transform))
-;(read-set! keywords 'prefix)
-;(set-module-transformer! (current-module) transformer)
-
 ;;; Everything below here is written in Elisp.
 
 (defun load-emacs ()
+  (scheme (read-set! keywords 'prefix))
   (message "Calling loadup.el to clothe the bare Emacs...")
   (load "loadup.el")
   (message "Guile Emacs now fully clothed"))

lang/elisp/example.el

@@ -8,3 +8,32 @@
 	  (apply 'concat contents)
 	  "</BODY>\n"
 	  "</HTML>\n"))
+
+(defmacro time (repeat-count &rest body)
+  `(let ((count ,repeat-count)
+	 (beg (current-time))
+	 end)
+     (while (> count 0)
+       (setq count (- count 1))
+       ,@body)
+     (setq end (current-time))
+     (+ (* 1000000.0 (+ (* 65536.0 (- (car end) (car beg)))
+			(- (cadr end) (cadr beg))))
+	(* 1.0 (- (caddr end) (caddr beg))))))
+
+;Non-scientific performance measurements (Guile measurements are with
+;`guile -q --no-debug'):
+;
+;(time 100000 (+ 3 4))
+; => 225,071 (Emacs) 4,000,000 (Guile)
+;(time 100000 (lambda () 1))
+; => 2,410,456 (Emacs) 4,000,000 (Guile)
+;(time 100000 (apply 'concat (mapcar (lambda (s) (concat s "." s)) '("a" "b" "c" "d"))))
+; => 10,185,792 (Emacs) 136,000,000 (Guile)
+;(defun sc (s) (concat s "." s))
+;(time 100000 (apply 'concat (mapcar 'sc  '("a" "b" "c" "d"))))
+; => 7,870,055 (Emacs) 26,700,000 (Guile)
+;
+;Sadly, it looks like the translator's performance sucks quite badly
+;when compared with Emacs.  But the translator is still very new, so
+;there's probably plenty of room of improvement.

lang/elisp/interface.scm

@@ -2,7 +2,9 @@
   #:use-module (lang elisp internals evaluation)
   #:use-module (lang elisp internals fset)
   #:use-module ((lang elisp internals load) #:select ((load . elisp:load)))
+  #:use-module ((lang elisp transform) #:select (transformer))
   #:export (eval-elisp
+	    translate-elisp
 	    elisp-function
 	    elisp-variable
 	    load-elisp-file
@@ -19,6 +21,10 @@
   "Evaluate the Elisp expression @var{x}."
   (eval x the-elisp-module))
 
+(define (translate-elisp x)
+  "Translate the Elisp expression @var{x} to equivalent Scheme code."
+  (transformer x))
+
 (define (elisp-function sym)
   "Return the procedure or macro that implements @var{sym} in Elisp.
 If @var{sym} has no Elisp function definition, return @code{#f}."
@@ -112,7 +118,7 @@ exported to Elisp."
 			   (error "No macro name specified or deducible:" obj)))
 		      ((symbol? obj)
 		       (or name
-			   (set! name symbol))
+			   (set! name obj))
 		       (module-add! the-elisp-module name
 				    (module-ref (current-module) obj)))
 		      (else

lang/elisp/internals/lambda.scm

@@ -67,28 +67,28 @@
 			  `(((,> %--num-args ,(+ num-required num-optional))
 			     (,error "Wrong number of args (too many args)"))))
 		    (else
-		     (@bind ,(append (map (lambda (i)
+		     (, @bind ,(append (map (lambda (i)
-					    (list (list-ref required i)
+					      (list (list-ref required i)
-						  `(,list-ref %--args ,i)))
+						    `(,list-ref %--args ,i)))
-					  (iota num-required))
+					    (iota num-required))
-				     (map (lambda (i)
+				       (map (lambda (i)
-					    (let ((i+nr (+ i num-required)))
+					      (let ((i+nr (+ i num-required)))
-					      (list (list-ref optional i)
+						(list (list-ref optional i)
-						    `(,if (,> %--num-args ,i+nr)
+						      `(,if (,> %--num-args ,i+nr)
-							  (,list-ref %--args ,i+nr)
+							    (,list-ref %--args ,i+nr)
-							  #f))))
+							    ,%nil))))
-					  (iota num-optional))
+					    (iota num-optional))
-				     (if rest
+				       (if rest
-					 (list (list rest
+					   (list (list rest
-						     `(,if (,> %--num-args
+						       `(,if (,> %--num-args
-							       ,(+ num-required
+								 ,(+ num-required
-								   num-optional))
+								     num-optional))
-							   (,list-tail %--args
+							     (,list-tail %--args
-								       ,(+ num-required
+									 ,(+ num-required
-									   num-optional))
+									     num-optional))
-							   '())))
+							     ,%nil)))
-					 '()))
+					   '()))
-			    ,@(map transformer (cddr exp)))))))))))
+			      ,@(map transformer (cddr exp)))))))))))
 
 (define (set-not-subr! proc boolean)
   (set! (not-subr? proc) boolean))
@@ -101,7 +101,7 @@
        (,set-procedure-property! %--lambda (,quote name) (,quote ,name))
        (,set-not-subr! %--lambda #t)
        ,@(if is
-	     `((,set! (,interactive-spec %--lambda) (,quote ,is)))
+	     `((,set! (,interactive-specification %--lambda) (,quote ,is)))
 	     '())
        %--lambda)))
 

lang/elisp/internals/null.scm

@@ -1,7 +1,13 @@
 (define-module (lang elisp internals null)
-  #:export (null))
+  #:export (->nil lambda->nil null))
+
+(define (->nil x)
+  (or x %nil))
+
+(define (lambda->nil proc)
+  (lambda args
+    (->nil (apply proc args))))
 
 (define (null obj)
-  (or (not obj)
+  (->nil (or (not obj)
-      (null? obj)
+	     (null? obj))))
-      (eq? obj 'nil)))			; Should be removed.

lang/elisp/primitives/features.scm

@@ -1,6 +1,7 @@
 (define-module (lang elisp primitives features)
   #:use-module (lang elisp internals fset)
   #:use-module (lang elisp internals load)
+  #:use-module (lang elisp internals null)
   #:use-module (ice-9 optargs))
 
 (define-public features '())
@@ -12,7 +13,7 @@
 
 (fset 'featurep
       (lambda (feature)
-	(memq feature features)))
+	(->nil (memq feature features))))
 
 (fset 'require
       (lambda* (feature #:optional file-name noerror)

lang/elisp/primitives/fns.scm

@@ -18,11 +18,11 @@
 
 (fset 'commandp
       (lambda (sym)
-	(if (interactive-spec (fref sym)) #t %nil)))
+	(if (interactive-specification (fref sym)) #t %nil)))
 
 (fset 'fboundp
       (lambda (sym)
-	(variable? (symbol-fref sym))))
+	(->nil (variable? (symbol-fref sym)))))
 
 (fset 'symbol-function fref/error-if-void)
 
@@ -30,7 +30,7 @@
 
 (fset 'subrp
       (lambda (obj)
-	(not (not-subr? obj))))
+	(->nil (not (not-subr? obj)))))
 
 (fset 'byte-code-function-p
       (lambda (object)

lang/elisp/primitives/lists.scm

@@ -3,9 +3,7 @@
   #:use-module (lang elisp internals null)
   #:use-module (lang elisp internals signal))
 
-(fset 'cons
+(fset 'cons cons)
-      (lambda (x y)
-	(cons x (or y '()))))
 
 (fset 'null null)
 
@@ -14,13 +12,13 @@
 (fset 'car
       (lambda (l)
 	(if (null l)
-	    #f
+	    %nil
 	    (car l))))
 
 (fset 'cdr
       (lambda (l)
 	(if (null l)
-	    #f
+	    %nil
 	    (cdr l))))
 
 (fset 'eq
@@ -35,12 +33,7 @@
 
 (fset 'setcar set-car!)
 
-(fset 'setcdr
+(fset 'setcdr set-cdr!)
-      (lambda (cell newcdr)
-	(set-cdr! cell
-		  (if (null newcdr)
-		      '()
-		      newcdr))))
 
 (for-each (lambda (sym proc)
 	    (fset sym
@@ -48,14 +41,10 @@
 		    (if (null list)
 			%nil
 			(if (null elt)
-			    (or (proc #f list)
+			    (let loop ((l list))
-				(proc '() list)
+			      (cond ((null l) %nil)
-				(proc %nil list)
+				    ((null (car l)) l)
-				(proc 'nil list)) ; 'nil shouldn't be
+				    (else (loop (cdr l)))))
-						  ; here, as it should
-						  ; have been
-						  ; translated by the
-						  ; transformer.
 			    (proc elt list))))))
 	  '( memq  member  assq  assoc)
 	  `(,memq ,member ,assq ,assoc))
@@ -97,7 +86,7 @@
       (lambda (n list)
 	(if (or (null list)
 		(>= n (length list)))
-	    #f
+	    %nil
 	    (list-ref list n))))
 
 (fset 'listp

lang/elisp/primitives/load.scm

@@ -14,4 +14,4 @@
       (lambda args
 	#t))
 
-(define-public current-load-list #f)
+(define-public current-load-list %nil)

lang/elisp/primitives/match.scm

@@ -45,7 +45,7 @@
 				(iota (match:count match))))
 		    #f)))
 
-	(if last-match (car last-match) #f)))
+	(if last-match (car last-match) %nil)))
 
 (fset 'match-beginning
       (lambda (subexp)

lang/elisp/primitives/numbers.scm

@@ -1,9 +1,10 @@
 (define-module (lang elisp primitives numbers)
-  #:use-module (lang elisp internals fset))
+  #:use-module (lang elisp internals fset)
+  #:use-module (lang elisp internals null))
 
 (fset 'logior logior)
 (fset 'logand logand)
-(fset 'integerp integer?)
+(fset 'integerp (lambda->nil integer?))
 (fset '= =)
 (fset '< <)
 (fset '> >)
@@ -39,4 +40,4 @@
 			(- shift 1))))))
 	lsh))
 
-(fset 'numberp number?)
+(fset 'numberp (lambda->nil number?))

lang/elisp/primitives/pure.scm

@@ -5,4 +5,4 @@
 
 (fset 'purecopy identity)
 
-(define-public purify-flag #f)
+(define-public purify-flag %nil)

lang/elisp/primitives/strings.scm

@@ -1,5 +1,6 @@
 (define-module (lang elisp primitives strings)
   #:use-module (lang elisp internals fset)
+  #:use-module (lang elisp internals null)
   #:use-module (lang elisp internals signal))
 
 (fset 'substring substring)
@@ -19,7 +20,7 @@
 
 (fset 'number-to-string number->string)
 
-(fset 'string-lessp string<?)
+(fset 'string-lessp (lambda->nil string<?))
 (fset 'string< 'string-lessp)
 
 (fset 'aref
@@ -28,6 +29,6 @@
 	      ((string? array) (char->integer (string-ref array idx)))
 	      (else (wta 'arrayp array 1)))))
 
-(fset 'stringp string?)
+(fset 'stringp (lambda->nil string?))
 
 (fset 'vector vector)

lang/elisp/primitives/symprop.scm

@@ -1,7 +1,8 @@
 (define-module (lang elisp primitives symprop)
-  #:use-module (lang elisp internals set)
-  #:use-module (lang elisp internals fset)
   #:use-module (lang elisp internals evaluation)
+  #:use-module (lang elisp internals fset)
+  #:use-module (lang elisp internals null)
+  #:use-module (lang elisp internals set)
   #:use-module (ice-9 optargs))
 
 ;;; {Elisp Exports}
@@ -16,7 +17,7 @@
 
 (fset 'boundp
       (lambda (sym)
-	(module-defined? the-elisp-module sym)))
+	(->nil (module-defined? the-elisp-module sym))))
 
 (fset 'default-boundp 'boundp)
 
@@ -29,10 +30,11 @@
 (fset 'symbolp
       (lambda (object)
 	(or (symbol? object)
-	    (keyword? object))))
+	    (keyword? object)
+	    %nil)))
 
 (fset 'local-variable-if-set-p
       (lambda* (variable #:optional buffer)
-	#f))
+	%nil))
 
 (fset 'symbol-name symbol->string)

lang/elisp/primitives/syntax.scm

@@ -32,7 +32,6 @@
 	      `(,quote ,(cadr exp))
 	      `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
 			    ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
-		       ;; (,macro-setq ,(cadr exp) ,(caddr exp)))
 		       (,quote ,(cadr exp)))))))
 
 (fset 'defconst
@@ -87,28 +86,28 @@
 						 `(((,> %--num-args ,(+ num-required num-optional))
 						    (,error "Wrong number of args (too many args)"))))
 					   (else (,transformer
-						  (@bind ,(append (map (lambda (i)
+						  (, @bind ,(append (map (lambda (i)
-									 (list (list-ref required i)
+									   (list (list-ref required i)
-									       `(,list-ref %--args ,i)))
+										 `(,list-ref %--args ,i)))
-								       (iota num-required))
+									 (iota num-required))
-								  (map (lambda (i)
+								    (map (lambda (i)
-									 (let ((i+nr (+ i num-required)))
+									   (let ((i+nr (+ i num-required)))
-									   (list (list-ref optional i)
+									     (list (list-ref optional i)
-										 `(,if (,> %--num-args ,i+nr)
+										   `(,if (,> %--num-args ,i+nr)
-										       (,list-ref %--args ,i+nr)
+											 (,list-ref %--args ,i+nr)
-										       #f))))
+											 ,%nil))))
-								       (iota num-optional))
+									 (iota num-optional))
-								  (if rest
+								    (if rest
-								      (list (list rest
+									(list (list rest
-										  `(,if (,> %--num-args
+										    `(,if (,> %--num-args
-											    ,(+ num-required
+											      ,(+ num-required
-												num-optional))
+												  num-optional))
-											(,list-tail %--args
+											  (,list-tail %--args
-												    ,(+ num-required
+												      ,(+ num-required
-													num-optional))
+													  num-optional))
-											'())))
+											  ,%nil)))
-								      '()))
+									'()))
-							 ,@(map transformer (cdddr exp)))))))))))))))))
+							   ,@(map transformer (cdddr exp)))))))))))))))))
 
 ;;; {Sequencing}
 
@@ -120,36 +119,34 @@
 (fset 'prog1
       (procedure->memoizing-macro
         (lambda (exp env)
-	  `(,let ((%res1 ,(transformer (cadr exp))))
+	  `(,let ((%--res1 ,(transformer (cadr exp))))
 	     ,@(map transformer (cddr exp))
-	     %res1))))
+	     %--res1))))
 
 (fset 'prog2
       (procedure->memoizing-macro
         (lambda (exp env)
 	  `(,begin ,(transformer (cadr exp))
-		   (,let ((%res2 ,(transformer (caddr exp))))
+		   (,let ((%--res2 ,(transformer (caddr exp))))
 		     ,@(map transformer (cdddr exp))
-		     %res2)))))
+		     %--res2)))))
 
 ;;; {Conditionals}
 
-(define <-- *unspecified*)
-
 (fset 'if
       (procedure->memoizing-macro
         (lambda (exp env)
 	  (let ((else-case (cdddr exp)))
 	    (cond ((null? else-case)
-		   `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f))
+		   `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
 		  ((null? (cdr else-case))
-		   `(nil-cond ,(transformer (cadr exp))
+		   `(,nil-cond ,(transformer (cadr exp))
-			      ,(transformer (caddr exp))
+			       ,(transformer (caddr exp))
-			      ,(transformer (car else-case))))
+			       ,(transformer (car else-case))))
 		  (else
-		   `(nil-cond ,(transformer (cadr exp))
+		   `(,nil-cond ,(transformer (cadr exp))
-			      ,(transformer (caddr exp))
+			       ,(transformer (caddr exp))
-			      (,begin ,@(map transformer else-case)))))))))
+			       (,begin ,@(map transformer else-case)))))))))
 
 (fset 'and
       (procedure->memoizing-macro
@@ -162,13 +159,26 @@
 			 (if (null? (cdr args))
 			     (list (transformer (car args)))
 			     (cons (list not (transformer (car args)))
-				   (cons #f
+				   (cons %nil
 					 (loop (cdr args))))))))))))
 
+;;; NIL-COND expressions have the form:
+;;;
+;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
+;;;
+;;; The CONDs are evaluated in order until one of them returns true
+;;; (in the Elisp sense, so not including empty lists).  If a COND
+;;; returns true, its corresponding VAL is evaluated and returned,
+;;; except if that VAL is the unspecified value, in which case the
+;;; result of evaluating the COND is returned.  If none of the COND's
+;;; returns true, ELSEVAL is evaluated and its value returned.
+
+(define <-- *unspecified*)
+
 (fset 'or
       (procedure->memoizing-macro
         (lambda (exp env)
-	  (cond ((null? (cdr exp)) #f)
+	  (cond ((null? (cdr exp)) %nil)
 		((null? (cddr exp)) (transformer (cadr exp)))
 		(else
 		 (cons nil-cond
@@ -183,15 +193,15 @@
       (procedure->memoizing-macro
        (lambda (exp env)
 	 (if (null? (cdr exp))
-	     #f
+	     %nil
 	     (cons
 	      nil-cond
 	      (let loop ((clauses (cdr exp)))
 		(if (null? clauses)
-		    '(#f)
+		    (list %nil)
 		    (let ((clause (car clauses)))
 		      (if (eq? (car clause) #t)
-			  (cond ((null? (cdr clause)) '(t))
+			  (cond ((null? (cdr clause)) (list #t))
 				((null? (cddr clause))
 				 (list (transformer (cadr clause))))
 				(else `((,begin ,@(map transformer (cdr clause))))))
@@ -210,7 +220,7 @@
 				  (,nil-cond ,(transformer (cadr exp))
 					     (,begin ,@(map transformer (cddr exp))
 						     (%--while))
-					     #f))))
+					     ,%nil))))
 	      %--while)))))
 
 ;;; {Local binding}
@@ -218,13 +228,13 @@
 (fset 'let
       (procedure->memoizing-macro
         (lambda (exp env)
-	  `(@bind ,(map (lambda (binding)
+	  `(, @bind ,(map (lambda (binding)
-			  (trc 'let binding)
+			    (trc 'let binding)
-			  (if (pair? binding)
+			    (if (pair? binding)
-			      `(,(car binding) ,(transformer (cadr binding)))
+				`(,(car binding) ,(transformer (cadr binding)))
-			      `(,binding #f)))
+				`(,binding ,%nil)))
-			(cadr exp))
+			  (cadr exp))
-		  ,@(map transformer (cddr exp))))))
+		    ,@(map transformer (cddr exp))))))
 
 (fset 'let*
       (procedure->memoizing-macro
@@ -234,11 +244,11 @@
 	      (car (let loop ((bindings (cadr exp)))
 		     (if (null? bindings)
 			 (map transformer (cddr exp))
-			 `((@bind (,(let ((binding (car bindings)))
+			 `((, @bind (,(let ((binding (car bindings)))
-				      (if (pair? binding)
+					(if (pair? binding)
-					  `(,(car binding) ,(transformer (cadr binding)))
+					    `(,(car binding) ,(transformer (cadr binding)))
-					  `(,binding #f))))
+					    `(,binding ,%nil))))
-				  ,@(loop (cdr bindings)))))))))))
+				    ,@(loop (cdr bindings)))))))))))
 
 ;;; {Exception handling}
 

lang/elisp/transform.scm

@@ -5,81 +5,98 @@
   #:use-module (ice-9 session)
   #:export (transformer transform))
 
-;;; {S-expressions}
+;;; A note on the difference between `(transform-* (cdr x))' and `(map
+;;; transform-* (cdr x))'.
 ;;;
+;;; In most cases, none, as most of the transform-* functions are
+;;; recursive.
+;;;
+;;; However, if (cdr x) is not a proper list, the `map' version will
+;;; signal an error immediately, whereas the non-`map' version will
+;;; produce a similarly improper list as its transformed output.  In
+;;; some cases, improper lists are allowed, so at least these cases
+;;; require non-`map'.
+;;;
+;;; Therefore we use the non-`map' approach in most cases below, but
+;;; `map' in transform-application, since in the application case we
+;;; know that `(func arg . args)' is an error.  It would probably be
+;;; better for the transform-application case to check for an improper
+;;; list explicitly and signal a more explicit error.
 
 (define (syntax-error x)
   (error "Syntax error in expression" x))
 
-;; Should be made mutating instead of constructing
+(define-macro (scheme exp . module)
-;;
+  (let ((m (resolve-module (if (null? module)
+			       '(guile-user)
+			       (car module)))))
+    (let ((x `(,eval (,quote ,exp) ,m)))
+      (write x)
+      (newline)
+      x)))
+
 (define (transformer x)
+  (cond ((pair? x)
+	 (cond ((symbol? (car x))
+		(case (car x)
+		  ;; Allow module-related forms through intact.
+		  ((define-module use-modules use-syntax)
+		   x)
+		  ;; Escape to Scheme.
+		  ((scheme)
+		   (cons-source x scheme (cdr x)))
+		  ;; Quoting.
+		  ((quote function)
+		   (cons-source x quote (transform-quote (cdr x))))
+		  ((quasiquote)
+		   (cons-source x quasiquote (transform-quasiquote (cdr x))))
+		  ;; Anything else is a function or macro application.
+		  (else (transform-application x))))
+	       ((and (pair? (car x))
+		     (eq? (caar x) 'quasiquote))
+		(transformer (car x)))
+	       (else (syntax-error x))))
+	(else
+	 (transform-datum x))))
+
+(define (transform-datum x)
   (cond ((eq? x 'nil) %nil)
 	((eq? x 't) #t)
-	((null? x) %nil)
+	;; Could add other translations here, notably `?A' -> 65 etc.
-	((not (pair? x)) x)
+	(else x)))
-	((and (pair? (car x))
-	      (eq? (caar x) 'quasiquote))
-	 (transformer (car x)))
-	((symbol? (car x))
-	 (case (car x)
-	   ((@fop @bind define-module use-modules use-syntax) x)
-	   ; Escape to Scheme syntax
-	   ((scheme) (cons begin (cdr x)))
-	   ; Should be handled in reader
-	   ((quote function) `(,quote ,@(cars->nil (cdr x))))
-	   ((quasiquote) (m-quasiquote x '()))
-	   ;((nil-cond) (transform-1 x))
-	   ;((let) (m-let x '()))
-	   ;((let*) (m-let* x '()))
-	   ;((if) (m-if x '()))
-	   ;((and) (m-and x '()))
-	   ;((or) (m-or x '()))
-	   ;((while) (m-while x '()))
-	   ;((while) (cons macro-while (cdr x)))
-	   ;((prog1) (m-prog1 x '()))
-	   ;((prog2) (m-prog2 x '()))
-	   ;((progn) (cons 'begin (map transformer (cdr x))))
-	   ;((cond) (m-cond x '()))
-	   ;((lambda) (transform-lambda/interactive x '<elisp-lambda>))
-	   ;((defun) (m-defun x '()))
-	   ;((defmacro) (m-defmacro x '()))
-	   ;((setq) (m-setq x '()))
-	   ;((interactive) (fluid-set! interactive-spec x) #f)
-	   ;((unwind-protect) (m-unwind-protect x '()))
-	   (else (transform-application x))))
-	(else (syntax-error x))))
 
-(define (m-quasiquote exp env)
+(define (transform-quote x)
-  (cons quasiquote
+  (trc 'transform-quote x)
-	(map transform-inside-qq (cdr exp))))
+  (cond ((not (pair? x))
+	 (transform-datum x))
+	(else
+	 (cons-source x
+		      (transform-quote (car x))
+		      (transform-quote (cdr x))))))
 
-(define (transform-inside-qq x)
+(define (transform-quasiquote x)
-  (trc 'transform-inside-qq x)
+  (trc 'transform-quasiquote x)
-  (cond ((not (pair? x)) x)
+  (cond ((not (pair? x))
+	 (transform-datum x))
 	((symbol? (car x))
 	 (case (car x)
 	   ((unquote) (list 'unquote (transformer (cadr x))))
 	   ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
-	   (else (cons (car x) (map transform-inside-qq (cdr x))))))
+	   (else (cons-source x
+			      (transform-datum (car x))
+			      (transform-quasiquote (cdr x))))))
 	(else
-	 (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))
+	 (cons-source x
+		      (transform-quasiquote (car x))
+		      (transform-quasiquote (cdr x))))))
 
 (define (transform-application x)
-  (cons-source x
+  (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x))))))
-	       '@fop
-	       `(,(car x) (,transformer-macro ,@(cdr x)))))
 
 (define transformer-macro
   (procedure->memoizing-macro
    (let ((cdr cdr))
      (lambda (exp env)
-       (cons 'list (map transformer (cdr exp)))))))
+       (cons-source exp list (map transformer (cdr exp)))))))
-
-(define (cars->nil ls)
-  (cond ((not (pair? ls)) ls)
-	((null? (car ls)) (cons '() (cars->nil (cdr ls))))
-	(else (cons (cars->nil (car ls))
-		    (cars->nil (cdr ls))))))
 
 (define transform transformer)