From b03e07bd12ba95543d32f1e346debb5919d15ef0 Mon Sep 17 00:00:00 2001 From: jgarcia Date: Mon, 12 Jun 2006 08:51:56 +0000 Subject: [PATCH] Replaced global variable *funs* by the new compiler environment. --- src/cmp/cmpcall.lsp | 2 +- src/cmp/cmpdefs.lsp | 12 +----- src/cmp/cmpenv.lsp | 66 +++++++++++++++++++++++++++++-- src/cmp/cmpeval.lsp | 2 +- src/cmp/cmpflet.lsp | 94 +++++++++++++++------------------------------ src/cmp/cmplam.lsp | 2 +- src/cmp/cmptop.lsp | 7 +--- src/cmp/cmputil.lsp | 4 +- 8 files changed, 103 insertions(+), 86 deletions(-) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 4c2f0d0a9..a30d0b24a 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -28,7 +28,7 @@ ;;; Like macro-function except it searches the lexical environment, ;;; to determine if the macro is shadowed by a function or a macro. (defun cmp-macro-function (name) - (or (sch-local-macro name) + (or (cmp-env-search-macro name) (macro-function name))) (defun c1funcall (args) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 763c67e17..2444e010e 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -359,18 +359,10 @@ The default value is NIL.") (defvar *exit*) (defvar *unwind-exit*) -;;; --cmpflet.lsp-- -;;; -;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions -;;; and the symbol 'CB' (Closure Boundary) or 'LB' (Level Boundary). -;;; 'CB' will be pushed on *funs* when the compiler begins to process a closure. -;;; 'LB' will be pushed on *funs* when the compiler begins to process a local -;;; function. -;;; A local macro definition is a list ( macro-name expansion-function). - -(defvar *funs* nil) (defvar *current-function* nil) +(defvar *cmp-env* (cons nil nil)) + ;;; --cmplog.lsp-- ;;; ;;; Destination of output of different forms. See cmploc.lsp for types diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index cb51a87a8..de5a4f1ed 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -117,10 +117,13 @@ (defun add-function-declaration (fname arg-types return-types) (if (si::valid-function-name-p fname) - (push (list (sch-local-fun fname) - (function-arg-types arg-types) - (function-return-type return-types)) - *function-declarations*) + (let ((fun (cmp-env-search-function fname *cmp-env* t))) + (if (functionp fun) + (warn "Found function declaration for local macro ~A" fname) + (push (list fun + (function-arg-types arg-types) + (function-return-type return-types)) + *function-declarations*))) (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))) (defun get-arg-types (fname) @@ -417,3 +420,58 @@ (unless (member x vnames) (cmpwarn "Ignore declaration was found for not bound variable ~s." x))) ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; COMPILER ENVIRONMENT +;;; + +(defmacro cmp-env-new () + '(cons nil nil)) + +(defun cmp-env-copy (&optional (env *cmp-env*)) + (cons (car env) (cdr env))) + +(defmacro cmp-env-variables (&optional (env '*cmp-env*)) + `(car ,env)) + +(defmacro cmp-env-functions (&optional (env '*cmp-env*)) + `(cdr ,env)) + +(defun cmp-env-register-function (fun &optional (env *cmp-env*)) + (push (list (fun-name fun) 'function fun) + (cmp-env-functions env))) + +(defun cmp-env-register-macro (name function &optional (env *cmp-env*)) + (push (list name 'si::macro function) + (cmp-env-functions env))) + +(defun cmp-env-search-function (name &optional (env *cmp-env*) macro-allowed) + (let ((ccb nil) + (clb nil) + (unw nil) + (found nil)) + (dolist (record (cmp-env-functions env)) + (cond ((eq record 'CB) + (setf ccb t)) + ((eq record 'LB) + (setf clb t)) + ((eq record 'UNWIND-PROTECT) + (setf unw t)) + ((atom record) + (baboon)) + ((eq (first record) name) + (setf found (first (last record))) + (when (and (functionp found) (not macro-allowed)) + ;; Macro definition appears in #'.... This should not happen. + (cmperr "The name of a macro ~A was found in special form FUNCTION." name)) + (return)))) + (values found ccb clb unw))) + +(defun cmp-env-search-macro (name &optional (env *cmp-env*)) + (let ((f (cmp-env-search-function name env t))) + (if (functionp f) f nil))) + +(defun cmp-env-mark (mark &optional (env *cmp-env*)) + (cons (cons mark (car env)) + (cons mark (cdr env)))) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 9d02344b1..6725ddce1 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -47,7 +47,7 @@ (defun c1call-symbol (fname args &aux fd) (cond ((setq fd (get-sysprop fname 'c1special)) (funcall fd args)) ((c1call-local fname args)) - ((setq fd (sch-local-macro fname)) + ((setq fd (cmp-env-search-macro fname)) (c1expr (cmp-expand-macro fd (list* fname args)))) ((and (setq fd (get-sysprop fname 'C1)) (inline-possible fname)) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 1d73da637..c2987b850 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -18,7 +18,7 @@ (defun c1labels/flet (origin args) (check-args-number origin args 1) - (let ((new-funs *funs*) + (let ((new-env (cmp-env-copy)) (defs '()) (local-funs '()) (fnames '()) @@ -38,12 +38,12 @@ (let* ((name (car def)) (var (make-var :name name :kind :object)) (fun (make-fun :name name :var var))) - (push (list (fun-name fun) 'FUNCTION fun) new-funs) + (cmp-env-register-function fun new-env) (push (cons fun (cdr def)) defs))) ;; Now we compile the functions, either in an empty environment ;; in which there are no new functions - (let ((*funs* (if (eq origin 'FLET) *funs* new-funs))) + (let ((*cmp-env* (cmp-env-copy (if (eq origin 'FLET) *cmp-env* new-env)))) (dolist (def (nreverse defs)) (let ((fun (first def))) ;; The closure type will be fixed later on by COMPUTE-... @@ -61,7 +61,7 @@ ;; Now we can compile the body itself. (let ((*vars* *vars*) - (*funs* new-funs)) + (*cmp-env* new-env)) (multiple-value-bind (body ss ts is other-decl) (c1body (rest args) t) (c1declare-specials ss) @@ -195,16 +195,16 @@ (check-vdecl nil ts is) (c1decl-body other-decl body))) -(defun c1macrolet (args &aux (*funs* *funs*)) +(defun c1macrolet (args) (check-args-number 'MACROLET args 1) - (dolist (def (car args)) - (let ((name (first def))) - (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def))) - "The macro definition ~s is illegal." def) - (push (list name 'MACRO - (si::eval-with-env (sys::expand-defmacro name (second def) (cddr def)))) - *funs*))) - (c1locally (cdr args))) + (let ((*cmp-env* (cmp-env-copy))) + (dolist (def (car args)) + (let ((name (first def))) + (cmpck (or (endp def) (not (symbolp name)) (endp (cdr def))) + "The macro definition ~s is illegal." def) + (cmp-env-register-macro name + (si::eval-with-env (sys::expand-defmacro name (second def) (cddr def)))))) + (c1locally (cdr args)))) (defun c1symbol-macrolet (args &aux (*vars* *vars*)) (check-args-number 'SYMBOL-MACROLET args 1) @@ -214,55 +214,25 @@ (push def *vars*)) (c1locally (cdr args))) -(defun local-function-ref (fname &optional build-object &aux (ccb nil) (clb nil)) - (dolist (fun *funs*) - (cond ((eq fun 'CB) - (setq ccb t)) - ((eq fun 'LB) - (setq clb t)) - ((and (consp fun) - (equal fname (first fun)) - (eq (second fun) 'MACRO)) - ;; a macro - (when build-object - (cmperr "The name of a macro ~A was found in a call to FUNCTION." - fname)) - (return nil)) - ((and (consp fun) - (same-fname-p (first fun) fname) - (eq (second fun) 'FUNCTION)) - ;; it is a function definition -- extract the actual function record - (let ((fun (third fun))) - (incf (fun-ref fun)) - (cond (build-object - (setf (fun-ref-ccb fun) t)) - (*current-function* - (push fun (fun-referred-funs *current-function*)))) - ;; we introduce a variable to hold the funob - (let ((var (fun-var fun))) - (cond (ccb (when build-object - (setf (var-ref-ccb var) t - (var-kind var) 'CLOSURE)) - (setf (fun-ref-ccb fun) t)) - (clb (when build-object - (setf (var-ref-clb var) t - (var-kind var) 'LEXICAL))))) - (return fun)))))) - -(defun sch-local-fun (fname) - ;; Returns fun-ob for the local function (not locat macro) named FNAME, - ;; if any. Otherwise, returns FNAME itself. - (dolist (fun *funs* fname) - (when (and (not (eq fun 'CB)) - (not (consp fun)) - (same-fname-p (fun-name fun) fname)) - (return fun)))) - -(defun sch-local-macro (fname) - (dolist (fun *funs*) - (when (and (consp fun) - (eq (first fun) fname)) - (return (third fun))))) +(defun local-function-ref (fname &optional build-object) + (multiple-value-bind (fun ccb clb unw) + (cmp-env-search-function fname *cmp-env* (not build-object)) + (when fun + (incf (fun-ref fun)) + (cond (build-object + (setf (fun-ref-ccb fun) t)) + (*current-function* + (push fun (fun-referred-funs *current-function*)))) + ;; we introduce a variable to hold the funob + (let ((var (fun-var fun))) + (cond (ccb (when build-object + (setf (var-ref-ccb var) t + (var-kind var) 'CLOSURE)) + (setf (fun-ref-ccb fun) t)) + (clb (when build-object + (setf (var-ref-clb var) t + (var-kind var) 'LEXICAL)))))) + fun)) (defun c2call-local (fun args &optional narg) (declare (type fun fun)) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 91871bf30..f9a07113d 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -73,7 +73,7 @@ (push fun (fun-child-funs *current-function*))) (let* ((*current-function* fun) (*vars* (cons CB/LB *vars*)) - (*funs* (cons CB/LB *funs*)) + (*cmp-env* (cmp-env-mark CB/LB)) (*blocks* (cons CB/LB *blocks*)) (*tags* (cons CB/LB *tags*)) (setjmps *setjmps*) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 2ec33a729..2ecd74ee4 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -14,7 +14,7 @@ (defun t1expr (form) (let ((*vars* nil) - (*funs* nil) + (*cmp-env* (cmp-env-new)) (*blocks* nil) (*tags* nil)) (push (t1expr* form) *top-level-forms*))) @@ -47,11 +47,8 @@ (cmp-expand-macro fd form)) success)) (t1expr* fd)) - ((setq fd (macro-function fun)) + ((setq fd (cmp-macro-function fun)) (t1expr* (cmp-expand-macro fd form))) - ((and (setq fd (assoc fun *funs*)) - (eq (second fd) 'MACRO)) - (t1expr* (cmp-expand-macro (third fd) form))) (t (t1ordinary form)) ))))) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 2a17b5129..bd42377fc 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -136,14 +136,14 @@ ~%;;; You are recommended to compile again.~%" form)))) -(defun cmp-macroexpand (form &optional (env (and *funs* (cons nil *funs*)))) +(defun cmp-macroexpand (form &optional (env (cons nil (cdr *cmp-env*)))) (with-cmp-protection (macroexpand form env) (let ((*print-case* :upcase)) (print-current-form) (format t "~&;;; The macro form ~S was not expanded successfully.~ ~%;;; You are recommended to compile again.~%" form)))) -(defun cmp-expand-macro (fd form &optional (env (and *funs* (cons nil *funs*)))) +(defun cmp-expand-macro (fd form &optional (env (cons nil (cdr *cmp-env*)))) (with-cmp-protection (let ((new-form (funcall *macroexpand-hook* fd form env))) (values new-form (not (eql new-form form))))