* More tests for Elisp nil value.
* Development work on Elisp translator.
+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
(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
+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.
-(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.
-
-(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))
-
-;;; Now switch into Emacs Lisp syntax.
-
-(use-modules (lang elisp transform))
-(read-set! keywords 'prefix)
-(read-set! language 'elisp)
-(set-module-transformer! (current-module) transformer)
-
-;;; Everything below here is written in Elisp.
-
-(defun load-emacs ()
- (message "Calling loadup.el to clothe the bare Emacs...")
- (load "loadup.el")
- (message "Guile Emacs now fully clothed"))
+(define-module (lang elisp base)
+
+ ;; 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
+
+ ;; 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
+ ;; 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)
+
+ ;; 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 ()
+ (message "Calling loadup.el to clothe the bare Emacs...")
+ (load "loadup.el")
+ (message "Guile Emacs now fully clothed"))
(define (null obj)
(or (not obj)
- (null? obj)))
+ (null? obj)
+ (eq? obj 'nil))) ; Should be removed.
(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)))
signal.scm \
strings.scm \
symprop.scm \
+ syntax.scm \
system.scm \
time.scm
(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)
(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)
(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)))
(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))
(else (wta 'arrayp array 1)))))
(fset 'stringp string?)
+
+(fset 'vector vector)
(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)
--- /dev/null
+(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))))))
-(define-module (lang elisp transform)
- #:use-module (lang elisp internals trace)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals evaluation)
- #:use-module (ice-9 session)
- #:export (transformer))
-
-(define interactive-spec (make-fluid))
-
-;;; {S-expressions}
-;;;
-
-(define (syntax-error x)
- (error "Syntax error in expression" x))
-
-;; Should be made mutating instead of constructing
-;;
-(define (transformer x)
- (cond ((null? x) '())
- ((not (pair? x)) 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) (cons '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 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 '()))
- (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))))
-
-(define (transform-inside-qq x)
- (trc 'transform-inside-qq x)
- (cond ((not (pair? x)) 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 (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))))
-
-(define transformer-macro
- (procedure->memoizing-macro
- (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)
- ((null? (car ls)) (cons '() (cars->nil (cdr ls))))
- (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-module (lang elisp transform)
+ #:use-module (lang elisp internals trace)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (ice-9 session)
+ #:export (transformer transform))
+
+;;; {S-expressions}
+;;;
+
+(define (syntax-error x)
+ (error "Syntax error in expression" x))
+
+;; Should be made mutating instead of constructing
+;;
+(define (transformer x)
+ (cond ((eq? x 'nil) %nil)
+ ((eq? x 't) #t)
+ ((null? x) '())
+ ((not (pair? x)) 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)
+ (cons 'quasiquote
+ (map transform-inside-qq (cdr exp))))
+
+(define (transform-inside-qq x)
+ (trc 'transform-inside-qq x)
+ (cond ((not (pair? x)) 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 (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))
+
+(define (transform-application x)
+ (cons-source 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)))))))
+
+(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)
(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.
+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.
(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)"))
(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"
(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)
HCoop / bpt / guile.git / commitdiff