[armedbear-cvs] r11919 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Thu May 21 20:25:18 UTC 2009
Author: ehuelsmann
Date: Thu May 21 16:25:17 2009
New Revision: 11919
Log:
Separate the precompiler and the file compiler
by giving each its own 'current environment' variable:
introduce *PRECOMPILE-ENV* in precompiler.lisp.
Modified:
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Thu May 21 16:25:17 2009
@@ -110,7 +110,7 @@
(return-from process-toplevel-form))
((IN-PACKAGE DEFPACKAGE)
(note-toplevel-form form)
- (setf form (precompile-form form nil))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*))
(eval form)
;; Force package prefix to be used when dumping form.
(let ((*package* +keyword-package+))
@@ -162,7 +162,9 @@
;; FIXME Should be a warning or error of some sort...
(format *error-output*
"; Unable to compile function ~A~%" name)
- (let ((precompiled-function (precompile-form expr nil)))
+ (let ((precompiled-function
+ (precompiler:precompile-form expr nil
+ *compile-file-environment*)))
(setf form
`(fset ',name
,precompiled-function
@@ -264,23 +266,24 @@
(return-from process-toplevel-form))
(cond ((eq operator 'QUOTE)
-;;; (setf form (precompile-form form nil))
+;;; (setf form (precompiler:precompile-form form nil
+;;; *compile-file-environment*))
(when compile-time-too
(eval form))
(return-from process-toplevel-form))
((eq operator 'PUT)
- (setf form (precompile-form form nil)))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
((eq operator 'COMPILER-DEFSTRUCT)
- (setf form (precompile-form form nil)))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
((eq operator 'PROCLAIM)
- (setf form (precompile-form form nil)))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW))
(or (keywordp (second form))
(and (listp (second form))
(eq (first (second form)) 'QUOTE))))
- (setf form (precompile-form form nil)))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
((eq operator 'IMPORT)
- (setf form (precompile-form form nil))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*))
;; Make sure package prefix is printed when symbols are imported.
(let ((*package* +keyword-package+))
(dump-form form stream))
@@ -293,22 +296,22 @@
(consp (third form))
(eq (%car (third form)) 'FUNCTION)
(symbolp (cadr (third form))))
- (setf form (precompile-form form nil)))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
;;; ((memq operator '(LET LET*))
;;; (let ((body (cddr form)))
;;; (if (dolist (subform body nil)
;;; (when (and (consp subform) (eq (%car subform) 'DEFUN))
;;; (return t)))
;;; (setf form (convert-toplevel-form form))
-;;; (setf form (precompile-form form nil)))))
+;;; (setf form (precompiler:precompile-form form nil)))))
((eq operator 'mop::ensure-method)
(setf form (convert-ensure-method form)))
((and (symbolp operator)
(not (special-operator-p operator))
(null (cdr form)))
- (setf form (precompile-form form nil)))
+ (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
(t
-;;; (setf form (precompile-form form nil))
+;;; (setf form (precompiler:precompile-form form nil))
(note-toplevel-form form)
(setf form (convert-toplevel-form form)))))))))
(when (consp form)
@@ -326,7 +329,7 @@
(defun convert-ensure-method (form)
(c-e-m-1 form :function)
(c-e-m-1 form :fast-function)
- (precompile-form form nil))
+ (precompiler:precompile-form form nil *compile-file-environment*))
(declaim (ftype (function (t t) t) c-e-m-1))
(defun c-e-m-1 (form key)
@@ -356,7 +359,7 @@
(setf form
(if compiled-function
`(funcall (load-compiled-function ,(file-namestring classfile)))
- (precompile-form form nil)))))
+ (precompiler:precompile-form form nil *compile-file-environment*)))))
(defun process-toplevel-macrolet (form stream compile-time-too)
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Thu May 21 16:25:17 2009
@@ -53,7 +53,7 @@
(t
(setf body (copy-tree body))
(list 'LAMBDA lambda-list
- (precompile-form (list* 'BLOCK block-name body) t)))))
+ (precompiler:precompile-form (list* 'BLOCK block-name body) t *compile-file-environment*)))))
) ; EVAL-WHEN
;;; Pass 1.
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 21 16:25:17 2009
@@ -7328,7 +7328,8 @@
(defknown p2-setq (t t t) t)
(defun p2-setq (form target representation)
(unless (= (length form) 3)
- (return-from p2-setq (compile-form (precompiler::precompile-setq form)
+ (return-from p2-setq (compile-form (precompiler:precompile-form form t
+ *compile-file-environment*)
target representation)))
(let ((expansion (macroexpand (%cadr form) *compile-file-environment*)))
(unless (eq expansion (%cadr form))
@@ -8259,7 +8260,9 @@
:lambda-name ',name
:lambda-list (cadr ',form)))))))
(compile-1 (make-compiland :name name
- :lambda-expression (precompile-form form t)
+ :lambda-expression
+ (precompiler:precompile-form form t
+ *compile-file-environment*)
:class-file class-file)))))
(defvar *catch-errors* t)
@@ -8400,7 +8403,7 @@
(sys::%format t "; Unable to compile ~S.~%"
(or name "top-level form"))
(return-from jvm-compile
- (precompiler::precompile name definition)))))
+ (sys:precompile name definition)))))
(style-warning
#'(lambda (c) (declare (ignore c))
(setf warnings-p t) nil))
Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Thu May 21 16:25:17 2009
@@ -333,8 +333,6 @@
(in-package "EXTENSIONS")
-(export '(precompile-form precompile))
-
(unless (find-package "PRECOMPILER")
(make-package "PRECOMPILER"
:nicknames '("PRE")
@@ -355,6 +353,8 @@
;; if *in-jvm-compile* is false
(defvar *in-jvm-compile* nil)
+(defvar *precompile-env* nil)
+
(declaim (ftype (function (t) t) precompile1))
(defun precompile1 (form)
@@ -373,7 +373,7 @@
(when (symbolp op)
(cond ((setf handler (get op 'precompile-handler))
(return-from precompile1 (funcall handler form)))
- ((macro-function op *compile-file-environment*)
+ ((macro-function op *precompile-env*)
(return-from precompile1 (precompile1 (expand-macro form))))
((special-operator-p op)
(error "PRECOMPILE1: unsupported special operator ~S." op))))
@@ -422,13 +422,13 @@
(defun precompile-dolist (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(cons 'DOLIST (cons (mapcar #'precompile1 (cadr form))
(mapcar #'precompile1 (cddr form))))))
(defun precompile-dotimes (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(cons 'DOTIMES (cons (mapcar #'precompile1 (cadr form))
(mapcar #'precompile1 (cddr form))))))
@@ -464,7 +464,7 @@
(defun precompile-do/do* (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(list* (car form)
(precompile-do/do*-vars (cadr form))
(precompile-do/do*-end-form (caddr form))
@@ -606,11 +606,10 @@
form))
(defun precompile-macrolet (form)
- (let ((*compile-file-environment*
- (make-environment *compile-file-environment*)))
+ (let ((*precompile-env* (make-environment *precompile-env*)))
(dolist (definition (cadr form))
(environment-add-macro-definition
- *compile-file-environment*
+ *precompile-env*
(car definition)
(make-macro (car definition)
(make-closure
@@ -621,8 +620,7 @@
`(locally , at decls ,@(mapcar #'precompile1 body)))))
(defun precompile-symbol-macrolet (form)
- (let ((*compile-file-environment*
- (make-environment *compile-file-environment*))
+ (let ((*precompile-env* (make-environment *precompile-env*))
(defs (cadr form)))
(dolist (def defs)
(let ((sym (car def))
@@ -632,7 +630,7 @@
:format-control
"Attempt to bind the special variable ~S with SYMBOL-MACROLET."
:format-arguments (list sym)))
- (environment-add-symbol-binding *compile-file-environment*
+ (environment-add-symbol-binding *precompile-env*
sym
(sys::make-symbol-macro expansion))))
(multiple-value-bind (body decls)
@@ -680,17 +678,15 @@
:format-control "The variable ~S is not a symbol."
:format-arguments (list v)))
(push (list v (precompile1 expr)) result)
- (environment-add-symbol-binding *compile-file-environment*
- v nil))) ;; any value will do
+ (environment-add-symbol-binding *precompile-env* v nil)))
+ ;; any value will do: we just need to shadow any symbol macros
(t
(push var result)
- (environment-add-symbol-binding *compile-file-environment*
- var nil))))
+ (environment-add-symbol-binding *precompile-env* var nil))))
(nreverse result)))
(defun precompile-let (form)
- (let ((*compile-file-environment*
- (make-environment *compile-file-environment*)))
+ (let ((*precompile-env* (make-environment *precompile-env*)))
(list* 'LET
(precompile-let/let*-vars (cadr form))
(mapcar #'precompile1 (cddr form)))))
@@ -707,15 +703,14 @@
(defun precompile-let* (form)
(setf form (maybe-fold-let* form))
- (let ((*compile-file-environment*
- (make-environment *compile-file-environment*)))
+ (let ((*precompile-env* (make-environment *precompile-env*)))
(list* 'LET*
(precompile-let/let*-vars (cadr form))
(mapcar #'precompile1 (cddr form)))))
(defun precompile-case (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(let* ((keyform (cadr form))
(clauses (cddr form))
(result (list (precompile1 keyform))))
@@ -730,7 +725,7 @@
(defun precompile-cond (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(let ((clauses (cdr form))
(result nil))
(dolist (clause clauses)
@@ -746,7 +741,7 @@
(let ((name (car def))
(body (cddr def)))
;; Macro names are shadowed by local functions.
- (environment-add-function-definition *compile-file-environment* name body)
+ (environment-add-function-definition *precompile-env* name body)
(cdr (precompile-named-lambda (list* 'NAMED-LAMBDA def)))))
(defun precompile-local-functions (defs)
@@ -766,8 +761,7 @@
(find-use name (%cdr expression))))))
(defun precompile-flet/labels (form)
- (let ((*compile-file-environment*
- (make-environment *compile-file-environment*))
+ (let ((*precompile-env* (make-environment *precompile-env*))
(operator (car form))
(locals (cadr form))
(body (cddr form)))
@@ -840,12 +834,12 @@
(defun precompile-when (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(precompile-cons form)))
(defun precompile-unless (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(precompile-cons form)))
;; MULTIPLE-VALUE-BIND is handled explicitly by the JVM compiler.
@@ -853,10 +847,9 @@
(let ((vars (cadr form))
(values-form (caddr form))
(body (cdddr form))
- (*compile-file-environment*
- (make-environment *compile-file-environment*)))
+ (*precompile-env* (make-environment *precompile-env*)))
(dolist (var vars)
- (environment-add-symbol-binding *compile-file-environment* var nil))
+ (environment-add-symbol-binding *precompile-env* var nil))
(list* 'MULTIPLE-VALUE-BIND
vars
(precompile1 values-form)
@@ -868,12 +861,12 @@
(defun precompile-nth-value (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
form))
(defun precompile-return (form)
(if *in-jvm-compile*
- (precompile1 (macroexpand form *compile-file-environment*))
+ (precompile1 (macroexpand form *precompile-env*))
(list 'RETURN (precompile1 (cadr form)))))
(defun precompile-return-from (form)
@@ -920,16 +913,18 @@
(special-operator-p (%car form)))
(return-from expand-macro form)))
(multiple-value-bind (result expanded)
- (macroexpand-1 form *compile-file-environment*)
+ (macroexpand-1 form *precompile-env*)
(unless expanded
(return-from expand-macro (values result exp)))
(setf form result
exp t)))))
(declaim (ftype (function (t t) t) precompile-form))
-(defun precompile-form (form in-jvm-compile)
+(defun precompile-form (form in-jvm-compile
+ &optional precompile-env)
(let ((*in-jvm-compile* in-jvm-compile)
- (*inline-declarations* *inline-declarations*))
+ (*inline-declarations* *inline-declarations*)
+ (pre::*precompile-env* precompile-env))
(precompile1 form)))
(defun install-handler (symbol &optional handler)
@@ -1004,11 +999,12 @@
(install-handlers)
+(export '(precompile-form))
+
(in-package #:system)
(defun macroexpand-all (form &optional env)
- (let ((*compile-file-environment* env))
- (precompile-form form nil)))
+ (precompiler:precompile-form form nil env))
(defmacro compiler-let (bindings &body forms &environment env)
(let ((bindings (mapcar #'(lambda (binding)
@@ -1034,7 +1030,8 @@
(unless definition
(setq definition (or (and (symbolp name) (macro-function name))
(fdefinition name))))
- (let (expr result)
+ (let (expr result
+ (pre::*precompile-env* nil))
(cond ((functionp definition)
(multiple-value-bind (form closure-p)
(function-lambda-expression definition)
@@ -1052,7 +1049,7 @@
;; (error 'type-error)))
(format t "Unable to precompile ~S.~%" name)
(return-from precompile (values nil t t))))
- (setf result (coerce-to-function (precompile-form expr nil)))
+ (setf result (coerce-to-function (precompiler:precompile-form expr nil)))
(when (and name (functionp result))
(sys::set-function-definition name result definition))
(values (or name result) nil nil)))
@@ -1131,8 +1128,12 @@
(when (and env (empty-environment-p env))
(setf env nil))
(when (null env)
- (setf lambda-expression (precompile-form lambda-expression nil)))
+ (setf lambda-expression (precompiler:precompile-form lambda-expression nil)))
`(progn
(%defun ',name ,lambda-expression)
,@(when doc
`((%set-documentation ',name 'function ,doc)))))))))
+
+(export '(precompile))
+
+;;(provide "PRECOMPILER")
\ No newline at end of file
More information about the armedbear-cvs
mailing list