diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index e4e5a67f4..343c40c97 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -50,7 +50,7 @@ (let (form) (let ((*blocks* (cons 'UNWIND-PROTECT *blocks*)) ;;(*vars* (cons 'LB *vars*)) - (*tags* (cons 'UNWIND-PROTECT *tags*))) + (*cmp-env* (cmp-env-mark 'UNWIND-PROTECT))) (setq form (c1expr (first args)))) (make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t :args form (c1progn (rest args))))) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 2444e010e..f47e81b5a 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -361,7 +361,31 @@ The default value is NIL.") (defvar *current-function* nil) -(defvar *cmp-env* (cons nil nil)) +(defvar *cmp-env* (cons nil nil) +"The compiler environment consists of a pair or cons of two +lists, one containing variable records, the other one macro and +function recors: + +variable-record = (:block block-name) | + (:tag ({tag-name}*)) | + (:function function-name) | + (var-name {:special | nil} bound-p) | + (symbol si::symbol-macro macro-function) | + CB | LB | UNWIND-PROTECT +macro-record = (function-name function) | + (macro-name si::macro macro-function) + CB | LB | UNWIND-PROTECT + +A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A +MACRO-FUNCTION is a function that provides us with the expansion +for that local macro or symbol macro. BOUND-P is true when the +variable has been bound by an enclosing form, while it is NIL if +the variable-record corresponds just to a special declaration. +CB, LB and UNWIND-PROTECT are only used by the C compiler and +they denote closure, lexical environment and unwind-protect +boundaries. Note that compared with the bytecodes compiler, these +records contain an additional variable, block, tag or function +object at the end.") ;;; --cmplog.lsp-- ;;; @@ -429,12 +453,6 @@ coprocessor).") ;;; Compiler program and flags. ;;; -;;; --cmptag.lsp-- -;;; -;;; List of tags with marks for closure boundaries. -;;; -(defvar *tags* nil) - ;;; --cmptop.lsp-- ;;; (defvar *compiler-phase* nil) @@ -493,19 +511,14 @@ lines are inserted, but the order is preserved") ;;; *reservations* holds (... ( cmacro . value ) ...). ;;; *reservation-cmacro* holds the cmacro current used as vs reservation. +;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). (defvar *global-entries* nil) -;;; *self-destructing-fasl* = T means that, when a FASL module is -;;; being unloaded (for instance during garbage collection), the -;;; associated file will be deleted. We need this because on windows -;;; DLLs cannot be deleted if they have been opened with LoadLibrary. -;;; Thus, (COMPILE ...) cannot create a DLL, load it and delete it -;;; while it is being used. -(defvar *self-destructing-fasl* nil) +(defvar *self-destructing-fasl* '() +"A value T means that, when a FASL module is being unloaded (for +instance during garbage collection), the associated file will be +deleted. We need this for #'COMPILE because windows DLLs cannot +be deleted if they have been opened with LoadLibrary.") -;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). - -;;; --cmpvar.lsp-- -;;; (defvar *vars* nil) (defvar *undefined-vars* nil) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 3869f1901..e8926ec70 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -450,6 +450,10 @@ (push (list :block (blk-name blk) blk) (cmp-env-variables env))) +(defun cmp-env-register-tag (tag &optional (env *cmp-env*)) + (push (list :tag (list (tag-name tag)) tag) + (cmp-env-variables env))) + (defun cmp-env-search-function (name &optional (env *cmp-env*)) (let ((ccb nil) (clb nil) @@ -484,12 +488,14 @@ ((atom record) (baboon)) ((not (eq (first record) type))) - ((and (eq type :block) (eq name (second record))) - (setf found record) - (return)) - ((and (eq type :tag) (member name (second record))) - (setf found record) - (return)) + ((eq type :block) + (when (eq name (second record)) + (setf found record) + (return))) + ((eq type :tag) + (when (member name (second record) :test #'eql) + (setf found record) + (return))) ((eq (second record) 'si::symbol-macro) (when (eq name 'si::symbol-macro) (setf found record)) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index f9a07113d..7c2f49689 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -75,7 +75,6 @@ (*vars* (cons CB/LB *vars*)) (*cmp-env* (cmp-env-mark CB/LB)) (*blocks* (cons CB/LB *blocks*)) - (*tags* (cons CB/LB *tags*)) (setjmps *setjmps*) (decl (si::process-declarations (rest lambda-list-and-body))) (lambda-expr (c1lambda-expr lambda-list-and-body diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index 0155e14dd..30482d5ab 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -13,12 +13,6 @@ (in-package "COMPILER") -;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB' -;;; (Closure Boundary), 'LB' (Level Boundary) or 'UNWIND-PROTECT'. -;;; 'CB' will be pushed on *tags* when the compiler begins to process -;;; a closure. -;;; 'LB' will be pushed on *tags* when *level* is incremented. -;;; 'UNWIND-PROTECT' is pushed when entering an unwind-protect. ;;; A dummy variable is created to hold the tag identifier and one tag ;;; structure (containing reference to such variable) is created for each ;;; label in the body. @@ -71,7 +65,7 @@ (setq end w))))))) ;; FIXME! The variable name should not be a usable one! -(defun c1tagbody (body &aux (*tags* *tags*) +(defun c1tagbody (body &aux (*cmp-env* (cmp-env-copy)) (tag-var (make-var :name 'TAGBODY :kind NIL)) (tag-index 0)) ;;; Establish tags. @@ -80,7 +74,7 @@ #'(lambda (x) (if (not (consp x)) (let ((tag (make-tag :name x :var tag-var :index tag-index))) - (push tag *tags*) + (cmp-env-register-tag tag) (incf tag-index) tag) x)) @@ -176,33 +170,25 @@ (defun c1go (args) (check-args-number 'GO args 1 1) - (unless (or (symbolp (car args)) (integerp (car args))) - (cmperr "The tag name ~s is not a symbol nor an integer." (car args))) - (do ((tags *tags* (cdr tags)) - (name (car args)) - (ccb) (clb) (unw) (tag) (var)) - ((endp tags) (cmperr "The tag ~s is undefined." name)) - (declare (type var var)) - (setq tag (car tags)) - (case tag - (CB (setq ccb t)) - (LB (setq clb t)) - (UNWIND-PROTECT (setq unw T)) - (T (when (eql (tag-name tag) name) - (setq var (tag-var tag)) - (cond (ccb (setf (tag-ref-ccb tag) t - (var-ref-ccb var) T - (var-kind var) 'CLOSURE)) - (clb (setf (tag-ref-clb tag) t - (var-ref-clb var) t - (var-kind var) 'LEXICAL)) - (unw (unless (var-kind var) - (setf (var-kind var) :OBJECT)))) - (incf (var-ref var)) - (incf (tag-ref tag)) - (return (add-to-read-nodes var (make-c1form* 'GO :args tag - (or ccb clb unw)))) - ))))) + (let ((name (first args))) + (unless (or (symbolp name) (integerp name)) + (cmperr "The tag name ~s is not a symbol nor an integer." name)) + (multiple-value-bind (tag ccb clb unw) + (cmp-env-search-tag name) + (unless tag + (cmperr "Undefined tag ~A" name)) + (setq var (tag-var tag)) + (cond (ccb (setf (tag-ref-ccb tag) t + (var-ref-ccb var) T + (var-kind var) 'CLOSURE)) + (clb (setf (tag-ref-clb tag) t + (var-ref-clb var) t + (var-kind var) 'LEXICAL)) + (unw (unless (var-kind var) + (setf (var-kind var) :OBJECT)))) + (incf (var-ref var)) + (incf (tag-ref tag)) + (add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw)))))) (defun c2go (tag nonlocal) (if nonlocal diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 2ecd74ee4..dc932ad9d 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -15,8 +15,7 @@ (defun t1expr (form) (let ((*vars* nil) (*cmp-env* (cmp-env-new)) - (*blocks* nil) - (*tags* nil)) + (*blocks* nil)) (push (t1expr* form) *top-level-forms*))) (defvar *toplevel-forms-to-print*