* Rename call-with-readline-completion-function' to with-readline-completion-function'.

* More tests for Elisp nil value.
* Development work on Elisp translator.

guile-readline/ChangeLog

@@ -1,3 +1,8 @@
+2002-01-29  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* readline.scm (with-readline-completion-function): Renamed from
+	`call-with-readline-completion-function'.
+
 2001-11-30  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* Makefile.am (EXTRA_DIST): Refer to $(ice9_DATA) rather than

guile-readline/readline.scm

@@ -187,7 +187,7 @@
       (set! *readline-completion-function* apropos-completion-function)
       ))
 
-(define-public (call-with-readline-completion-function completer thunk)
+(define-public (with-readline-completion-function completer thunk)
   "With @var{completer} as readline completion function, call @var{thunk}."
   (let ((old-completer *readline-completion-function*))
     (dynamic-wind

lang/elisp/ChangeLog

@@ -1,3 +1,44 @@
+2002-01-29  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* transform.scm (transform-1, transform-2, transform-3,
+	transform-list): Removed (unused).
+	
+	* transform.scm, primitives/syntax.scm: Add commas everywhere
+	before use of (guile) primitives in generated code, so that (lang
+	elisp base) doesn't have to import bindings from (guile).
+	
+	* base.scm: Move use-modules expressions inside the define-module,
+	and add #:pure so that we don't import bindings from (guile).
+
+2002-01-25  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* transform.scm (transform-application): Preserve source
+	properties of original elisp expression by using cons-source.
+
+	* transform.scm: Don't handle special forms specially in the
+	translator.  Instead, define them as macros in ...
+	
+	* primitives/syntax.scm: New file; special form definitions.
+
+	* primitives/fns.scm (run-hooks): Rewritten correctly.
+
+	* primitives/symprop.scm (symbol-value): Use `value'.
+
+	* internals/set.scm (value): New function.
+
+	* primitives/fns.scm: Use (lang elisp internals null), as null is
+	no longer a primitive.  Change generated #f values to %nil.
+
+	* internals/null.scm (null): Handle nil symbol.
+
+	* primitives/lists.scm (memq, member, assq, assoc): Handle all
+	possible nil values.
+
+	* transform.scm (transformer): Translate `nil' and `t' to #nil and
+	#t.
+
+	* base.scm: Remove setting of 'language read-option.
+
 2001-11-03  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* README (Resources): Fill in missing URLs.

lang/elisp/base.scm

@@ -1,34 +1,42 @@
-(define-module (lang elisp base))
+(define-module (lang elisp base)
 
-;;; {Elisp Primitives}
+  ;; Be pure.  Nothing in this module requires most of the standard
-;;;
+  ;; Guile builtins, and it creates a problem if this module has
-;;; In other words, Scheme definitions of elisp primitives.  This
+  ;; access to them, as @bind can dynamically change their values.
-;;; should (ultimately) include everything that Emacs defines in C.
+  #:pure
 
-(use-modules (lang elisp primitives buffers)
+  ;; But we do need a few builtins - import them here.
-	     (lang elisp primitives features)
+  #:use-module ((guile) #:select (@fop @bind nil-cond))
-	     (lang elisp primitives format)
-	     (lang elisp primitives fns)
-	     (lang elisp primitives guile)
-	     (lang elisp primitives keymaps)
-	     (lang elisp primitives lists)
-	     (lang elisp primitives load)
-	     (lang elisp primitives match)
-	     (lang elisp primitives numbers)
-	     (lang elisp primitives pure)
-	     (lang elisp primitives read)
-	     (lang elisp primitives signal)
-	     (lang elisp primitives strings)
-	     (lang elisp primitives symprop)
-	     (lang elisp primitives system)
-	     (lang elisp primitives time))
 
-;;; Now switch into Emacs Lisp syntax.
+  ;; {Elisp Primitives}
+  ;;
+  ;; In other words, Scheme definitions of elisp primitives.  This
+  ;; should (ultimately) include everything that Emacs defines in C.
+  #:use-module (lang elisp primitives buffers)
+  #:use-module (lang elisp primitives features)
+  #:use-module (lang elisp primitives format)
+  #:use-module (lang elisp primitives fns)
+  #:use-module (lang elisp primitives guile)
+  #:use-module (lang elisp primitives keymaps)
+  #:use-module (lang elisp primitives lists)
+  #:use-module (lang elisp primitives load)
+  #:use-module (lang elisp primitives match)
+  #:use-module (lang elisp primitives numbers)
+  #:use-module (lang elisp primitives pure)
+  #:use-module (lang elisp primitives read)
+  #:use-module (lang elisp primitives signal)
+  #:use-module (lang elisp primitives strings)
+  #:use-module (lang elisp primitives symprop)
+  #:use-module (lang elisp primitives syntax)
+  #:use-module (lang elisp primitives system)
+  #:use-module (lang elisp primitives time)
 
-(use-modules (lang elisp transform))
+  ;; Now switch into Emacs Lisp syntax.
-(read-set! keywords 'prefix)
+  #:use-syntax (lang elisp transform))
-(read-set! language 'elisp)
+
-(set-module-transformer! (current-module) transformer)
+;(use-modules (lang elisp transform))
+;(read-set! keywords 'prefix)
+;(set-module-transformer! (current-module) transformer)
 
 ;;; Everything below here is written in Elisp.
 

lang/elisp/internals/null.scm

@@ -3,4 +3,5 @@
 
 (define (null obj)
   (or (not obj)
-      (null? obj)))
+      (null? obj)
+      (eq? obj 'nil)))			; Should be removed.

lang/elisp/internals/set.scm

@@ -1,9 +1,18 @@
 (define-module (lang elisp internals set)
   #:use-module (lang elisp internals evaluation)
   #:use-module (lang elisp internals signal)
-  #:export (set))
+  #:export (set value))
 
 ;; Set SYM's variable value to VAL, and return VAL.
 (define (set sym val)
   (module-define! the-elisp-module sym val)
   val)
+
+;; Return SYM's variable value.  If it has none, signal an error if
+;; MUST-EXIST is true, just return #nil otherwise.
+(define (value sym must-exist)
+  (if (module-defined? the-elisp-module sym)
+      (module-ref the-elisp-module sym)
+      (if must-exist
+	  (error "Symbol's value as variable is void:" sym)
+	  %nil)))

lang/elisp/primitives/Makefile.am

@@ -39,6 +39,7 @@ elisp_sources = \
 	signal.scm \
 	strings.scm \
 	symprop.scm \
+	syntax.scm \
 	system.scm \
 	time.scm
 

lang/elisp/primitives/fns.scm

@@ -1,5 +1,7 @@
 (define-module (lang elisp primitives fns)
-  #:use-module (lang elisp internals fset))
+  #:use-module (lang elisp internals set)
+  #:use-module (lang elisp internals fset)
+  #:use-module (lang elisp internals null))
 
 (fset 'fset fset)
 (fset 'defalias fset)
@@ -12,11 +14,11 @@
 
 (fset 'interactive-p
       (lambda ()
-	#f))
+	%nil))
 
 (fset 'commandp
       (lambda (sym)
-	(if (interactive-spec (fref sym)) #t #f)))
+	(if (interactive-spec (fref sym)) #t %nil)))
 
 (fset 'fboundp
       (lambda (sym)
@@ -32,14 +34,12 @@
 
 (fset 'byte-code-function-p
       (lambda (object)
-	#f))
+	%nil))
 
 (fset 'run-hooks
-      (lambda (hooks)
+      (lambda hooks
-	(cond ((null hooks))
+	(for-each (lambda (hooksym)
-	      ((list? hooks)
+		    (for-each (lambda (fn)
-	       (for-each (lambda (hook)
+				(elisp-apply fn '()))
-			   (elisp-apply hook '()))
+			      (value hooksym #f)))
-			 hooks))
+		  hooks)))
-	      (else
-	       (elisp-apply hooks '())))))

lang/elisp/primitives/lists.scm

@@ -46,10 +46,16 @@
 	    (fset sym
 		  (lambda (elt list)
 		    (if (null list)
-			#f
+			%nil
 			(if (null elt)
 			    (or (proc #f list)
-				(proc '() list))
+				(proc '() list)
+				(proc %nil list)
+				(proc 'nil list)) ; 'nil shouldn't be
+						  ; here, as it should
+						  ; have been
+						  ; translated by the
+						  ; transformer.
 			    (proc elt list))))))
 	  '( memq  member  assq  assoc)
 	  `(,memq ,member ,assq ,assoc))

lang/elisp/primitives/strings.scm

@@ -29,3 +29,5 @@
 	      (else (wta 'arrayp array 1)))))
 
 (fset 'stringp string?)
+
+(fset 'vector vector)

lang/elisp/primitives/symprop.scm

@@ -22,9 +22,7 @@
 
 (fset 'symbol-value
       (lambda (sym)
-	(if (module-defined? the-elisp-module sym)
+	(value sym #t)))
-	    (module-ref the-elisp-module sym)
-	    (error "Symbol's value as variable is void:" sym))))
 
 (fset 'default-value 'symbol-value)
 

lang/elisp/primitives/syntax.scm

@@ -0,0 +1,359 @@
+(define-module (lang elisp primitives syntax)
+  #:use-module (lang elisp internals evaluation)
+  #:use-module (lang elisp internals fset)
+  #:use-module (lang elisp internals trace)
+  #:use-module (lang elisp transform))
+
+;;; Define Emacs Lisp special forms as macros.  This is much more
+;;; flexible than handling them specially in the translator: allows
+;;; them to be redefined, and hopefully allows better source location
+;;; tracking.
+
+;;; {Variables}
+
+(define (setq exp env)
+  (cons begin
+	(let loop ((sets (cdr exp)) (last-sym #f))
+	  (if (null? sets)
+	      (list last-sym)
+	      (cons `(,module-define! ,the-elisp-module
+				      (,quote ,(car sets))
+				      ,(transformer (cadr sets)))
+		    (loop (cddr sets) (car sets)))))))
+
+(fset 'setq
+      (procedure->memoizing-macro setq))
+
+(fset 'defvar
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  (trc 'defvar (cadr exp))
+	  (if (null? (cddr exp))
+	      `(,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
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  (trc 'defconst (cadr exp))
+	  `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
+		   (,quote ,(cadr exp))))))
+
+;;; {lambda, function and macro definitions}
+
+;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
+;;; returns three values: (i) list of symbols for required arguments,
+;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
+;;; #f if there is no rest argument.
+(define (parse-formals formals)
+  (letrec ((do-required
+	    (lambda (required formals)
+	      (if (null? formals)
+		  (values (reverse required) '() #f)
+		  (let ((next-sym (car formals)))
+		    (cond ((not (symbol? next-sym))
+			   (error "Bad formals (non-symbol in required list)"))
+			  ((eq? next-sym '&optional)
+			   (do-optional required '() (cdr formals)))
+			  ((eq? next-sym '&rest)
+			   (do-rest required '() (cdr formals)))
+			  (else
+			   (do-required (cons next-sym required)
+					(cdr formals))))))))
+	   (do-optional
+	    (lambda (required optional formals)
+	      (if (null? formals)
+		  (values (reverse required) (reverse optional) #f)
+		  (let ((next-sym (car formals)))
+		    (cond ((not (symbol? next-sym))
+			   (error "Bad formals (non-symbol in optional list)"))
+			  ((eq? next-sym '&rest)
+			   (do-rest required optional (cdr formals)))
+			  (else
+			   (do-optional required
+					(cons next-sym optional)
+					(cdr formals))))))))
+	   (do-rest
+	    (lambda (required optional formals)
+	      (if (= (length formals) 1)
+		  (let ((next-sym (car formals)))
+		    (if (symbol? next-sym)
+			(values (reverse required) (reverse optional) next-sym)
+			(error "Bad formals (non-symbol rest formal)")))
+		  (error "Bad formals (more than one rest formal)")))))
+
+    (do-required '() (cond ((list? formals)
+			    formals)
+			   ((symbol? formals)
+			    (list '&rest formals))
+			   (else
+			    (error "Bad formals (not a list or a single symbol)"))))))
+
+(define (transform-lambda exp)
+  (call-with-values (lambda () (parse-formals (cadr exp)))
+    (lambda (required optional rest)
+      (let ((num-required (length required))
+	    (num-optional (length optional)))
+	`(,lambda %--args
+	   (,let ((%--num-args (,length %--args)))
+	     (,cond ((,< %--num-args ,num-required)
+		     (,error "Wrong number of args (not enough required args)"))
+		    ,@(if rest
+			  '()
+			  `(((,> %--num-args ,(+ num-required num-optional))
+			     (,error "Wrong number of args (too many args)"))))
+		    (else
+		     (@bind ,(append (map (lambda (i)
+					    (list (list-ref required i)
+						  `(,list-ref %--args ,i)))
+					  (iota num-required))
+				     (map (lambda (i)
+					    (let ((i+nr (+ i num-required)))
+					      (list (list-ref optional i)
+						    `(,if (,> %--num-args ,i+nr)
+							  (,list-ref %--args ,i+nr)
+							  #f))))
+					  (iota num-optional))
+				     (if rest
+					 (list (list rest
+						     `(,if (,> %--num-args
+							       ,(+ num-required
+								   num-optional))
+							   (,list-tail %--args
+								       ,(+ num-required
+									   num-optional))
+							   '())))
+					 '()))
+			    ,@(map transformer (cddr exp)))))))))))
+
+(define interactive-spec (make-fluid))
+
+(define (set-not-subr! proc boolean)
+  (set! (not-subr? proc) boolean))
+
+(define (transform-lambda/interactive exp name)
+  (fluid-set! interactive-spec #f)
+  (let* ((x (transform-lambda exp))
+	 (is (fluid-ref interactive-spec)))
+    `(,let ((%--lambda ,x))
+       (,set-procedure-property! %--lambda (,quote name) (,quote ,name))
+       (,set-not-subr! %--lambda #t)
+       ,@(if is
+	     `((,set! (,interactive-spec %--lambda) (,quote ,is)))
+	     '())
+       %--lambda)))
+
+(fset 'lambda
+      (procedure->memoizing-macro
+       (lambda (exp env)
+	 (transform-lambda/interactive exp '<elisp-lambda>))))
+
+(fset 'defun
+      (procedure->memoizing-macro
+       (lambda (exp env)
+	 (trc 'defun (cadr exp))
+	 `(,begin (,fset (,quote ,(cadr exp))
+			 ,(transform-lambda/interactive (cdr exp)
+							(symbol-append '<elisp-defun:
+								       (cadr exp)
+								       '>)))
+		  (,quote ,(cadr exp))))))
+
+(fset 'interactive
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  (fluid-set! interactive-spec exp)
+	  #f)))
+
+(fset 'defmacro
+      (procedure->memoizing-macro
+       (lambda (exp env)
+	 (trc 'defmacro (cadr exp))
+	 (call-with-values (lambda () (parse-formals (caddr exp)))
+	   (lambda (required optional rest)
+	     (let ((num-required (length required))
+		   (num-optional (length optional)))
+	       `(,begin (,fset (,quote ,(cadr exp))
+			       (,procedure->memoizing-macro
+				(,lambda (exp1 env1)
+				  (,trc (,quote using) (,quote ,(cadr exp)))
+				  (,let* ((%--args (,cdr exp1))
+					  (%--num-args (,length %--args)))
+				    (,cond ((,< %--num-args ,num-required)
+					    (,error "Wrong number of args (not enough required args)"))
+					   ,@(if rest
+						 '()
+						 `(((,> %--num-args ,(+ num-required num-optional))
+						    (,error "Wrong number of args (too many args)"))))
+					   (else (,transformer
+						  (@bind ,(append (map (lambda (i)
+									 (list (list-ref required i)
+									       `(,list-ref %--args ,i)))
+								       (iota num-required))
+								  (map (lambda (i)
+									 (let ((i+nr (+ i num-required)))
+									   (list (list-ref optional i)
+										 `(,if (,> %--num-args ,i+nr)
+										       (,list-ref %--args ,i+nr)
+										       #f))))
+								       (iota num-optional))
+								  (if rest
+								      (list (list rest
+										  `(,if (,> %--num-args
+											    ,(+ num-required
+												num-optional))
+											(,list-tail %--args
+												    ,(+ num-required
+													num-optional))
+											'())))
+								      '()))
+							 ,@(map transformer (cdddr exp)))))))))))))))))
+
+;;; {Sequencing}
+
+(fset 'progn
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  `(,begin ,@(map transformer (cdr exp))))))
+
+(fset 'prog1
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  `(,let ((%res1 ,(transformer (cadr exp))))
+	     ,@(map transformer (cddr exp))
+	     %res1))))
+
+(fset 'prog2
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  `(,begin ,(transformer (cadr exp))
+		   (,let ((%res2 ,(transformer (caddr exp))))
+		     ,@(map transformer (cdddr exp))
+		     %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))
+		  ((null? (cdr else-case))
+		   `(nil-cond ,(transformer (cadr exp))
+			      ,(transformer (caddr exp))
+			      ,(transformer (car else-case))))
+		  (else
+		   `(nil-cond ,(transformer (cadr exp))
+			      ,(transformer (caddr exp))
+			      (,begin ,@(map transformer else-case)))))))))
+
+(fset 'and
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  (cond ((null? (cdr exp)) #t)
+		((null? (cddr exp)) (transformer (cadr exp)))
+		(else
+		 (cons nil-cond
+		       (let loop ((args (cdr exp)))
+			 (if (null? (cdr args))
+			     (list (transformer (car args)))
+			     (cons (list not (transformer (car args)))
+				   (cons #f
+					 (loop (cdr args))))))))))))
+
+(fset 'or
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  (cond ((null? (cdr exp)) #f)
+		((null? (cddr exp)) (transformer (cadr exp)))
+		(else
+		 (cons nil-cond
+		       (let loop ((args (cdr exp)))
+			 (if (null? (cdr args))
+			     (list (transformer (car args)))
+			     (cons (transformer (car args))
+				   (cons <--
+					 (loop (cdr args))))))))))))
+
+(fset 'cond
+      (procedure->memoizing-macro
+       (lambda (exp env)
+	 (if (null? (cdr exp))
+	     #f
+	     (cons
+	      nil-cond
+	      (let loop ((clauses (cdr exp)))
+		(if (null? clauses)
+		    '(#f)
+		    (let ((clause (car clauses)))
+		      (if (eq? (car clause) #t)
+			  (cond ((null? (cdr clause)) '(t))
+				((null? (cddr clause))
+				 (list (transformer (cadr clause))))
+				(else `((,begin ,@(map transformer (cdr clause))))))
+			  (cons (transformer (car clause))
+				(cons (cond ((null? (cdr clause)) <--)
+					    ((null? (cddr clause))
+					     (transformer (cadr clause)))
+					    (else
+					     `(,begin ,@(map transformer (cdr clause)))))
+				      (loop (cdr clauses)))))))))))))
+
+(fset 'while
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  `((,letrec ((%--while (,lambda ()
+				  (,nil-cond ,(transformer (cadr exp))
+					     (,begin ,@(map transformer (cddr exp))
+						     (%--while))
+					     #f))))
+	      %--while)))))
+
+;;; {Local binding}
+
+(fset 'let
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  `(@bind ,(map (lambda (binding)
+			  (trc 'let binding)
+			  (if (pair? binding)
+			      `(,(car binding) ,(transformer (cadr binding)))
+			      `(,binding #f)))
+			(cadr exp))
+		  ,@(map transformer (cddr exp))))))
+
+(fset 'let*
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  (if (null? (cadr exp))
+	      `(begin ,@(map transformer (cddr exp)))
+	      (car (let loop ((bindings (cadr exp)))
+		     (if (null? bindings)
+			 (map transformer (cddr exp))
+			 `((@bind (,(let ((binding (car bindings)))
+				      (if (pair? binding)
+					  `(,(car binding) ,(transformer (cadr binding)))
+					  `(,binding #f))))
+				  ,@(loop (cdr bindings)))))))))))
+
+;;; {Exception handling}
+
+(fset 'unwind-protect
+      (procedure->memoizing-macro
+        (lambda (exp env)
+	  (trc 'unwind-protect (cadr exp))
+	  `(,let ((%--throw-args #f))
+	     (,catch #t
+	       (,lambda ()
+		 ,(transformer (cadr exp)))
+	       (,lambda args
+		 (,set! %--throw-args args)))
+	     ,@(map transformer (cddr exp))
+	     (,if %--throw-args
+		  (,apply ,throw %--throw-args))))))

lang/elisp/transform.scm

@@ -3,9 +3,7 @@
   #:use-module (lang elisp internals fset)
   #:use-module (lang elisp internals evaluation)
   #:use-module (ice-9 session)
-  #:export (transformer))
+  #:export (transformer transform))
-
-(define interactive-spec (make-fluid))
 
 ;;; {S-expressions}
 ;;;
@@ -16,7 +14,9 @@
 ;; Should be made mutating instead of constructing
 ;;
 (define (transformer x)
-  (cond ((null? x) '())
+  (cond ((eq? x 'nil) %nil)
+	((eq? x 't) #t)
+	((null? x) '())
 	((not (pair? x)) x)
 	((and (pair? (car x))
 	      (eq? (caar x) 'quasiquote))
@@ -27,43 +27,29 @@
 	   ; Escape to Scheme syntax
 	   ((scheme) (cons 'begin (cdr x)))
 	   ; Should be handled in reader
-	   ((quote function) (cons 'quote (cars->nil (cdr x))))
+	   ((quote function) `(,quote ,@(cars->nil (cdr x))))
 	   ((quasiquote) (m-quasiquote x '()))
-	   ((nil-cond) (transform-1 x))
+	   ;((nil-cond) (transform-1 x))
-	   ((let) (m-let x '()))
+	   ;((let) (m-let x '()))
-	   ((let*) (m-let* x '()))
+	   ;((let*) (m-let* x '()))
-	   ((if) (m-if x '()))
+	   ;((if) (m-if x '()))
-	   ((and) (m-and x '()))
+	   ;((and) (m-and x '()))
-	   ((or) (m-or x '()))
+	   ;((or) (m-or x '()))
-	   ((while) (m-while x '()))
+	   ;((while) (m-while x '()))
 	   ;((while) (cons macro-while (cdr x)))
-	   ((prog1) (m-prog1 x '()))
+	   ;((prog1) (m-prog1 x '()))
-	   ((prog2) (m-prog2 x '()))
+	   ;((prog2) (m-prog2 x '()))
-	   ((progn begin) (cons 'begin (map transformer (cdr x))))
+	   ;((progn) (cons 'begin (map transformer (cdr x))))
-	   ((cond) (m-cond x '()))
+	   ;((cond) (m-cond x '()))
-	   ((lambda) (transform-lambda/interactive x '<elisp-lambda>))
+	   ;((lambda) (transform-lambda/interactive x '<elisp-lambda>))
-	   ((defun) (m-defun x '()))
+	   ;((defun) (m-defun x '()))
-	   ((defmacro) (m-defmacro x '()))
+	   ;((defmacro) (m-defmacro x '()))
-	   ((setq) (m-setq x '()))
+	   ;((setq) (m-setq x '()))
-	   ((defvar) (m-defvar x '()))
+	   ;((interactive) (fluid-set! interactive-spec x) #f)
-	   ((defconst) (m-defconst x '()))
+	   ;((unwind-protect) (m-unwind-protect x '()))
-	   ((interactive) (fluid-set! interactive-spec x) #f)
-	   ((unwind-protect) (m-unwind-protect x '()))
 	   (else (transform-application x))))
 	(else (syntax-error x))))
 
-(define (m-unwind-protect exp env)
-  (trc 'unwind-protect (cadr exp))
-  `(let ((%--throw-args #f))
-     (catch #t
-	    (lambda ()
-	      ,(transformer (cadr exp)))
-	    (lambda args
-	      (set! %--throw-args args)))
-     ,@(transform-list (cddr exp))
-     (if %--throw-args
-	 (apply throw %--throw-args))))
-
 (define (m-quasiquote exp env)
   (cons 'quasiquote
 	(map transform-inside-qq (cdr exp))))
@@ -78,185 +64,17 @@
 	   (else (cons (car x) (map transform-inside-qq (cdr x))))))
 	(else
 	 (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))
-	
-(define (transform-1 x)
-  (cons (car x) (map transformer (cdr x))))
-
-(define (transform-2 x)
-  (cons (car x)
-	(cons (cadr x)
-	      (map transformer (cddr x)))))
-
-(define (transform-3 x)
-  (cons (car x)
-	(cons (cadr x)
-	      (cons (caddr x)
-		    (map transformer (cdddr x))))))
-
-(define (transform-list x)
-  (map transformer x))
-
-;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
-;;; returns three values: (i) list of symbols for required arguments,
-;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
-;;; #f if there is no rest argument.
-(define (parse-formals formals)
-  (letrec ((do-required
-	    (lambda (required formals)
-	      (if (null? formals)
-		  (values (reverse required) '() #f)
-		  (let ((next-sym (car formals)))
-		    (cond ((not (symbol? next-sym))
-			   (error "Bad formals (non-symbol in required list)"))
-			  ((eq? next-sym '&optional)
-			   (do-optional required '() (cdr formals)))
-			  ((eq? next-sym '&rest)
-			   (do-rest required '() (cdr formals)))
-			  (else
-			   (do-required (cons next-sym required)
-					(cdr formals))))))))
-	   (do-optional
-	    (lambda (required optional formals)
-	      (if (null? formals)
-		  (values (reverse required) (reverse optional) #f)
-		  (let ((next-sym (car formals)))
-		    (cond ((not (symbol? next-sym))
-			   (error "Bad formals (non-symbol in optional list)"))
-			  ((eq? next-sym '&rest)
-			   (do-rest required optional (cdr formals)))
-			  (else
-			   (do-optional required
-					(cons next-sym optional)
-					(cdr formals))))))))
-	   (do-rest
-	    (lambda (required optional formals)
-	      (if (= (length formals) 1)
-		  (let ((next-sym (car formals)))
-		    (if (symbol? next-sym)
-			(values (reverse required) (reverse optional) next-sym)
-			(error "Bad formals (non-symbol rest formal)")))
-		  (error "Bad formals (more than one rest formal)")))))
-
-    (do-required '() (cond ((list? formals)
-			    formals)
-			   ((symbol? formals)
-			    (list '&rest formals))
-			   (else
-			    (error "Bad formals (not a list or a single symbol)"))))))
-
-(define (transform-lambda/interactive exp name)
-  (fluid-set! interactive-spec #f)
-  (let* ((x (transform-lambda exp))
-	 (is (fluid-ref interactive-spec)))
-    `(let ((%--lambda ,x))
-       (set-procedure-property! %--lambda 'name ',name)
-       (set! (,not-subr? %--lambda) #t)
-       ,@(if is
-	     `((set! (,interactive-specification %--lambda) ',is))
-	     '())
-       %--lambda)))
-
-(define (transform-lambda exp)
-  (call-with-values (lambda () (parse-formals (cadr exp)))
-    (lambda (required optional rest)
-      (let ((num-required (length required))
-	    (num-optional (length optional)))
-	`(lambda %--args
-	   (let ((%--num-args (length %--args)))
-	     (cond ((< %--num-args ,num-required)
-		    (error "Wrong number of args (not enough required args)"))
-		   ,@(if rest
-			 '()
-			 `(((> %--num-args ,(+ num-required num-optional))
-			    (error "Wrong number of args (too many args)"))))
-		   (else
-		    (@bind ,(append (map (lambda (i)
-					   (list (list-ref required i)
-						 `(list-ref %--args ,i)))
-					 (iota num-required))
-				    (map (lambda (i)
-					   (let ((i+nr (+ i num-required)))
-					     (list (list-ref optional i)
-						   `(if (> %--num-args ,i+nr)
-							(list-ref %--args ,i+nr)
-							#f))))
-					 (iota num-optional))
-				    (if rest
-					(list (list rest
-						    `(if (> %--num-args
-							    ,(+ num-required
-								num-optional))
-							 (list-tail %--args
-								    ,(+ num-required
-									num-optional))
-							 '())))
-					'()))
-			   ,@(transform-list (cddr exp)))))))
-	))))
-
-(define (m-defun exp env)
-  (trc 'defun (cadr exp))
-  `(begin (,fset ',(cadr exp)
-		 ,(transform-lambda/interactive (cdr exp)
-						(symbol-append '<elisp-defun:
-							       (cadr exp)
-							       '>)))
-	  ',(cadr exp)))
-
-(define (m-defmacro exp env)
-  (trc 'defmacro (cadr exp))
-  (call-with-values (lambda () (parse-formals (caddr exp)))
-    (lambda (required optional rest)
-      (let ((num-required (length required))
-	    (num-optional (length optional)))
-	`(begin (,fset ',(cadr exp)
-		       (procedure->memoizing-macro
-			(lambda (exp1 env1)
-			  (,trc 'using ',(cadr exp))
-			  (let* ((%--args (cdr exp1))
-				 (%--num-args (length %--args)))
-			    (cond ((< %--num-args ,num-required)
-				   (error "Wrong number of args (not enough required args)"))
-				  ,@(if rest
-					'()
-					`(((> %--num-args ,(+ num-required num-optional))
-					   (error "Wrong number of args (too many args)"))))
-				  (else (,transformer
-					 (@bind ,(append (map (lambda (i)
-								(list (list-ref required i)
-								      `(list-ref %--args ,i)))
-							      (iota num-required))
-							 (map (lambda (i)
-								(let ((i+nr (+ i num-required)))
-								  (list (list-ref optional i)
-									`(if (> %--num-args ,i+nr)
-									     (list-ref %--args ,i+nr)
-									     #f))))
-							      (iota num-optional))
-							 (if rest
-							     (list (list rest
-									 `(if (> %--num-args
-										 ,(+ num-required
-										     num-optional))
-									      (list-tail %--args
-											 ,(+ num-required
-											     num-optional))
-									      '())))
-							     '()))
-						,@(transform-list (cdddr exp)))))))))))))))
 
 (define (transform-application x)
-  `(@fop ,(car x)
+  (cons-source x
-	 (,transformer-macro ,@(cdr x))))
+	       '@fop
+	       `(,(car x) (,transformer-macro ,@(cdr x)))))
 
 (define transformer-macro
   (procedure->memoizing-macro
-   (lambda (exp env)
+   (let ((cdr cdr))
-     (cons 'list (map transformer (cdr exp))))))
+     (lambda (exp env)
-
+       (cons 'list (map transformer (cdr exp)))))))
-;  (cons '@fop
-;	(cons (car x)
-;	      (map transformer (cdr x)))))
 
 (define (cars->nil ls)
   (cond ((not (pair? ls)) ls)
@@ -264,151 +82,4 @@
 	(else (cons (cars->nil (car ls))
 		    (cars->nil (cdr ls))))))
 
-;;; {Special forms}
+(define transform transformer)
-;;;
-
-(define (m-setq exp env)
-  (cons 'begin
-	(let loop ((sets (cdr exp)) (last-sym #f))
-	  (if (null? sets)
-	      (list last-sym)
-	      (cons `(module-define! ,the-elisp-module
-				     ',(car sets)
-				     ,(transformer (cadr sets)))
-		    (loop (cddr sets) (car sets)))))))
-
-;(define (m-setq exp env)
-;  (let* ((binder (car (last-pair env)))
-;	 (varvals (let loop ((ls (cdr exp)))
-;		    (if (null? ls)
-;			'()
-;			;; Ensure existence only at macro expansion time
-;			(let ((var (or (binder (car ls) #f)
-;				       (binder (car ls) #t))))
-;			  (if (not (variable-bound? var))
-;			      (variable-set! var #f))
-;			  (cons (list 'set! (car ls) (transformer (cadr ls)))
-;				(loop (cddr ls))))))))
-;    (cond ((null? varvals) '())
-;	  ((null? (cdr varvals)) (car varvals))
-;	  (else (cons 'begin varvals)))))
-
-(define (m-let exp env)
-  `(@bind ,(map (lambda (binding)
-		  (trc 'let binding)
-		  (if (pair? binding)
-		      `(,(car binding) ,(transformer (cadr binding)))
-		      `(,binding #f)))
-		(cadr exp))
-	  ,@(transform-list (cddr exp))))
-
-(define (m-let* exp env)
-  (if (null? (cadr exp))
-      `(begin ,@(transform-list (cddr exp)))
-      (car (let loop ((bindings (cadr exp)))
-	     (if (null? bindings)
-		 (transform-list (cddr exp))
-		 `((@bind (,(let ((binding (car bindings)))
-			      (if (pair? binding)
-				  `(,(car binding) ,(transformer (cadr binding)))
-				  `(,binding #f))))
-			  ,@(loop (cdr bindings)))))))))
-
-(define (m-prog1 exp env)
-  `(,let ((%res1 ,(transformer (cadr exp))))
-	 ,@(transform-list (cddr exp))
-	 %res1))
-
-(define (m-prog2 exp env)
-  `(begin ,(transformer (cadr exp))
-	  (,let ((%res2 ,(transformer (caddr exp))))
-		,@(transform-list (cdddr exp))
-		%res2)))
-
-(define <-- *unspecified*)
-
-(define (m-if exp env)
-  (let ((else-case (cdddr exp)))
-    (cond ((null? else-case)
-	   `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f))
-	  ((null? (cdr else-case))
-	   `(nil-cond ,(transformer (cadr exp))
-		      ,(transformer (caddr exp))
-		      ,(transformer (car else-case))))
-	  (else
-	   `(nil-cond ,(transformer (cadr exp))
-		      ,(transformer (caddr exp))
-		      (begin ,@(transform-list else-case)))))))
-
-(define (m-and exp env)
-  (cond ((null? (cdr exp)) #t)
-	((null? (cddr exp)) (transformer (cadr exp)))
-	(else
-	 (cons 'nil-cond
-	       (let loop ((args (cdr exp)))
-		 (if (null? (cdr args))
-		     (list (transformer (car args)))
-		     (cons (list 'not (transformer (car args)))
-			   (cons #f
-				 (loop (cdr args))))))))))
-
-(define (m-or exp env)
-  (cond ((null? (cdr exp)) #f)
-	((null? (cddr exp)) (transformer (cadr exp)))
-	(else
-	 (cons 'nil-cond
-	       (let loop ((args (cdr exp)))
-		 (if (null? (cdr args))
-		     (list (transformer (car args)))
-		     (cons (transformer (car args))
-			   (cons <--
-				 (loop (cdr args))))))))))
-
-(define m-cond
-  (lambda (exp env)
-    (if (null? (cdr exp))
-	#f
-	(cons
-	 'nil-cond
-	 (let loop ((clauses (cdr exp)))
-	   (if (null? clauses)
-	       '(#f)
-	       (let ((clause (car clauses)))
-		 (if (eq? (car clause) #t)
-		     (cond ((null? (cdr clause)) '(t))
-			   ((null? (cddr clause))
-			    (list (transformer (cadr clause))))
-			   (else `((begin ,@(transform-list (cdr clause))))))
-		     (cons (transformer (car clause))
-			   (cons (cond ((null? (cdr clause)) <--)
-				       ((null? (cddr clause))
-					(transformer (cadr clause)))
-				       (else
-					`(begin ,@(transform-list (cdr clause)))))
-				 (loop (cdr clauses))))))))))))
-
-(define (m-while exp env)
-  `(,let %while ()
-	 (nil-cond ,(transformer (cadr exp))
-		   (begin ,@(transform-list (cddr exp)) (%while))
-		   #f)))
-
-(define (m-defvar exp env)
-  (trc 'defvar (cadr exp))
-  (if (null? (cddr exp))
-      `',(cadr exp)
-      `(begin (if (not (defined? ',(cadr exp)))
-		  (,macro-setq ,(cadr exp) ,(caddr exp)))
-	      ',(cadr exp))))
-
-(define (m-defconst exp env)
-  (trc 'defconst (cadr exp))
-  `(begin ,(m-setq (list (car exp) (cadr exp) (caddr exp)) env)
-	  ',(cadr exp)))
-
-;(export-mmacros
-; '(setq defun let let* if and or cond while prog1 prog2 progn)
-; (list m-setq m-defun m-let m-let* m-if m-and m-or m-cond m-while m-prog1 m-prog2 begin))
-
-(define macro-setq (procedure->memoizing-macro m-setq))
-(define macro-while (procedure->memoizing-macro m-while))

libguile/ChangeLog

@@ -53,11 +53,11 @@
 	(scm_swap_fluids, scm_swap_fluids_reverse), list.c (scm_null_p,
 	scm_ilength, scm_append_x, scm_last_pair, scm_reverse,
 	scm_reverse_x, scm_list_ref, scm_list_set_x, scm_list_cdr_set_x,
-	scm_c_memq, scm_memv), load.c (scm_search_path), options.c
+	scm_c_memq, scm_memv, scm_member), load.c (scm_search_path),
-	(change_option_setting, scm_options), posix.c (environ_list_to_c),
+	options.c (change_option_setting, scm_options), posix.c
-	print.c (scm_iprlist), throw.c (scm_exit_status), vectors.c
+	(environ_list_to_c), print.c (scm_iprlist), throw.c
-	(scm_vector), weaks.c (scm_weak_vector): Use SCM_NULL_OR_NIL_P
+	(scm_exit_status), vectors.c (scm_vector), weaks.c
-	instead of SCM_NULLP.
+	(scm_weak_vector): Use SCM_NULL_OR_NIL_P instead of SCM_NULLP.
 
 	* boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of
 	just SCM_FALSEP.

test-suite/ChangeLog

@@ -1,3 +1,11 @@
+2002-01-25  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* tests/load.test: New test; for search-path with Elisp
+	nil-terminated lists for PATH and EXTENSIONS.
+
+	* tests/elisp.test: More tests for Scheme primitives that should
+	accept Elisp nil-terminated lists.
+
 2002-01-24  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* tests/elisp.test: More new tests for the Elisp nil value.

test-suite/tests/elisp.test

@@ -109,12 +109,22 @@
         (pass-if "length (with backquoted list)"
           (= (length `(a b c . ,%nil)) 3))
 
-	(pass-if "write"
+	(pass-if "write (%nil)"
+          (string=? (with-output-to-string
+		      (lambda () (write %nil)))
+		    "#nil"))		; Hmmm... should be "()" ?
+
+	(pass-if "display (%nil)"
+          (string=? (with-output-to-string
+		      (lambda () (display %nil)))
+		    "#nil"))		; Ditto.
+
+	(pass-if "write (list)"
           (string=? (with-output-to-string
 		      (lambda () (write (cons 'a %nil))))
 		    "(a)"))
 
-	(pass-if "display"
+	(pass-if "display (list)"
           (string=? (with-output-to-string
 		      (lambda () (display (cons 'a %nil))))
 		    "(a)"))
@@ -186,6 +196,72 @@
 	    (list-set! l 6 44)
 	    (= (list-ref l 6) 44)))
 
+	(pass-if "list-cdr-set!"
+	  (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
+	    (and (begin
+		   (list-cdr-set! l 4 44)
+		   (equal? l '(0 1 2 3 4 . 44)))
+		 (begin
+		   (list-cdr-set! l 3 `(new . ,%nil))
+		   (equal? l `(0 1 2 3 new . ,%nil))))))
+
+	(pass-if-exception "list-cdr-set!"
+	  exception:out-of-range
+	  (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
+	    (list-cdr-set! l 6 44)))
+
+        (pass-if "memq"
+          (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
+
+        (pass-if "memv"
+          (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
+
+        (pass-if "member"
+          (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil)))
+
+	(pass-if "list->vector"
+          (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil))))
+
+	(pass-if "list->vector"
+          (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil))))
+
+	(pass-if "list->weak-vector"
+          (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil))))
+
+	(pass-if "sorted?"
+	  (and (sorted? `(1 2 3 . ,%nil) <)
+	       (not (sorted? `(1 6 3 . ,%nil) <))))
+
+	(pass-if "merge"
+          (equal? (merge '(1 4 7 10)
+			 (merge `(2 5 8 11 . ,%nil)
+				`(3 6 9 12 . ,%nil)
+				<)
+			 <)
+		  `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
+
+	(pass-if "merge!"
+          (equal? (merge! (copy-tree '(1 4 7 10))
+			  (merge! (copy-tree `(2 5 8 11 . ,%nil))
+				  (copy-tree `(3 6 9 12 . ,%nil))
+				  <)
+			 <)
+		  `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
+
+	(pass-if "sort"
+          (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
+
+	(pass-if "stable-sort"
+          (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
+
+	(pass-if "sort!"
+          (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
+		  '(1 3 4 5 8)))
+
+	(pass-if "stable-sort!"
+          (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
+		  '(1 3 4 5 8)))
+
 	)
 
       (with-test-prefix "value preservation"

test-suite/tests/load.test

@@ -114,4 +114,13 @@
 (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
 (try-search-with-extensions path "ugly.ss"  extensions #f)
 
+(if (defined? '%nil)
+    ;; Check that search-path accepts Elisp nil-terminated lists for
+    ;; PATH and EXTENSIONS.
+    (with-test-prefix "elisp-nil"
+      (set-cdr! (last-pair path) %nil)
+      (set-cdr! (last-pair extensions) %nil)
+      (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
+      (try-search-with-extensions path "ugly.ss"  extensions #f)))
+      
 (delete-tree temp-dir)