mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
use tree-il's support for optional arguments
* module/language/elisp/compile-tree-il.scm (compile-lambda): Use Tree-IL's support for optional arguments. (process-optionals, process-rest): Remove. Signed-off-by: Andy Wingo <wingo@pobox.com>
This commit is contained in:
Brian Templeton
Andy Wingo
parent
450cb50419
commit
eda83f0ac9
1 changed files with 101 additions and 189 deletions
|
|
@ -25,6 +25,9 @@
|
|||
#:use-module (system base pmatch)
|
||||
#:use-module (system base compile)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-8)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (compile-tree-il))
|
||||
|
||||
;;; Certain common parameters (like the bindings data structure or
|
||||
|
|
@ -417,202 +420,111 @@
|
|||
(error "invalid mode in split-lambda-arguments"
|
||||
mode)))))))))
|
||||
|
||||
;;; Compile a lambda expression. Things get a little complicated because
|
||||
;;; TreeIL does not allow optional arguments but only one rest argument,
|
||||
;;; and also the rest argument should be nil instead of '() for no
|
||||
;;; values given. Because of this, we have to do a little preprocessing
|
||||
;;; to get everything done before the real body is called.
|
||||
;;;
|
||||
;;; (lambda (a &optional b &rest c) body) should become:
|
||||
;;; (lambda (a_ . rest_)
|
||||
;;; (with-fluids* (list a b c) (list a_ nil nil)
|
||||
;;; (lambda ()
|
||||
;;; (if (not (null? rest_))
|
||||
;;; (begin
|
||||
;;; (fluid-set! b (car rest_))
|
||||
;;; (set! rest_ (cdr rest_))
|
||||
;;; (if (not (null? rest_))
|
||||
;;; (fluid-set! c rest_))))
|
||||
;;; body)))
|
||||
;;;
|
||||
;;; 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
|
||||
;;; 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 let-dynamic 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.
|
||||
;;; Compile a lambda expression. One thing we have to be aware of is
|
||||
;;; that lambda arguments are usually dynamically bound, even when a
|
||||
;;; lexical binding is intact for a symbol. For symbols that are marked
|
||||
;;; as 'always lexical,' however, we lexically bind here as well, and
|
||||
;;; thus we get them out of the let-dynamic call and register a lexical
|
||||
;;; binding for them (the lexical target variable is already there,
|
||||
;;; namely the real lambda argument from TreeIL).
|
||||
|
||||
(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"))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(split-lambda-arguments loc args))
|
||||
(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-global-needed! (fluid-ref bindings-data)
|
||||
sym
|
||||
value-slot))
|
||||
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
|
||||
'()
|
||||
(make-lambda-case
|
||||
#f
|
||||
required
|
||||
#f
|
||||
(if have-real-rest rest-name #f)
|
||||
#f
|
||||
'()
|
||||
(if have-real-rest
|
||||
(append required-sym (list rest-sym))
|
||||
required-sym)
|
||||
(let* ((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))))
|
||||
(dynlet (let-dynamic loc
|
||||
dynamic
|
||||
value-slot
|
||||
init
|
||||
func-body))
|
||||
(full-body (if (null? dynamic)
|
||||
func-body
|
||||
dynlet)))
|
||||
(if (null? optional-sym)
|
||||
full-body
|
||||
(make-let loc
|
||||
optional-sym
|
||||
optional-sym
|
||||
(map (lambda (sym)
|
||||
(nil-value loc))
|
||||
optional-sym)
|
||||
full-body)))
|
||||
#f))))))))))
|
||||
|
||||
;;; Build the code to handle setting of optional arguments that are
|
||||
;;; present and updating the rest list.
|
||||
|
||||
(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-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-name
|
||||
rest-sym)))
|
||||
(make-lexical-set
|
||||
(report-error loc "function body must not be empty"))
|
||||
(receive (required optional rest lexical dynamic)
|
||||
(split-lambda-arguments loc args)
|
||||
(define (process-args args)
|
||||
(define (find-pairs pairs filter)
|
||||
(lset-intersection (lambda (name+sym x)
|
||||
(eq? (car name+sym) x))
|
||||
pairs
|
||||
filter))
|
||||
(let* ((syms (map (lambda (x) (gensym)) args))
|
||||
(pairs (map cons args syms))
|
||||
(lexical-pairs (find-pairs pairs lexical))
|
||||
(dynamic-pairs (find-pairs pairs dynamic)))
|
||||
(values syms pairs lexical-pairs dynamic-pairs)))
|
||||
(let*-values (((required-syms
|
||||
required-pairs
|
||||
required-lex-pairs
|
||||
required-dyn-pairs)
|
||||
(process-args required))
|
||||
((optional-syms
|
||||
optional-pairs
|
||||
optional-lex-pairs
|
||||
optional-dyn-pairs)
|
||||
(process-args optional))
|
||||
((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
|
||||
(process-args (if rest (list rest) '())))
|
||||
((the-rest-sym) (if rest (car rest-syms) #f))
|
||||
((all-syms) (append required-syms
|
||||
optional-syms
|
||||
rest-syms))
|
||||
((all-lex-pairs) (append required-lex-pairs
|
||||
optional-lex-pairs
|
||||
rest-lex-pairs))
|
||||
((all-dyn-pairs) (append required-dyn-pairs
|
||||
optional-dyn-pairs
|
||||
rest-dyn-pairs)))
|
||||
(for-each (lambda (sym)
|
||||
(mark-global-needed! (fluid-ref bindings-data)
|
||||
sym
|
||||
value-slot))
|
||||
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
|
||||
'()
|
||||
(make-lambda-case
|
||||
#f
|
||||
required
|
||||
optional
|
||||
rest
|
||||
#f
|
||||
(map (lambda (x) (nil-value loc)) optional)
|
||||
all-syms
|
||||
(let ((compiled-body
|
||||
(make-sequence loc (map compile-expr body))))
|
||||
(make-sequence
|
||||
loc
|
||||
rest-name
|
||||
rest-sym
|
||||
(call-primitive
|
||||
loc
|
||||
'cdr
|
||||
(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-name rest-sym)
|
||||
(let ((rest-empty (call-primitive loc
|
||||
'null?
|
||||
(make-lexical-ref loc
|
||||
rest-name
|
||||
rest-sym))))
|
||||
(cond
|
||||
(rest
|
||||
(make-conditional loc
|
||||
rest-empty
|
||||
(make-void loc)
|
||||
(set-variable! loc
|
||||
rest
|
||||
value-slot
|
||||
(list
|
||||
(if rest
|
||||
(make-conditional
|
||||
loc
|
||||
(call-primitive loc
|
||||
'null?
|
||||
(make-lexical-ref loc
|
||||
rest-name
|
||||
rest-sym))))
|
||||
((not (null? rest-sym))
|
||||
(make-conditional loc rest-empty
|
||||
(make-void loc)
|
||||
(runtime-error
|
||||
loc
|
||||
"too many arguments and no rest argument")))
|
||||
(else (make-void loc)))))
|
||||
rest
|
||||
the-rest-sym))
|
||||
(make-lexical-set loc
|
||||
rest
|
||||
the-rest-sym
|
||||
(nil-value loc))
|
||||
(make-void loc))
|
||||
(make-void loc))
|
||||
(if (null? dynamic)
|
||||
compiled-body
|
||||
(let-dynamic loc
|
||||
dynamic
|
||||
value-slot
|
||||
(map (lambda (name-sym)
|
||||
(make-lexical-ref
|
||||
loc
|
||||
(car name-sym)
|
||||
(cdr name-sym)))
|
||||
all-dyn-pairs)
|
||||
compiled-body)))))
|
||||
#f)))))))))
|
||||
|
||||
;;; Handle the common part of defconst and defvar, that is, checking for
|
||||
;;; a correct doc string and arguments as well as maybe in the future
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue