"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"
"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"
"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"
"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"
;;; 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."
: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))
: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
(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)
;;; 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)))
;;;; 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)
;; (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))
(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))
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)
(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)
(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
(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*))))
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)
(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.
(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)
(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
(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)))
\f
;;;; 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)
(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))
;;; 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)))
(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.
(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
;;;; 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)
;;; 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)
(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
(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))))
((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))))))
"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)
;;; (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,
;;;; 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)))
(,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
;; 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)
\f
;;;; DEFINE-COMPILER-MACRO
: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)
(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))
;;; 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)
(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)))
(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
;;; 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))
;;; 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"
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)))
`(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))))
\f
(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.~@
"~%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)))
\f
(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
;;;; 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)))
(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)))
(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)))
;;; the VM support routines
(defvar *backend-support-routines* (make-vm-support-routines))
(declaim (type vm-support-routines *backend-support-routines*))
+\f
+;;;; 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.
(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
"-PRINTER"))
(make-printer-defun printer-source funstate name)))))
\f
-(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)
#+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)
;;; 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 '(+ * / -))
(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))
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
;;; 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.
(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)
;; 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))
(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))
`(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))))
(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
#+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.
: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
: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
;;; 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))
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
;;; 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)
(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)
(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)
(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))))
((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."
(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*))
#!+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
(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))))
(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))
(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"))
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)
(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)))))))
\f
;;; Grovel over CONSTANT checking for any sub-parts that need to be
;;; processed with MAKE-LOAD-FORM. We have to be careful, because
;;; 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))
: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))
(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,
;; 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))
(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)
;;; 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)
\f
;;;; 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))
;;; 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*)
(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
(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
(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)
(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)
;; 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))))
;;; 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.
;; 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
(/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
;; 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
(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)
(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)))
\f
;;; 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)
;;; 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
(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))))
(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)
(generic-function standard-method-combination t)
standard-compute-effective-method))))
\f
-(defmacro defgeneric (function-name lambda-list &body options)
+(defmacro defgeneric (fun-name lambda-list &body options)
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
(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)))
`',(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))
\f
(defmacro defmethod (&rest args &environment env)
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)
(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))))
((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)
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))
(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)
(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
(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))
\f
;;;; 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)
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
(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)
(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)
(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)))))
\f
(defun get-generic-function-info (gf)
;; values nreq applyp metatypes nkeys arg-info
(fn (fdefinition fn-name))
(initargs
(list :function
- (set-function-name
+ (set-fun-name
#'(lambda (args next-methods)
(declare (ignore
next-methods))
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
(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)))
\f
(defun extract-parameters (specialized-lambda-list)
(t constant))
constant))
constants))
- (function (set-function-name
+ (function (set-fun-name
(apply cfunction constants)
`(combined-method ,name))))
(make-fast-method-call :function function
;;; 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)
(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)))
\f
;; 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)
&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))
;;; 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)
;; 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*)
`(apply (the function ,form) ,@args))
\f
-(defun get-setf-function-name (name)
+(defun get-setf-fun-name (name)
`(setf ,name))
(defsetf slot-value set-slot-value)
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:~%~
(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)
(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)
(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)
(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)
(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)))
`(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)
(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))
;; 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")
;;; 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"
projects / sbcl.git / commitdiff