Commit d27f1494 authored by Marius Gerbershagen's avatar Marius Gerbershagen
Browse files

cmp: fix compile call for closures

    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.
parent b0a7684f
......@@ -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))
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment