to remove dead symbols
* made system handle stack overflow safely unless SAFETY is dominated
by SPEED or SPACE
+* Probably get rid of or at least rework the fdefinition/encapsulation
+ system so that (SYMBOL-FUNCTION 'FOO) = (FDEFINITION 'FOO).
=======================================================================
for 1.0:
"DEFTRANSFORM" "DERIVE-TYPE"
"ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP"
"PHYSENV-DEBUG-LIVE-TN" "PHYSENV-LIVE-TN"
- "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FOLDABLE"
+ "FAST-SYMBOL-VALUE" "FOLDABLE"
"FORCE-TN-TO-STACK"
"GET-VECTOR-SUBTYPE"
"HALT"
"OBJECT-NOT-CONS-ERROR"
"OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
"OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR"
- "OBJECT-NOT-FUNCTION-OR-SYMBOL-ERROR"
"OBJECT-NOT-INSTANCE-ERROR"
"OBJECT-NOT-INTEGER-ERROR"
"OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-LONG-FLOAT-ERROR"
"FDEFN" "MAKE-FDEFN" "FDEFN-P"
"FDEFN-NAME" "FDEFN-FUN"
- "FDEFN-MAKUNBOUND" "%COERCE-NAME-TO-FUNCTION"
- "%COERCE-CALLABLE-TO-FUNCTION"
+ "FDEFN-MAKUNBOUND" "OUTER-FDEFN"
+ "%COERCE-CALLABLE-TO-FUN"
"FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*"
"%SET-SYMBOL-PLIST" "INFINITE-ERROR-PROTECT"
"FIND-CALLER-NAME-AND-FRAME"
"%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE"
"OUTPUT-SYMBOL-NAME"
- "FSET" "RAW-DEFINITION"
+ "%COERCE-NAME-TO-FUN"
"INVOKE-MACROEXPAND-HOOK"
"DEFAULT-STRUCTURE-PRINT"
"LAYOUT" "LAYOUT-LENGTH"
(defsetf %array-dimension %set-array-dimension)
(defsetf sb!kernel:%raw-bits sb!kernel:%set-raw-bits)
#-sb-xc-host (defsetf symbol-value set)
-#-sb-xc-host (defsetf symbol-function fset)
#-sb-xc-host (defsetf symbol-plist %set-symbol-plist)
#-sb-xc-host (defsetf nth %setnth)
#-sb-xc-host (defsetf fill-pointer %set-fill-pointer)
(dolist (fdefn *!initial-fdefn-objects*)
(setf (info :function :definition (fdefn-name fdefn)) fdefn)))
+;;; Return the fdefn object for NAME. If it doesn't already exist and
+;;; CREATE is non-NIL, create a new (unbound) one.
(defun fdefinition-object (name create)
- #!+sb-doc
- "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-fun-name-p name)
(error 'simple-type-error
(setf (info :function :definition name) (make-fdefn name))
fdefn)))
-;;; FIXME: If the fundamental operation performed when
-;;; funcalling a symbol is %COERCE-NAME-TO-FUNCTION, which expands into
-;;; FDEFINITION-OBJECT, which does (INFO :FUNCTION :DEFINITION NAME),
-;;; that's a horrendously heavyweight way to implement SYMBOL-FUNCTION.
-;;; What compelling reason is there for all this hairiness? The only
-;;; thing I can think of is that it does give a place to store
-;;; SETF functions, but I don't think that's a good enough reason.
-;;; It might even be that the FDEFINITION arrangement saves a little
-;;; space, if the proportion of function-less symbols is high enough,
-;;; but I don't think that's a good enough reason, either.
-;;; I'd really like to wipe out FDEFN stuff root and branch, and
-;;; just store SETF functions in the symbol property list.
-;;;
-;;; One problem with just doing the simple thing: What happens when
-;;; people call symbols which have no function definitions?
-;;; 1. Just hit "undefined function" error -- with no clue as to
-;;; what undefined function it was. (This might actually not be
-;;; too horrible, since the compiler warns you about undefined
-;;; functions and the debugger aims, with incomplete success,
-;;; to show you what form caused an error.)
-;;; 2. various solutions involving closures in the function slot,
-;;; all of which have the drawback of extra memory use and extra
-;;; difficulty in detecting when functions are undefined
-;;; 2a. Have every single symbol have an undefined function closure
-;;; which points back to it to tell you which undefined symbol it
-;;; was. (4 extra words per undefined symbol)
-;;; 2b. Play tricks with FDEFINITION, where the default SYMBOL-FUNCTION
-;;; for any function is an anonymous "undefined function" error
-;;; which doesn't tell you what the problem was, but if FDEFINITION
-;;; is ever called on an undefined symbol, it helpfully changes the
-;;; function definition to point to a closure which knows which
-;;; symbol caused the problem.
-;;; 4. Just don't sweat it except when DEBUG>SPEED, where the calling
-;;; convention gets tweaked to test for the undefined-function
-;;; function at call time and bail out with helpful information
-;;; if it's there.
-;;; 5. Require that the function calling convention be stereotyped
-;;; along the lines of
-;;; mov %ebx, local_immediate_3 ; Point to symbol.
-;;; mov %eax, symbol_fun_offset(%eax) ; Point to function.
-;;; call *function_code_pointer(%eax) ; Go.
-;;; That way, it's guaranteed that on entry to a function, %EBX points
-;;; back to the symbol which was used to indirect into the function,
-;;; so the undefined function handler can base its complaint on that.
-;;;
-;;; Another problem with doing the simple thing: people will want to
-;;; indirect through something in order to get to SETF functions, in
-;;; order to be able to redefine them. What will they indirect
-;;; through? This could be done with a hack, making an anonymous
-;;; symbol and linking it to the main symbol's SB!KERNEL:SETF-FUNCTION
-;;; property. The anonymous symbol could even point back to the symbol
-;;; it's the SETF function for, so that if the SETF function was
-;;; undefined at the time a call was made, the debugger could say
-;;; which function caused the problem. It'd probably be cleaner,
-;;; though, to use a new type of primitive object (SYMBOLOID?)
-;;; instead. It could probably be like symbol except that its name
-;;; could be any object and its value points back to the symbol which
-;;; owns it. Then the setf functions for FOO could be on the list (GET
-;;; FOO 'SB!KERNEL:SYMBOLOIDS)
-;;;
-;;; FIXME: Oh, my. Now that I've started thinking about it, I
-;;; appreciate more fully how weird and twisted FDEFNs might be. Look
-;;; at the calling sequence for full calls. It goes and reads the
-;;; address of a function object from its own table of immediate
-;;; values, then jumps into that. Consider how weird that is. Not only
-;;; is it not doing indirection through a symbol (which I'd already
-;;; realized) but it's not doing indirection through
-
-;;; The compiler emits calls to this when someone tries to funcall a symbol.
-(defun %coerce-name-to-function (name)
- #!+sb-doc
- "Return the definition for name, including any encapsulations. Settable
- with SETF."
+;;; Return the fdefinition of NAME, including any encapsulations.
+;;; The compiler emits calls to this when someone tries to FUNCALL
+;;; something. SETFable.
+#!-sb-fluid (declaim (inline %coerce-name-to-fun))
+(defun %coerce-name-to-fun (name)
(let ((fdefn (fdefinition-object name nil)))
(or (and fdefn (fdefn-fun fdefn))
(error 'undefined-function :name name))))
-
-(defun %coerce-callable-to-function (callable)
- (if (functionp callable)
- callable
- (%coerce-name-to-function callable)))
-
-;;; This is just another name for %COERCE-NAME-TO-FUNCTION.
-#!-sb-fluid (declaim (inline raw-definition))
-(defun raw-definition (name)
- ;; We know that we are calling %COERCE-NAME-TO-FUNCTION, so don't remind us.
- (declare (optimize (inhibit-warnings 3)))
- (%coerce-name-to-function name))
-(defun (setf raw-definition) (function name)
+(defun (setf %coerce-name-to-fun) (function name)
(let ((fdefn (fdefinition-object name t)))
(setf (fdefn-fun fdefn) function)))
-;;; FIXME: There seems to be no good reason to have both
-;;; %COERCE-NAME-TO-FUNCTION and RAW-DEFINITION names for the same
-;;; thing. And despite what the doc string of %COERCE-NAME-TO-FUNCTION
-;;; says, it's doesn't look settable. Perhaps we could collapse
-;;; %COERCE-TO-FUNCTION, RAW-DEFINITION, and (SETF RAW-DEFINITION)
-;;; into RAW-FDEFINITION and (SETF RAW-FDEFINITION), or
-;;; OUTER-FDEFINITION and (SETF OUTER-FDEFINITION).
+(defun %coerce-callable-to-fun (callable)
+ (if (functionp callable)
+ callable
+ (%coerce-name-to-fun callable)))
\f
;;;; definition encapsulation
;;; KLUDGE: Er, it looks as though this means that
;;; (FUNCALL (FDEFINITION 'FOO))
;;; doesn't do the same thing as
-;;; (FUNCALL 'FOO).
-;;; That doesn't look like ANSI behavior to me. Look e.g. at the
-;;; ANSI definition of TRACE: "Whenever a traced function is invoked,
-;;; information about the call, ..". Try this:
+;;; (FUNCALL 'FOO),
+;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
+;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
+;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
+;;; function is invoked, information about the call, ..". Try this:
;;; (DEFUN FOO () (PRINT "foo"))
;;; (TRACE FOO)
;;; (FUNCALL 'FOO)
;;; The only problem I can see with not having a wrapper: If tracing
;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
-;;; on those function values. -- WHN 19990906
+;;; on those function values. But given the ANSI statement about
+;;; TRACE causing things to change, that doesn't seem too unreasonable;
+;;; and we might even be able to forbid tracing these functions.
+;;; -- WHN 2001-11-02
(defun fdefinition (name)
#!+sb-doc
"Return name's global function definition taking care to respect any
encapsulations and to return the innermost encapsulated definition.
This is SETF'able."
- (let ((fun (raw-definition name)))
+ (let ((fun (%coerce-name-to-fun name)))
(loop
(let ((encap-info (encapsulation-info fun)))
(if encap-info
:datum object
:expected-type 'fixnum))
-(deferr object-not-function-or-symbol-error (object)
- (error 'type-error
- :datum object
- :expected-type '(or function symbol)))
-
(deferr object-not-vector-error (object)
(error 'type-error
:datum object
(vector (dovector (,i sequence) ,@body))))))
(defun %map-to-list-arity-1 (fun sequence)
(let ((reversed-result nil)
- (really-fun (%coerce-callable-to-function fun)))
+ (really-fun (%coerce-callable-to-fun fun)))
(dosequence (element sequence)
(push (funcall really-fun element)
reversed-result))
(defun %map-to-simple-vector-arity-1 (fun sequence)
(let ((result (make-array (length sequence)))
(index 0)
- (really-fun (%coerce-callable-to-function fun)))
+ (really-fun (%coerce-callable-to-fun fun)))
(declare (type index index))
(dosequence (element sequence)
(setf (aref result index)
(incf index))
result))
(defun %map-for-effect-arity-1 (fun sequence)
- (let ((really-fun (%coerce-callable-to-function fun)))
+ (let ((really-fun (%coerce-callable-to-fun fun)))
(dosequence (element sequence)
(funcall really-fun element)))
nil))
;;; length of the output sequence matches any length specified
;;; in RESULT-TYPE.
(defun %map (result-type function first-sequence &rest more-sequences)
- (let ((really-function (%coerce-callable-to-function function)))
+ (let ((really-function (%coerce-callable-to-fun function)))
;; Handle one-argument MAP NIL specially, using ETYPECASE to turn
;; it into something which can be DEFTRANSFORMed away. (It's
;; fairly important to handle this case efficiently, since
(when fp-result
(setf (fill-pointer result-sequence) len))
- (let ((really-fun (%coerce-callable-to-function function)))
+ (let ((really-fun (%coerce-callable-to-fun function)))
(dotimes (index len)
(setf (elt result-sequence index)
(apply really-fun
(defun effective-find-position-test (test test-not)
(cond ((and test test-not)
(error "can't specify both :TEST and :TEST-NOT"))
- (test (%coerce-callable-to-function test))
+ (test (%coerce-callable-to-fun test))
(test-not
;; (Without DYNAMIC-EXTENT, this is potentially horribly
;; inefficient, but since the TEST-NOT option is deprecated
;; anyway, we don't care.)
- (complement (%coerce-callable-to-function test-not)))
+ (complement (%coerce-callable-to-fun test-not)))
(t #'eql)))
(defun effective-find-position-key (key)
(if key
- (%coerce-callable-to-function key)
+ (%coerce-callable-to-fun key)
#'identity))
;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
&key from-end (start 0) end key)
(nth-value
,values-index
- (%find-position-if (%coerce-callable-to-function predicate)
+ (%find-position-if (%coerce-callable-to-fun predicate)
sequence
from-end
start
&key from-end (start 0) end key)
(nth-value
,values-index
- (%find-position-if (complement (%coerce-callable-to-function
+ (%find-position-if (complement (%coerce-callable-to-fun
predicate))
sequence
from-end
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
- (let ((predicate-function (%coerce-callable-to-function predicate))
- (key-function (and key (%coerce-callable-to-function key))))
+ (let ((predicate-function (%coerce-callable-to-fun predicate))
+ (key-function (and key (%coerce-callable-to-fun key))))
(typecase sequence
(list (sort-list sequence predicate-function key-function))
(vector
(defun symbol-function (symbol)
#!+sb-doc
"Return SYMBOL's current function definition. Settable with SETF."
- (raw-definition symbol))
+ (%coerce-name-to-fun symbol))
-(defun fset (symbol new-value)
+(defun (setf symbol-function) (new-value symbol)
(declare (type symbol symbol) (type function new-value))
- (setf (raw-definition symbol) new-value))
+ (setf (%coerce-name-to-fun symbol) new-value))
(defun symbol-plist (symbol)
#!+sb-doc
#!+sb-doc
"For each entry in HASH-TABLE, call the designated two-argument function
on the key and value of the entry. Return NIL."
- (let ((fun (%coerce-callable-to-function function-designator))
+ (let ((fun (%coerce-callable-to-fun function-designator))
(size (length (hash-table-next-vector hash-table))))
(declare (type function fun))
(do ((i 1 (1+ i)))
(values (simple-array * (*)) index index index)
(foldable flushable))
(defknown %set-symbol-package (symbol t) t (unsafe))
-(defknown %coerce-name-to-function ((or symbol cons)) function (flushable))
-(defknown %coerce-callable-to-function (callable) function (flushable))
+(defknown %coerce-name-to-fun ((or symbol cons)) function (flushable))
+(defknown %coerce-callable-to-fun (callable) function (flushable))
(defknown failed-%with-array-data (t t t) nil)
(defknown %find-position
(t sequence t index sequence-end function function)
(defknown %charset (string index character) character (unsafe))
(defknown %scharset (simple-string index character) character (unsafe))
(defknown %set-symbol-value (symbol t) t (unsafe))
-(defknown fset (symbol function) function (unsafe))
+(defknown (setf symbol-function) (function symbol) function (unsafe))
(defknown %set-symbol-plist (symbol t) t (unsafe))
(defknown (setf fdocumentation) ((or string null) t symbol)
(or string null)
;;; FIXME: Having each of these error handlers be a full, named function
;;; seems to contribute a noticeable amount of bloat and little value.
;;; Perhaps we could just make a single error-handling function with a
-;;; big CASE statement inside it?
+;;; big CASE statement inside it? Or at least implement the error handling
+;;; functions as closures instead of DEFUNs?
(eval-when (:compile-toplevel :execute)
(def!macro define-internal-errors (&rest errors)
(let ((info (mapcar #'(lambda (x)
"Object is not of type SIMPLE-VECTOR.")
(object-not-fixnum
"Object is not of type FIXNUM.")
- (object-not-function-or-symbol
- "Object is not of type FUNCTION or SYMBOL.")
(object-not-vector
"Object is not of type VECTOR.")
(object-not-string
(%funcall ,(if (csubtypep (continuation-type function)
(specifier-type 'function))
'function
- '(%coerce-callable-to-function function))
+ '(%coerce-callable-to-fun function))
,@arg-names))))
(def-ir1-translator %funcall ((function &rest args) start cont)
`(%funcall ,function ,@args)
(values nil t)))
-(deftransform %coerce-callable-to-function ((thing) (function) *
- :when :both
- :important t)
+(deftransform %coerce-callable-to-fun ((thing) (function) *
+ :when :both
+ :important t)
"optimize away possible call to FDEFINITION at runtime"
'thing)
\f
(ir1-convert start fun-cont
(if (and (consp fun) (eq (car fun) 'function))
fun
- `(%coerce-callable-to-function ,fun)))
+ `(%coerce-callable-to-fun ,fun)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
(specifier-type '(or function symbol)))
;; of the &REST vars.)
`(lambda (result-type fun ,@seq-args)
(declare (ignore result-type))
- (do ((really-fun (%coerce-callable-to-function fun))
+ (do ((really-fun (%coerce-callable-to-fun fun))
,@index-bindingoids
(acc nil))
((or ,@tests)
(return (values find position)))
(when (>= index start)
(when (funcall predicate key-i)
- ;; This hack of dealing with non-NIL FROM-END for list data
- ;; by iterating forward through the list and keeping track of
- ;; the last time we found a match might be more screwy than
- ;; what the user expects, but it seems to be allowed by the
- ;; ANSI standard. (And if the user is screwy enough to ask
- ;; for FROM-END behavior on list data, turnabout is fair play.)
+ ;; This hack of dealing with non-NIL FROM-END for list
+ ;; data by iterating forward through the list and keeping
+ ;; track of the last time we found a match might be more
+ ;; screwy than what the user expects, but it seems to be
+ ;; allowed by the ANSI standard. (And if the user is
+ ;; screwy enough to ask for FROM-END behavior on list
+ ;; data, turnabout is fair play.)
;;
- ;; It's also not enormously efficient, calling PREDICATE and
- ;; KEY more often than necessary; but all the alternatives
- ;; seem to have their own efficiency problems.
+ ;; It's also not enormously efficient, calling PREDICATE
+ ;; and KEY more often than necessary; but all the
+ ;; alternatives seem to have their own efficiency
+ ;; problems.
(if from-end
(setf find i
position index)
:policy (> speed space)
:important t)
"expand inline"
- '(%find-position-if (let ((test-fun (%coerce-callable-to-function test)))
+ '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
;; I'm having difficulty believing I'm
;; reading it right, but as far as I can see,
;; the only guidance that ANSI gives for the
from-end
start
end
- (%coerce-callable-to-function key)))
+ (%coerce-callable-to-fun key)))
;;; The inline expansions for the VECTOR case are saved as macros so
;;; that we can share them between the DEFTRANSFORMs and the default
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.82"
+"0.pre7.83"
projects / sbcl.git / commitdiff