mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

Allow lexical binding of lambda arguments.

Browse source 
* module/language/elisp/compile-tree-il.scm: Rework lambda compiler to allow
  opional lexical binding of (some) lambda arguments.
* test-suite/tests/elisp-compiler.test: Check this.
This commit is contained in:
Daniel Kraft 2009-08-01 13:00:27 +02:00
parent c808c926fd
commit dfbc6e9d54
2 changed files with 174 additions and 55 deletions
Download patch file Download diff file Expand all files Collapse all files

175
module/language/elisp/compile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; Guile Emac Lisp
;;; Guile Emacs Lisp
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; Copyright (C) 2009 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@ -24,6 +24,7 @@
#:use-module (language tree-il)
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (srfi srfi-1)
#:export (compile-tree-il))
@ -304,36 +305,74 @@
; Split the argument list of a lambda expression into required, optional and
; rest arguments and also check it is actually valid.
; Additionally, we create a list of all "local variables" (that is, required,
; optional and rest arguments together) and also this one split into those to
; be bound lexically and dynamically.
; Returned is as multiple values: required optional rest lexical dynamic
(define (bind-arg-lexical? arg)
(let ((always (fluid-ref always-lexical)))
(or (eq? always 'all)
(memq arg always))))
(define (split-lambda-arguments loc args)
(let iterate ((tail args)
(mode 'required)
(required '())
(optional '()))
(optional '())
(lexical '())
(dynamic '()))
(cond
((null? tail)
(values (reverse required) (reverse optional) #f))
(let ((final-required (reverse required))
(final-optional (reverse optional))
(final-lexical (reverse lexical))
(final-dynamic (reverse dynamic)))
(values final-required final-optional #f
final-lexical final-dynamic)))
((and (eq? mode 'required)
(eq? (car tail) '&optional))
(iterate (cdr tail) 'optional required optional))
(iterate (cdr tail) 'optional required optional lexical dynamic))
((eq? (car tail) '&rest)
(if (or (null? (cdr tail))
(not (null? (cddr tail))))
(report-error loc "expected exactly one symbol after &rest")
(values (reverse required) (reverse optional) (cadr tail))))
(let* ((rest (cadr tail))
(rest-lexical (bind-arg-lexical? rest))
(final-required (reverse required))
(final-optional (reverse optional))
(final-lexical (reverse (if rest-lexical
(cons rest lexical)
lexical)))
(final-dynamic (reverse (if rest-lexical
dynamic
(cons rest dynamic)))))
(values final-required final-optional rest
final-lexical final-dynamic))))
(else
(if (not (symbol? (car tail)))
(report-error loc "expected symbol in argument list, got" (car tail))
(let* ((arg (car tail))
(bind-lexical (bind-arg-lexical? arg))
(new-lexical (if bind-lexical
(cons arg lexical)
lexical))
(new-dynamic (if bind-lexical
dynamic
(cons arg dynamic))))
(case mode
((required) (iterate (cdr tail) mode
(cons (car tail) required) optional))
(cons arg required) optional
new-lexical new-dynamic))
((optional) (iterate (cdr tail) mode
required (cons (car tail) optional)))
((else) (error "invalid mode in split-lambda-arguments" mode))))))))
required (cons arg optional)
new-lexical new-dynamic))
(else
(error "invalid mode in split-lambda-arguments" mode)))))))))
; Compile a lambda expression. Things get a little complicated because TreeIL
@ -357,77 +396,125 @@
; This is formulated very imperatively, but I think in this case that is quite
; clear and better than creating a lot of nested let's.
;
; Another thing we have to be aware of is that lambda arguments are always
; Another thing we have to be aware of is that lambda arguments are usually
; dynamically bound, even when a lexical binding is in tact for a symbol.
; For symbols that are marked as 'always lexical' however, we bind them here
; lexically, too -- and thus we get them out of the with-fluids* call and
; register a lexical binding for them (the lexical target variable is already
; there, namely the real lambda argument from TreeIL).
; For optional arguments that are lexically bound we need to create the lexical
; bindings though with an additional let, as those arguments are not part of the
; ordinary argument list.
(define (compile-lambda loc args body)
(if (not (list? args))
(report-error loc "expected list for argument-list" args))
(if (null? body)
(report-error loc "function body might not be empty"))
(with-dynamic-bindings (fluid-ref bindings-data) args
(lambda ()
(call-with-values
(lambda ()
(split-lambda-arguments loc args))
(lambda (required optional rest)
(let ((required-sym (map (lambda (sym) (gensym)) required))
(rest-sym (if (or rest (not (null? optional))) (gensym) '())))
(let ((real-args (append required-sym rest-sym))
(locals `(,@required ,@optional ,@(if rest (list rest) '()))))
(make-lambda loc
real-args real-args '()
(begin
(lambda (required optional rest lexical dynamic)
(let* ((make-sym (lambda (sym) (gensym)))
(required-sym (map make-sym required))
(required-pairs (map cons required required-sym))
(have-real-rest (or rest (not (null? optional))))
(rest-sym (if have-real-rest (gensym) '()))
(rest-name (if rest rest rest-sym))
(rest-lexical (and rest (memq rest lexical)))
(rest-dynamic (and rest (not rest-lexical)))
(real-args (append required-sym rest-sym))
(arg-names (append required rest-name))
(lex-optionals (lset-intersection eq? optional lexical))
(dyn-optionals (lset-intersection eq? optional dynamic))
(optional-sym (map make-sym lex-optionals))
(optional-lex-pairs (map cons lex-optionals optional-sym))
(find-required-pairs (lambda (filter)
(lset-intersection (lambda (name-sym el)
(eq? (car name-sym)
el))
required-pairs filter)))
(required-lex-pairs (find-required-pairs lexical))
(rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
(all-lex-pairs (append required-lex-pairs optional-lex-pairs
rest-pair)))
(for-each (lambda (sym)
(mark-fluid-needed! (fluid-ref bindings-data)
sym value-slot))
locals)
(call-primitive loc 'with-fluids*
(make-application loc (make-primitive-ref loc 'list)
(map (lambda (sym)
dynamic)
(with-dynamic-bindings (fluid-ref bindings-data) dynamic
(lambda ()
(with-lexical-bindings (fluid-ref bindings-data)
(map car all-lex-pairs)
(map cdr all-lex-pairs)
(lambda ()
(make-lambda loc
arg-names real-args '()
(let* ((fluids (map (lambda (sym)
(make-module-ref loc value-slot sym #t))
locals))
(make-application loc (make-primitive-ref loc 'list)
(append (map (lambda (sym) (make-lexical-ref loc sym sym))
required-sym)
(map (lambda (sym) (nil-value loc))
(if rest
`(,@optional ,rest-sym)
optional))))
dynamic))
(init-req (map (lambda (name-sym)
(make-lexical-ref loc (car name-sym)
(cdr name-sym)))
(find-required-pairs dynamic)))
(init-nils (map (lambda (sym) (nil-value loc))
(if rest-dynamic
`(,@dyn-optionals ,rest-sym)
dyn-optionals)))
(init (append init-req init-nils))
(func-body (make-sequence loc
`(,(process-optionals loc optional
rest-name rest-sym)
,(process-rest loc rest
rest-name rest-sym)
,@(map compile-expr body))))
(with-fluids-call (call-primitive loc 'with-fluids*
(make-application loc
(make-primitive-ref loc 'list)
fluids)
(make-application loc
(make-primitive-ref loc 'list)
init)
(make-lambda loc '() '() '()
(make-sequence loc
`(,(process-optionals loc optional rest-sym)
,(process-rest loc rest rest-sym)
,@(map compile-expr body))))))))))))))
func-body)))
(full-body (if (null? dynamic)
func-body
with-fluids-call)))
(if (null? optional-sym)
full-body
(make-let loc
optional-sym optional-sym
(map (lambda (sym) (nil-value loc)) optional-sym)
full-body))))))))))))
; Build the code to handle setting of optional arguments that are present
; and updating the rest list.
(define (process-optionals loc optional rest-sym)
(define (process-optionals loc optional rest-name rest-sym)
(let iterate ((tail optional))
(if (null? tail)
(make-void loc)
(make-conditional loc
(call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym))
(call-primitive loc 'null? (make-lexical-ref loc rest-name rest-sym))
(make-void loc)
(make-sequence loc
(list (set-variable! loc (car tail) value-slot
(call-primitive loc 'car
(make-lexical-ref loc rest-sym rest-sym)))
(make-lexical-set loc rest-sym rest-sym
(make-lexical-ref loc rest-name rest-sym)))
(make-lexical-set loc rest-name rest-sym
(call-primitive loc 'cdr
(make-lexical-ref loc rest-sym rest-sym)))
(make-lexical-ref loc rest-name rest-sym)))
(iterate (cdr tail))))))))
; This builds the code to set the rest variable to nil if it is empty.
(define (process-rest loc rest rest-sym)
(define (process-rest loc rest rest-name rest-sym)
(let ((rest-empty (call-primitive loc 'null?
(make-lexical-ref loc rest-sym rest-sym))))
(make-lexical-ref loc rest-name rest-sym))))
(cond
(rest
(make-conditional loc rest-empty
(make-void loc)
(set-variable! loc rest value-slot
(make-lexical-ref loc rest-sym rest-sym))))
(make-lexical-ref loc rest-name rest-sym))))
((not (null? rest-sym))
(make-conditional loc rest-empty
(make-void loc)

34
test-suite/tests/elisp-compiler.test
View file

@ -327,6 +327,8 @@
(lexical-let ((a 2) (b 42))
(and (= a 2) (= (dyna) 1)
((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
((lambda () (let ((a 3))
(and (= a 3) (= (dyna) 1)))))
(= a 2) (= (dyna) 1)))
(= a 1)))
@ -364,7 +366,37 @@
(defun dyna () a)
(with-always-lexical (a)
(let ((a 1))
(and (= a 1) (= (dyna) 0)))))))
(and (= a 1) (= (dyna) 0))))))
(pass-if "lexical lambda args"
(progn (setq a 1 b 1)
(defun dyna () a)
(defun dynb () b)
(with-always-lexical (a c)
((lambda (a b &optional c)
(and (= a 3) (= (dyna) 1)
(= b 2) (= (dynb) 2)
(= c 1)))
3 2 1))))
; Check if a lambda without dynamically bound arguments
; is tail-optimized by doing a deep recursion that would otherwise overflow
; the stack.
(pass-if "lexical lambda tail-recursion"
(with-always-lexical (i)
(setq to 1000000)
(defun iteration-1 (i)
(if (< i to)
(iteration-1 (1+ i))))
(iteration-1 0)
(setq x 0)
(defun iteration-2 ()
(if (< x to)
(setq x (1+ x))
(iteration-2)))
(iteration-2)
t)))
(with-test-prefix/compile "defconst and defvar"