From 0a82f2db352cc348d2107a882e50af222ff97ed3 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 13 Oct 2001 02:44:15 +0000 Subject: [PATCH] 0.pre7.61: OK, that's enough renaming for a while. I'm tired of rebuilding taking so long, and from the long compile times of the DEFSTRUCT-heavy files like node.lisp, the use of DEFUN instead of closures to define structure accessors is likely to be contributing, and that's something I wanted to fix anyway. So in preparation for removing DEFUNs from DEFSTRUCT macroexpansion.. ..hacked the definition of INFO :FUNCTION :INLINE-EXPANSION so that it will accept FUNCTION values as well as lambda expressions, with the nonobvious but convenient interpretation that the function is to be called to get a lambda expression. ..wrote FUN-NAME-INLINE-EXPANSION to support this ..renamed other FUNCTION-NAME stuff to have parallel names ..renamed INFO :FUNCTION :INLINE-EXPANSION to INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..renamed CLASS-STRUCTURE-P to DD-CLASS-P, since I keep forgetting exactly what CLASS-STRUCTURE-P means (and vice versa, forgetting the name for this property) tweaked representation of INFO :VARIABLE :CONSTANT-VALUE so that it returns only a single value, so that we no longer need the complexity of VALUES-returning INFO entries, so that the type declaration of the return value doesn't wander into the twilight zone of whether T is a (VALUES T T) and similar questions that ANSI seems not to've considered restructured compiler-macro implementation of INFO to avoid the (VALUES T T) ambiguity rewrote FIND-FREE-VARIABLE to use bare (EQL (INFO :VARIABLE :KIND ..) :CONSTANT) instead of messing with the second value return from (INFO :VARIABLE :CONSTANT-VALUE ..); and checked that there are no other uses of the second value split #'SYMBOL-SELF-EVALUATING-P out of #'ABOUT-TO-MODIFY, and used it in INFO instead of the funky special casing of T and NIL in :DEFAULT of INFO :VARIABLE :KIND and elsewhere copied Christophe Rhodes' *BACKEND-FEATURES* documentation from the CLiki SBCL internals site and pasted them into the source code --- package-data-list.lisp-expr | 12 +++-- src/code/cold-error.lisp | 6 +-- src/code/debug-int.lisp | 4 +- src/code/defboot.lisp | 19 +++---- src/code/defstruct.lisp | 38 ++++++------- src/code/describe.lisp | 10 ++-- src/code/early-extensions.lisp | 63 +++++++++++++--------- src/code/early-setf.lisp | 2 +- src/code/eval.lisp | 2 +- src/code/fdefinition.lisp | 15 +++--- src/code/late-format.lisp | 4 +- src/code/macros.lisp | 6 +-- src/code/print.lisp | 2 +- src/code/profile.lisp | 24 ++++----- src/code/target-format.lisp | 2 +- src/compiler/aliencomp.lisp | 4 +- src/compiler/backend.lisp | 51 +++++++++++++++--- src/compiler/constraint.lisp | 2 +- src/compiler/disassem.lisp | 4 +- src/compiler/dump.lisp | 2 +- src/compiler/float-tran.lisp | 4 +- src/compiler/generic/genesis.lisp | 4 +- src/compiler/globaldb.lisp | 106 +++++++++++++++++++++++++------------ src/compiler/info-functions.lisp | 20 +++---- src/compiler/ir1-translators.lisp | 6 +-- src/compiler/ir1final.lisp | 2 +- src/compiler/ir1opt.lisp | 8 +-- src/compiler/ir1tran.lisp | 47 ++++++++-------- src/compiler/ir1util.lisp | 4 +- src/compiler/ir2tran.lisp | 15 +++--- src/compiler/ltn.lisp | 6 +-- src/compiler/macros.lisp | 4 +- src/compiler/main.lisp | 4 +- src/compiler/proclaim.lisp | 4 +- src/compiler/srctran.lisp | 2 +- src/compiler/target-disassem.lisp | 2 +- src/compiler/target-main.lisp | 2 +- src/pcl/boot.lisp | 97 +++++++++++++++++---------------- src/pcl/combin.lisp | 2 +- src/pcl/construct.lisp | 2 +- src/pcl/dfun.lisp | 2 +- src/pcl/fast-init.lisp | 2 +- src/pcl/generic-functions.lisp | 2 +- src/pcl/low.lisp | 14 ++--- src/pcl/macros.lisp | 2 +- src/pcl/methods.lisp | 5 +- src/pcl/slots-boot.lisp | 8 +-- src/pcl/vector.lisp | 4 +- stems-and-flags.lisp-expr | 2 +- version.lisp-expr | 2 +- 50 files changed, 374 insertions(+), 282 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3c0cd3e..042c224 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -811,8 +811,9 @@ retained, possibly temporariliy, because it might be used internally." "C-STRINGS->STRING-LIST" ;; misc. utilities used internally - "LEGAL-FUNCTION-NAME-P" - "FUNCTION-NAME-BLOCK-NAME" + "LEGAL-FUN-NAME-P" + "FUN-NAME-BLOCK-NAME" + "FUN-NAME-INLINE-EXPANSION" "WHITESPACE-CHAR-P" "LISTEN-SKIP-WHITESPACE" "PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT" @@ -827,6 +828,7 @@ retained, possibly temporariliy, because it might be used internally." "FLUSH-STANDARD-OUTPUT-STREAMS" "MAKE-GENSYM-LIST" "ABOUT-TO-MODIFY" + "SYMBOL-SELF-EVALUATING-P" "PRINT-PRETTY-ON-STREAM-P" "LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P" "POSITIVE-PRIMEP" @@ -1227,7 +1229,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" "DSD-RAW-TYPE" "DEFSTRUCT-DESCRIPTION" "UNDEFINE-STRUCTURE" - "DD-COPIER" "UNDEFINE-FUNCTION-NAME" "DD-TYPE" + "DD-COPIER" "UNDEFINE-FUN-NAME" "DD-TYPE" "CLASS-STATE" "INSTANCE" "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" "DSD-NAME" "%TYPEP" "DD-RAW-INDEX" @@ -1246,8 +1248,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "LAYOUT-OF" "%SIMPLE-FUN-SELF" "%REALPART" "STRUCTURE-CLASS-P" "DSD-INDEX" "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" - "%SIMPLE-FUN-TYPE" "PROCLAIM-AS-FUNCTION-NAME" - "BECOME-DEFINED-FUNCTION-NAME" + "%SIMPLE-FUN-TYPE" "PROCLAIM-AS-FUN-NAME" + "BECOME-DEFINED-FUN-NAME" "%NUMERATOR" "CLASS-TYPEP" "STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY" "LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS" diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 768551a..af60c4e 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -43,7 +43,7 @@ ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a ;;; single argument that's directly usable by all the other routines. -(defun coerce-to-condition (datum arguments default-type function-name) +(defun coerce-to-condition (datum arguments default-type fun-name) (cond ((typep datum 'condition) (if arguments (cerror "Ignore the additional arguments." @@ -52,7 +52,7 @@ :expected-type 'null :format-control "You may not supply additional arguments ~ when giving ~S to ~S." - :format-arguments (list datum function-name))) + :format-arguments (list datum fun-name))) datum) ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) (apply #'make-condition datum arguments)) @@ -65,7 +65,7 @@ :datum datum :expected-type '(or symbol string) :format-control "bad argument to ~S: ~S" - :format-arguments (list function-name datum))))) + :format-arguments (list fun-name datum))))) ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably ;;; doesn't want to hear that the error "occurred in" one of these diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index bb1eb1f..9786b0b 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -349,7 +349,7 @@ (elsewhere-p nil :type boolean)) (def!method print-object ((obj debug-block) str) (print-unreadable-object (obj str :type t) - (prin1 (debug-block-function-name obj) str))) + (prin1 (debug-block-fun-name obj) str))) #!+sb-doc (setf (fdocumentation 'debug-block-successors 'function) @@ -1889,7 +1889,7 @@ ;;; Return the name of the function represented by DEBUG-FUN. ;;; This may be a string or a cons; do not assume it is a symbol. -(defun debug-block-function-name (debug-block) +(defun debug-block-fun-name (debug-block) (etypecase debug-block (compiled-debug-block (let ((code-locs (compiled-debug-block-code-locations debug-block))) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 48f1497..fb80dc3 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -144,7 +144,7 @@ ;;;; DEFUN ;;; Should we save the inline expansion of the function named NAME? -(defun inline-function-name-p (name) +(defun inline-fun-name-p (name) (or ;; the normal reason for saving the inline expansion (info :function :inlinep name) @@ -157,26 +157,27 @@ ;; (DEFUN FOO ..) ;; without a preceding ;; (DECLAIM (INLINE FOO)) - ;; what should we do with the old inline expansion? Overwriting it - ;; with the new definition seems like the only unsurprising choice. - (info :function :inline-expansion name))) + ;; what should we do with the old inline expansion when we see the + ;; new DEFUN? Overwriting it with the new definition seems like + ;; the only unsurprising choice. + (info :function :inline-expansion-designator name))) ;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can ;;; make a reasonably readable definition of DEFUN. (defmacro-mundanely defun (&environment env name args &body body) "Define a function at top level." #+sb-xc-host - (unless (symbol-package (function-name-block-name name)) + (unless (symbol-package (fun-name-block-name name)) (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name)) (multiple-value-bind (forms decls doc) (parse-body body) (let* ((lambda `(lambda ,args ,@decls - (block ,(function-name-block-name name) + (block ,(fun-name-block-name name) ,@forms))) (want-to-inline ) (inline-lambda (cond (;; Does the user not even want to inline? - (not (inline-function-name-p name)) + (not (inline-fun-name-p name)) nil) (;; Does inlining look too hairy to handle? (not (sb!c:lambda-independent-of-lexenv-p lambda env)) @@ -221,8 +222,8 @@ (declare (type function def)) (declare (type (or null simple-string doc))) (/show0 "entering %DEFUN, name (or block name) = ..") - (/primitive-print (symbol-name (function-name-block-name name))) - (aver (legal-function-name-p name)) + (/primitive-print (symbol-name (fun-name-block-name name))) + (aver (legal-fun-name-p name)) (when (fboundp name) (/show0 "redefining NAME") (style-warn "redefining ~S in DEFUN" name)) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 6b1f516..8934602 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -82,7 +82,7 @@ funcallable-structure)) ;; The next three slots are for :TYPE'd structures (which aren't - ;; classes, CLASS-STRUCTURE-P = NIL) + ;; classes, DD-CLASS-P = NIL) ;; ;; vector element type (element-type t) @@ -104,7 +104,7 @@ (raw-index nil :type (or index null)) (raw-length 0 :type index) ;; the value of the :PURE option, or :UNSPECIFIED. This is only - ;; meaningful if CLASS-STRUCTURE-P = T. + ;; meaningful if DD-CLASS-P = T. (pure :unspecified :type (member t nil :substructure :unspecified))) (def!method print-object ((x defstruct-description) stream) (print-unreadable-object (x stream :type t) @@ -147,7 +147,7 @@ (prin1 (dsd-name x) stream))) ;;; Is DEFSTRUCT a structure with a class? -(defun class-structure-p (defstruct) +(defun dd-class-p (defstruct) (member (dd-type defstruct) '(structure funcallable-structure))) ;;; Return the name of a defstruct slot as a symbol. We store it as a @@ -193,8 +193,8 @@ (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION ;; option, return the value to pass as an arg to FUNCTION. (farg (oarg) - (destructuring-bind (function-name) oarg - function-name))) + (destructuring-bind (fun-name) oarg + fun-name))) (cond ((not (eql pf 0)) `((def!method print-object ((,x ,name) ,s) (funcall #',(farg pf) ,x ,s *current-level*)))) @@ -232,7 +232,7 @@ name-and-options slot-descriptions)) (name (dd-name dd))) - (if (class-structure-p dd) + (if (dd-class-p dd) (let ((inherits (inherits-for-structure dd))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -437,7 +437,7 @@ (defun require-no-print-options-so-far (defstruct) (unless (and (eql (dd-print-function defstruct) 0) (eql (dd-print-object defstruct) 0)) - (error "no more than one of the following options may be specified: + (error "No more than one of the following options may be specified: :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE"))) ;;; Parse a single DEFSTRUCT option and store the results in DD. @@ -700,17 +700,17 @@ (destructuring-bind (included-name &rest modified-slots) (dd-include dd) (let* ((type (dd-type dd)) (included-structure - (if (class-structure-p dd) + (if (dd-class-p dd) (layout-info (compiler-layout-or-lose included-name)) (typed-structure-info-or-lose included-name)))) (unless (and (eq type (dd-type included-structure)) (type= (specifier-type (dd-element-type included-structure)) (specifier-type (dd-element-type dd)))) - (error ":TYPE option mismatch between structures ~S and ~S." + (error ":TYPE option mismatch between structures ~S and ~S" (dd-name dd) included-name)) (incf (dd-length dd) (dd-length included-structure)) - (when (class-structure-p dd) + (when (dd-class-p dd) (let ((mc (rest (dd-alternate-metaclass included-structure)))) (when (and mc (not (dd-alternate-metaclass dd))) (setf (dd-alternate-metaclass dd) @@ -875,10 +875,10 @@ (let* ((fun (dsd-accessor-name slot)) (setf-fun `(setf ,fun))) (when (and fun (eq (dsd-raw-type slot) t)) - (proclaim-as-defstruct-function-name fun) + (proclaim-as-defstruct-fun-name fun) (setf (info :function :accessor-for fun) class) (unless (dsd-read-only slot) - (proclaim-as-defstruct-function-name setf-fun) + (proclaim-as-defstruct-fun-name setf-fun) (setf (info :function :accessor-for setf-fun) class))))) ;; FIXME: Couldn't this logic be merged into @@ -1040,13 +1040,13 @@ (when (defstruct-description-p info) (let ((type (dd-name info))) (setf (info :type :compiler-layout type) nil) - (undefine-function-name (dd-copier info)) - (undefine-function-name (dd-predicate-name info)) + (undefine-fun-name (dd-copier info)) + (undefine-fun-name (dd-predicate-name info)) (dolist (slot (dd-slots info)) (let ((fun (dsd-accessor-name slot))) - (undefine-function-name fun) + (undefine-fun-name fun) (unless (dsd-read-only slot) - (undefine-function-name `(setf ,fun)))))) + (undefine-fun-name `(setf ,fun)))))) ;; Clear out the SPECIFIER-TYPE cache so that subsequent ;; references are unknown types. (values-specifier-type-cache-clear))) @@ -1345,15 +1345,15 @@ ;;;; compiler stuff -;;; This is like PROCLAIM-AS-FUNCTION-NAME, but we also set the kind to +;;; This is like PROCLAIM-AS-FUN-NAME, but we also set the kind to ;;; :DECLARED and blow away any ASSUMED-TYPE. Also, if the thing is a ;;; slot accessor currently, quietly unaccessorize it. And if there ;;; are any undefined warnings, we nuke them. -(defun proclaim-as-defstruct-function-name (name) +(defun proclaim-as-defstruct-fun-name (name) (when name (when (info :function :accessor-for name) (setf (info :function :accessor-for name) nil)) - (proclaim-as-function-name name) + (proclaim-as-fun-name name) (note-name-defined name :function) (setf (info :function :where-from name) :declared) (when (info :function :assumed-type name) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index cf4e87f..fc04552 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -36,7 +36,7 @@ (defmethod describe-object ((x cons) s) (call-next-method) - (when (and (legal-function-name-p x) + (when (and (legal-fun-name-p x) (fboundp x)) (%describe-function (fdefinition x) s :function x) ;;was: (format s "~@:_Its FDEFINITION is ~S.~@:_" (fdefinition x)) @@ -110,8 +110,8 @@ ;;; up as a name. (In the case of anonymous closures and other ;;; things, it might not be.) TYPE-SPEC is the function type specifier ;;; extracted from the definition, or NIL if none. -(declaim (ftype (function (t stream t)) %describe-function-name)) -(defun %describe-function-name (name s type-spec) +(declaim (ftype (function (t stream t)) %describe-fun-name)) +(defun %describe-fun-name (name s type-spec) (when (and name (typep name '(or symbol cons))) (multiple-value-bind (type where) (if (or (symbolp name) (and (listp name) (eq (car name) 'setf))) @@ -127,7 +127,7 @@ (format s "~@:_It is currently declared ~(~A~);~ ~:[no~;~] expansion is available." - inlinep (info :function :inline-expansion name)))))) + inlinep (info :function :inline-expansion-designator name)))))) ;;; Print information from the debug-info about where CODE-OBJ was ;;; compiled from. @@ -179,7 +179,7 @@ (let ((name (or name (%simple-fun-name x)))) (%describe-doc name s 'function kind) (unless (eq kind :macro) - (%describe-function-name name s (%simple-fun-type x)))) + (%describe-fun-name name s (%simple-fun-type x)))) (%describe-compiled-from (sb-kernel:fun-code-header x) s)) ;;; Describe a function with the specified kind and name. The latter diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index de6421e..7946088 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -555,7 +555,7 @@ ;;;; various operations on names ;;; Is NAME a legal function name? -(defun legal-function-name-p (name) +(defun legal-fun-name-p (name) (or (symbolp name) (and (consp name) (eq (car name) 'setf) @@ -565,16 +565,16 @@ ;;; 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) function-name-block-name)) -(defun function-name-block-name (function-name) - (cond ((symbolp function-name) - function-name) - ((and (consp function-name) - (= (length function-name) 2) - (eq (first function-name) 'setf)) - (second function-name)) +(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) +(defun fun-name-block-name (fun-name) + (cond ((symbolp fun-name) + fun-name) + ((and (consp fun-name) + (= (length fun-name) 2) + (eq (first fun-name) 'setf)) + (second fun-name)) (t - (error "not legal as a function name: ~S" function-name)))) + (error "not legal as a function name: ~S" fun-name)))) (defun looks-like-name-of-special-var-p (x) (and (symbolp x) @@ -583,26 +583,37 @@ (char= #\* (aref name 0)) (char= #\* (aref name (1- (length name)))))))) -;;; ANSI guarantees that some symbols are self-evaluating. This -;;; function is to be called just before a change which would affect -;;; that. (We don't absolutely have to call this function before such -;;; changes, since such changes are given as undefined behavior. In -;;; particular, we don't if the runtime cost would be annoying. But -;;; otherwise it's nice to do so.) -(defun about-to-modify (symbol) +;;; Some symbols are defined by ANSI to be self-evaluating. Return +;;; non-NIL for such symbols (and make the non-NIL value a traditional +;;; message, for use in contexts where the user asks us to change such +;;; a symbol). +(defun symbol-self-evaluating-p (symbol) (declare (type symbol symbol)) (cond ((eq symbol t) - (error "Veritas aeterna. (can't change T)")) + "Veritas aeterna. (can't change T)") ((eq symbol nil) - (error "Nihil ex nihil. (can't change NIL)")) + "Nihil ex nihil. (can't change NIL)") ((keywordp symbol) - (error "Keyword values can't be changed.")) - ;; (Just because a value is CONSTANTP is not a good enough - ;; reason to complain here, because we want DEFCONSTANT to - ;; be able to use this function, and it's legal to DEFCONSTANT - ;; a constant as long as the new value is EQL to the old - ;; value.) - )) + "Keyword values can't be changed.") + (t + nil))) + +;;; This function is to be called just before a change which would +;;; affect that. (We don't absolutely have to call this function +;;; before such changes, since such changes are given as undefined +;;; behavior. In particular, we don't if the runtime cost would be +;;; annoying. But otherwise it's nice to do so.) +(defun about-to-modify (symbol) + (declare (type symbol symbol)) + (let ((reason (symbol-self-evaluating-p symbol))) + (when reason + (error reason))) + ;; (Note: Just because a value is CONSTANTP is not a good enough + ;; reason to complain here, because we want DEFCONSTANT to be able + ;; to use this function, and it's legal to DEFCONSTANT a constant as + ;; long as the new value is EQL to the old value.) + (values)) + ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary ;;; assignment. That way things like diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 86968cf..6fc65d7 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -343,7 +343,7 @@ GET-SETF-EXPANSION directly." (warn "defining SETF macro for DEFSTRUCT slot ~ accessor; redefining as a normal function: ~S" name) - (proclaim-as-function-name name)) + (proclaim-as-fun-name name)) ((not (eq (symbol-package name) (symbol-package 'aref))) (style-warn "defining setf macro for ~S when ~S is fbound" name `(setf ,name)))) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 3e30128..c1ea72b 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -177,7 +177,7 @@ ((stringp name) (values nil t name)) (t - (let ((exp (info :function :inline-expansion name))) + (let ((exp (fun-name-inline-expansion name))) (if exp (values exp nil name) (values nil t name)))))) diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index bcc0736..b5b6840 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -55,7 +55,7 @@ "Return the fdefn object for NAME. If it doesn't already exist and CREATE is non-NIL, create a new (unbound) one." (declare (values (or fdefn null))) - (unless (legal-function-name-p name) + (unless (legal-fun-name-p name) (error 'simple-type-error :datum name :expected-type '(or symbol list) @@ -285,12 +285,13 @@ ;;; (TRACE FOO) ;;; (FUNCALL 'FOO) ;;; (FUNCALL (FDEFINITION 'FOO)) -;;; What to do? ANSI says TRACE "Might change the definitions of the functions -;;; named by function-names." Might it be OK to just get punt all this -;;; encapsulation stuff and go back to a simple but correct implementation of -;;; TRACE? We'd lose the ability to redefine a TRACEd function and keep the -;;; trace in place, but that seems tolerable to me. (Is the wrapper stuff -;;; needed for anything else besides TRACE?) +;;; What to do? ANSI says TRACE "Might change the definitions of the +;;; functions named by function-names." Might it be OK to just get +;;; punt all this encapsulation stuff and go back to a simple but +;;; correct implementation of TRACE? We'd lose the ability to redefine +;;; a TRACEd function and keep the trace in place, but that seems +;;; tolerable to me. (Is the wrapper stuff needed for anything else +;;; besides TRACE?) ;;; ;;; The only problem I can see with not having a wrapper: If tracing ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change, diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 1a3be5c..65ffe67 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -1116,7 +1116,7 @@ ;;;; format directive and support function for user-defined method (def-format-directive #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-function-name string start end))) + (let ((symbol (extract-user-fun-name string start end))) (collect ((param-names) (bindings)) (dolist (param-and-offset params) (let ((param (cdr param-and-offset))) @@ -1131,7 +1131,7 @@ (,symbol stream ,(expand-next-arg) ,colonp ,atsignp ,@(param-names)))))) -(defun extract-user-function-name (string start end) +(defun extract-user-fun-name (string start end) (let ((slash (position #\/ string :start start :end (1- end) :from-end t))) (unless slash diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 629f7dd..1976274 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -176,8 +176,8 @@ the usual naming convention (names like *FOO*) for special variables" ;; 2001-03-24 (eval `(defconstant ,name ',value)))) - (setf (info :variable :kind name) :constant) - (setf (info :variable :constant-value name) value) + (setf (info :variable :kind name) :constant + (info :variable :constant-value name) value) name) ;;;; DEFINE-COMPILER-MACRO @@ -198,7 +198,7 @@ the usual naming convention (names like *FOO*) for special variables" :environment environment) (let ((def `(lambda (,whole ,environment) ,@local-decs - (block ,(function-name-block-name name) + (block ,(fun-name-block-name name) ,body)))) `(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc))))) (defun sb!c::%define-compiler-macro (name definition lambda-list doc) diff --git a/src/code/print.lisp b/src/code/print.lisp index 5cd2a14..30b41ab 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1553,7 +1553,7 @@ (let* ((*print-length* 3) ; in case we have to.. (*print-level* 3) ; ..print an interpreted function definition ;; FIXME: This find-the-function-name idiom ought to be - ;; pulled out in a function somewhere. + ;; encapsulated in a function somewhere. (name (case (function-subtype object) (#.sb!vm:closure-header-widetag "CLOSURE") (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object)) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 77edb58..b1b3544 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -47,7 +47,7 @@ ;;; We associate a PROFILE-INFO structure with each profiled function ;;; name. This holds the functions that we call to manipulate the ;;; closure which implements the encapsulation. -(defvar *profiled-function-name->info* (make-hash-table)) +(defvar *profiled-fun-name->info* (make-hash-table)) (defstruct (profile-info (:copier nil)) (name (required-argument) :read-only t) (encapsulated-fun (required-argument) :type function :read-only t) @@ -224,7 +224,7 @@ (list ;; We call this just for the side effect of checking that ;; NAME is a legal function name: - (function-name-block-name name) + (fun-name-block-name name) ;; Then we map onto it. (funcall function name)) (string (let ((package (find-undeleted-package-or-lose name))) @@ -245,7 +245,7 @@ (profile-encapsulation-lambdas encapsulated-fun) (setf (fdefinition name) encapsulation-fun) - (setf (gethash name *profiled-function-name->info*) + (setf (gethash name *profiled-fun-name->info*) (make-profile-info :name name :encapsulated-fun encapsulated-fun :encapsulation-fun encapsulation-fun @@ -256,7 +256,7 @@ ;;; Profile the named function. If already profiled, unprofile first. (defun profile-1-function (name) (cond ((fboundp name) - (when (gethash name *profiled-function-name->info*) + (when (gethash name *profiled-fun-name->info*) (warn "~S is already profiled, so unprofiling it first." name) (unprofile-1-function name)) (profile-1-unprofiled-function name)) @@ -266,9 +266,9 @@ ;;; Unprofile the named function, if it is profiled. (defun unprofile-1-function (name) - (let ((pinfo (gethash name *profiled-function-name->info*))) + (let ((pinfo (gethash name *profiled-fun-name->info*))) (cond (pinfo - (remhash name *profiled-function-name->info*) + (remhash name *profiled-fun-name->info*) (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo)) (setf (fdefinition name) (profile-info-encapsulated-fun pinfo)) (warn "preserving current definition of redefined function ~S" @@ -291,7 +291,7 @@ undefined, then we give a warning and ignore it. See also UNPROFILE, REPORT and RESET." (if (null names) - `(loop for k being each hash-key in *profiled-function-name->info* + `(loop for k being each hash-key in *profiled-fun-name->info* collecting k) `(mapc-on-named-functions #'profile-1-function ',names))) @@ -307,13 +307,13 @@ `(unprofile-all))) (defun unprofile-all () - (dohash (name profile-info *profiled-function-name->info*) + (dohash (name profile-info *profiled-fun-name->info*) (declare (ignore profile-info)) (unprofile-1-function name))) (defun reset () "Reset the counters for all profiled functions." - (dohash (name profile-info *profiled-function-name->info*) + (dohash (name profile-info *profiled-fun-name->info*) (declare (ignore name)) (funcall (profile-info-clear-stats-fun profile-info)))) @@ -356,7 +356,7 @@ Lisp process." (compute-overhead))) (let ((time-info-list ()) (no-call-name-list ())) - (dohash (name pinfo *profiled-function-name->info*) + (dohash (name pinfo *profiled-fun-name->info*) (unless (eq (fdefinition name) (profile-info-encapsulation-fun pinfo)) (warn "Function ~S has been redefined, so times may be inaccurate.~@ @@ -416,7 +416,7 @@ Lisp process." "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" (sort no-call-name-list #'string< :key (lambda (name) - (symbol-name (function-name-block-name name)))))) + (symbol-name (fun-name-block-name name)))))) (values))) @@ -459,7 +459,7 @@ Lisp process." (setf total-overhead (- (frob) call-overhead))) (let* ((pinfo (gethash 'compute-overhead-aux - *profiled-function-name->info*)) + *profiled-fun-name->info*)) (read-stats-fun (profile-info-read-stats-fun pinfo)) (time (nth-value 1 (funcall read-stats-fun)))) (setf internal-overhead diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 3e62ac0..a129f24 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -1158,7 +1158,7 @@ ;;;; format interpreter and support functions for user-defined method (def-format-interpreter #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-function-name string start end))) + (let ((symbol (extract-user-fun-name string start end))) (collect ((args)) (dolist (param-and-offset params) (let ((param (cdr param-and-offset))) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index bcb569c..80176a6 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -521,7 +521,7 @@ (count-low-order-zeros (continuation-value thing)) (count-low-order-zeros (continuation-use thing)))) (combination - (case (continuation-function-name (combination-fun thing)) + (case (continuation-fun-name (combination-fun thing)) ((+ -) (let ((min most-positive-fixnum) (itype (specifier-type 'integer))) @@ -572,7 +572,7 @@ (deftransform ash ((value amount)) (let ((value-node (continuation-use value))) (unless (and (combination-p value-node) - (eq (continuation-function-name (combination-fun value-node)) + (eq (continuation-fun-name (combination-fun value-node)) 'ash)) (give-up-ir1-transform)) (let ((inside-args (combination-args value-node))) diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index e843d69..04c4e35 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -224,12 +224,51 @@ ;;; the VM support routines (defvar *backend-support-routines* (make-vm-support-routines)) (declaim (type vm-support-routines *backend-support-routines*)) + +;;;; This is a prototype interface to support Christophe Rhodes' new +;;;; (sbcl-0.pre7.57) VOP :GUARD clauses for implementations which +;;;; depend on CPU variants, e.g. the differences between I486, +;;;; Pentium, and Pentium Pro, or the differences between different +;;;; SPARC versions. + +;;;; Christophe Rhodes' longer explanation (cut and pasted +;;;; from CLiki SBCL internals site 2001-10-12): +#| +In CMUCL, the :guard argument to VOPs provided a way of disallowing +the use of a particular VOP in compiled code. As an example, from the +SPARC code in CMUCL, + +(DEFINE-VOP? (FAST-V8-TRUNCATE/SIGNED=>SIGNED? FAST-SAFE-ARITH-OP?) + (:TRANSLATE TRUNCATE?) + ... + (:GUARD (OR (BACKEND-FEATUREP :SPARC-V8) + (AND (BACKEND-FEATUREP :SPARC-V9) + (NOT (BACKEND-FEATUREP :SPARC-64))))) + ...) + +and at the IR2 translation stage, the function #'`(LAMBDA () ,GUARD) would be called. + +Until SBCL-0.7pre57, this is translated as + (:GUARD #!+(OR :SPARC-V8 (AND :SPARC-V9 (NOT :SPARC-64))) T + #!-(OR :SPARC-V8 (AND :SPARC-V9 (NOT :SPARC-64))) NIL) +which means that whether this VOP will ever be used is determined at +compiler compile-time depending on the contents of +*SHEBANG-FEATURES*?. + +As of SBCL-0.7pre57, a new special variable, +SB-C:*BACKEND-SUBFEATURES*?, is introduced. As of that version, only +VOPs translating %log1p? query it, and :PENTIUM-STYLE-FYL2XP1 is the +only useful value to be pushed onto that list, for x86. This is not +yet an ideal interface, but it does allow for compile-time +conditionalization. +|# -;;; This is a prototype interface to support Christophe Rhodes' new -;;; (sbcl-0.pre7.57) VOP :GUARD clauses for implementations which -;;; depend on CPU variants, e.g. the differences between I486, -;;; Pentium, and Pentium Pro, or the differences between different -;;; SPARC versions. -;;; ;;; The default value of NIL means use only unguarded VOPs. (defvar *backend-subfeatures* nil) + +;;; possible *BACKEND-SUBFEATURES* values: +;;; +;;; :PENTIUM-STYLE-FYL2XP1 is a useful value for x86 SBCLs to have on +;;; SB-C:*BACKEND-SUBFEATURES*?; it enables the use of the +;;; %flog1p-pentium? VOP rather than the %flog1p? VOP, which is a few +;;; instructions longer. diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index c4c9755..c8b5715 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -126,7 +126,7 @@ (add-complement-constraints if 'typep (ok-ref-lambda-var use) (specifier-type 'null) t)) (combination - (let ((name (continuation-function-name + (let ((name (continuation-fun-name (basic-combination-fun use))) (args (basic-combination-args use))) (case name diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index d8afb76..30bfebb 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -1044,10 +1044,10 @@ "-PRINTER")) (make-printer-defun printer-source funstate name))))) -(defun make-printer-defun (source funstate function-name) +(defun make-printer-defun (source funstate fun-name) (let ((printer-form (compile-printer-list source funstate)) (bindings (make-arg-temp-bindings funstate))) - `(defun ,function-name (chunk inst stream dstate) + `(defun ,fun-name (chunk inst stream dstate) (declare (type dchunk chunk) (type instruction inst) (type stream stream) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 62e6a9a..2cd271c 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1166,7 +1166,7 @@ #+sb-xc-host (defun fasl-dump-cold-fset (fun-name fun-dump-handle fasl-output) (declare (type fixnum fun-dump-handle)) - (aver (legal-function-name-p fun-name)) + (aver (legal-fun-name-p fun-name)) (dump-non-immediate-object fun-name fasl-output) (dump-push fun-dump-handle fasl-output) (dump-fop 'fop-fset fasl-output) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index e426747..dc2615f 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -270,10 +270,10 @@ ;;; rational arithmetic, or different float types, and fix it up. If ;;; we don't, he won't even get so much as an efficiency note. (deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node) - `(,(continuation-function-name (basic-combination-fun node)) + `(,(continuation-fun-name (basic-combination-fun node)) (float x y) y)) (deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node) - `(,(continuation-function-name (basic-combination-fun node)) + `(,(continuation-fun-name (basic-combination-fun node)) x (float y x))) (dolist (x '(+ * / -)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 3204827..b54e70e 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1352,7 +1352,7 @@ (warm-symbol cadr-des)))) (#.sb!vm:other-pointer-lowtag (warm-symbol des))))) - (unless (legal-function-name-p result) + (unless (legal-fun-name-p result) (error "not a legal function name: ~S" result)) result)) @@ -2705,7 +2705,7 @@ that they were called before the out-of-line definition is installed, as is fairly common for structure accessors.) initially undefined function references:~2%") - (setf undefs (sort undefs #'string< :key #'function-name-block-name)) + (setf undefs (sort undefs #'string< :key #'fun-name-block-name)) (dolist (name undefs) (format t "~S" name) ;; FIXME: This ACCESSOR-FOR stuff should go away when the diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index b009be7..f586c10 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -264,6 +264,13 @@ ;;; cold load time. (defparameter *reversed-type-info-init-forms* nil) +;;; Define a new type of global information for CLASS. TYPE is the +;;; name of the type, DEFAULT is the value for that type when it +;;; hasn't been set, and TYPE-SPEC is a type specifier which values of +;;; the type must satisfy. The default expression is evaluated each +;;; time the information is needed, with NAME bound to the name for +;;; which the information is being looked up. +;;; ;;; The main thing we do is determine the type's number. We need to do ;;; this at macroexpansion time, since both the COMPILE and LOAD time ;;; calls to %DEFINE-INFO-TYPE must use the same type number. @@ -273,15 +280,6 @@ (type (required-argument)) (type-spec (required-argument)) default) - #!+sb-doc - "Define-Info-Type Class Type default Type-Spec - Define a new type of global information for Class. Type is the name - of the type, Default is the value for that type when it hasn't been set, and - Type-Spec is a type-specifier which values of the type must satisfy. The - default expression is evaluated each time the information is needed, with - Name bound to the name for which the information is being looked up. If the - default evaluates to something with the second value true, then the second - value of Info will also be true." (declare (type keyword class type)) `(progn (eval-when (:compile-toplevel :execute) @@ -511,18 +509,19 @@ ;; a vector contining in contiguous ranges the values of for all the ;; types of info for each name. (entries (required-argument) :type simple-vector) - ;; Vector parallel to ENTRIES, indicating the type number for the value - ;; stored in that location and whether this location is the last type of info - ;; stored for this name. The type number is in the low TYPE-NUMBER-BITS - ;; bits, and the next bit is set if this is the last entry. + ;; a vector parallel to ENTRIES, indicating the type number for the + ;; value stored in that location and whether this location is the + ;; last type of info stored for this name. The type number is in the + ;; low TYPE-NUMBER-BITS bits, and the next bit is set if this is the + ;; last entry. (entries-info (required-argument) :type (simple-array compact-info-entry (*)))) (defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1)) (defconstant compact-info-entry-last (ash 1 type-number-bits)) -;;; Return the value of the type corresponding to Number for the currently -;;; cached name in Env. +;;; Return the value of the type corresponding to NUMBER for the +;;; currently cached name in ENV. #!-sb-fluid (declaim (inline compact-info-cache-hit)) (defun compact-info-cache-hit (env number) (declare (type compact-info-env env) (type type-number number)) @@ -540,8 +539,8 @@ (return (values nil nil))))) (values nil nil)))) -;;; Encache Name in the compact environment Env. Hash is the -;;; GLOBALDB-SXHASHOID of Name. +;;; Encache NAME in the compact environment ENV. HASH is the +;;; GLOBALDB-SXHASHOID of NAME. (defun compact-info-lookup (env name hash) (declare (type compact-info-env env) (type index hash)) (let* ((table (compact-info-env-table env)) @@ -553,7 +552,7 @@ `(do ((probe (rem hash len) (let ((new (+ probe hash2))) (declare (type index new)) - ;; same as (mod new len), but faster. + ;; same as (MOD NEW LEN), but faster. (if (>= new len) (the index (- new len)) new)))) @@ -819,13 +818,17 @@ (define-compiler-macro info (&whole whole class type name &optional (env-list nil env-list-p)) ;; Constant CLASS and TYPE is an overwhelmingly common special case, - ;; and we can resolve it much more efficiently than the general case. + ;; and we can implement it much more efficiently than the general case. (if (and (constantp class) (constantp type)) - (let ((info (type-info-or-lose class type))) - `(the ,(type-info-type info) - (get-info-value ,name - ,(type-info-number info) - ,@(when env-list-p `(,env-list))))) + (let ((info (type-info-or-lose class type)) + (value (gensym "VALUE")) + (foundp (gensym "FOUNDP"))) + `(multiple-value-bind (,value ,foundp) + (get-info-value ,name + ,(type-info-number info) + ,@(when env-list-p `(,env-list))) + (values (the ,(type-info-type info) ,value) + ,foundp))) whole)) (defun (setf info) (new-value class @@ -1055,11 +1058,39 @@ #+sb-xc-host :assumed #-sb-xc-host (if (fboundp name) :defined :assumed)) -;;; lambda used for inline expansion of this function +;;; something which can be decoded into the inline expansion of the +;;; function, or NIL if there is none +;;; +;;; To inline a function, we want a lambda expression, e.g. +;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two +;;; ways. +;;; * The value in INFO can be the lambda expression itself, e.g. +;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO) +;;; '(LAMBDA (X) (+ X 1))) +;;; This is the ordinary way, the natural way of representing e.g. +;;; (DECLAIM (INLINE FOO)) +;;; (DEFUN FOO (X) (+ X 1)) +;;; * The value in INFO can be a closure which returns the lambda +;;; expression, e.g. +;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'BAR-LEFT-CHILD) +;;; (LAMBDA () +;;; '(LAMBDA (BAR) (BAR-REF BAR 3)))) +;;; This twisty way of storing values is supported in order to +;;; allow structure slot accessors, and perhaps later other +;;; stereotyped functions, to be represented compactly. (define-info-type :class :function - :type :inline-expansion - :type-spec list) + :type :inline-expansion-designator + :type-spec (or list function) + :default nil) +;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME) +;;; value into a lambda expression, or return NIL if there is none. +(declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion)) +(defun fun-name-inline-expansion (fun-name) + (let ((info (info :function :inline-expansion-designator fun-name))) + (if (functionp info) + (funcall info) + info))) ;;; This specifies whether this function may be expanded inline. If ;;; null, we don't care. @@ -1142,10 +1173,9 @@ :class :variable :type :kind :type-spec (member :special :constant :global :alien) - :default (if (or (eq (symbol-package name) *keyword-package*) - (member name '(t nil))) - :constant - :global)) + :default (if (symbol-self-evaluating-p name) + :constant + :global)) ;;; the declared type for this variable (define-info-type @@ -1166,9 +1196,17 @@ :class :variable :type :constant-value :type-spec t - :default (if (boundp name) - (values (symbol-value name) t) - (values nil nil))) + ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..). + ;; Now we don't: it was the last remaining multiple-value return from + ;; the INFO system, and bringing it down to one value lets us simplify + ;; things, especially simplifying the declaration of return types. + ;; Software which used to check the second value (for "is it defined + ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT) + ;; instead. + :default (if (symbol-self-evaluating-p name) + name + (error "internal error: constant lookup of nonconstant ~S" + name))) (define-info-type :class :variable diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index f6f51dd..8384932 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -21,7 +21,7 @@ ;;; OK, and signalling an error if not. In addition to checking for ;;; basic well-formedness, we also check that symbol names are not NIL ;;; or the name of a special form. -(defun check-function-name (name) +(defun check-fun-name (name) (typecase name (list (unless (and (consp name) (consp (cdr name)) @@ -36,9 +36,9 @@ name) ;;; Record a new function definition, and check its legality. -(declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name)) -(defun proclaim-as-function-name (name) - (check-function-name name) +(declaim (ftype (function ((or symbol cons)) t) proclaim-as-fun-name)) +(defun proclaim-as-fun-name (name) + (check-fun-name name) (when (fboundp name) (ecase (info :function :kind name) (:function @@ -79,7 +79,7 @@ ;;; Make NAME no longer be a function name: clear everything back to ;;; the default. -(defun undefine-function-name (name) +(defun undefine-fun-name (name) (when name (macrolet ((frob (type &optional val) `(unless (eq (info :function ,type name) ,val) @@ -90,15 +90,15 @@ (frob :inlinep) (frob :kind) (frob :accessor-for) - (frob :inline-expansion) + (frob :inline-expansion-designator) (frob :source-transform) (frob :assumed-type))) (values)) ;;; part of what happens with DEFUN, also with some PCL stuff: Make ;;; NAME known to be a function definition. -(defun become-defined-function-name (name) - (proclaim-as-function-name name) +(defun become-defined-fun-name (name) + (proclaim-as-fun-name name) (when (eq (info :function :where-from name) :assumed) (setf (info :function :where-from name) :defined) (if (info :function :assumed-type name) @@ -225,13 +225,13 @@ (function (cond ((functionp x) (function-doc x)) - ((legal-function-name-p x) + ((legal-fun-name-p x) ;; FIXME: Is it really right to make ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL ;; did, so we do it, but I'm not sure it's what ANSI wants. (values (info :function :documentation - (function-name-block-name x)))))) + (fun-name-block-name x)))))) (structure (typecase x (symbol (when (eq (info :type :kind x) :instance) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 82b129f..8cecb52 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -554,12 +554,12 @@ (when (or (atom def) (< (length def) 2)) (compiler-error "The ~S definition spec ~S is malformed." context def)) - (let ((name (check-function-name (first def)))) + (let ((name (check-fun-name (first def)))) (names name) (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def)) (defs `(lambda ,(second def) ,@decls - (block ,(function-name-block-name name) + (block ,(fun-name-block-name name) . ,forms)))))) (values (names) (defs)))) @@ -1002,7 +1002,7 @@ ((nil)) (:function (remhash name *free-functions*) - (undefine-function-name name) + (undefine-fun-name name) (compiler-warning "~S is being redefined as a macro when it was ~ previously ~(~A~) to be a function." diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 6b0bcb6..2eab275 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -60,7 +60,7 @@ (name (leaf-name leaf)) (defined-ftype (definition-type leaf))) (setf (leaf-type leaf) defined-ftype) - (when (legal-function-name-p name) + (when (legal-fun-name-p name) (let* ((where (info :function :where-from name)) (*compiler-error-context* (lambda-bind (main-entry leaf))) (global-def (gethash name *free-functions*)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index a38f2fb..2fdd9d9 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -705,7 +705,7 @@ #!+sb-show (when *show-transforms-p* (let* ((cont (basic-combination-fun node)) - (fname (continuation-function-name cont t))) + (fname (continuation-fun-name cont t))) (/show "trying transform" x (transform-function x) "for" fname))) (unless (ir1-transform node x) #!+sb-show @@ -1372,7 +1372,7 @@ (when (eq (basic-combination-kind node) :local) (maybe-let-convert (ref-leaf use)))))) (unless (or (eq (basic-combination-kind node) :local) - (eq (continuation-function-name fun) '%throw)) + (eq (continuation-fun-name fun) '%throw)) (ir1-optimize-mv-call node)) (dolist (arg args) (setf (continuation-reoptimize arg) nil)))) @@ -1499,7 +1499,7 @@ (let* ((arg (first (basic-combination-args call))) (use (continuation-use arg))) (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) + (eq (continuation-fun-name (combination-fun use)) 'values)) (let* ((fun (combination-lambda call)) (vars (lambda-vars fun)) @@ -1549,7 +1549,7 @@ (defoptimizer (values-list optimizer) ((list) node) (let ((use (continuation-use list))) (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) + (eq (continuation-fun-name (combination-fun use)) 'list)) (change-ref-leaf (continuation-use (combination-fun node)) (find-free-function 'values "in a strange place")) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index f042787..7ee6bdd 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -117,9 +117,9 @@ name context)) ((:function nil) - (check-function-name name) + (check-fun-name name) (note-if-setf-function-and-macro name) - (let ((expansion (info :function :inline-expansion name)) + (let ((expansion (fun-name-inline-expansion name)) (inlinep (info :function :inlinep name))) (setf (gethash name *free-functions*) (if (or expansion inlinep) @@ -172,21 +172,21 @@ (where-from (info :variable :where-from name))) (when (and (eq where-from :assumed) (eq kind :global)) (note-undefined-reference name :variable)) - (setf (gethash name *free-variables*) - (if (eq kind :alien) - (info :variable :alien-info name) - (multiple-value-bind (val valp) - (info :variable :constant-value name) - (if (and (eq kind :constant) valp) - (make-constant :value val - :name name - :type (ctype-of val) - :where-from where-from) - (make-global-var :kind kind - :name name - :type type - :where-from where-from)))))))) + (case kind + (:alien + (info :variable :alien-info name)) + (:constant + (let ((value (info :variable :constant-value name))) + (make-constant :value value + :name name + :type (ctype-of value) + :where-from where-from))) + (t + (make-global-var :kind kind + :name name + :type type + :where-from where-from))))))) ;;; Grovel over CONSTANT checking for any sub-parts that need to be ;;; processed with MAKE-LOAD-FORM. We have to be careful, because @@ -1836,7 +1836,7 @@ ;;; define. If the function has been forward referenced, then ;;; substitute for the previous references. (defun get-defined-function (name) - (let* ((name (proclaim-as-function-name name)) + (let* ((name (proclaim-as-fun-name name)) (found (find-free-function name "Eh?"))) (note-name-defined name :function) (cond ((not (defined-function-p found)) @@ -1849,8 +1849,8 @@ :type (leaf-type found)))) (substitute-leaf res found) (setf (gethash name *free-functions*) res))) - ;; If *FREE-FUNCTIONS* has a previously converted definition for this - ;; name, then blow it away and try again. + ;; If *FREE-FUNCTIONS* has a previously converted definition + ;; for this name, then blow it away and try again. ((defined-function-functional found) (remhash name *free-functions*) (get-defined-function name)) @@ -1938,15 +1938,16 @@ (remhash name *free-functions*) (setf defined-function (get-defined-function name))) - (become-defined-function-name name) + (become-defined-fun-name name) (cond (lambda-with-lexenv - (setf (info :function :inline-expansion name) lambda-with-lexenv) + (setf (info :function :inline-expansion-designator name) + lambda-with-lexenv) (when defined-function (setf (defined-function-inline-expansion defined-function) lambda-with-lexenv))) (t - (clear-info :function :inline-expansion name))) + (clear-info :function :inline-expansion-designator name))) ;; old CMU CL comment: ;; If there is a type from a previous definition, blast it, @@ -1973,5 +1974,5 @@ ;; non-stub version might use either macro-level LOAD-TIME-VALUE ;; hackery or customized IR1-transform level magic to actually put ;; the name in place. - (aver (legal-function-name-p name)) + (aver (legal-fun-name-p name)) `(lambda ,args ,@body)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 9585c63..cf49747 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1087,7 +1087,7 @@ (unless (combination-p inside) (give-up-ir1-transform)) (let ((inside-fun (combination-fun inside))) - (unless (eq (continuation-function-name inside-fun) fun) + (unless (eq (continuation-fun-name inside-fun) fun) (give-up-ir1-transform)) (let ((inside-args (combination-args inside))) (unless (= (length inside-args) num-args) @@ -1206,7 +1206,7 @@ ;;; If CONT's only use is a non-notinline global function reference, ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK ;;; is true, then we don't care if the leaf is NOTINLINE. -(defun continuation-function-name (cont &optional notinline-ok) +(defun continuation-fun-name (cont &optional notinline-ok) (declare (type continuation cont)) (let ((use (continuation-use cont))) (if (ref-p use) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 9d96c87..41910d2 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -784,16 +784,17 @@ ;;;; full call -;;; Given a function continuation Fun, return as values a TN holding +;;; Given a function continuation FUN, return as values a TN holding ;;; the thing that we call and true if the thing is named (false if it ;;; is a function). There are two interesting non-named cases: -;;; -- Known to be a function, no check needed: return the continuation loc. -;;; -- Not known what it is. +;;; -- Known to be a function, no check needed: return the +;;; continuation loc. +;;; -- Not known what it is. (defun function-continuation-tn (node block cont) (declare (type continuation cont)) (let ((2cont (continuation-info cont))) (if (eq (ir2-continuation-kind 2cont) :delayed) - (let ((name (continuation-function-name cont t))) + (let ((name (continuation-fun-name cont t))) (aver name) (values (make-load-time-constant-tn :fdefinition name) t)) (let* ((locs (ir2-continuation-locs 2cont)) @@ -956,7 +957,7 @@ ;;; a DEFSETF or some such thing elsewhere in the program? (defun check-full-call (node) (let* ((cont (basic-combination-fun node)) - (fname (continuation-function-name cont t))) + (fname (continuation-fun-name cont t))) (declare (type (or symbol cons) fname)) #!+sb-show (unless (gethash fname *full-called-fnames*) @@ -1530,7 +1531,7 @@ (unless (or (and (bind-p first-node) (external-entry-point-p (bind-lambda first-node))) - (eq (continuation-function-name + (eq (continuation-fun-name (node-cont first-node)) '%nlx-entry)) (vop count-me @@ -1617,7 +1618,7 @@ (cond ((eq (basic-combination-kind node) :local) (ir2-convert-mv-bind node 2block)) - ((eq (continuation-function-name (basic-combination-fun node)) + ((eq (continuation-fun-name (basic-combination-fun node)) '%throw) (ir2-convert-throw node 2block)) (t diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index d09dacc..2f06e0d 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -152,7 +152,7 @@ (continuation-proven-type cont))))) (info (make-ir2-continuation ptype))) (setf (continuation-info cont) info) - (let ((name (continuation-function-name cont t))) + (let ((name (continuation-fun-name cont t))) (if (and delay name) (setf (ir2-continuation-kind info) :delayed) (setf (ir2-continuation-locs info) @@ -382,7 +382,7 @@ (declare (type mv-combination call) (type ltn-policy ltn-policy)) (let ((fun (basic-combination-fun call)) (args (basic-combination-args call))) - (cond ((eq (continuation-function-name fun) '%throw) + (cond ((eq (continuation-fun-name fun) '%throw) (setf (basic-combination-info call) :funny) (annotate-ordinary-continuation (first args) ltn-policy) (annotate-unknown-values-continuation (second args) ltn-policy) @@ -895,7 +895,7 @@ ;; to implement an out-of-line version in terms of inline ;; transforms or VOPs or whatever. (unless template - (when (and (eq (continuation-function-name (combination-fun call)) + (when (and (eq (continuation-fun-name (combination-fun call)) (leaf-name (physenv-function (node-physenv call)))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 5844829..456a622 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -532,9 +532,9 @@ ;;; Create a function which parses combination args according to WHAT ;;; and LAMBDA-LIST, where WHAT is either a function name or a list -;;; (FUNCTION-NAME KIND) and does some KIND of optimization. +;;; (FUN-NAME KIND) and does some KIND of optimization. ;;; -;;; The FUNCTION-NAME must name a known function. LAMBDA-LIST is used +;;; The FUN-NAME must name a known function. LAMBDA-LIST is used ;;; to parse the arguments to the combination as in DEFTRANSFORM. If ;;; the argument syntax is invalid or there are non-constant keys, ;;; then we simply return NIL. diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 82c5e73..42682be 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -886,7 +886,7 @@ ;; real source path (as in e.g. inside CL:COMPILE). '(original-source-start 0 0))) (/show "entering %COMPILE" name) - (unless (or (null name) (legal-function-name-p name)) + (unless (or (null name) (legal-fun-name-p name)) (error "not a legal function name: ~S" name)) (let* ((*lexenv* (make-lexenv :policy *policy*)) (fun (make-functional-from-top-level-lambda lambda-expression @@ -938,7 +938,7 @@ (/show "entering PROCESS-TOP-LEVEL-COLD-FSET" name) (unless (producing-fasl-file) (error "can't COLD-FSET except in a fasl file")) - (unless (legal-function-name-p name) + (unless (legal-fun-name-p name) (error "not a legal function name: ~S" name)) (fasl-dump-cold-fset name (%compile lambda-expression diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 3bedcb5..0a6e7e3 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -155,7 +155,7 @@ ;; function name was already declared as a structure ;; accessor, then that was already been taken care of.) (unless (info :function :accessor-for name) - (proclaim-as-function-name name) + (proclaim-as-fun-name name) (note-name-defined name :function)) ;; the actual type declaration @@ -175,7 +175,7 @@ (setq *policy* (process-optimize-decl form *policy*))) ((inline notinline maybe-inline) (dolist (name args) - ;; (CMU CL did (PROCLAIM-AS-FUNCTION-NAME NAME) here, but that + ;; (CMU CL did (PROCLAIM-AS-FUN-NAME NAME) here, but that ;; seems more likely to surprise the user than to help him, so ;; we don't do it.) (setf (info :function :inlinep name) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 6eada1a..b858d5b 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2484,7 +2484,7 @@ (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node) (if (and (constant-continuation-p x) (not (constant-continuation-p y))) - `(,(continuation-function-name (basic-combination-fun node)) + `(,(continuation-fun-name (basic-combination-fun node)) y ,(continuation-value x)) (give-up-ir1-transform))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index c64d632..6c922b6 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1731,7 +1731,7 @@ ;;; routines to find things in the Lisp environment -;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots +;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots ;;; in a symbol object that we know about (defparameter *grokked-symbol-slots* (sort `((,sb!vm:symbol-value-slot . symbol-value) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 2b53bd4..7017895 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -33,7 +33,7 @@ ;;; top-level lambda for the compilation. A REF for the real function ;;; is the only thing in the top-level lambda other than the bind and ;;; return, so it isn't too hard to find. -(defun compile-fix-function-name (lambda name) +(defun compile-fix-fun-name (lambda name) (declare (type clambda lambda) (type (or symbol cons) name)) (when name (let ((fun (ref-leaf diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index cd9d775..40c79da 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -109,7 +109,7 @@ bootstrapping. (let ((name (car fns)) (early-name (cadr fns))) (setf (gdefinition name) - (set-function-name + (set-fun-name (lambda (&rest args) (apply (fdefinition early-name) args)) name)))) @@ -131,12 +131,12 @@ bootstrapping. (standard-generic-function t t) real-get-method)) (ensure-generic-function-using-class - ((generic-function function-name + ((generic-function fun-name &key generic-function-class environment &allow-other-keys) (generic-function t) real-ensure-gf-using-class--generic-function) - ((generic-function function-name + ((generic-function fun-name &key generic-function-class environment &allow-other-keys) (null t) @@ -156,7 +156,7 @@ bootstrapping. (generic-function standard-method-combination t) standard-compute-effective-method)))) -(defmacro defgeneric (function-name lambda-list &body options) +(defmacro defgeneric (fun-name lambda-list &body options) (let ((initargs ()) (methods ())) (flet ((duplicate-option (name) @@ -168,7 +168,7 @@ bootstrapping. (arglist (elt qab arglist-pos)) (qualifiers (subseq qab 0 arglist-pos)) (body (nthcdr (1+ arglist-pos) qab))) - `(defmethod ,function-name ,@qualifiers ,arglist ,@body)))) + `(defmethod ,fun-name ,@qualifiers ,arglist ,@body)))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) (let ((car-option (car option))) @@ -200,27 +200,26 @@ bootstrapping. `',(initarg :declarations)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (compile-or-load-defgeneric ',function-name)) - (load-defgeneric ',function-name ',lambda-list ,@initargs) + (compile-or-load-defgeneric ',fun-name)) + (load-defgeneric ',fun-name ',lambda-list ,@initargs) ,@(mapcar #'expand-method-definition methods) - `,(function ,function-name))))) - -(defun compile-or-load-defgeneric (function-name) - (sb-kernel:proclaim-as-function-name function-name) - (sb-kernel:note-name-defined function-name :function) - (unless (eq (info :function :where-from function-name) :declared) - (setf (info :function :where-from function-name) :defined) - (setf (info :function :type function-name) + `,(function ,fun-name))))) + +(defun compile-or-load-defgeneric (fun-name) + (sb-kernel:proclaim-as-fun-name fun-name) + (sb-kernel:note-name-defined fun-name :function) + (unless (eq (info :function :where-from fun-name) :declared) + (setf (info :function :where-from fun-name) :defined) + (setf (info :function :type fun-name) (sb-kernel:specifier-type 'function)))) -(defun load-defgeneric (function-name lambda-list &rest initargs) - (when (fboundp function-name) - (sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name)) +(defun load-defgeneric (fun-name lambda-list &rest initargs) + (when (fboundp fun-name) + (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)) (apply #'ensure-generic-function - function-name + fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,function-name) - ,*load-truename*) + :definition-source `((defgeneric ,fun-name) ,*load-truename*) initargs)) (defmacro defmethod (&rest args &environment env) @@ -340,7 +339,7 @@ bootstrapping. initargs-form &optional pv-table-symbol) (let (fn fn-lambda) - (if (and (interned-symbol-p (function-name-block-name name)) + (if (and (interned-symbol-p (fun-name-block-name name)) (every #'interned-symbol-p qualifiers) (every #'(lambda (s) (if (consp s) @@ -585,8 +584,7 @@ bootstrapping. (declare (ignorable ,@required-parameters)) ,class-declarations ,@declarations - (block ,(function-name-block-name - generic-function-name) + (block ,(fun-name-block-name generic-function-name) ,@real-body))) (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) @@ -1101,8 +1099,9 @@ bootstrapping. ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) (constantp (caddr form))) - (let ((parameter - (can-optimize-access form required-parameters env))) + (let ((parameter (can-optimize-access form + required-parameters + env))) (let ((fun (ecase (car form) (slot-value #'optimize-slot-value) (set-slot-value #'optimize-set-slot-value) @@ -1133,7 +1132,7 @@ bootstrapping. next-method-p-p))))) (defun generic-function-name-p (name) - (and (legal-function-name-p name) + (and (legal-fun-name-p name) (gboundp name) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) @@ -1254,7 +1253,7 @@ bootstrapping. (setf (method-function-get mff p) v)))) (when method-spec (when mf - (setq mf (set-function-name mf method-spec))) + (setq mf (set-fun-name mf method-spec))) (when mff (let ((name `(,(or (get (car method-spec) 'fast-sym) (setf (get (car method-spec) 'fast-sym) @@ -1270,7 +1269,7 @@ bootstrapping. (car method-spec)) *pcl-package*))) ,@(cdr method-spec)))) - (set-function-name mff name) + (set-fun-name mff name) (unless mf (set-mf-property :name name))))) (when plist @@ -1366,31 +1365,31 @@ bootstrapping. (defun defgeneric-declaration (spec lambda-list) (when (consp spec) - (setq spec (get-setf-function-name (cadr spec)))) + (setq spec (get-setf-fun-name (cadr spec)))) `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec)) ;;;; early generic function support (defvar *!early-generic-functions* ()) -(defun ensure-generic-function (function-name +(defun ensure-generic-function (fun-name &rest all-keys &key environment &allow-other-keys) (declare (ignore environment)) - (let ((existing (and (gboundp function-name) - (gdefinition function-name)))) + (let ((existing (and (gboundp fun-name) + (gdefinition fun-name)))) (if (and existing (eq *boot-state* 'complete) (null (generic-function-p existing))) - (generic-clobbers-function function-name) + (generic-clobbers-function fun-name) (apply #'ensure-generic-function-using-class - existing function-name all-keys)))) + existing fun-name all-keys)))) -(defun generic-clobbers-function (function-name) +(defun generic-clobbers-function (fun-name) (error 'simple-program-error :format-control "~S already names an ordinary function or a macro." - :format-arguments (list function-name))) + :format-arguments (list fun-name))) (defvar *sgf-wrapper* (boot-make-wrapper (early-class-size 'standard-generic-function) @@ -1672,7 +1671,7 @@ bootstrapping. fin 'source *load-truename*) - (set-function-name fin spec) + (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p @@ -1760,7 +1759,7 @@ bootstrapping. (defun real-ensure-gf-using-class--generic-function (existing - function-name + fun-name &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function gf-class-p) @@ -1772,11 +1771,11 @@ bootstrapping. (prog1 (apply #'reinitialize-instance existing all-keys) (when lambda-list-p - (proclaim (defgeneric-declaration function-name lambda-list))))) + (proclaim (defgeneric-declaration fun-name lambda-list))))) (defun real-ensure-gf-using-class--null (existing - function-name + fun-name &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function) @@ -1784,11 +1783,11 @@ bootstrapping. (declare (ignore existing)) (real-ensure-gf-internal generic-function-class all-keys environment) (prog1 - (setf (gdefinition function-name) + (setf (gdefinition fun-name) (apply #'make-instance generic-function-class - :name function-name all-keys)) + :name fun-name all-keys)) (when lambda-list-p - (proclaim (defgeneric-declaration function-name lambda-list))))) + (proclaim (defgeneric-declaration fun-name lambda-list))))) (defun get-generic-function-info (gf) ;; values nreq applyp metatypes nkeys arg-info @@ -2033,7 +2032,7 @@ bootstrapping. (fn (fdefinition fn-name)) (initargs (list :function - (set-function-name + (set-fun-name #'(lambda (args next-methods) (declare (ignore next-methods)) @@ -2104,7 +2103,7 @@ bootstrapping. gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp - (intern-function-name + (intern-fun-name (make-method-spec temp (method-qualifiers method) (unparse-specializers @@ -2122,9 +2121,9 @@ bootstrapping. (and (setq method (get-method gf quals specls errorp)) (setq name - (intern-function-name (make-method-spec gf-spec - quals - specls)))))))) + (intern-fun-name (make-method-spec gf-spec + quals + specls)))))))) (values gf method name))) (defun extract-parameters (specialized-lambda-list) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 1221782..7674689 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -289,7 +289,7 @@ (t constant)) constant)) constants)) - (function (set-function-name + (function (set-fun-name (apply cfunction constants) `(combined-method ,name)))) (make-fast-method-call :function function diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp index 8217abb..5f3b40c 100644 --- a/src/pcl/construct.lisp +++ b/src/pcl/construct.lisp @@ -207,7 +207,7 @@ ;;; should always be used to set them both at the same time. (defun set-constructor-code (constructor code type) (set-funcallable-instance-fun constructor code) - (set-function-name constructor (constructor-name constructor)) + (set-fun-name constructor (constructor-name constructor)) (setf (constructor-code-type constructor) type)) (defmethod describe-object ((constructor constructor) stream) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 003f6d3..7e0b1be 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1506,7 +1506,7 @@ And so, we are saved. (or dfun (make-initial-dfun generic-function)) (compute-discriminating-function generic-function)))) (set-funcallable-instance-fun generic-function dfun) - (set-function-name generic-function gf-name) + (set-fun-name generic-function gf-name) (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 3869368..0154304 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -71,7 +71,7 @@ ;; even if it hasn't been defined yet, the user doesn't get ;; obscure warnings about undefined internal implementation ;; functions like HAIRY-MAKE-instance-name. - (sb-kernel:become-defined-function-name sym) + (sb-kernel:become-defined-fun-name sym) `(,sym ',class (list ,@initargs))))))) (defmacro expanding-make-instance-top-level (&rest forms &environment env) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 503d8d2..0e101bc 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -472,7 +472,7 @@ &key &allow-other-keys)) (defgeneric ensure-generic-function-using-class (generic-function - function-name + fun-name &key &allow-other-keys)) (defgeneric initialize-instance (gf &key &allow-other-keys)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 584ff72..5128295 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -145,23 +145,23 @@ ;;; NEW-NAME. Note that NEW-NAME is sometimes a list. Some lisps ;;; get the upset in the tummy when they start thinking about ;;; functions which have lists as names. To deal with that there is -;;; SET-FUNCTION-NAME-INTERN which takes a list spec for a function +;;; SET-FUN-NAME-INTERN which takes a list spec for a function ;;; name and turns it into a symbol if need be. ;;; -;;; When given a funcallable instance, SET-FUNCTION-NAME *must* +;;; When given a funcallable instance, SET-FUN-NAME *must* ;;; side-effect that FIN to give it the name. When given any other -;;; kind of function SET-FUNCTION-NAME is allowed to return a new +;;; kind of function SET-FUN-NAME is allowed to return a new ;;; function which is "the same" except that it has the name. ;;; -;;; In all cases, SET-FUNCTION-NAME must return the new (or same) +;;; In all cases, SET-FUN-NAME must return the new (or same) ;;; function. (Unlike other functions to set stuff, it does not return ;;; the new value.) -(defun set-function-name (fcn new-name) +(defun set-fun-name (fcn new-name) #+sb-doc "Set the name of a compiled function object. Return the function." (declare (special *boot-state* *the-class-standard-generic-function*)) (cond ((symbolp fcn) - (set-function-name (symbol-function fcn) new-name)) + (set-fun-name (symbol-function fcn) new-name)) ((funcallable-instance-p fcn) (if (if (eq *boot-state* 'complete) (typep fcn 'generic-function) @@ -195,7 +195,7 @@ ;; XXX Maybe add better scheme here someday. fcn))) -(defun intern-function-name (name) +(defun intern-fun-name (name) (cond ((symbolp name) name) ((listp name) (intern (let ((*package* *pcl-package*) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 7013080..d028d8f 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -274,7 +274,7 @@ `(apply (the function ,form) ,@args)) -(defun get-setf-function-name (name) +(defun get-setf-fun-name (name) `(setf ,name)) (defsetf slot-value set-slot-value) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 9ba3364..34e166a 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -205,7 +205,7 @@ lambda-list lambda-list-p)) (when namep - (set-function-name generic-function name)) + (set-fun-name generic-function name)) (flet ((initarg-error (initarg value string) (error "when initializing the generic function ~S:~%~ @@ -1289,8 +1289,7 @@ (if function-p function (make-fast-method-call - :function (set-function-name function - `(sdfun-method ,name)) + :function (set-fun-name function `(sdfun-method ,name)) :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 865fc94..59908e9 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -129,7 +129,7 @@ (defun make-optimized-std-reader-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) - (set-function-name + (set-fun-name (etypecase index (fixnum (if fsc-p (lambda (instance) @@ -153,7 +153,7 @@ (defun make-optimized-std-writer-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) - (set-function-name + (set-fun-name (etypecase index (fixnum (if fsc-p (lambda (nv instance) @@ -169,7 +169,7 @@ (defun make-optimized-std-boundp-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) - (set-function-name + (set-fun-name (etypecase index (fixnum (if fsc-p #'(lambda (instance) @@ -299,7 +299,7 @@ (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) `(invoke-effective-method-function ,emf nil ,@args))) - (set-function-name + (set-fun-name (case name (reader (lambda (instance) (emf-funcall sdfun class instance slotd))) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 76179ea..444b3d6 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -727,7 +727,7 @@ `(instance-write-internal .pv. ,(slot-vector-symbol position) ,pv-offset ,new-value (,(if (consp gf-name) - (get-setf-function-name gf-name) + (get-setf-fun-name gf-name) gf-name) (instance-accessor-parameter ,parameter) ,new-value) @@ -1088,7 +1088,7 @@ (intern (subseq str 5) *pcl-package*) (car fname))))) ,@(cdr fname)))) - (set-function-name method-function name)) + (set-fun-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function)) diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 0926a18..20cd9ee 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -365,7 +365,7 @@ ;; This needs not just the SB!XC:DEFSTRUCT machinery, but also ;; the TYPE= stuff defined in late-type.lisp, and the - ;; CHECK-FUNCTION-NAME defined in proclaim.lisp. + ;; CHECK-FUN-NAME defined in proclaim.lisp. ("src/code/force-delayed-defbangstructs") ("src/code/typep") diff --git a/version.lisp-expr b/version.lisp-expr index 8501875..d33187f 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.pre7.60" +"0.pre7.61" -- 1.7.10.4