+2002-02-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * primitives/syntax.scm (parse-formals, transform-lambda,
+ interactive-spec, set-not-subr!, transform-lambda/interactive):
+ Move into internals/lambda.scm so that these can also be used
+ by...
+
+ * internals/fset.scm (elisp-apply): Use `eval' and
+ `transform-lambda/interactive' to turn a quoted lambda expression
+ into a Scheme procedure.
+
+ * transform.scm (m-quasiquote): Don't quote `quasiquote' in
+ transformed code.
+ (transformer): Transform '() to #nil.
+
+2002-02-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * internals/Makefile.am (elisp_sources): Add lambda.scm.
+
+ * internals/lambda.scm (lang): New file.
+
2002-02-01 Neil Jerram <neil@ossau.uklinux.net>
* transform.scm (transformer), primitives/syntax.scm (let*):
evaluation.scm \
format.scm \
fset.scm \
+ lambda.scm \
load.scm \
null.scm \
set.scm \
(define-module (lang elisp internals fset)
- #:use-module (lang elisp internals signal)
#:use-module (lang elisp internals evaluation)
+ #:use-module (lang elisp internals lambda)
+ #:use-module (lang elisp internals signal)
#:export (fset
fref
fref/error-if-void
function)
((and (pair? function)
(eq? (car function) 'lambda))
- (eval function the-elisp-module))
+ (eval (transform-lambda/interactive function '<elisp-lambda>)
+ the-root-module))
(else
(signal 'invalid-function (list function))))
args))
--- /dev/null
+(define-module (lang elisp internals lambda)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp transform)
+ #:export (parse-formals
+ transform-lambda/interactive
+ interactive-spec))
+
+;;; 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 (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)))
+
+(define interactive-spec (make-fluid))
(define-module (lang elisp primitives syntax)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals lambda)
#: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.
+;;; Define Emacs Lisp special forms as macros. This is more flexible
+;;; than handling them specially in the translator: allows them to be
+;;; redefined, and hopefully allows better source location tracking.
;;; {Variables}
;;; {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)
(define (transformer x)
(cond ((eq? x 'nil) %nil)
((eq? x 't) #t)
- ((null? x) '())
+ ((null? x) %nil)
((not (pair? x)) x)
((and (pair? (car x))
(eq? (caar x) 'quasiquote))
(else (syntax-error x))))
(define (m-quasiquote exp env)
- (cons 'quasiquote
+ (cons quasiquote
(map transform-inside-qq (cdr exp))))
(define (transform-inside-qq x)
HCoop / bpt / guile.git / commitdiff