From 41ed816c7915806abca6b09ecd2136458f27adcc Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 14 Aug 2002 13:16:12 +0000 Subject: [PATCH] 0.7.6.20: (I set out to suppress compiler macro expansion when (> COMPILATION-SPEED SPEED), but now that I've read the DEFINE-COMPILER-MACRO specification, I think that'd probably be illegal. So I guess I won't.) As far as I can tell from the ANSI spec, it's nonconforming to return NIL from COMPILER-MACRO-FUNCTION just because of a NOTINLINE declaration. So make COMPILER-MACRO-FUNCTION ignore NOTINLINEness. (I set out to make (DEFINE-COMPILER-MACRO (SETF FOO) ...) work, but gave up, first because (SETF (FOO X) Y) expands into (FUNCALL #'(SETF FOO) Y X) and it's not clear that it's kosher to use compiler macros to transform FUNCALL, and second because ANSI 3.2.2.1 says any compiler macro definition can always be ignored.) made DEFINE-COMPILER-MACRO (SETF FOO) issue a STYLE-WARNING made COMPILER-MACRO-FUNCTION check for legal function names factored out LEGAL-FUN-NAME-OR-TYPE-ERROR to support this tiny ANSI-compliance tweak: made (SETF (COMPILER-MACRO-FUNCTION FOO NIL) ...) work various tweaks to *DEBUG-HELP-STRING* (especially to help people avoid messing with restart numbers, ow!) s/make-breakpoint-info/%make-breakpoint-info/, since leaving the traditional default name MAKE-... exposed when you're really supposed to use CREATE-... is an attractive nuisance s/code-location-number/code-location-selector/, since it's not necessarily a number --- package-data-list.lisp-expr | 2 +- src/code/debug.lisp | 78 ++++++++++++++++++----------------- src/code/defboot.lisp | 2 +- src/code/early-extensions.lisp | 9 ++++ src/code/fdefinition.lisp | 7 +--- src/code/macros.lisp | 23 ++++++++--- src/code/target-hash-table.lisp | 8 ++++ src/compiler/generic/genesis.lisp | 3 +- src/compiler/info-functions.lisp | 29 ++++++------- src/compiler/ir1-translators.lisp | 2 + src/compiler/ir1tran.lisp | 37 ++++++++++------- src/compiler/main.lisp | 7 ++-- src/compiler/parse-lambda-list.lisp | 6 +-- src/pcl/boot.lisp | 5 +-- version.lisp-expr | 2 +- 15 files changed, 127 insertions(+), 93 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 72930fe..87a3f64 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -826,7 +826,7 @@ retained, possibly temporariliy, because it might be used internally." "C-STRINGS->STRING-LIST" ;; misc. utilities used internally - "LEGAL-FUN-NAME-P" + "LEGAL-FUN-NAME-P" "LEGAL-FUN-NAME-OR-TYPE-ERROR" "FUN-NAME-BLOCK-NAME" "FUN-NAME-INLINE-EXPANSION" "WHITESPACE-CHAR-P" diff --git a/src/code/debug.lisp b/src/code/debug.lisp index faa5279..7ac9469 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -78,22 +78,24 @@ *debug-command-level*)) (defparameter *debug-help-string* -"The prompt is right square brackets, the number indicating how many - recursive command loops you are in. -Any command may be uniquely abbreviated. +"The prompt is square brackets, with number(s) indicating the current control + stack level and, if you've entered the debugger recursively, how deeply + recursed you are. +Any command -- including the name of a restart -- may be uniquely abbreviated. The debugger rebinds various special variables for controlling i/o, sometimes to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to its own special values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*. -Debug commands do not affect * and friends, but evaluation in the debug loop - does affect these variables. +Debug commands do not affect *, //, and similar variables, but evaluation in + the debug loop does affect these variables. SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt - drop you into deeper into the debugger. + drop you deeper into the debugger. Getting in and out of the debugger: RESTART invokes restart numbered as shown (prompt if not given). ERROR prints the error condition and restart cases. - The name of any restart, or its number, is a valid command, and is the same - as using RESTART to invoke that restart. + The number of any restart, or its name, or a unique abbreviation for its + name, is a valid command, and is the same as using RESTART to invoke that + restart. Changing frames: U up frame D down frame @@ -266,30 +268,32 @@ Other commands: ;;;; the BREAKPOINT-INFO structure ;;; info about a made breakpoint -(defstruct (breakpoint-info (:copier nil)) +(defstruct (breakpoint-info (:copier nil) + (:constructor %make-breakpoint-info)) ;; where we are going to stop - (place (missing-arg) :type (or sb!di:code-location sb!di:debug-fun)) - ;; the breakpoint returned by sb!di:make-breakpoint - (breakpoint (missing-arg) :type sb!di:breakpoint) + (place (missing-arg) + :type (or sb!di:code-location sb!di:debug-fun) + :read-only t) + ;; the breakpoint returned by SB!DI:MAKE-BREAKPOINT + (breakpoint (missing-arg) :type sb!di:breakpoint :read-only t) ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is ;; non-NIL, drop into the debugger. - (break #'identity :type function) - ;; the function returned from sb!di:preprocess-for-eval. If result is + (break #'identity :type function :read-only t) + ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is ;; non-NIL, eval (each) print and print results. - (condition #'identity :type function) - ;; the list of functions from sb!di:preprocess-for-eval to evaluate. - ;; Results are conditionally printed. Car of each element is the - ;; function, cdr is the form it goes with. - (print nil :type list) + (condition #'identity :type function :read-only t) + ;; the list of functions from SB!DI:PREPROCESS-FOR-EVAL to evaluate. + ;; Results are conditionally printed. CAR of each element is the + ;; function, CDR is the form it goes with. + (print nil :type list :read-only t) ;; the number used when listing the possible breakpoints within a - ;; function. Could also be a symbol such as start or end. - (code-location-number (missing-arg) :type (or symbol integer)) - ;; the number used when listing the breakpoints active and to delete - ;; breakpoints - (breakpoint-number (missing-arg) :type integer)) - -;;; Return a new BREAKPOINT-INFO structure with the info passed. -(defun create-breakpoint-info (place breakpoint code-location-number + ;; function; or could also be a symbol such as START or END + (code-location-selector (missing-arg) :type (or symbol integer) :read-only t) + ;; the number used when listing the active breakpoints, and when + ;; deleting breakpoints + (breakpoint-number (missing-arg) :type integer) :read-only t) + +(defun create-breakpoint-info (place breakpoint code-location-selector &key (break #'identity) (condition #'identity) (print nil)) (setf *breakpoints* @@ -301,25 +305,25 @@ Other commands: (first breakpoints))))) i)))) - (make-breakpoint-info :place place :breakpoint breakpoint - :code-location-number code-location-number - :breakpoint-number breakpoint-number - :break break :condition condition :print print))) + (%make-breakpoint-info :place place + :breakpoint breakpoint + :code-location-selector code-location-selector + :breakpoint-number breakpoint-number + :break break + :condition condition + :print print))) -;;; Print the breakpoint info for the breakpoint-info structure passed. (defun print-breakpoint-info (breakpoint-info) (let ((place (breakpoint-info-place breakpoint-info)) - (bp-number (breakpoint-info-breakpoint-number breakpoint-info)) - (loc-number (breakpoint-info-code-location-number breakpoint-info))) + (bp-number (breakpoint-info-breakpoint-number breakpoint-info))) (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info)) (:code-location (print-code-location-source-form place 0) (format t "~&~S: ~S in ~S" bp-number - loc-number - (sb!di:debug-fun-name (sb!di:code-location-debug-fun - place)))) + (breakpoint-info-code-location-selector breakpoint-info) + (sb!di:debug-fun-name (sb!di:code-location-debug-fun place)))) (:fun-start (format t "~&~S: FUN-START in ~S" bp-number (sb!di:debug-fun-name place))) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index fdec808..53e1742 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -229,7 +229,7 @@ (defun %defun (name def doc) (declare (type function def)) (declare (type (or null simple-string doc))) - (aver (legal-fun-name-p name)) + (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN (when (fboundp name) (/show0 "redefining NAME in %DEFUN") (style-warn "redefining ~S in DEFUN" name)) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index cb48d4e..75ec633 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -588,6 +588,15 @@ (symbolp (cadr name)) (null (cddr name))))) +;;; Signal an error unless NAME is a legal function name. +(defun legal-fun-name-or-type-error (name) + (unless (legal-fun-name-p name) + (error 'simple-type-error + :datum name + :expected-type '(or symbol list) + :format-control "invalid function name: ~S" + :format-arguments (list name)))) + ;;; Given a function name, return the name for the BLOCK which ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET). (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index fd0fdd5..78a574a 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -54,12 +54,7 @@ ;;; CREATE is non-NIL, create a new (unbound) one. (defun fdefinition-object (name create) (declare (values (or fdefn null))) - (unless (legal-fun-name-p name) - (error 'simple-type-error - :datum name - :expected-type '(or symbol list) - :format-control "invalid function name: ~S" - :format-arguments (list name))) + (legal-fun-name-or-type-error name) (let ((fdefn (info :function :definition name))) (if (and (null fdefn) create) (setf (info :function :definition name) (make-fdefn name)) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index adceea0..32cc184 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -104,15 +104,26 @@ ;;;; DEFINE-COMPILER-MACRO -;;; FIXME: The logic here for handling compiler macros named (SETF -;;; FOO) was added after the fork from SBCL, is not well tested, and -;;; may conflict with subtleties of the ANSI standard. E.g. section -;;; "3.2.2.1 Compiler Macros" says that creating a lexical binding for -;;; a function name shadows a compiler macro, and it's not clear that -;;; that works with this version. It should be tested. (defmacro-mundanely define-compiler-macro (name lambda-list &body body) #!+sb-doc "Define a compiler-macro for NAME." + (legal-fun-name-or-type-error name) + (when (consp name) + ;; It's fairly clear that the user intends the compiler macro to + ;; expand when he does (SETF (FOO ...) X). And that's even a + ;; useful and reasonable thing to want. Unfortunately, + ;; (SETF (FOO ...) X) macroexpands into (FUNCALL (SETF FOO) X ...), + ;; and it's not at all clear that it's valid to expand a FUNCALL form, + ;; and the ANSI standard doesn't seem to say anything else which + ;; would justify us expanding the compiler macro the way the user + ;; wants. So instead we rely on 3.2.2.1.3 "When Compiler Macros Are + ;; Used" which says they never have to be used, so by ignoring such + ;; macros we're erring on the safe side. But any user who does + ;; (DEFINE-COMPILER-MACRO (SETF FOO) ...) could easily be surprised + ;; by this way of complying with a rather screwy aspect of the ANSI + ;; spec, so at least we can warn him... + (compiler-style-warn + "defining compiler macro of (SETF ...), which will not be expanded")) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (body local-decs doc) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 52f01c3..cb9c502 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -176,6 +176,14 @@ :hash-vector (unless (eq test 'eq) (make-array size+1 :element-type '(unsigned-byte 32) + ;; as explained by pmai on + ;; openprojects #lisp IRC + ;; 2002-07-30: #x80000000 is + ;; bigger than any possible nonEQ + ;; hash value, and thus indicates + ;; an empty slot; and EQ hash + ;; tables don't use + ;; HASH-TABLE-HASH-VECTOR :initial-element #x80000000))))) (declare (type index size+1 scaled-size length)) ;; Set up the free list, all free. These lists are 0 terminated. diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ca733d9..1d1ac48 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1453,8 +1453,7 @@ (warm-symbol cadr-des)))) (#.sb!vm:other-pointer-lowtag (warm-symbol des))))) - (unless (legal-fun-name-p result) - (error "not a legal function name: ~S" result)) + (legal-fun-name-or-type-error result) result)) (defun cold-fdefinition-object (cold-name &optional leave-fn-raw) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 52cf65f..81d3525 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -189,22 +189,23 @@ (defun sb!xc:compiler-macro-function (name &optional env) #!+sb-doc - "If NAME names a compiler-macro, return the expansion function, else - return NIL. Note: if the name is shadowed in ENV by a local definition, - or declared NOTINLINE, NIL is returned. Can be set with SETF." - (let ((found (and env - (cdr (assoc name (sb!c::lexenv-funs env) - :test #'equal))))) - (unless (eq (cond ((sb!c::defined-fun-p found) - (sb!c::defined-fun-inlinep found)) - (found :notinline) - (t - (info :function :inlinep name))) - :notinline) - (values (info :function :compiler-macro-function name))))) -(defun (setf sb!xc:compiler-macro-function) (function name) + "If NAME names a compiler-macro in ENV, return the expansion function, else + return NIL. Can be set with SETF when ENV is NIL." + (legal-fun-name-or-type-error name) + ;; Note: CMU CL used to return NIL here when a NOTINLINE declaration + ;; was in force. That's fairly logical, given the specified effect + ;; of NOTINLINE declarations on compiler-macro expansion. However, + ;; (1) it doesn't seem to be consistent with the ANSI spec for + ;; COMPILER-MACRO-FUNCTION, and (2) it would give surprising + ;; behavior for (SETF (COMPILER-MACRO-FUNCTION FOO) ...) in the + ;; presence of a (PROCLAIM '(NOTINLINE FOO)). So we don't do it. + (values (info :function :compiler-macro-function name))) +(defun (setf sb!xc:compiler-macro-function) (function name &optional env) (declare (type (or symbol list) name) (type (or function null) function)) + (when env + ;; ANSI says this operation is undefined. + (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL")) (when (eq (info :function :kind name) :special-form) (error "~S names a special form." name)) (setf (info :function :compiler-macro-function name) function) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index c06a99b..1c129bf 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -729,6 +729,8 @@ (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new)) (when (and (not intersects) + ;; FIXME: Is it really right to look at *LEXENV* here, + ;; instead of looking at the LEXENV argument? Why? (not (policy *lexenv* (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warn diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 269345d..7b53cb5 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -586,22 +586,31 @@ (values)) ;;; Convert anything that looks like a special form, global function -;;; or macro call. +;;; or compiler-macro call. (defun ir1-convert-global-functoid (start cont form) (declare (type continuation start cont) (list form)) - (let* ((fun (first form)) - (translator (info :function :ir1-convert fun)) - (cmacro (info :function :compiler-macro-function fun))) - (cond (translator (funcall translator start cont form)) - ((and cmacro - (not (eq (info :function :inlinep fun) - :notinline))) - (let ((res (careful-expand-macro cmacro form))) + (let* ((fun-name (first form)) + (translator (info :function :ir1-convert fun-name)) + (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*))) + (cond (translator + (when cmacro-fun + (compiler-warn "ignoring compiler macro for special form")) + (funcall translator start cont form)) + ((and cmacro-fun + ;; gotcha: If you look up the DEFINE-COMPILER-MACRO + ;; macro in the ANSI spec, you might think that + ;; suppressing compiler-macro expansion when NOTINLINE + ;; is some pre-ANSI hack. However, if you look up the + ;; NOTINLINE declaration, you'll find that ANSI + ;; requires this behavior after all. + (not (eq (info :function :inlinep fun-name) :notinline))) + (let ((res (careful-expand-macro cmacro-fun form))) (if (eq res form) - (ir1-convert-global-functoid-no-cmacro start cont form fun) + (ir1-convert-global-functoid-no-cmacro + start cont form fun-name) (ir1-convert start cont res)))) (t - (ir1-convert-global-functoid-no-cmacro start cont form fun))))) + (ir1-convert-global-functoid-no-cmacro start cont form fun-name))))) ;;; Handle the case of where the call was not a compiler macro, or was ;;; a compiler macro and passed. @@ -1988,9 +1997,9 @@ :source-name source-name :debug-name debug-name)))) -;;; Get a DEFINED-FUN object for a function we are about to -;;; define. If the function has been forward referenced, then -;;; substitute for the previous references. +;;; Get a DEFINED-FUN object for a function we are about to define. If +;;; the function has been forward referenced, then substitute for the +;;; previous references. (defun get-defined-fun (name) (proclaim-as-fun-name name) (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 8834de1..610990c 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -903,8 +903,8 @@ ;; nice default for things where we don't have a ;; real source path (as in e.g. inside CL:COMPILE). '(original-source-start 0 0))) - (unless (or (null name) (legal-fun-name-p name)) - (error "not a legal function name: ~S" name)) + (when name + (legal-fun-name-or-type-error name)) (let* ((*lexenv* (make-lexenv :policy *policy*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name @@ -974,8 +974,7 @@ (defun process-toplevel-cold-fset (name lambda-expression path) (unless (producing-fasl-file) (error "can't COLD-FSET except in a fasl file")) - (unless (legal-fun-name-p name) - (error "not a legal function name: ~S" name)) + (legal-fun-name-or-type-error name) (fasl-dump-cold-fset name (%compile lambda-expression *compile-object* diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 2c30e85..85325e3 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -14,9 +14,9 @@ ;;; Break a lambda list into its component parts. We return eleven ;;; values: ;;; 1. a list of the required args; -;;; 2. a list of the optional arg specs; -;;; 3. true if a rest arg was specified; -;;; 4. the &rest arg; +;;; 2. a list of the &OPTIONAL arg specs; +;;; 3. true if a &REST arg was specified; +;;; 4. the &REST arg; ;;; 5. true if &KEY args are present; ;;; 6. a list of the &KEY arg specs; ;;; 7. true if &ALLOW-OTHER-KEYS was specified.; diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 6f4177c..3e51cf8 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -157,10 +157,7 @@ bootstrapping. (defmacro defgeneric (fun-name lambda-list &body options) (declare (type list lambda-list)) - (unless (legal-fun-name-p fun-name) - (error 'simple-program-error - :format-control "illegal generic function name ~S" - :format-arguments (list fun-name))) + (legal-fun-name-or-type-error fun-name) (let ((initargs ()) (methods ())) (flet ((duplicate-option (name) diff --git a/version.lisp-expr b/version.lisp-expr index 1b37878..22d5c92 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.6.19" +"0.7.6.20" -- 1.7.10.4