mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-22 20:42:03 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: fix compile call for closures

Browse source 
Signal an error for compilation of cclosures. Allow for
    compilation of bclosures over macros, functions and variables.
    Macros are simply added to the compiler environment. For functions
    and variables we enclose the definition of the closure in
    appropiate let/flet forms, e.g. for `(lambda () (fun var))'
    closing over the function `fun' and variable `var':
    (let ((var ...))
      (flet ((fun (x) ...))
        (lambda () (fun var))))
    Closures over tags and blocks are not implemented and will signal
    an error during compilation.
This commit is contained in:
Marius Gerbershagen 2018-06-23 20:49:42 +02:00
parent b0a7684f2f
commit d27f1494e1
2 changed files with 71 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

53
src/cmp/cmpenv-api.lsp
View file

@ -25,6 +25,54 @@ that are susceptible to be changed by PROCLAIM."
(defun cmp-env-copy (&optional (env *cmp-env*))
(cons (car env) (cdr env)))
(defun set-closure-env (definition lexenv &optional (env *cmp-env*))
"Set up an environment for compilation of closures: Register closed
over macros in the compiler environment and enclose the definition of
the closure in let/flet forms for variables/functions it closes over."
(loop for record in lexenv
do (cond ((not (listp record))
(multiple-value-bind (record-def record-lexenv)
(function-lambda-expression record)
(cond ((eql (car record-def) 'LAMBDA)
(setf record-def (cdr record-def)))
((eql (car record-def) 'EXT:LAMBDA-BLOCK)
(setf record-def (cddr record-def)))
(t
(error "~&;;; Error: Not a valid lambda expression: ~s." record-def)))
;; allow for closures which close over closures.
;; (first record-def) is the lambda list, (rest
;; record-def) the definition of the local function
;; in record
(setf (rest record-def)
(list (set-closure-env (if (= (length record-def) 2)
(second record-def)
`(progn ,@(rest record-def)))
record-lexenv env)))
(setf definition
`(flet ((,(compiled-function-name record)
,@record-def))
,definition))))
((and (listp record) (symbolp (car record)))
(cond ((eq (car record) 'si::macro)
(cmp-env-register-macro (cddr record) (cadr record) env))
((eq (car record) 'si::symbol-macro)
(cmp-env-register-symbol-macro-function (cddr record) (cadr record) env))
(t
(setf definition
`(let ((,(car record) ',(cdr record)))
,definition)))
))
;; ((and (integerp (cdr record)) (= (cdr record) 0))
;; Tags: We have lost the information, which tag
;; corresponds to the lex-env record. If we are
;; compiling a closure over a tag, we will get an
;; error later on.
;; )
;; (t
;; Blocks: Not yet implemented
)
finally (return definition)))
(defmacro cmp-env-variables (&optional (env '*cmp-env*))
`(car ,env))
@ -102,6 +150,11 @@ that are susceptible to be changed by PROCLAIM."
(cmp-env-variables env))
env)
(defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*))
(push (list name 'si::symbol-macro function)
(cmp-env-variables env))
env)
(defun cmp-env-register-block (blk &optional (env *cmp-env*))
(push (list :block (blk-name blk) blk)
(cmp-env-variables env))

28
src/cmp/cmpmain.lsp
View file

@ -734,6 +734,7 @@ compiled successfully, returns the pathname of the compiled file"
#+dlopen
(defun compile (name &optional (def nil supplied-p)
&aux form data-pathname
(lexenv nil)
(*suppress-compiler-messages* (or *suppress-compiler-messages*
(not *compile-verbose*)))
(*compiler-in-use* *compiler-in-use*)
@ -761,7 +762,11 @@ after compilation."
(when (functionp def)
(unless (function-lambda-expression def)
(return-from compile def))
(setf def (function-lambda-expression def)))
(multiple-value-setq (def lexenv)
(function-lambda-expression def))
(when (eq lexenv t)
(warn "COMPILE can not compile C closures")
(return-from compile (values def t nil))))
(setq form (if name
`(setf (fdefinition ',name) #',def)
`(set 'GAZONK #',def))))
@ -777,17 +782,20 @@ after compilation."
(t
(setq form `(setf (fdefinition ',name) #',form))))
(let*((*load-time-values* 'values) ;; Only the value is kept
(tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*))))
(data-pathname (first tmp-names))
(c-pathname (compile-file-pathname data-pathname :type :c))
(h-pathname (compile-file-pathname data-pathname :type :h))
(o-pathname (compile-file-pathname data-pathname :type :object))
(so-pathname (compile-file-pathname data-pathname))
(init-name (compute-init-name so-pathname :kind :fasl))
(compiler-conditions nil))
(let* ((*load-time-values* 'values) ;; Only the value is kept
(tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*))))
(data-pathname (first tmp-names))
(c-pathname (compile-file-pathname data-pathname :type :c))
(h-pathname (compile-file-pathname data-pathname :type :h))
(o-pathname (compile-file-pathname data-pathname :type :object))
(so-pathname (compile-file-pathname data-pathname))
(init-name (compute-init-name so-pathname :kind :fasl))
(compiler-conditions nil)
(*permanent-data* t) ; needed for literal objects in closures
(*cmp-env-root* *cmp-env-root*))
(with-compiler-env (compiler-conditions)
(setf form (set-closure-env form lexenv *cmp-env-root*))
(print-compiler-info)
(data-init)
(t1expr form)