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

195
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 ;; 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 ;; it under the terms of the GNU General Public License as published by
@ -24,6 +24,7 @@
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (system base compile) #:use-module (system base compile)
#:use-module (srfi srfi-1)
#:export (compile-tree-il)) #:export (compile-tree-il))
@ -304,36 +305,74 @@
; Split the argument list of a lambda expression into required, optional and ; Split the argument list of a lambda expression into required, optional and
; rest arguments and also check it is actually valid. ; 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) (define (split-lambda-arguments loc args)
(let iterate ((tail args) (let iterate ((tail args)
(mode 'required) (mode 'required)
(required '()) (required '())
(optional '())) (optional '())
(lexical '())
(dynamic '()))
(cond (cond
((null? tail) ((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) ((and (eq? mode 'required)
(eq? (car tail) '&optional)) (eq? (car tail) '&optional))
(iterate (cdr tail) 'optional required optional)) (iterate (cdr tail) 'optional required optional lexical dynamic))
((eq? (car tail) '&rest) ((eq? (car tail) '&rest)
(if (or (null? (cdr tail)) (if (or (null? (cdr tail))
(not (null? (cddr tail)))) (not (null? (cddr tail))))
(report-error loc "expected exactly one symbol after &rest") (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 (else
(if (not (symbol? (car tail))) (if (not (symbol? (car tail)))
(report-error loc "expected symbol in argument list, got" (car tail)) (report-error loc "expected symbol in argument list, got" (car tail))
(case mode (let* ((arg (car tail))
((required) (iterate (cdr tail) mode (bind-lexical (bind-arg-lexical? arg))
(cons (car tail) required) optional)) (new-lexical (if bind-lexical
((optional) (iterate (cdr tail) mode (cons arg lexical)
required (cons (car tail) optional))) lexical))
((else) (error "invalid mode in split-lambda-arguments" mode)))))))) (new-dynamic (if bind-lexical
dynamic
(cons arg dynamic))))
(case mode
((required) (iterate (cdr tail) mode
(cons arg required) optional
new-lexical new-dynamic))
((optional) (iterate (cdr tail) 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 ; 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 ; 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. ; 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. ; 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) (define (compile-lambda loc args body)
(if (not (list? args)) (if (not (list? args))
(report-error loc "expected list for argument-list" args)) (report-error loc "expected list for argument-list" args))
(if (null? body) (if (null? body)
(report-error loc "function body might not be empty")) (report-error loc "function body might not be empty"))
(with-dynamic-bindings (fluid-ref bindings-data) args (call-with-values
(lambda () (lambda ()
(call-with-values (split-lambda-arguments loc args))
(lambda () (lambda (required optional rest lexical dynamic)
(split-lambda-arguments loc args)) (let* ((make-sym (lambda (sym) (gensym)))
(lambda (required optional rest) (required-sym (map make-sym required))
(let ((required-sym (map (lambda (sym) (gensym)) required)) (required-pairs (map cons required required-sym))
(rest-sym (if (or rest (not (null? optional))) (gensym) '()))) (have-real-rest (or rest (not (null? optional))))
(let ((real-args (append required-sym rest-sym)) (rest-sym (if have-real-rest (gensym) '()))
(locals `(,@required ,@optional ,@(if rest (list rest) '())))) (rest-name (if rest rest rest-sym))
(make-lambda loc (rest-lexical (and rest (memq rest lexical)))
real-args real-args '() (rest-dynamic (and rest (not rest-lexical)))
(begin (real-args (append required-sym rest-sym))
(for-each (lambda (sym) (arg-names (append required rest-name))
(mark-fluid-needed! (fluid-ref bindings-data) (lex-optionals (lset-intersection eq? optional lexical))
sym value-slot)) (dyn-optionals (lset-intersection eq? optional dynamic))
locals) (optional-sym (map make-sym lex-optionals))
(call-primitive loc 'with-fluids* (optional-lex-pairs (map cons lex-optionals optional-sym))
(make-application loc (make-primitive-ref loc 'list) (find-required-pairs (lambda (filter)
(map (lambda (sym) (lset-intersection (lambda (name-sym el)
(make-module-ref loc value-slot sym #t)) (eq? (car name-sym)
locals)) el))
(make-application loc (make-primitive-ref loc 'list) required-pairs filter)))
(append (map (lambda (sym) (make-lexical-ref loc sym sym)) (required-lex-pairs (find-required-pairs lexical))
required-sym) (rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
(map (lambda (sym) (nil-value loc)) (all-lex-pairs (append required-lex-pairs optional-lex-pairs
(if rest rest-pair)))
`(,@optional ,rest-sym) (for-each (lambda (sym)
optional)))) (mark-fluid-needed! (fluid-ref bindings-data)
(make-lambda loc '() '() '() sym value-slot))
(make-sequence loc dynamic)
`(,(process-optionals loc optional rest-sym) (with-dynamic-bindings (fluid-ref bindings-data) dynamic
,(process-rest loc rest rest-sym) (lambda ()
,@(map compile-expr body)))))))))))))) (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))
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 '() '() '()
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 ; Build the code to handle setting of optional arguments that are present
; and updating the rest list. ; 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)) (let iterate ((tail optional))
(if (null? tail) (if (null? tail)
(make-void loc) (make-void loc)
(make-conditional 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-void loc)
(make-sequence loc (make-sequence loc
(list (set-variable! loc (car tail) value-slot (list (set-variable! loc (car tail) value-slot
(call-primitive loc 'car (call-primitive loc 'car
(make-lexical-ref loc rest-sym rest-sym))) (make-lexical-ref loc rest-name rest-sym)))
(make-lexical-set loc rest-sym rest-sym (make-lexical-set loc rest-name rest-sym
(call-primitive loc 'cdr (call-primitive loc 'cdr
(make-lexical-ref loc rest-sym rest-sym))) (make-lexical-ref loc rest-name rest-sym)))
(iterate (cdr tail)))))))) (iterate (cdr tail))))))))
; This builds the code to set the rest variable to nil if it is empty. ; 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? (let ((rest-empty (call-primitive loc 'null?
(make-lexical-ref loc rest-sym rest-sym)))) (make-lexical-ref loc rest-name rest-sym))))
(cond (cond
(rest (rest
(make-conditional loc rest-empty (make-conditional loc rest-empty
(make-void loc) (make-void loc)
(set-variable! loc rest value-slot (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)) ((not (null? rest-sym))
(make-conditional loc rest-empty (make-conditional loc rest-empty
(make-void loc) (make-void loc)

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

@ -327,6 +327,8 @@
(lexical-let ((a 2) (b 42)) (lexical-let ((a 2) (b 42))
(and (= a 2) (= (dyna) 1) (and (= a 2) (= (dyna) 1)
((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3) ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
((lambda () (let ((a 3))
(and (= a 3) (= (dyna) 1)))))
(= a 2) (= (dyna) 1))) (= a 2) (= (dyna) 1)))
(= a 1))) (= a 1)))
@ -364,7 +366,37 @@
(defun dyna () a) (defun dyna () a)
(with-always-lexical (a) (with-always-lexical (a)
(let ((a 1)) (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" (with-test-prefix/compile "defconst and defvar"