diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 44e27eb42110b7866c04e8e374aa2f2237239f57..474f623b23a54303ee4755aea9e83cc1b0ab3f13 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.125 2001/10/15 14:36:40 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.126 2001/10/28 14:35:57 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2489,6 +2489,8 @@ (def (second spec))) (unless (symbolp name) (compiler-error "Symbol macro name is not a symbol: ~S." name)) + (when (eq (info variable kind name) :special) + (compiler-error "Attempt to bind a special variable with SYMBOL-MACROLET: ~S." name)) (when (assoc name (res) :test #'eq) (compiler-warning "Repeated name in SYMBOL-MACROLET: ~S." name)) (res `(,name . (MACRO . ,def))))) diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp index 365f975103347c4b86dc23741d815a6608667fbb..3cebcacde7c30e0daf2d01a348a034368f63bda6 100644 --- a/compiler/new-assem.lisp +++ b/compiler/new-assem.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.27 1998/03/21 08:07:00 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.28 2001/10/28 14:35:58 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -49,7 +49,7 @@ ;;; (defmacro def-assembler-params (&rest options) "Set up the assembler." - `(eval-when (compile load eval) + `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (c:backend-assembler-params c:*target-backend*) (make-assem-params :backend c:*target-backend* ,@options)))) @@ -306,7 +306,7 @@ ;;; WITHOUT-SCHEDULING -- interface. ;;; -(defmacro without-scheduling ((&optional (segment '*current-segment*)) +(defmacro without-scheduling ((&optional (segment (%%current-segment%%))) &body body) "Execute BODY (as a progn) without scheduling any of the instructions generated inside it. DO NOT throw or return-from out of it." @@ -1304,29 +1304,29 @@ ;;;; Interface to the rest of the compiler. -;;; *CURRENT-SEGMENT* -- internal. +;;; Macro %%CURRENT-SEGMENT%% -- internal. ;;; -;;; The holds the current segment while assembling. Use ASSEMBLE to change -;;; it. +;;; Returns the current segment while assembling. Use ASSEMBLE to +;;; change it. ;;; -(defvar *current-segment*) +;;; Using a macro to access the underlying special variable +;;; *CURRENT-SEGMENT* allows us to play scoping tricks in +;;; DEFINE-INSTRUCTION to detect calls to the INST macro which aren't +;;; inside the scope of an ASSEMBLE. +;;; +(defvar *current-segment* nil) +(defmacro %%current-segment%% () '*current-segment*) -;;; *CURRENT-VOP* -- internal. +;;; Macro %%CURRENT-VOP%% -- internal. ;;; -;;; Just like *CURRENT-SEGMENT*, but holds the current vop. Used only to keep +;;; Just like %%CURRENT-SEGMENT%%, but holds the current vop. Used only to keep ;;; track of which vops emit which insts. ;;; (defvar *current-vop* nil) +(defmacro %%current-vop%% () '*current-vop*) ;;; ASSEMBLE -- interface. ;;; -;;; We also symbol-macrolet *current-segment* to a local holding the segment -;;; so uses of *current-segment* inside the body don't have to keep -;;; dereferencing the symbol. Given that ASSEMBLE is the only interface to -;;; *current-segment*, we don't have to worry about the special value becomming -;;; out of sync with the lexical value. Unless some bozo closes over it, -;;; but nobody does anything like that... -;;; (defmacro assemble ((&optional segment vop &key labels) &body body &environment env) "Execute BODY (as a progn) with SEGMENT as the current segment." @@ -1348,18 +1348,14 @@ (when (intersection labels inherited-labels) (error "Duplicate nested labels: ~S" (intersection labels inherited-labels))) - `(let* ((,seg-var ,(or segment '*current-segment*)) - (,vop-var ,(or vop '*current-vop*)) - ,@(when segment - `((*current-segment* ,seg-var))) - ,@(when vop - `((*current-vop* ,vop-var))) + `(let* ((,seg-var ,(or segment (%%current-segment%%))) + (,vop-var ,(or vop (%%current-vop%%))) + (*current-segment* ,seg-var) + (*current-vop* ,vop-var) ,@(mapcar #'(lambda (name) `(,name (gen-label))) new-labels)) - (symbol-macrolet ((*current-segment* ,seg-var) - (*current-vop* ,vop-var) - ,@(when (or inherited-labels nested-labels) + (symbol-macrolet (,@(when (or inherited-labels nested-labels) `((..inherited-labels.. ,nested-labels)))) ,@(mapcar #'(lambda (form) (if (label-name-p form) @@ -1379,24 +1375,24 @@ ((functionp inst) (funcall inst (cdr whole) env)) (t - `(,inst *current-segment* *current-vop* ,@args))))) + `(,inst (%%current-segment%%) (%%current-vop%%) ,@args))))) ;;; EMIT-LABEL -- interface. ;;; (defmacro emit-label (label) "Emit LABEL at this location in the current segment." - `(%emit-label *current-segment* *current-vop* ,label)) + `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label)) ;;; EMIT-POSTIT -- interface. ;;; (defmacro emit-postit (function) - `(%emit-postit *current-segment* ,function)) + `(%emit-postit (%%current-segment%%) ,function)) ;;; ALIGN -- interface. ;;; (defmacro align (bits &optional (fill-byte 0)) "Emit an alignment restriction to the current segment." - `(emit-alignment *current-segment* *current-vop* ,bits ,fill-byte)) + `(emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte)) ;;; LABEL-POSITION -- interface. ;;; @@ -1808,15 +1804,11 @@ `((declare ,@decls))) (let ((,postits (segment-postits ,segment-name))) (setf (segment-postits ,segment-name) nil) - (symbol-macrolet - ((*current-segment* - (macrolet ((lose () - (error "Can't use INST without an ASSEMBLE ~ - inside emitters."))) - (lose)))) + (macrolet ((%%current-segment%% () + (error "Can't use INST without an ASSEMBLE inside emitters."))) ,@emitter)) (ext:undefined-value)) - (eval-when (compile load eval) + (eval-when (:compile-toplevel :load-toplevel :execute) (%define-instruction ,sym-name ',defun-name)) ,@(extract-nths 1 'progn pdefs) ,@(when pdefs @@ -1824,6 +1816,7 @@ ',name (append ,@(extract-nths 0 'list pdefs))))))))) + ;;; DEFINE-INSTRUCTION-MACRO -- interface. ;;; (defmacro define-instruction-macro (name lambda-list &body body) @@ -1833,7 +1826,7 @@ (body local-defs) (lisp::parse-defmacro lambda-list whole body name 'instruction-macro :environment env) - `(eval-when (compile load eval) + `(eval-when (:compile-toplevel :load-toplevel :execute) (%define-instruction ,(symbol-name name) #'(lambda (,whole ,env) ,@local-defs