summaryrefslogtreecommitdiff
path: root/module/language/elisp/compile-tree-il.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/elisp/compile-tree-il.scm')
-rw-r--r--module/language/elisp/compile-tree-il.scm974
1 files changed, 408 insertions, 566 deletions
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index e1d75ba7a..293495495 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -31,26 +31,24 @@
#:use-module (srfi srfi-26)
#:export (compile-tree-il
compile-progn
+ compile-eval-when-compile
compile-if
compile-defconst
compile-defvar
compile-setq
compile-let
- compile-lexical-let
compile-flet
+ compile-labels
compile-let*
- compile-lexical-let*
- compile-flet*
- compile-without-void-checks
- compile-with-always-lexical
compile-guile-ref
compile-guile-primitive
- compile-while
compile-function
compile-defmacro
compile-defun
#{compile-`}#
- compile-quote))
+ compile-quote
+ compile-%funcall
+ compile-%set-lexical-binding-mode))
;;; Certain common parameters (like the bindings data structure or
;;; compiler options) are not always passed around but accessed using
@@ -61,14 +59,7 @@
(define bindings-data (make-fluid))
-;;; Store for which symbols (or all/none) void checks are disabled.
-
-(define disable-void-check (make-fluid))
-
-;;; Store which symbols (or all/none) should always be bound lexically,
-;;; even with ordinary let and as lambda arguments.
-
-(define always-lexical (make-fluid))
+(define lexical-binding (make-fluid))
;;; Find the source properties of some parsed expression if there are
;;; any associated with it.
@@ -117,419 +108,246 @@
(define (report-error loc . args)
(apply error args))
-(define (runtime-error loc msg . args)
- (make-primcall loc 'error
- (cons (make-const loc msg) args)))
-
-;;; Generate code to ensure a global symbol is there for further use of
-;;; a given symbol. In general during the compilation, those needed are
-;;; only tracked with the bindings data structure. Afterwards, however,
-;;; for all those needed symbols the globals are really generated with
-;;; this routine.
-
-(define (generate-ensure-global loc sym module)
- (make-call loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
-(define (ensuring-globals loc bindings body)
- (list->seq
- loc
- `(,@(map-globals-needed (fluid-ref bindings)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,body)))
-
-;;; Build a construct that establishes dynamic bindings for certain
-;;; variables. We may want to choose between binding with fluids and
-;;; with-fluids* and using just ordinary module symbols and
-;;; setting/reverting their values with a dynamic-wind.
-
-(define (let-dynamic loc syms module vals body)
- (call-primitive
- loc
- 'with-fluids*
- (make-primcall loc 'list
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-primcall loc 'list vals)
- (make-lambda loc
- '()
- (make-lambda-case #f '() #f #f #f '() '() body #f))))
-
-;;; Handle access to a variable (reference/setting) correctly depending
-;;; on whether it is currently lexically or dynamically bound. lexical
-;;; access is done only for references to the value-slot module!
-
-(define (access-variable loc
- sym
- module
- handle-global
- handle-lexical
- handle-dynamic)
- (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (cond
- (lexical (handle-lexical lexical))
- ((equal? module function-slot) (handle-global))
- (else (handle-dynamic)))))
-
-;;; Generate code to reference a variable. For references in the
-;;; value-slot module, we may want to generate a lexical reference
-;;; instead if the variable has a lexical binding.
+(define (access-variable loc symbol handle-lexical handle-dynamic)
+ (cond
+ ((get-lexical-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-dynamic))))
-(define (reference-variable loc sym module)
+(define (reference-variable loc symbol)
(access-variable
loc
- sym
- module
- (lambda () (make-module-ref loc module sym #t))
- (lambda (lexical) (make-lexical-ref loc lexical lexical))
+ symbol
+ (lambda (lexical)
+ (make-lexical-ref loc lexical lexical))
(lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc
'fluid-ref
- (make-module-ref loc module sym #t)))))
+ (make-module-ref loc value-slot symbol #t)))))
+
+(define (global? module symbol)
+ (module-variable module symbol))
+
+(define (ensure-globals! loc names body)
+ (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (every symbol-interned? names))
+ body
+ (list->seq
+ loc
+ `(,@(map
+ (lambda (name)
+ (ensure-fluid! value-slot name)
+ (make-call loc
+ (make-module-ref loc runtime 'ensure-fluid! #t)
+ (list (make-const loc value-slot)
+ (make-const loc name))))
+ names)
+ ,body))))
+
+(define (set-variable! loc symbol value)
+ (access-variable
+ loc
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
+ (lambda ()
+ (ensure-globals!
+ loc
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
-;;; Generate code to set a variable. Just as with reference-variable, in
-;;; case of a reference to value-slot, we want to generate a lexical set
-;;; when the variable has a lexical binding.
+(define (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
-(define (set-variable! loc sym module value)
- (access-variable
+(define (reference-function loc symbol)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-ref loc symbol gensym))
+ (lambda () (make-module-ref loc function-slot symbol #t))))
+
+(define (set-function! loc symbol value)
+ (access-function
loc
- sym
- module
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
(lambda ()
(make-call
loc
- (make-module-ref loc runtime 'set-variable! #t)
- (list (make-const loc module) (make-const loc sym) value)))
- (lambda (lexical) (make-lexical-set loc lexical lexical value))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc module sym #t)
- value))))
-
-;;; Process the bindings part of a let or let* expression; that is,
-;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
-;;; . val2) ...).
-
-(define (process-let-bindings loc bindings)
- (map
- (lambda (b)
- (if (symbol? b)
- (cons b 'nil)
- (if (or (not (list? b))
- (not (= (length b) 2)))
- (report-error
- loc
- "expected symbol or list of 2 elements in let")
- (if (not (symbol? (car b)))
- (report-error loc "expected symbol in let")
- (cons (car b) (cadr b))))))
- bindings))
-
-;;; Split the let bindings into a list to be done lexically and one
-;;; dynamically. A symbol will be bound lexically if and only if: We're
-;;; processing a lexical-let (i.e. module is 'lexical), OR we're
-;;; processing a value-slot binding AND the symbol is already lexically
-;;; bound or is always lexical, OR we're processing a function-slot
-;;; binding.
-
-(define (bind-lexically? sym module)
- (or (eq? module 'lexical)
- (eq? module function-slot)
- (and (equal? module value-slot)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq sym always)
- (get-lexical-binding (fluid-ref bindings-data) sym))))))
-
-(define (split-let-bindings bindings module)
- (let iterate ((tail bindings)
- (lexical '())
- (dynamic '()))
- (if (null? tail)
- (values (reverse lexical) (reverse dynamic))
- (if (bind-lexically? (caar tail) module)
- (iterate (cdr tail) (cons (car tail) lexical) dynamic)
- (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
-
-;;; Compile let and let* expressions. The code here is used both for
-;;; let/let* and flet/flet*, just with a different bindings module.
-;;;
-;;; A special module value 'lexical means that we're doing a lexical-let
-;;; instead and the bindings should not be saved to globals at all but
-;;; be done with the lexical framework instead.
-
-;;; Let is done with a single call to let-dynamic binding them locally
-;;; to new values all "at once". If there is at least one variable to
-;;; bind lexically among the bindings, we first do a let for all of them
-;;; to evaluate all values before any bindings take place, and then call
-;;; let-dynamic for the variables to bind dynamically.
-
-(define (generate-let loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (call-with-values
- (lambda () (split-let-bindings bind module))
- (lambda (lexical dynamic)
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module))
- (map car dynamic))
- (let ((make-values (lambda (for)
- (map (lambda (el) (compile-expr (cdr el)))
- for)))
- (make-body (lambda ()
- (list->seq loc (map compile-expr body)))))
- (if (null? lexical)
- (let-dynamic loc (map car dynamic) module
- (make-values dynamic) (make-body))
- (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
- (dynamic-syms (map (lambda (el) (gensym)) dynamic))
- (all-syms (append lexical-syms dynamic-syms))
- (vals (append (make-values lexical)
- (make-values dynamic))))
- (make-let loc
- all-syms
- all-syms
- vals
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car lexical) lexical-syms
- (lambda ()
- (if (null? dynamic)
- (make-body)
- (let-dynamic loc
- (map car dynamic)
- module
- (map
- (lambda (sym)
- (make-lexical-ref loc
- sym
- sym))
- dynamic-syms)
- (make-body)))))))))))))
-
-;;; Let* is compiled to a cascaded set of "small lets" for each binding
-;;; in turn so that each one already sees the preceding bindings.
-
-(define (generate-let* loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (begin
- (for-each (lambda (sym)
- (if (not (bind-lexically? sym module))
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module)))
- (map car bind))
- (let iterate ((tail bind))
- (if (null? tail)
- (list->seq loc (map compile-expr body))
- (let ((sym (caar tail))
- (value (compile-expr (cdar tail))))
- (if (bind-lexically? sym module)
- (let ((target (gensym)))
- (make-let loc
- `(,target)
- `(,target)
- `(,value)
- (with-lexical-bindings
- (fluid-ref bindings-data)
- `(,sym)
- `(,target)
- (lambda () (iterate (cdr tail))))))
- (let-dynamic loc
- `(,(caar tail))
- module
- `(,value)
- (iterate (cdr tail))))))))))
-
-;;; 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 '())
- (lexical '())
- (dynamic '()))
- (cond
- ((null? tail)
- (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 lexical dynamic))
- ((eq? (car tail) '&rest)
- (if (or (null? (cdr tail))
- (not (null? (cddr tail))))
- (report-error loc "expected exactly one symbol after &rest")
- (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 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. 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 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
- (list->seq loc (map compile-expr body))))
- (make-seq
- loc
- (if rest
- (make-conditional
- loc
- (call-primitive loc
- 'null?
- (make-lexical-ref 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)))))))))
+ (make-module-ref loc runtime 'set-symbol-function! #t)
+ (list (make-const loc symbol) value)))))
+
+(define (bind-lexically? sym module decls)
+ (or (eq? module function-slot)
+ (let ((decl (assq-ref decls sym)))
+ (and (equal? module value-slot)
+ (or
+ (eq? decl 'lexical)
+ (and
+ (fluid-ref lexical-binding)
+ (not (global? (resolve-module module) sym))))))))
+
+(define (parse-let-binding loc binding)
+ (pmatch binding
+ ((unquote var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var ,val)
+ (guard (symbol? var))
+ (cons var val))
+ (else
+ (report-error loc "malformed variable binding" binding))))
+
+(define (parse-flet-binding loc binding)
+ (pmatch binding
+ ((,var ,args . ,body)
+ (guard (symbol? var))
+ (cons var `(function (lambda ,args ,@body))))
+ (else
+ (report-error loc "malformed function binding" binding))))
+
+(define (parse-declaration expr)
+ (pmatch expr
+ ((lexical . ,vars)
+ (map (cut cons <> 'lexical) vars))
+ (else
+ '())))
+
+(define (parse-body-1 body lambda?)
+ (let loop ((lst body)
+ (decls '())
+ (intspec #f)
+ (doc #f))
+ (pmatch lst
+ (((declare . ,x) . ,tail)
+ (loop tail (append-reverse x decls) intspec doc))
+ (((interactive . ,x) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls x doc))
+ ((,x . ,tail)
+ (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (loop tail decls intspec x))
+ (else
+ (values (append-map parse-declaration decls)
+ intspec
+ doc
+ lst)))))
+
+(define (parse-lambda-body body)
+ (parse-body-1 body #t))
+
+(define (parse-body body)
+ (receive (decls intspec doc body) (parse-body-1 body #f)
+ (values decls body)))
+
+;;; Partition the argument list of a lambda expression into required,
+;;; optional and rest arguments.
+
+(define (parse-lambda-list lst)
+ (define (%match lst null optional rest symbol)
+ (pmatch lst
+ (() (null))
+ ((&optional . ,tail) (optional tail))
+ ((&rest . ,tail) (rest tail))
+ ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ (else (fail))))
+ (define (return rreq ropt rest)
+ (values #t (reverse rreq) (reverse ropt) rest))
+ (define (fail)
+ (values #f #f #f #f))
+ (define (parse-req lst rreq)
+ (%match lst
+ (lambda () (return rreq '() #f))
+ (lambda (tail) (parse-opt tail rreq '()))
+ (lambda (tail) (parse-rest tail rreq '()))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (define (parse-opt lst rreq ropt)
+ (%match lst
+ (lambda () (return rreq ropt #f))
+ (lambda (tail) (fail))
+ (lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
+ (define (parse-rest lst rreq ropt)
+ (%match lst
+ (lambda () (fail))
+ (lambda (tail) (fail))
+ (lambda (tail) (fail))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (define (parse-post-rest lst rreq ropt rest)
+ (%match lst
+ (lambda () (return rreq ropt rest))
+ (lambda () (fail))
+ (lambda () (fail))
+ (lambda (arg tail) (fail))))
+ (parse-req lst '()))
+
+(define (make-simple-lambda loc meta req opt init rest vars body)
+ (make-lambda loc
+ meta
+ (make-lambda-case #f req opt rest #f init vars body #f)))
+
+(define (compile-lambda loc meta args body)
+ (receive (valid? req-ids opt-ids rest-id)
+ (parse-lambda-list args)
+ (if valid?
+ (let* ((all-ids (append req-ids
+ opt-ids
+ (or (and=> rest-id list) '())))
+ (all-vars (map (lambda (ignore) (gensym)) all-ids)))
+ (let*-values (((decls intspec doc forms)
+ (parse-lambda-body body))
+ ((lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ (map list all-ids all-vars)))
+ ((lexical-ids lexical-vars) (unzip2 lexical))
+ ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic-ids
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ lexical-ids
+ lexical-vars
+ (lambda ()
+ (ensure-globals!
+ loc
+ dynamic-ids
+ (let* ((tree-il (compile-expr `(progn ,@forms)))
+ (full-body
+ (if (null? dynamic)
+ tree-il
+ (make-dynlet
+ loc
+ (map (cut make-module-ref loc value-slot <> #t)
+ dynamic-ids)
+ (map (cut make-lexical-ref loc <> <>)
+ dynamic-ids
+ dynamic-vars)
+ tree-il))))
+ (make-simple-lambda loc
+ meta
+ req-ids
+ opt-ids
+ (map (const (nil-value loc))
+ opt-ids)
+ rest-id
+ all-vars
+ full-body)))))))))
+ (report-error "invalid function" `(lambda ,args ,@body)))))
;;; 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
@@ -547,12 +365,11 @@
;;; Handle macro and special operator bindings.
-(define (find-operator sym type)
+(define (find-operator name type)
(and
- (symbol? sym)
- (module-defined? (resolve-interface function-slot) sym)
- (let* ((op (module-ref (resolve-module function-slot) sym))
- (op (if (fluid? op) (fluid-ref op) op)))
+ (symbol? name)
+ (module-defined? (resolve-interface function-slot) name)
+ (let ((op (module-ref (resolve-module function-slot) name)))
(if (and (pair? op) (eq? (car op) type))
(cdr op)
#f))))
@@ -608,52 +425,34 @@
expr))
(make-const loc expr)))
-;;; Temporarily update a list of symbols that are handled specially
-;;; (disabled void check or always lexical) for compiling body. We need
-;;; to handle special cases for already all / set to all and the like.
-
-(define (with-added-symbols loc fluid syms body)
- (if (null? body)
- (report-error loc "symbol-list construct has empty body"))
- (if (not (or (eq? syms 'all)
- (and (list? syms) (and-map symbol? syms))))
- (report-error loc "invalid symbol list" syms))
- (let ((old (fluid-ref fluid))
- (make-body (lambda ()
- (list->seq loc (map compile-expr body)))))
- (if (eq? old 'all)
- (make-body)
- (let ((new (if (eq? syms 'all)
- 'all
- (append syms old))))
- (with-fluids ((fluid new))
- (make-body))))))
-
;;; Special operators
(defspecial progn (loc args)
- (list->seq loc (map compile-expr args)))
+ (list->seq loc
+ (if (null? args)
+ (list (nil-value loc))
+ (map compile-expr args))))
+
+(defspecial eval-when-compile (loc args)
+ (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
(defspecial if (loc args)
(pmatch args
((,cond ,then . ,else)
- (make-conditional loc
- (compile-expr cond)
- (compile-expr then)
- (if (null? else)
- (nil-value loc)
- (list->seq loc (map compile-expr else)))))))
+ (make-conditional
+ loc
+ (call-primitive loc 'not
+ (call-primitive loc 'nil? (compile-expr cond)))
+ (compile-expr then)
+ (compile-expr `(progn ,@else))))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
(make-seq loc
- (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym))))))
+ (set-variable! loc sym (compile-expr value))
+ (make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
@@ -678,7 +477,7 @@
(make-module-ref loc value-slot sym #t))
(make-const loc #f))
(make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
+ (set-variable! loc sym (compile-expr value)))
(make-const loc sym))))))
(defspecial setq (loc args)
@@ -696,47 +495,141 @@
(if (not (symbol? sym))
(report-error loc "expected symbol in setq")
(cons
- (set-variable! loc sym value-slot val)
+ (set-variable! loc sym val)
(loop (cddr* args)
- (reference-variable loc sym value-slot)))))))))
+ (reference-variable loc sym)))))))))
(defspecial let (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let loc value-slot bindings body))))
-
-(defspecial lexical-let (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc 'lexical bindings body))))
-
-(defspecial flet (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc function-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (receive (lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ bindings)
+ (let ((make-values (lambda (for)
+ (map (lambda (el) (compile-expr (cdr el)))
+ for)))
+ (make-body (lambda () (compile-expr `(progn ,@forms)))))
+ (ensure-globals!
+ loc
+ (map car dynamic)
+ (if (null? lexical)
+ (make-dynlet loc
+ (map (compose (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map (compose compile-expr cdr)
+ dynamic)
+ (make-body))
+ (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
+ (dynamic-syms (map (lambda (el) (gensym)) dynamic))
+ (all-syms (append lexical-syms dynamic-syms))
+ (vals (append (make-values lexical)
+ (make-values dynamic))))
+ (make-let loc
+ all-syms
+ all-syms
+ vals
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ (map car lexical)
+ lexical-syms
+ (lambda ()
+ (if (null? dynamic)
+ (make-body)
+ (make-dynlet loc
+ (map
+ (compose
+ (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map
+ (lambda (sym)
+ (make-lexical-ref
+ loc
+ sym
+ sym))
+ dynamic-syms)
+ (make-body))))))))))))))))
(defspecial let* (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let* loc value-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (let iterate ((tail bindings))
+ (if (null? tail)
+ (compile-expr `(progn ,@forms))
+ (let ((sym (caar tail))
+ (value (compile-expr (cdar tail))))
+ (if (bind-lexically? sym value-slot decls)
+ (let ((target (gensym)))
+ (make-let loc
+ `(,target)
+ `(,target)
+ `(,value)
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ `(,sym)
+ `(,target)
+ (lambda () (iterate (cdr tail))))))
+ (ensure-globals!
+ loc
+ (list sym)
+ (make-dynlet loc
+ (list (make-module-ref loc value-slot sym #t))
+ (list value)
+ (iterate (cdr tail)))))))))))))
-(defspecial lexical-let* (loc args)
+(defspecial flet (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc 'lexical bindings body))))
-
-(defspecial flet* (loc args)
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-let loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
+
+(defspecial labels (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc function-slot bindings body))))
-
-;;; Temporarily set symbols as always lexical only for the lexical scope
-;;; of a construct.
-
-(defspecial with-always-lexical (loc args)
- (pmatch args
- ((,syms . ,body)
- (with-added-symbols loc always-lexical syms body))))
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-letrec #f
+ loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module
@@ -756,58 +649,12 @@
((,sym)
(make-primitive-ref loc sym))))
-;;; A while construct is transformed into a tail-recursive loop like
-;;; this:
-;;;
-;;; (letrec ((iterate (lambda ()
-;;; (if condition
-;;; (begin body
-;;; (iterate))
-;;; #nil))))
-;;; (iterate))
-;;;
-;;; As letrec is not directly accessible from elisp, while is
-;;; implemented here instead of with a macro.
-
-(defspecial while (loc args)
- (pmatch args
- ((,condition . ,body)
- (let* ((itersym (gensym))
- (compiled-body (map compile-expr body))
- (iter-call (make-call loc
- (make-lexical-ref loc
- 'iterate
- itersym)
- (list)))
- (full-body (list->seq loc `(,@compiled-body ,iter-call)))
- (lambda-body (make-conditional loc
- (compile-expr condition)
- full-body
- (nil-value loc)))
- (iter-thunk (make-lambda loc
- '()
- (make-lambda-case #f
- '()
- #f
- #f
- #f
- '()
- '()
- lambda-body
- #f))))
- (make-letrec loc
- #f
- '(iterate)
- (list itersym)
- (list iter-thunk)
- iter-call)))))
-
(defspecial function (loc args)
(pmatch args
(((lambda ,args . ,body))
- (compile-lambda loc args body))
+ (compile-lambda loc '() args body))
((,sym) (guard (symbol? sym))
- (reference-variable loc sym function-slot))))
+ (reference-function loc sym))))
(defspecial defmacro (loc args)
(pmatch args
@@ -817,17 +664,19 @@
(let* ((tree-il
(make-seq
loc
- (set-variable!
+ (set-function!
loc
name
- function-slot
- (make-primcall loc 'cons
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
+ (make-call
+ loc
+ (make-module-ref loc '(guile) 'cons #t)
+ (list (make-const loc 'macro)
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))))
(make-const loc name))))
- (compile (ensuring-globals loc bindings-data tree-il)
- #:from 'tree-il
- #:to 'value)
+ (compile tree-il #:from 'tree-il #:to 'value)
tree-il)))))
(defspecial defun (loc args)
@@ -836,10 +685,10 @@
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
(make-seq loc
- (set-variable! loc
+ (set-function! loc
name
- function-slot
(compile-lambda loc
+ `((name . ,name))
args
body))
(make-const loc name))))))
@@ -854,6 +703,19 @@
((,val)
(make-const loc val))))
+(defspecial %funcall (loc args)
+ (pmatch args
+ ((,function . ,arguments)
+ (make-call loc
+ (compile-expr function)
+ (map compile-expr arguments)))))
+
+(defspecial %set-lexical-binding-mode (loc args)
+ (pmatch args
+ ((,val)
+ (fluid-set! lexical-binding val)
+ (make-void loc))))
+
;;; Compile a compound expression to Tree-IL.
(define (compile-pair loc expr)
@@ -867,13 +729,7 @@
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
(else
- (make-call loc
- (if (symbol? operator)
- (reference-variable loc
- operator
- function-slot)
- (compile-expr operator))
- (map compile-expr arguments))))))
+ (compile-expr `(%funcall (function ,operator) ,@arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
@@ -882,7 +738,7 @@
(case sym
((nil) (nil-value loc))
((t) (t-value loc))
- (else (reference-variable loc sym value-slot))))
+ (else (reference-variable loc sym))))
;;; Compile a single expression to TreeIL.
@@ -912,28 +768,14 @@
(case key
((#:warnings) ; ignore
#f)
- ((#:always-lexical)
- (if (valid-symbol-list-arg? value)
- (fluid-set! always-lexical value)
- (report-error #f
- "Invalid value for #:always-lexical"
- value)))
(else (report-error #f
"Invalid compiler option"
key)))))))
-;;; Entry point for compilation to TreeIL. This creates the bindings
-;;; data structure, and after compiling the main expression we need to
-;;; make sure all globals for symbols used during the compilation are
-;;; created using the generate-ensure-global function.
-
(define (compile-tree-il expr env opts)
(values
- (with-fluids ((bindings-data (make-bindings))
- (disable-void-check '())
- (always-lexical '()))
+ (with-fluids ((bindings-data (make-bindings)))
(process-options! opts)
- (let ((compiled (compile-expr expr)))
- (ensuring-globals (location expr) bindings-data compiled)))
+ (compile-expr expr))
env
env))