mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

use tree-il's support for optional arguments

Browse source 
* 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 2010-06-16 17:18:30 -04:00 • committed by Andy Wingo
parent 450cb50419
commit eda83f0ac9
1 changed files with 101 additions and 189 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -25,6 +25,9 @@
#: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) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (compile-tree-il)) #:export (compile-tree-il))
;;; Certain common parameters (like the bindings data structure or ;;; Certain common parameters (like the bindings data structure or
@ -417,202 +420,111 @@
(error "invalid mode in split-lambda-arguments" (error "invalid mode in split-lambda-arguments"
mode))))))))) mode)))))))))
;;; Compile a lambda expression. Things get a little complicated because ;;; Compile a lambda expression. One thing we have to be aware of is
;;; TreeIL does not allow optional arguments but only one rest argument, ;;; that lambda arguments are usually dynamically bound, even when a
;;; and also the rest argument should be nil instead of '() for no ;;; lexical binding is intact for a symbol. For symbols that are marked
;;; values given. Because of this, we have to do a little preprocessing ;;; as 'always lexical,' however, we lexically bind here as well, and
;;; to get everything done before the real body is called. ;;; thus we get them out of the let-dynamic call and register a lexical
;;; ;;; binding for them (the lexical target variable is already there,
;;; (lambda (a &optional b &rest c) body) should become: ;;; namely the real lambda argument from TreeIL).
;;; (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.
(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 must not be empty"))
(call-with-values (receive (required optional rest lexical dynamic)
(lambda () (split-lambda-arguments loc args)
(split-lambda-arguments loc args)) (define (process-args args)
(lambda (required optional rest lexical dynamic) (define (find-pairs pairs filter)
(let* ((make-sym (lambda (sym) (gensym))) (lset-intersection (lambda (name+sym x)
(required-sym (map make-sym required)) (eq? (car name+sym) x))
(required-pairs (map cons required required-sym)) pairs
(have-real-rest (or rest (not (null? optional)))) filter))
(rest-sym (if have-real-rest (gensym) '())) (let* ((syms (map (lambda (x) (gensym)) args))
(rest-name (if rest rest rest-sym)) (pairs (map cons args syms))
(rest-lexical (and rest (memq rest lexical))) (lexical-pairs (find-pairs pairs lexical))
(rest-dynamic (and rest (not rest-lexical))) (dynamic-pairs (find-pairs pairs dynamic)))
(real-args (append required-sym rest-sym)) (values syms pairs lexical-pairs dynamic-pairs)))
(arg-names (append required rest-name)) (let*-values (((required-syms
(lex-optionals (lset-intersection eq? optional lexical)) required-pairs
(dyn-optionals (lset-intersection eq? optional dynamic)) required-lex-pairs
(optional-sym (map make-sym lex-optionals)) required-dyn-pairs)
(optional-lex-pairs (map cons lex-optionals optional-sym)) (process-args required))
(find-required-pairs (lambda (filter) ((optional-syms
(lset-intersection optional-pairs
(lambda (name-sym el) optional-lex-pairs
(eq? (car name-sym) el)) optional-dyn-pairs)
required-pairs (process-args optional))
filter))) ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
(required-lex-pairs (find-required-pairs lexical)) (process-args (if rest (list rest) '())))
(rest-pair (if rest-lexical `((,rest . ,rest-sym)) '())) ((the-rest-sym) (if rest (car rest-syms) #f))
(all-lex-pairs (append required-lex-pairs ((all-syms) (append required-syms
optional-lex-pairs optional-syms
rest-pair))) rest-syms))
(for-each (lambda (sym) ((all-lex-pairs) (append required-lex-pairs
(mark-global-needed! (fluid-ref bindings-data) optional-lex-pairs
sym rest-lex-pairs))
value-slot)) ((all-dyn-pairs) (append required-dyn-pairs
dynamic) optional-dyn-pairs
(with-dynamic-bindings rest-dyn-pairs)))
(fluid-ref bindings-data) (for-each (lambda (sym)
dynamic (mark-global-needed! (fluid-ref bindings-data)
(lambda () sym
(with-lexical-bindings value-slot))
(fluid-ref bindings-data) dynamic)
(map car all-lex-pairs) (with-dynamic-bindings
(map cdr all-lex-pairs) (fluid-ref bindings-data)
(lambda () dynamic
(make-lambda loc (lambda ()
'() (with-lexical-bindings
(make-lambda-case (fluid-ref bindings-data)
#f (map car all-lex-pairs)
required (map cdr all-lex-pairs)
#f (lambda ()
(if have-real-rest rest-name #f) (make-lambda
#f loc
'() '()
(if have-real-rest (make-lambda-case
(append required-sym (list rest-sym)) #f
required-sym) required
(let* ((init-req optional
(map (lambda (name-sym) rest
(make-lexical-ref #f
loc (map (lambda (x) (nil-value loc)) optional)
(car name-sym) all-syms
(cdr name-sym))) (let ((compiled-body
(find-required-pairs dynamic))) (make-sequence loc (map compile-expr body))))
(init-nils (make-sequence
(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
loc loc
rest-name (list
rest-sym (if rest
(call-primitive (make-conditional
loc loc
'cdr (call-primitive loc
(make-lexical-ref loc rest-name rest-sym))) 'null?
(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
(make-lexical-ref loc (make-lexical-ref loc
rest-name rest
rest-sym)))) the-rest-sym))
((not (null? rest-sym)) (make-lexical-set loc
(make-conditional loc rest-empty rest
(make-void loc) the-rest-sym
(runtime-error (nil-value loc))
loc (make-void loc))
"too many arguments and no rest argument"))) (make-void loc))
(else (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 ;;; 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 ;;; a correct doc string and arguments as well as maybe in the future