diff options
author | Neil Jerram <neil@ossau.uklinux.net> | 2002-01-30 00:03:40 +0000 |
---|---|---|
committer | Neil Jerram <neil@ossau.uklinux.net> | 2002-01-30 00:03:40 +0000 |
commit | bbd26b5ae5a9a595f8a39abe906c46fe3f139da7 (patch) | |
tree | 1b6e5f7bf3250231978c4c8950a9fcad47cd97f6 | |
parent | f74fa0a0fde2a484cbf751b90798c75a15852150 (diff) | |
download | guile-bbd26b5ae5a9a595f8a39abe906c46fe3f139da7.tar.gz |
* Rename `call-with-readline-completion-function' to `with-readline-completion-function'.
* More tests for Elisp nil value.
* Development work on Elisp translator.
-rw-r--r-- | guile-readline/ChangeLog | 5 | ||||
-rw-r--r-- | guile-readline/readline.scm | 2 | ||||
-rw-r--r-- | lang/elisp/ChangeLog | 41 | ||||
-rw-r--r-- | lang/elisp/base.scm | 62 | ||||
-rw-r--r-- | lang/elisp/internals/null.scm | 3 | ||||
-rw-r--r-- | lang/elisp/internals/set.scm | 11 | ||||
-rw-r--r-- | lang/elisp/primitives/Makefile.am | 1 | ||||
-rw-r--r-- | lang/elisp/primitives/fns.scm | 24 | ||||
-rw-r--r-- | lang/elisp/primitives/lists.scm | 10 | ||||
-rw-r--r-- | lang/elisp/primitives/strings.scm | 2 | ||||
-rw-r--r-- | lang/elisp/primitives/symprop.scm | 4 | ||||
-rw-r--r-- | lang/elisp/primitives/syntax.scm | 359 | ||||
-rw-r--r-- | lang/elisp/transform.scm | 387 | ||||
-rw-r--r-- | libguile/ChangeLog | 10 | ||||
-rw-r--r-- | test-suite/ChangeLog | 8 | ||||
-rw-r--r-- | test-suite/tests/elisp.test | 80 | ||||
-rw-r--r-- | test-suite/tests/load.test | 9 |
17 files changed, 606 insertions, 412 deletions
diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 374e655e7..e56498535 100644 --- a/guile-readline/ChangeLog +++ b/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 diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 2afb03513..cae45e30b 100644 --- a/guile-readline/readline.scm +++ b/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 diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index 8338ab0e8..f1ed71dbb 100644 --- a/lang/elisp/ChangeLog +++ b/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. diff --git a/lang/elisp/base.scm b/lang/elisp/base.scm index 070be333b..c4d2b8d9a 100644 --- a/lang/elisp/base.scm +++ b/lang/elisp/base.scm @@ -1,34 +1,42 @@ -(define-module (lang elisp base)) +(define-module (lang elisp base) -;;; {Elisp Primitives} -;;; -;;; In other words, Scheme definitions of elisp primitives. This -;;; should (ultimately) include everything that Emacs defines in C. + ;; Be pure. Nothing in this module requires most of the standard + ;; Guile builtins, and it creates a problem if this module has + ;; access to them, as @bind can dynamically change their values. + #:pure -(use-modules (lang elisp primitives buffers) - (lang elisp primitives features) - (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)) + ;; But we do need a few builtins - import them here. + #:use-module ((guile) #:select (@fop @bind nil-cond)) -;;; 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)) -(read-set! keywords 'prefix) -(read-set! language 'elisp) -(set-module-transformer! (current-module) transformer) + ;; 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. diff --git a/lang/elisp/internals/null.scm b/lang/elisp/internals/null.scm index d574e3424..420278e0c 100644 --- a/lang/elisp/internals/null.scm +++ b/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. diff --git a/lang/elisp/internals/set.scm b/lang/elisp/internals/set.scm index cee332101..8137a6221 100644 --- a/lang/elisp/internals/set.scm +++ b/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))) diff --git a/lang/elisp/primitives/Makefile.am b/lang/elisp/primitives/Makefile.am index f2bd3e919..283467a41 100644 --- a/lang/elisp/primitives/Makefile.am +++ b/lang/elisp/primitives/Makefile.am @@ -39,6 +39,7 @@ elisp_sources = \ signal.scm \ strings.scm \ symprop.scm \ + syntax.scm \ system.scm \ time.scm diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm index 87b05c7e0..ba2b53a79 100644 --- a/lang/elisp/primitives/fns.scm +++ b/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) - (cond ((null hooks)) - ((list? hooks) - (for-each (lambda (hook) - (elisp-apply hook '())) - hooks)) - (else - (elisp-apply hooks '()))))) + (lambda hooks + (for-each (lambda (hooksym) + (for-each (lambda (fn) + (elisp-apply fn '())) + (value hooksym #f))) + hooks))) diff --git a/lang/elisp/primitives/lists.scm b/lang/elisp/primitives/lists.scm index be603e2c8..43843f811 100644 --- a/lang/elisp/primitives/lists.scm +++ b/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)) diff --git a/lang/elisp/primitives/strings.scm b/lang/elisp/primitives/strings.scm index 4326aeb93..08bd8f8de 100644 --- a/lang/elisp/primitives/strings.scm +++ b/lang/elisp/primitives/strings.scm @@ -29,3 +29,5 @@ (else (wta 'arrayp array 1))))) (fset 'stringp string?) + +(fset 'vector vector) diff --git a/lang/elisp/primitives/symprop.scm b/lang/elisp/primitives/symprop.scm index ffdc7e6ae..4ca169226 100644 --- a/lang/elisp/primitives/symprop.scm +++ b/lang/elisp/primitives/symprop.scm @@ -22,9 +22,7 @@ (fset 'symbol-value (lambda (sym) - (if (module-defined? the-elisp-module sym) - (module-ref the-elisp-module sym) - (error "Symbol's value as variable is void:" sym)))) + (value sym #t))) (fset 'default-value 'symbol-value) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm new file mode 100644 index 000000000..ac0951439 --- /dev/null +++ b/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)))))) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index 2f6ed8db5..ec1639d6e 100644 --- a/lang/elisp/transform.scm +++ b/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)) - -(define interactive-spec (make-fluid)) + #:export (transformer transform)) ;;; {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)) - ((let) (m-let x '())) - ((let*) (m-let* x '())) - ((if) (m-if x '())) - ((and) (m-and x '())) - ((or) (m-or x '())) - ((while) (m-while 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 begin) (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 '())) - ((defvar) (m-defvar x '())) - ((defconst) (m-defconst x '())) - ((interactive) (fluid-set! interactive-spec x) #f) - ((unwind-protect) (m-unwind-protect 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-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) - (,transformer-macro ,@(cdr x)))) + (cons-source x + '@fop + `(,(car x) (,transformer-macro ,@(cdr x))))) (define transformer-macro (procedure->memoizing-macro - (lambda (exp env) - (cons 'list (map transformer (cdr exp)))))) - -; (cons '@fop -; (cons (car x) -; (map transformer (cdr x))))) + (let ((cdr cdr)) + (lambda (exp env) + (cons 'list (map transformer (cdr exp))))))) (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 (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)) +(define transform transformer) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 767002040..bd6395e74 100644 --- a/libguile/ChangeLog +++ b/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 - (change_option_setting, scm_options), posix.c (environ_list_to_c), - print.c (scm_iprlist), throw.c (scm_exit_status), vectors.c - (scm_vector), weaks.c (scm_weak_vector): Use SCM_NULL_OR_NIL_P - instead of SCM_NULLP. + scm_c_memq, scm_memv, scm_member), load.c (scm_search_path), + options.c (change_option_setting, scm_options), posix.c + (environ_list_to_c), print.c (scm_iprlist), throw.c + (scm_exit_status), vectors.c (scm_vector), weaks.c + (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. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b407c1a81..c18b87194 100644 --- a/test-suite/ChangeLog +++ b/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. diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 3d7f3a303..a7a4c4a51 100644 --- a/test-suite/tests/elisp.test +++ b/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" diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 294bd252a..6b0de7612 100644 --- a/test-suite/tests/load.test +++ b/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) |