MNA pointed out that bug #25 is gone.
applied MNA "pcl cleanups" megapatch from sbcl-devel 2001-02-19
(will be hacked on some more soon, as per my reply and
ensuing discussion)
Perhaps any number of such consecutive lines ought to turn into a
single "byte compiling top-level forms:" line.
-9:
- The handling of IGNORE declarations on lambda list arguments of
- DEFMETHOD is at least weird, and in fact seems broken and useless.
- I should fix up another layer of binding, declared IGNORABLE, for
- typed lambda list arguments.
-
10:
The way that the compiler munges types with arguments together
with types with no arguments (in e.g. TYPE-EXPAND) leads to
a secondary error "caught ERROR: unrecoverable error during compilation"
and then return with FAILURE-P true,
-25:
- from CMU CL mailing list 01 May 2000
-
-I realize I can take care of this by doing (proclaim (ignore pcl::.slots1.))
-but seeing as .slots0. is not-exported, shouldn't it be ignored within the
-+expansion
-when not used?
-
-In: DEFMETHOD FOO-BAR-BAZ (RESOURCE-TYPE)
- (DEFMETHOD FOO-BAR-BAZ
- ((SELF RESOURCE-TYPE))
- (SETF (SLOT-VALUE SELF 'NAME) 3))
---> BLOCK MACROLET PCL::FAST-LEXICAL-METHOD-FUNCTIONS
---> PCL::BIND-FAST-LEXICAL-METHOD-MACROS MACROLET
---> PCL::BIND-LEXICAL-METHOD-FUNCTIONS LET PCL::BIND-ARGS LET* PCL::PV-BINDING
---> PCL::PV-BINDING1 PCL::PV-ENV LET
-==>
- (LET ((PCL::.SLOTS0. #))
- (PROGN SELF)
- (BLOCK FOO-BAR-BAZ
- (LET #
- #)))
-Warning: Variable PCL::.SLOTS0. defined but never used.
-
-Compilation unit finished.
- 1 warning
-
-#<Standard-Method FOO-BAR-BAZ (RESOURCE-TYPE) {480918FD}>
-
26:
reported by Sam Steingold on the cmucl-imp mailing list 12 May 2000:
some time ago.
changes in sbcl-0.6.11 relative to sbcl-0.6.10:
+* Martin Atzmueller pointed out that bugs #9 and #25 are gone in
+ current SBCL.
* bug 34 fixed by Martin Atzmueller: dumping/loading instances works
better
* fixed bug 40: TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE,
"*SETF-FDEFINITION-HOOK*"
;; non-standard but widely useful user-level functions..
- "ASSQ" "DELQ" "MEMQ"
+ "ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ"
"%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
"SANE-PACKAGE"
"CIRCULAR-LIST-P"
"PACKAGE-DOC-STRING"
"PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
"PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"
- "SB!INT" "SB!EXT"))
+ "SB!INT" "SB!EXT")
+ ("SB!INT" "MEMQ" "ASSQ" "DELQ" "POSQ" "NEQ"))
:reexport ("ADD-METHOD" "ALLOCATE-INSTANCE"
"COMPUTE-APPLICABLE-METHODS"
"ENSURE-GENERIC-FUNCTION"
(setq list (cdr x))
(rplacd splice (cdr x))))
(t (setq splice x)))))) ; Move splice along to include element.
+
+
+;; (defmacro posq (item list) `(position ,item ,list :test #'eq))
+(defun posq (item list)
+ #!+sb-doc
+ "Returns the position of the first element EQ to ITEM."
+ (do ((i list (cdr i))
+ (j 0 (1+ j)))
+ ((null i))
+ (when (eq (car i) item)
+ (return j))))
+
+;; (defmacro neq (x y) `(not (eq ,x ,y)))
+(defun neq (x y) (not (eq x y)))
|#
;; old code
(reduce #'type-union
- (mapcar #'specifier-type type-specifiers)
- :initial-value *empty-type*))
+ (mapcar #'specifier-type type-specifiers)
+ :initial-value *empty-type*))
\f
;;;; CONS types
"src/pcl/iterate"
"src/pcl/early-low"
"src/pcl/macros"
+ "src/pcl/compiler-support"
"src/pcl/low"
"src/pcl/fin"
"src/pcl/defclass"
;;; early definition. Do this in a way that makes sure that if we
;;; redefine one of the early definitions the redefinition will take
;;; effect. This makes development easier.
-;;;
-;;; The function which generates the redirection closure is pulled out
-;;; into a separate piece of code because of a bug in ExCL which
-;;; causes this not to work if it is inlined.
-;;; FIXME: We no longer need to worry about ExCL now, so we could unscrew this.
(eval-when (:load-toplevel :execute)
-
-(defun !redirect-early-function-internal (real early)
- (setf (gdefinition real)
- (set-function-name
- #'(lambda (&rest args)
- (apply (the function (symbol-function early)) args))
- real)))
-
+
(dolist (fns *!early-functions*)
(let ((name (car fns))
(early-name (cadr fns)))
- (!redirect-early-function-internal name early-name)))
-
+ (setf (gdefinition name)
+ (set-function-name
+ #'(lambda (&rest args)
+ (apply (the function (name-get-fdefinition early-name)) args))
+ name))))
) ; EVAL-WHEN
;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
(expand-defgeneric function-name lambda-list options))
(defun expand-defgeneric (function-name lambda-list options)
- (when (listp function-name)
- (do-standard-defsetf-1 (sb-int:function-name-block-name function-name)))
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(compile-or-load-defgeneric ',function-name))
- ,(make-top-level-form
- `(defgeneric ,function-name)
- *defgeneric-times*
- `(load-defgeneric ',function-name ',lambda-list ,@initargs))
+ (load-defgeneric ',function-name ',lambda-list ,@initargs)
,@(mapcar #'expand-method-definition methods)
`,(function ,function-name)))))
(sb-kernel:specifier-type 'function))))
(defun load-defgeneric (function-name lambda-list &rest initargs)
- (when (listp function-name)
- (do-standard-defsetf-1 (cadr function-name)))
(when (fboundp function-name)
(sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name))
(apply #'ensure-generic-function
lambda-list
body
env)
- (when (listp name)
- (do-standard-defsetf-1 (cadr name)))
(let ((*make-instance-function-keys* nil)
(*optimize-asv-funcall-p* t)
(*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
;; prefixes.)
(*package* sb-int:*keyword-package*))
(format nil "~S" mname)))))
- `(eval-when ,*defmethod-times*
+ `(eval-when (:load-toplevel :execute)
(defun ,mname-sym ,(cadr fn-lambda)
,@(cddr fn-lambda))
,(make-defmethod-form-internal
#',mname-sym
,@(cdddr initargs-form))
pv-table-symbol)))
- (make-top-level-form
- `(defmethod ,name ,@qualifiers ,specializers)
- *defmethod-times*
- (make-defmethod-form-internal
- name qualifiers
+ (make-defmethod-form-internal
+ name qualifiers
`(list ,@(mapcar #'(lambda (specializer)
(if (consp specializer)
``(,',(car specializer)
,,(cadr specializer))
`',specializer))
- specializers))
+ specializers))
unspecialized-lambda-list method-class-name
initargs-form
- pv-table-symbol)))))
+ pv-table-symbol))))
(defun make-defmethod-form-internal
(name qualifiers specializers-form unspecialized-lambda-list
(constantp (car real-body))))
(constant-value (and constant-value-p
(eval (car real-body))))
- ;; FIXME: This can become a bare AND (no IF), just like
- ;; the expression for CONSTANT-VALUE just above.
- (plist (if (and constant-value-p
- (or (typep constant-value
- '(or number character))
- (and (symbolp constant-value)
- (symbol-package constant-value))))
- (list :constant-value constant-value)
- ()))
+ (plist (and constant-value-p
+ (or (typep constant-value
+ '(or number character))
+ (and (symbolp constant-value)
+ (symbol-package constant-value)))
+ (list :constant-value constant-value)))
(applyp (dolist (p lambda-list nil)
(cond ((memq p '(&optional &rest &key))
(return t))
`(((typep ,emf 'fixnum)
(let* ((.slots. (get-slots-or-nil
,(car required-args+rest-arg)))
- (value (when .slots. (%instance-ref .slots. ,emf))))
+ (value (when .slots. (instance-ref .slots. ,emf))))
(if (eq value +slot-unbound+)
(slot-unbound-internal ,(car required-args+rest-arg)
,emf)
(let ((.new-value. ,(car required-args+rest-arg))
(.slots. (get-slots-or-nil
,(car required-args+rest-arg))))
- (when .slots. ; just to avoid compiler warnings
- (setf (%instance-ref .slots. ,emf) .new-value.))))))
+ (when .slots.
+ (setf (instance-ref .slots. ,emf) .new-value.))))))
#||
,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
`(((typep ,emf 'fast-instance-boundp)
(let ((.slots. (get-slots-or-nil
,(car required-args+rest-arg))))
(and .slots.
- (not (eq (%instance-ref
+ (not (eq (instance-ref
.slots. (fast-instance-boundp-index ,emf))
+slot-unbound+)))))))
||#
(fixnum
(cond ((null args) (error "1 or 2 args were expected."))
((null (cdr args))
- (let ((value (%instance-ref (get-slots (car args)) emf)))
+ (let* ((slots (get-slots (car args)))
+ (value (instance-ref slots emf)))
(if (eq value +slot-unbound+)
(slot-unbound-internal (car args) emf)
value)))
((null (cddr args))
- (setf (%instance-ref (get-slots (cadr args)) emf)
- (car args)))
+ (setf (instance-ref (get-slots (cadr args)) emf)
+ (car args)))
(t (error "1 or 2 args were expected."))))
(fast-instance-boundp
(if (or (null args) (cdr args))
(error "1 arg was expected.")
- (not (eq (%instance-ref (get-slots (car args))
- (fast-instance-boundp-index emf))
- +slot-unbound+))))
+ (let ((slots (get-slots (car args))))
+ (not (eq (instance-ref slots
+ (fast-instance-boundp-index emf))
+ +slot-unbound+)))))
(function
(apply emf args))))
(setq closurep t)
form)
(t nil))))
- (;; FIXME: should be MEMQ or FIND :TEST #'EQ
- (and (or (eq (car form) 'slot-value)
- (eq (car form) 'set-slot-value)
- (eq (car form) 'slot-boundp))
+ ((and (memq (car form)
+ '(slot-value set-slot-value slot-boundp))
(constantp (caddr form)))
- (let ((parameter (can-optimize-access form
- required-parameters
- env)))
- ;; FIXME: could be
- ;; (LET ((FUN (ECASE (CAR FORM) ..)))
- ;; (FUNCALL FUN SLOTS PARAMETER FORM))
- (ecase (car form)
- (slot-value
- (optimize-slot-value slots parameter form))
- (set-slot-value
- (optimize-set-slot-value slots parameter form))
- (slot-boundp
- (optimize-slot-boundp slots parameter form)))))
+ (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)
+ (slot-boundp #'optimize-slot-boundp))))
+ (funcall fun slots parameter form))))
((and (eq (car form) 'apply)
(consp (cadr form))
(eq (car (cadr form)) 'function)
*mf1p* (gethash method-function *method-function-plist*)))
*mf1p*)
-(defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-PLIST
- #+setf (setf method-function-plist)
+(defun (setf method-function-plist)
(val method-function)
(unless (eq method-function *mf1*)
(rotatef *mf1* *mf2*)
(defun method-function-get (method-function key &optional default)
(getf (method-function-plist method-function) key default))
-(defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-GET
- #+setf (setf method-function-get)
+(defun (setf method-function-get)
(val method-function key)
(setf (getf (method-function-plist method-function) key) val))
(defun load-defmethod
(class name quals specls ll initargs &optional pv-table-symbol)
- (when (listp name) (do-standard-defsetf-1 (cadr name)))
(setq initargs (copy-tree initargs))
(let ((method-spec (or (getf initargs ':method-spec)
(make-method-spec name quals specls))))
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
initargs pv-table-symbol)
- (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
(when pv-table-symbol
(setf (getf (getf initargs ':plist) :pv-table-symbol)
pv-table-symbol))
- ;; FIXME: It seems as though I should be able to get this to work.
- ;; But it keeps on screwing up PCL bootstrapping.
- #+nil
(when (and (eq *boot-state* 'complete)
(fboundp gf-spec))
- (let* ((gf (symbol-function gf-spec))
+ (let* ((gf (name-get-fdefinition gf-spec))
(method (and (generic-function-p gf)
(find-method gf
qualifiers
- (mapcar #'find-class specializers)
+ (parse-specializers specializers)
nil))))
(when method
(sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
keywords keyword-parameters)
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
- (let* ((old (sb-c::info :function :type name)) ;FIXME:FDOCUMENTATION instead?
- (old-ftype (if (sb-c::function-type-p old) old nil))
- (old-restp (and old-ftype (sb-c::function-type-rest old-ftype)))
+ (let* ((old (sb-int:info :function :type name)) ;FIXME:FDOCUMENTATION instead?
+ (old-ftype (if (sb-kernel:function-type-p old) old nil))
+ (old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype)))
(old-keys (and old-ftype
- (mapcar #'sb-c::key-info-name
- (sb-c::function-type-keywords old-ftype))))
- (old-keysp (and old-ftype (sb-c::function-type-keyp old-ftype)))
- (old-allowp (and old-ftype (sb-c::function-type-allowp old-ftype)))
+ (mapcar #'sb-kernel:key-info-name
+ (sb-kernel:function-type-keywords old-ftype))))
+ (old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype)))
+ (old-allowp (and old-ftype (sb-kernel:function-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
`(function ,(append (make-list nrequired :initial-element 't)
(when (plusp noptional)
(dolist (fn *!early-functions*)
(sb-int:/show fn)
- (setf (gdefinition (car fn)) (symbol-function (caddr fn))))
+ (setf (gdefinition (car fn)) (name-get-fdefinition (caddr fn))))
(dolist (fixup *!generic-function-fixups*)
(sb-int:/show fixup)
(specializers (second method))
(method-fn-name (third method))
(fn-name (or method-fn-name fspec))
- (fn (symbol-function fn-name))
+ (fn (name-get-fdefinition fn-name))
(initargs
(list :function
(set-function-name
;; "internal error: unrecognized lambda-list keyword ~S"?
(warn "Unrecognized lambda-list keyword ~S in arglist.~%~
Assuming that the symbols following it are parameters,~%~
- and not allowing any parameter specializers to follow~%~
- to follow it."
+ and not allowing any parameter specializers to follow it."
arg))
;; When we are at a lambda-list keyword, the parameters
;; don't include the lambda-list keyword; the lambda-list
`(cache-vector-ref ,cache-vector 0))
(defun flush-cache-vector-internal (cache-vector)
- (without-interrupts
+ (sb-sys:without-interrupts
(fill (the simple-vector cache-vector) nil)
(setf (cache-vector-lock-count cache-vector) 0))
cache-vector)
(defmacro modify-cache (cache-vector &body body)
- `(without-interrupts
+ `(sb-sys:without-interrupts
(multiple-value-prog1
(progn ,@body)
(let ((old-count (cache-vector-lock-count ,cache-vector)))
;;; ever return a larger cache.
(defun get-cache-vector (size)
(let ((entry (gethash size *free-cache-vectors*)))
- (without-interrupts
+ (sb-sys:without-interrupts
(cond ((null entry)
(setf (gethash size *free-cache-vectors*) (cons 0 nil))
(get-cache-vector size))
(defun free-cache-vector (cache-vector)
(let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
- (without-interrupts
+ (sb-sys:without-interrupts
(if (null entry)
(error
"attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
(defvar *free-caches* nil)
(defun get-cache (nkeys valuep limit-fn nlines)
- (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+ (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*))
+ (make-cache))))
(declare (type cache cache))
(multiple-value-bind (cache-mask actual-size line-size nlines)
(compute-cache-parameters nkeys valuep nlines)
&optional (new-field (first-wrapper-cache-number-index)))
(let ((nkeys (cache-nkeys old-cache))
(valuep (cache-valuep old-cache))
- (cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+ (cache (or (sb-sys:without-interrupts (pop *free-caches*))
+ (make-cache))))
(declare (type cache cache))
(multiple-value-bind (cache-mask actual-size line-size nlines)
(if (= new-nlines (cache-nlines old-cache))
--- /dev/null
+;;;; things which the main SBCL compiler needs to know about the
+;;;; implementation of CLOS
+;;;;
+;;;; (Our CLOS is derived from PCL, which was implemented in terms of
+;;;; portable high-level Common Lisp. But now that it no longer needs
+;;;; to be portable, we can make some special hacks to support it
+;;;; better.)
+
+;;;; This software is part of the SBCL system. See the README file for more
+;;;; information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-C")
+\f
+;;;; very low-level representation of instances with meta-class
+;;;; STANDARD-CLASS
+
+(defknown sb-pcl::pcl-instance-p (t) boolean
+ (movable foldable flushable explicit-check))
+
+(deftransform sb-pcl::pcl-instance-p ((object))
+ (let* ((otype (continuation-type object))
+ (std-obj (specifier-type 'sb-pcl::std-object)))
+ (cond
+ ;; Flush tests whose result is known at compile time.
+ ((csubtypep otype std-obj) 't)
+ ((not (types-intersect otype std-obj)) 'nil)
+ (t
+ `(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))
+
+(def-source-context defmethod (name &rest stuff)
+ (let ((arg-pos (position-if #'listp stuff)))
+ (if arg-pos
+ `(defmethod ,name ,@(subseq stuff 0 arg-pos)
+ ,(nth-value 2 (sb-pcl::parse-specialized-lambda-list
+ (elt stuff arg-pos))))
+ `(defmethod ,name "<illegal syntax>"))))
;; So instead:
(declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name)
,name))
- ,(make-top-level-form `(defconstructor ,name)
- '(load eval)
- `(load-constructor
- ',class-name
- ',(class-name (class-of class))
- ',name
- ',supplied-initarg-names
- ;; make-constructor-code-generators is called to return a list
- ;; of constructor code generators. The actual interpretation
- ;; of this list is left to compute-constructor-code, but the
- ;; general idea is that it should be an plist where the keys
- ;; name a kind of constructor code and the values are generator
- ;; functions which return the actual constructor code. The
- ;; constructor code is usually a closures over the arguments
- ;; to the generator.
- ,(make-constructor-code-generators class
- name
- lambda-list
- supplied-initarg-names
- supplied-initargs))))))
+ (load-constructor
+ ',class-name
+ ',(class-name (class-of class))
+ ',name
+ ',supplied-initarg-names
+ ;; make-constructor-code-generators is called to return a list
+ ;; of constructor code generators. The actual interpretation
+ ;; of this list is left to compute-constructor-code, but the
+ ;; general idea is that it should be an plist where the keys
+ ;; name a kind of constructor code and the values are generator
+ ;; functions which return the actual constructor code. The
+ ;; constructor code is usually a closures over the arguments
+ ;; to the generator.
+ ,(make-constructor-code-generators class
+ name
+ lambda-list
+ supplied-initarg-names
+ supplied-initargs)))))
(defun load-constructor (class-name metaclass-name constructor-name
supplied-initarg-names code-generators)
(.initargs. .constant-initargs.))
.positions.
- (dolist (entry .initfns-initargs-and-positions.)
- (let ((val (funcall (car entry)))
- (initarg (cadr entry)))
- (when initarg
- (push val .initargs.)
- (push initarg .initargs.))
- (dolist (pos (cddr entry))
- (setf (%instance-ref .slots. pos) val))))
+ (dolist (entry .initfns-initargs-and-positions.)
+ (let ((val (funcall (car entry)))
+ (initarg (cadr entry)))
+ (when initarg
+ (push val .initargs.)
+ (push initarg .initargs.))
+ (dolist (pos (cddr entry))
+ (setf (instance-ref .slots. pos) val))))
,@(gathering1 (collecting)
- (doplist (initarg value) supplied-initargs
+ (doplist (initarg value) supplied-initargs
(unless (constantp value)
(gather1 `(let ((.value. ,value))
(push .value. .initargs.)
(push ',initarg .initargs.)
(dolist (.p. (pop .positions.))
- (setf (%instance-ref .slots. .p.)
+ (setf (instance-ref .slots. .p.)
.value.)))))))
(dolist (fn .shared-initfns.)
(dolist (entry .initfns-and-positions.)
(let ((val (funcall (car entry))))
(dolist (pos (cdr entry))
- (setf (%instance-ref .slots. pos) val))))
+ (setf (instance-ref .slots. pos) val))))
,@(gathering1 (collecting)
(doplist (initarg value) supplied-initargs
(gather1
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
- (setf (%instance-ref .slots. .p.) .value.)))))))
+ (setf (instance-ref .slots. .p.) .value.)))))))
.instance.))))))))
(gather1
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
- (setf (%instance-ref .slots. .p.)
- .value.)))))))
+ (setf (instance-ref .slots. .p.)
+ .value.)))))))
.instance.))))))))))
(bail-out)))))
(values constants (nreverse supplied-initarg-positions)))))
-
(in-package "SB-PCL")
\f
-;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
-;;;
-;;; The original motiviation for this function was to deal with the
-;;; bug in the Genera compiler that prevents lambda expressions in
-;;; top-level forms other than DEFUN from being compiled.
-;;;
-;;; Now this function is used to grab other functionality as well. This
-;;; includes:
-;;; - Preventing the grouping of top-level forms. For example, a
-;;; DEFCLASS followed by a DEFMETHOD may not want to be grouped
-;;; into the same top-level form.
-;;; - Telling the programming environment what the pretty version
-;;; of the name of this form is. This is used by WARN.
-;;;
-;;; FIXME: It's not clear that this adds value any more. Couldn't
-;;; we just use EVAL-WHEN?
-(defun make-top-level-form (name times form)
- (if (or (member 'compile times)
- (member ':compile-toplevel times))
- `(eval-when ,times ,form)
- form))
(defun make-progn (&rest forms)
(let ((progn-form nil))
;; FIXME: We should probably just ensure that the relevant
;; DEFVAR/DEFPARAMETERs occur before this definition, rather
;; than locally declaring them SPECIAL.
- (declare (special *defclass-times* *boot-state* *the-class-structure-class*))
+ (declare (special *boot-state* *the-class-structure-class*))
(setq supers (copy-tree supers)
slots (copy-tree slots)
options (copy-tree options))
(return t))))
(let ((*initfunctions* ())
- (*accessors* ()) ;Truly a crock, but we got
- (*readers* ()) ;to have it to live nicely.
- (*writers* ()))
- (declare (special *initfunctions* *accessors* *readers* *writers*))
+ (*readers* ()) ;Truly a crock, but we got
+ (*writers* ())) ;to have it to live nicely.
+ (declare (special *initfunctions* *readers* *writers*))
(let ((canonical-slots
(mapcar #'(lambda (spec)
(canonicalize-slot-specification name spec))
(and mclass
(*subtypep mclass
*the-class-structure-class*))))))
- (do-standard-defsetfs-for-defclass *accessors*)
(let ((defclass-form
- (make-top-level-form `(defclass ,name)
- (if defstruct-p '(:load-toplevel :execute) *defclass-times*)
- `(progn
- ,@(mapcar #'(lambda (x)
- `(declaim (ftype (function (t) t) ,x)))
- *readers*)
- ,@(mapcar #'(lambda (x)
- #-setf (when (consp x)
- (setq x (get-setf-function-name (cadr x))))
- `(declaim (ftype (function (t t) t) ,x)))
- *writers*)
- (let ,(mapcar #'cdr *initfunctions*)
- (load-defclass ',name
- ',metaclass
- ',supers
- (list ,@canonical-slots)
- (list ,@(apply #'append
- (when defstruct-p
- '(:from-defclass-p t))
- other-initargs))
- ',*accessors*))))))
+ (eval-when (:load-toplevel :execute)
+ `(progn
+ ,@(mapcar #'(lambda (x)
+ `(declaim (ftype (function (t) t) ,x)))
+ *readers*)
+ ,@(mapcar #'(lambda (x)
+ `(declaim (ftype (function (t t) t) ,x)))
+ *writers*)
+ (let ,(mapcar #'cdr *initfunctions*)
+ (load-defclass ',name
+ ',metaclass
+ ',supers
+ (list ,@canonical-slots)
+ (list ,@(apply #'append
+ (when defstruct-p
+ '(:from-defclass-p t))
+ other-initargs))))))))
(if defstruct-p
(progn
(eval defclass-form) ; Define the class now, so that..
,(class-defstruct-form (find-class name))
,defclass-form))
(progn
- (when (and (eq *boot-state* 'complete)
- (not (member 'compile *defclass-times*)))
+ (when (eq *boot-state* 'complete)
(inform-type-system-about-std-class name))
defclass-form)))))))
(cadr entry)))))
(defun canonicalize-slot-specification (class-name spec)
- (declare (special *accessors* *readers* *writers*))
+ (declare (special *readers* *writers*))
(cond ((and (symbolp spec)
(not (keywordp spec))
(not (memq spec '(t nil))))
(initform (getf spec :initform unsupplied)))
(doplist (key val) spec
(case key
- (:accessor (push val *accessors*)
- (push val readers)
+ (:accessor (push val readers)
(push `(setf ,val) writers))
(:reader (push val readers))
(:writer (push val writers))
(unless (fboundp 'class-name-of)
(setf (symbol-function 'class-name-of)
(symbol-function 'early-class-name-of)))
-;;; FIXME: Can we then delete EARLY-CLASS-NAME-OF?
+(unintern 'early-class-name-of)
(defun early-class-direct-subclasses (class)
(!bootstrap-get-slot 'class class 'direct-subclasses))
(declaim (notinline load-defclass))
-(defun load-defclass
- (name metaclass supers canonical-slots canonical-options accessor-names)
+(defun load-defclass (name metaclass supers canonical-slots canonical-options)
(setq supers (copy-tree supers)
canonical-slots (copy-tree canonical-slots)
canonical-options (copy-tree canonical-options))
- (do-standard-defsetfs-for-defclass accessor-names)
(when (eq metaclass 'standard-class)
(inform-type-system-about-std-class name))
(let ((ecd
(getf (cddr whole) :identity-with-one-argument nil))
(operator
(getf (cddr whole) :operator type)))
- (make-top-level-form `(define-method-combination ,type)
- '(:load-toplevel :execute)
- `(load-short-defcombin
- ',type ',operator ',identity-with-one-arg ',documentation))))
+ `(load-short-defcombin
+ ',type ',operator ',identity-with-one-arg ',documentation)))
(defun load-short-defcombin (type operator ioa doc)
(let* ((truename *load-truename*)
(make-long-method-combination-function
type lambda-list method-group-specifiers arguments-option gf-var
body)
- (make-top-level-form `(define-method-combination ,type)
- '(:load-toplevel :execute)
- `(load-long-defcombin ',type ',documentation #',function)))))
+ `(load-long-defcombin ',type ',documentation #',function))))
(defvar *long-method-combination-functions* (make-hash-table :test 'eq))
(in-package "SB-PCL")
\f
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; FIXME: These are non-ANSI hacks which it would be nice to get rid of.
-(defvar *defclass-times* '(:load-toplevel :execute)) ; You probably have
- ; to change this if you use
- ; DEFCONSTRUCTOR.
-(defvar *defmethod-times* '(:load-toplevel :execute))
-(defvar *defgeneric-times* '(:load-toplevel :execute))
-
-) ; EVAL-WHEN
(eval-when (:load-toplevel :execute)
(when (eq *boot-state* 'complete)
;;; which has a 'real' function spec mechanism can use that instead
;;; and in that way get rid of setf generic function names.
(defmacro parse-gspec (spec
- (non-setf-var . non-setf-case)
- (setf-var . setf-case))
- #+setf (declare (ignore setf-var setf-case))
- (once-only (spec)
- `(cond (#-setf (symbolp ,spec) #+setf t
- (let ((,non-setf-var ,spec)) ,@non-setf-case))
- #-setf
- ((and (listp ,spec)
- (eq (car ,spec) 'setf)
- (symbolp (cadr ,spec)))
- (let ((,setf-var (cadr ,spec))) ,@setf-case))
- #-setf
- (t
- (error
- "Can't understand ~S as a generic function specifier.~%~
- It must be either a symbol which can name a function or~%~
- a list like ~S, where the car is the symbol ~S and the cadr~%~
- is a symbol which can name a generic function."
- ,spec '(setf <foo>) 'setf)))))
+ (non-setf-var . non-setf-case))
+ `(let ((,non-setf-var ,spec)) ,@non-setf-case))
;;; If symbol names a function which is traced or advised, return the
;;; unadvised, traced etc. definition. This lets me get at the generic
;;; function object even when it is traced.
(defun unencapsulated-fdefinition (symbol)
- (symbol-function symbol))
+ (name-get-fdefinition symbol))
;;; If symbol names a function which is traced or advised, redefine
;;; the `real' definition without affecting the advise.
(sb-c::%%defun name new-definition nil)
(sb-c::note-name-defined name :function)
new-definition)
- (setf (symbol-function name) new-definition))
+ (name-set-fdefinition name new-definition))
(defun gboundp (spec)
(parse-gspec spec
- (name (fboundp name))
- (name (fboundp (get-setf-function-name name)))))
+ (name (fboundp name))))
(defun gmakunbound (spec)
(parse-gspec spec
- (name (fmakunbound name))
- (name (fmakunbound (get-setf-function-name name)))))
+ (name (fmakunbound name))))
(defun gdefinition (spec)
(parse-gspec spec
- (name (or #-setf (macro-function name) ;??
- (unencapsulated-fdefinition name)))
- (name (unencapsulated-fdefinition (get-setf-function-name name)))))
+ (name (unencapsulated-fdefinition name))))
-(defun #-setf SETF\ SB-PCL\ GDEFINITION #+setf (setf gdefinition) (new-value
- spec)
+(defun (setf gdefinition) (new-value spec)
(parse-gspec spec
- (name (fdefine-carefully name new-value))
- (name (fdefine-carefully (get-setf-function-name name) new-value))))
+ (name (fdefine-carefully name new-value))))
\f
(declaim (special *the-class-t*
*the-class-vector* *the-class-symbol*
(defun plist-value (object name)
(getf (object-plist object) name))
-(defun #-setf SETF\ SB-PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value
- object
- name)
+(defun (setf plist-value) (new-value object name)
(if new-value
(setf (getf (object-plist object) name) new-value)
(progn
(let* ((generator-entry (assq generator *dfun-constructors*))
(args-entry (assoc args (cdr generator-entry) :test #'equal)))
(if (null *enable-dfun-constructor-caching*)
- (apply (symbol-function generator) args)
+ (apply (name-get-fdefinition generator) args)
(or (cadr args-entry)
(multiple-value-bind (new not-best-p)
(apply (symbol-function generator) args)
(eq (caddr args-entry) system))
(when system (setf (caddr args-entry) system))
(gather1
- (make-top-level-form `(precompile-dfun-constructor
- ,(car generator-entry))
- '(:load-toplevel)
- `(load-precompiled-dfun-constructor
- ',(car generator-entry)
- ',(car args-entry)
- ',system
- ,(apply (symbol-function (car generator-entry))
- (car args-entry))))))))))))
+ `(load-precompiled-dfun-constructor
+ ',(car generator-entry)
+ ',(car args-entry)
+ ',system
+ ,(apply (name-get-fdefinition (car generator-entry))
+ (car args-entry)))))))))))
\f
;;; When all the methods of a generic function are automatically generated
;;; reader or writer methods a number of special optimizations are possible.
,form)))))
(values (if *precompiling-lap*
`#',lambda
- (compile-lambda lambda))
+ (compile nil lambda))
nil)))
;;; note on implementation for CMU 17 and later (including SBCL):
(defun emit-slot-read-form (class-slot-p index slots)
(if class-slot-p
`(cdr ,index)
- `(%instance-ref ,slots ,index)))
+ `(instance-ref ,slots ,index)))
+
+(defun emit-slot-write-form (class-slot-p index slots value)
+ (if class-slot-p
+ `(setf (cdr ,index) ,value)
+ `(and ,slots (setf (instance-ref ,slots ,index) ,value))))
(defun emit-boundp-check (value-form miss-fn arglist)
`(let ((value ,value-form))
value)))
(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
- (let ((read-form (emit-slot-read-form class-slot-p index slots)))
+ (let ((read-form (emit-slot-read-form class-slot-p index slots))
+ (write-form (emit-slot-write-form
+ class-slot-p index slots (car arglist))))
(ecase reader/writer
(:reader (emit-boundp-check read-form miss-fn arglist))
- (:writer `(setf ,read-form ,(car arglist))))))
+ (:writer write-form))))
(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
(let ((*emit-function-p* nil)
(defun trace-method-internal (ofunction name options)
(eval `(untrace ,name))
- (setf (symbol-function name) ofunction)
+ (name-set-fdefinition name ofunction)
(eval `(trace ,name ,@options))
- (symbol-function name))
+ (name-get-fdefinition name))
|#
\f
;;;; MAKE-LOAD-FORM
(nconc *initialize-instance-simple-alist*
(list entry)))))
(unless (or *note-iis-entry-p* (cadr entry))
- (setf (cadr entry) (compile-lambda (car entry))))
+ (setf (cadr entry) (compile nil (car entry))))
(if (cadr entry)
(apply (the function (cadr entry)) args)
`(call-initialize-instance-simple ,pv-cell ,form-list))))
:test #'equal))))
(defmacro precompile-iis-functions (&optional system)
- (let ((index -1))
- `(progn
- ,@(gathering1 (collecting)
- (dolist (iis-entry *initialize-instance-simple-alist*)
- (when (or (null (caddr iis-entry))
- (eq (caddr iis-entry) system))
- (when system (setf (caddr iis-entry) system))
- (gather1
- (make-top-level-form
- `(precompile-initialize-instance-simple ,system ,(incf index))
- '(:load-toplevel)
- `(load-precompiled-iis-entry
- ',(car iis-entry)
- #',(car iis-entry)
- ',system
- ',(cdddr iis-entry))))))))))
+ `(progn
+ ,@(gathering1 (collecting)
+ (dolist (iis-entry *initialize-instance-simple-alist*)
+ (when (or (null (caddr iis-entry))
+ (eq (caddr iis-entry) system))
+ (when system (setf (caddr iis-entry) system))
+ (gather1
+ `(load-precompiled-iis-entry
+ ',(car iis-entry)
+ #',(car iis-entry)
+ ',system
+ ',(cdddr iis-entry))))))))
(defun compile-iis-functions (after-p)
(let ((*compile-make-instance-functions-p* t)
value)))
(if *inline-iis-instance-locations-p*
(typecase location
- (fixnum `((setf (%instance-ref slots ,(const location)) value)))
+ (fixnum `((and slots
+ (setf (instance-ref slots ,(const location))
+ value))))
(cons `((setf (cdr ,(const location)) value)))
(t `(,default)))
`((instance-write-internal pv slots ,(const pv-offset) value
,(const (caddr form)))))
`((unless ,(if *inline-iis-instance-locations-p*
(typecase location
- (fixnum `(not (eq (%instance-ref slots ,(const location))
- +slot-unbound+)))
+ (fixnum `(not (and slots
+ (eq (instance-ref slots ,(const location))
+ +slot-unbound+))))
(cons `(not (eq (cdr ,(const location)) +slot-unbound+)))
(t default))
`(instance-boundp-internal pv slots ,(const pv-offset)
(let* ((*make-instance-function-keys* nil)
(expanded-form (expand-make-instance-form form)))
(if expanded-form
- `(funcall (symbol-function
+ `(funcall (name-get-fdefinition
;; The symbol is guaranteed to be fbound.
;; Is there a way to declare this?
(load-time-value
(in-package "SB-PCL")
\f
;;; GET-FUNCTION is the main user interface to this code. It is like
-;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by
+;;; COMPILE, only more efficient. It achieves this efficiency by
;;; reducing the number of times that the compiler needs to be called.
;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants
;;; can use the same piece of compiled code. (For example, dispatch dfuns and
;;; compute-constants is used to generate the argument list that is
;;; to be passed to the compiled function.
;;;
-;;; Whether the returned function is actually compiled depends on whether
-;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
-;;; code was precompiled.
(defun get-function (lambda
&optional (test-converter #'default-test-converter)
(code-converter #'default-code-converter)
(defun get-new-function-generator (lambda test code-converter)
(multiple-value-bind (gensyms generator-lambda)
(get-new-function-generator-internal lambda code-converter)
- (let* ((generator (compile-lambda generator-lambda))
+ (let* ((generator (compile nil generator-lambda))
(fgen (make-fgen test gensyms generator generator-lambda nil)))
(store-fgen fgen)
generator)))
f)))))))))
\f
(defmacro precompile-function-generators (&optional system)
- (let ((index -1))
- `(progn ,@(gathering1 (collecting)
- (dolist (fgen *fgens*)
- (when (or (null (fgen-system fgen))
- (eq (fgen-system fgen) system))
- (when system (setf (svref fgen 4) system))
- (gather1
- (make-top-level-form
- `(precompile-function-generators ,system ,(incf index))
- '(:load-toplevel)
- `(load-function-generator
- ',(fgen-test fgen)
- ',(fgen-gensyms fgen)
- (function ,(fgen-generator-lambda fgen))
- ',(fgen-generator-lambda fgen)
- ',system)))))))))
+ `(progn
+ ,@(gathering1 (collecting)
+ (dolist (fgen *fgens*)
+ (when (or (null (fgen-system fgen))
+ (eq (fgen-system fgen) system))
+ (when system (setf (svref fgen 4) system))
+ (gather1
+ `(load-function-generator
+ ',(fgen-test fgen)
+ ',(fgen-gensyms fgen)
+ (function ,(fgen-generator-lambda fgen))
+ ',(fgen-generator-lambda fgen)
+ ',system)))))))
(defun load-function-generator (test gensyms generator generator-lambda system)
(store-fgen (make-fgen test gensyms generator generator-lambda system)))
t)
(defmethod pcl-close ((stream fundamental-stream) &key abort)
+ (declare (ignore abort))
(setf (stream-open-p stream) nil)
t)
(defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
) ; EVAL-WHEN
-;;; FIXME: Do these definitions actually increase speed significantly?
-;;; Could we just use SVREF instead, possibly with a few extra
-;;; OPTIMIZE declarations added here and ther?
-(defmacro %svref (vector index)
- `(locally (declare #.*optimize-speed*
- (inline svref))
- (svref (the simple-vector ,vector) (the fixnum ,index))))
-(defsetf %svref %set-svref)
-(defmacro %set-svref (vector index new-value)
- `(locally (declare #.*optimize-speed*
- (inline svref))
- (setf (svref (the simple-vector ,vector) (the fixnum ,index))
- ,new-value)))
-
-;;; I want the body to be evaluated in such a way that no other code that is
-;;; running PCL can be run during that evaluation. I agree that the body
-;;; won't take *long* to evaluate. That is to say that I will only use
-;;; WITHOUT-INTERRUPTS around relatively small computations.
-;;;
-;;; FIXME: We can get rid of this macro definitionand either USE package %SYS
-;;; or add an explicit SB-SYS: prefix to each reference to WITHOUT-INTERRUPTS.
-(defmacro without-interrupts (&rest stuff)
- `(sb-sys:without-interrupts ,@stuff))
-
(defmacro dotimes-fixnum ((var count &optional (result nil)) &body body)
`(dotimes (,var (the fixnum ,count) ,result)
(declare (fixnum ,var))
,@body))
\f
-;;;; very low-level representation of instances with meta-class
-;;;; STANDARD-CLASS
-
-;;; FIXME: more than one IN-PACKAGE in a source file, ick
-(in-package "SB-C")
-
-(defknown sb-pcl::pcl-instance-p (t) boolean
- (movable foldable flushable explicit-check))
-
-(deftransform sb-pcl::pcl-instance-p ((object))
- (let* ((otype (continuation-type object))
- (std-obj (specifier-type 'sb-pcl::std-object)))
- (cond
- ;; Flush tests whose result is known at compile time.
- ((csubtypep otype std-obj) 't)
- ((not (types-intersect otype std-obj)) 'nil)
- (t
- `(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))
-(in-package "SB-PCL")
-
-;;; FIXME: What do these do? Could we use SB-KERNEL:INSTANCE-REF instead?
-(defmacro %instance-ref (slots index)
- `(%svref ,slots ,index))
(defmacro instance-ref (slots index)
`(svref ,slots ,index))
-;;; Note on implementation under CMU CL >=17 and SBCL: STD-INSTANCE-P is
-;;; only used to discriminate between functions (including FINs) and
-;;; normal instances, so we can return true on structures also. A few
-;;; uses of (or std-instance-p fsc-instance-p) are changed to
+;;; Note on implementation under CMU CL >=17 and SBCL: STD-INSTANCE-P
+;;; is only used to discriminate between functions (including FINs)
+;;; and normal instances, so we can return true on structures also. A
+;;; few uses of (or std-instance-p fsc-instance-p) are changed to
;;; pcl-instance-p.
(defmacro std-instance-p (x)
`(sb-kernel:%instancep ,x))
(defmacro std-instance-class (instance)
`(wrapper-class* (std-instance-wrapper ,instance)))
\f
-;;;; FUNCTION-ARGLIST
-
-;;; FIXME: Does FUNCTION-PRETTY-ARGLIST need to be settable at all?
-(defsetf function-pretty-arglist set-function-pretty-arglist)
-(defun set-function-pretty-arglist (function new-value)
- (declare (ignore function))
- new-value)
;;; SET-FUNCTION-NAME
;;;
(format nil "~S" name))
*pcl-package*))))
\f
-;;;; COMPILE-LAMBDA
-
-;;; This is like the Common Lisp function COMPILE. In fact, that is what it
-;;; ends up calling. The difference is that it deals with things like not
-;;; calling the compiler in certain cases.
-;;;
-;;; FIXME: I suspect that in SBCL, we should always call the compiler. (PCL
-;;; was originally designed to run even on systems with dog-slow call-out-to-C
-;;; compilers, and I suspect that this code is needed only for that.)
-(defun compile-lambda (lambda &optional (desirability :fast))
- (cond ((eq desirability :fast)
- (compile nil lambda))
- (t
- (compile-lambda-uncompiled lambda))))
-
-(defun compile-lambda-uncompiled (uncompiled)
- #'(lambda (&rest args) (apply (coerce uncompiled 'function) args)))
-
-(defun compile-lambda-deferred (uncompiled)
- (let ((function (coerce uncompiled 'function))
- (compiled nil))
- (declare (type (or function null) compiled))
- #'(lambda (&rest args)
- (if compiled
- (apply compiled args)
- (if (in-the-compiler-p)
- (apply function args)
- (progn (setq compiled (compile nil uncompiled))
- (apply compiled args)))))))
-
;;; FIXME: probably no longer needed after init
(defmacro precompile-random-code-segments (&optional system)
`(progn
(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
\f
-;;;; low level functions for structures I: functions on arbitrary objects
-
-;;; FIXME: Maybe we don't need this given the SBCL-specific
-;;; versions of the functions which would otherwise use it?
-(defvar *structure-table* (make-hash-table :test 'eq))
-
-(defun declare-structure (name included-name slot-description-list)
- (setf (gethash name *structure-table*)
- (cons included-name slot-description-list)))
-
-(unless (fboundp 'structure-functions-exist-p)
- (setf (symbol-function 'structure-functions-exist-p)
- #'(lambda () nil)))
-
-;;; FIXME: should probably be INLINE
-;;; FIXME: should probably be moved to package SB-INT along with
-;;; other nonstandard type predicates, or removed entirely
-(defun structurep (x)
- (typep x 'cl:structure-object))
-\f
;;; This definition is for interpreted code.
(defun pcl-instance-p (x)
(typep (sb-kernel:layout-of x) 'wrapper))
(fsc-instance-slots ,n-inst)))))
\f
;;;; structure-instance stuff
-
-;;; FIXME: This can be removed by hardwiring uses of it to T.
-(defun structure-functions-exist-p ()
- t)
-
;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
(defun get-structure-dd (type)
(defun structure-slotd-init-form (slotd)
(sb-kernel::dsd-default slotd))
-
-;;; FIXME: more than one IN-PACKAGE in a source file, ick
-(in-package "SB-C")
-
-(def-source-context defmethod (name &rest stuff)
- (let ((arg-pos (position-if #'listp stuff)))
- (if arg-pos
- `(defmethod ,name ,@(subseq stuff 0 arg-pos)
- ,(nth-value 2 (sb-pcl::parse-specialized-lambda-list
- (elt stuff arg-pos))))
- `(defmethod ,name "<illegal syntax>"))))
;; information around, I'm not sure. -- WHN 2000-12-30
%variable-rebinding))
-;;; comment from CMU CL PCL:
-;;; These are age-old functions which CommonLisp cleaned-up away. They
-;;; probably exist in other packages in all CommonLisp
-;;; implementations, but I will leave it to the compiler to optimize
-;;; into calls to them.
-;;;
-;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we
-;;; should use those definitions. POSQ and NEQ aren't defined in SBCL,
-;;; and are used too often in PCL to make it appealing to hand expand
-;;; all uses and then delete the macros, so they should be boosted up
-;;; to SB-INT to stand by MEMQ, ASSQ, and DELQ.
-(defmacro memq (item list) `(member ,item ,list :test #'eq))
-(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
-(defmacro delq (item list) `(delete ,item ,list :test #'eq))
-(defmacro posq (item list) `(position ,item ,list :test #'eq))
-(defmacro neq (x y) `(not (eq ,x ,y)))
+(defmacro name-get-fdefinition (name)
+ (sb-int:once-only ((name name))
+ `(if (symbolp ,name) ; take care of "setf <fun>"'s
+ (symbol-function ,name)
+ (fdefinition ,name))))
+
+(defmacro name-set-fdefinition (name new-definition)
+ (sb-int:once-only ((name name))
+ `(if (symbolp ,name) ; take care of "setf <fun>"'s
+ (setf (symbol-function ,name) ,new-definition)
+ (setf (fdefinition ,name) ,new-definition))))
+
;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too.
(macrolet ((def-constantly-fun (name constant-expr)
- `(setf (symbol-function ',name)
+ `(name-set-fdefinition ',name
(constantly ,constant-expr))))
(def-constantly-fun constantly-t t)
(def-constantly-fun constantly-nil nil)
(def-constantly-fun constantly-0 0))
-;;; comment from original CMU CL PCL: ONCE-ONLY does the same thing as
-;;; it does in zetalisp. I should have just lifted it from there but I
-;;; am honest. Not only that but this one is written in Common Lisp. I
-;;; feel a lot like bootstrapping, or maybe more like rebuilding Rome.
-;;;
-;;; FIXME: We should only need one ONCE-ONLY in SBCL, and there's one
-;;; in SB-INT already. Can we use only one of these in both places?
-(defmacro once-only (vars &body body)
- (let ((gensym-var (gensym))
- (run-time-vars (gensym))
- (run-time-vals (gensym))
- (expand-time-val-forms ()))
- (dolist (var vars)
- (push `(if (or (symbolp ,var)
- (numberp ,var)
- (and (listp ,var)
- (member (car ,var) '(quote function))))
- ,var
- (let ((,gensym-var (gensym)))
- (push ,gensym-var ,run-time-vars)
- (push ,var ,run-time-vals)
- ,gensym-var))
- expand-time-val-forms))
- `(let* (,run-time-vars
- ,run-time-vals
- (wrapped-body
- (let ,(mapcar #'list vars (reverse expand-time-val-forms))
- ,@body)))
- `(let ,(mapcar #'list (reverse ,run-time-vars)
- (reverse ,run-time-vals))
- ,wrapped-body))))
-
;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun extract-declarations (body &optional environment)
(find-class-from-cell ',symbol ,class-cell nil))))))
form))
-;;; FIXME: These #-SETF forms are pretty ugly. Could they please go away?
-#-setf
-(defsetf find-class (symbol &optional (errorp t) environment) (new-value)
- (declare (ignore errorp environment))
- `(SETF\ SB-PCL\ FIND-CLASS ,new-value ,symbol))
-
-(defun #-setf SETF\ SB-PCL\ FIND-CLASS #+setf (setf find-class) (new-value
- symbol)
+(defun (setf find-class) (new-value symbol)
(if (legal-class-name-p symbol)
(let ((cell (find-class-cell symbol)))
(setf (find-class-cell-class cell) new-value)
(eq *boot-state* 'braid))
(when (and new-value (class-wrapper new-value))
(setf (find-class-cell-predicate cell)
- (symbol-function (class-predicate-name new-value))))
+ (name-get-fdefinition (class-predicate-name new-value))))
(when (and new-value (not (forward-referenced-class-p new-value)))
(dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
new-value)
(error "~S is not a legal class name." symbol)))
-#-setf
-(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
- (declare (ignore errorp environment))
- `(SETF\ SB-PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
-
-(defun #-setf SETF\ SB-PCL\ FIND-CLASS-PREDICATE
- #+setf (setf find-class-predicate)
- (new-value symbol)
+(defun (setf find-class-predicate)
+ (new-value symbol)
(if (legal-class-name-p symbol)
- (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
- (error "~S is not a legal class name." symbol)))
+ (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
+ (error "~S is not a legal class name." symbol)))
(defun find-wrapper (symbol)
(class-wrapper (find-class symbol)))
(defmacro function-apply (form &rest args)
`(apply (the function ,form) ,@args))
\f
-;;;; various nastiness to work around nonstandardness of SETF when PCL
-;;;; was written
-
-;;; Convert a function name to its standard SETF function name. We
-;;; have to do this hack because not all Common Lisps have yet
-;;; converted to having SETF function specs.
-;;;
-;;; KLUDGE: We probably don't have to do this any more. But in Debian
-;;; cmucl 2.4.8 the :SETF feature isn't set (?). Perhaps it's because of
-;;; the comment ca. 10 lines down about how the built-in setf mechanism
-;;; takes a hash table lookup each time? It would be nice to go one
-;;; way or another on this, perhaps some benchmarking would be in order..
-;;; (Oh, more info: In debian src/pcl/notes.text, which looks like stale
-;;; documentation from 1992, it says TO DO: When CMU CL improves its
-;;; SETF handling, remove the comment in macros.lisp beginning the line
-;;; #+CMU (PUSHNEW :SETF *FEATURES*). So since CMU CL's (and now SBCL's)
-;;; SETF handling seems OK to me these days, there's a fairly decent chance
-;;; this would work.) -- WHN 19991203
-;;;
-;;; In a port that does have SETF function specs you can use those just by
-;;; making the obvious simple changes to these functions. The rest of PCL
-;;; believes that there are function names like (SETF <foo>), this is the
-;;; only place that knows about this hack.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-; In 15e (and also 16c), using the built-in SETF mechanism costs
-; a hash table lookup every time a SETF function is called.
-; Uncomment the next line to use the built in SETF mechanism.
-;#+cmu (pushnew :setf *features*)
-) ; EVAL-WHEN
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-#-setf
-(defvar *setf-function-names* (make-hash-table :size 200 :test 'eq))
(defun get-setf-function-name (name)
- #+setf `(setf ,name)
- #-setf
- (or (gethash name *setf-function-names*)
- (setf (gethash name *setf-function-names*)
- (let ((pkg (symbol-package name)))
- (if pkg
- (intern (format nil
- "SETF ~A ~A"
- (package-name pkg)
- (symbol-name name))
- *pcl-package*)
- (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
-
-;;; Call this to define a setf macro for a function with the same behavior as
-;;; specified by the SETF function cleanup proposal. Specifically, this will
-;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
-;;;
-;;; do-standard-defsetf A macro interface for use at top level
-;;; in files. Unfortunately, users may
-;;; have to use this for a while.
-;;;
-;;; do-standard-defsetfs-for-defclass A special version called by defclass.
-;;;
-;;; do-standard-defsetf-1 A functional interface called by the
-;;; above, defmethod and defgeneric.
-;;; Since this is all a crock anyways,
-;;; users are free to call this as well.
-;;;
-;;; FIXME: Once we fix up SETF, a lot of stuff around here should evaporate.
-(defmacro do-standard-defsetf (&rest function-names)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
-
-(defun do-standard-defsetfs-for-defclass (accessors)
- (dolist (name accessors) (do-standard-defsetf-1 name)))
-
-(defun do-standard-defsetf-1 (function-name)
- #+setf
- (declare (ignore function-name))
- #+setf nil
- #-setf
- (unless (and (setfboundp function-name)
- (get function-name 'standard-setf))
- (setf (get function-name 'standard-setf) t)
- (let* ((setf-function-name (get-setf-function-name function-name)))
- (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
- (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
- (vars (mapcar #'car bindings)))
- `(let ,bindings
- (,',setf-function-name ,new-value ,@vars))))))))
-
-(defun setfboundp (symbol)
- (fboundp `(setf ,symbol)))
-
-) ; EVAL-WHEN
-
-;;; PCL, like user code, must endure the fact that we don't have a
-;;; properly working SETF. Many things work because they get mentioned
-;;; by a DEFCLASS or DEFMETHOD before they are used, but others have
-;;; to be done by hand.
-;;;
-;;; FIXME: We don't have to do this stuff any more, do we?
-(do-standard-defsetf
- class-wrapper ;***
- generic-function-name
- method-function-plist
- method-function-get
- plist-value
- object-plist
- gdefinition
- slot-value-using-class)
+ `(setf ,name))
(defsetf slot-value set-slot-value)
(cond ((or (null (fboundp generic-function-name))
(not (generic-function-p
(setq generic-function
- (symbol-function generic-function-name)))))
+ (name-get-fdefinition generic-function-name)))))
(error "~S does not name a generic function."
generic-function-name))
((null (setq method (get-method generic-function
lambda-list
&rest other-initargs)
(unless (and (fboundp generic-function-name)
- (typep (symbol-function generic-function-name)
+ (typep (name-get-fdefinition generic-function-name)
'generic-function))
(sb-kernel::style-warn "implicitly creating new generic function ~S"
generic-function-name))
(etypecase index
(fixnum (if fsc-p
#'(lambda (instance)
- (let ((value (%instance-ref (fsc-instance-slots instance) index)))
+ (let ((value (instance-ref (fsc-instance-slots instance) index)))
(if (eq value +slot-unbound+)
(slot-unbound (class-of instance) instance slot-name)
value)))
#'(lambda (instance)
- (let ((value (%instance-ref (std-instance-slots instance) index)))
+ (let ((value (instance-ref (std-instance-slots instance) index)))
(if (eq value +slot-unbound+)
(slot-unbound (class-of instance) instance slot-name)
value)))))
(etypecase index
(fixnum (if fsc-p
#'(lambda (nv instance)
- (setf (%instance-ref (fsc-instance-slots instance) index) nv))
+ (setf (instance-ref (fsc-instance-slots instance) index) nv))
#'(lambda (nv instance)
- (setf (%instance-ref (std-instance-slots instance) index) nv))))
+ (setf (instance-ref (std-instance-slots instance) index) nv))))
(cons #'(lambda (nv instance)
(declare (ignore instance))
(setf (cdr index) nv))))
(etypecase index
(fixnum (if fsc-p
#'(lambda (instance)
- (not (eq (%instance-ref (fsc-instance-slots instance)
+ (not (eq (instance-ref (fsc-instance-slots instance)
index)
+slot-unbound+)))
#'(lambda (instance)
- (not (eq (%instance-ref (std-instance-slots instance)
+ (not (eq (instance-ref (std-instance-slots instance)
index)
+slot-unbound+)))))
(cons #'(lambda (instance)
#'(lambda (class instance slotd)
(declare (ignore slotd))
(unless (fsc-instance-p instance) (error "not fsc"))
- (let ((value (%instance-ref (fsc-instance-slots instance) index)))
+ (let ((value (instance-ref (fsc-instance-slots instance) index)))
(if (eq value +slot-unbound+)
(slot-unbound class instance slot-name)
value)))
#'(lambda (class instance slotd)
(declare (ignore slotd))
(unless (std-instance-p instance) (error "not std"))
- (let ((value (%instance-ref (std-instance-slots instance) index)))
+ (let ((value (instance-ref (std-instance-slots instance) index)))
(if (eq value +slot-unbound+)
(slot-unbound class instance slot-name)
value)))))
(fixnum (if fsc-p
#'(lambda (nv class instance slotd)
(declare (ignore class slotd))
- (setf (%instance-ref (fsc-instance-slots instance) index) nv))
+ (setf (instance-ref (fsc-instance-slots instance) index) nv))
#'(lambda (nv class instance slotd)
(declare (ignore class slotd))
- (setf (%instance-ref (std-instance-slots instance) index) nv))))
+ (setf (instance-ref (std-instance-slots instance) index) nv))))
(cons #'(lambda (nv class instance slotd)
(declare (ignore class instance slotd))
(setf (cdr index) nv)))))
(fixnum (if fsc-p
#'(lambda (class instance slotd)
(declare (ignore class slotd))
- (not (eq (%instance-ref (fsc-instance-slots instance)
+ (not (eq (instance-ref (fsc-instance-slots instance)
index)
+slot-unbound+ )))
#'(lambda (class instance slotd)
(declare (ignore class slotd))
- (not (eq (%instance-ref (std-instance-slots instance)
+ (not (eq (instance-ref (std-instance-slots instance)
index)
+slot-unbound+ )))))
(cons #'(lambda (class instance slotd)
(assq slot-name (wrapper-class-slots wrapper)))))
(typecase index
(fixnum
- (let ((value (%instance-ref (get-slots instance) index)))
+ (let ((value (instance-ref (get-slots instance) index)))
(if (eq value +slot-unbound+)
(slot-unbound (class-of instance) instance slot-name)
value)))
(error "unrecognized instance type"))))
(defun swap-wrappers-and-slots (i1 i2)
- (without-interrupts
+ (sb-sys:without-interrupts
(cond ((std-instance-p i1)
(let ((w1 (std-instance-wrapper i1))
(s1 (std-instance-slots i1)))
default))
\f
(defun standard-instance-access (instance location)
- (%instance-ref (std-instance-slots instance) location))
+ (instance-ref (std-instance-slots instance) location))
(defun funcallable-standard-instance-access (instance location)
- (%instance-ref (fsc-instance-slots instance) location))
+ (instance-ref (fsc-instance-slots instance) location))
(defmethod slot-value-using-class ((class std-class)
(object std-object)
(unless (eq t (wrapper-state (std-instance-wrapper
object)))
(check-wrapper-validity object))
- (%instance-ref (std-instance-slots object) location))
+ (instance-ref (std-instance-slots object) location))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper
object)))
(check-wrapper-validity object))
- (%instance-ref (fsc-instance-slots object) location))
+ (instance-ref (fsc-instance-slots object) location))
(t (error "unrecognized instance type"))))
(cons
(cdr location))
(cond ((std-instance-p object)
(unless (eq t (wrapper-state (std-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (%instance-ref (std-instance-slots object) location)
- new-value))
+ (setf (instance-ref (std-instance-slots object) location)
+ new-value))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (%instance-ref (fsc-instance-slots object) location)
- new-value))
+ (setf (instance-ref (fsc-instance-slots object) location)
+ new-value))
(t (error "unrecognized instance type"))))
(cons
(setf (cdr location) new-value))
(unless (eq t (wrapper-state (std-instance-wrapper
object)))
(check-wrapper-validity object))
- (%instance-ref (std-instance-slots object) location))
+ (instance-ref (std-instance-slots object) location))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper
object)))
(check-wrapper-validity object))
- (%instance-ref (fsc-instance-slots object) location))
+ (instance-ref (fsc-instance-slots object) location))
(t (error "unrecognized instance type"))))
(cons
(cdr location))
(cond ((std-instance-p object)
(unless (eq t (wrapper-state (std-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (%instance-ref (std-instance-slots object) location)
- +slot-unbound+))
+ (setf (instance-ref (std-instance-slots object) location)
+ +slot-unbound+))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (%instance-ref (fsc-instance-slots object) location)
- +slot-unbound+))
+ (setf (instance-ref (fsc-instance-slots object) location)
+ +slot-unbound+))
(t (error "unrecognized instance type"))))
(cons
(setf (cdr location) +slot-unbound+))
(declare (ignore slot-names))
(setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
\f
-(defun real-load-defclass (name metaclass-name supers slots other accessors)
- (do-standard-defsetfs-for-defclass accessors) ;***
+(defun real-load-defclass (name metaclass-name supers slots other)
(let ((res (apply #'ensure-class name :metaclass metaclass-name
:direct-superclasses supers
:direct-slots slots
`(progn
,defstruct
,@readers-init ,@writers-init
- (declare-structure ',name nil nil))))
+ (cons nil nil))))
(unless (structure-type-p name) (eval defstruct-form))
(mapc #'(lambda (dslotd reader-name writer-name)
(let* ((reader (gdefinition reader-name))
(wrapper-instance-slots-layout owrapper))
(setf (wrapper-class-slots nwrapper)
(wrapper-class-slots owrapper))
- (without-interrupts
+ (sb-sys:without-interrupts
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(invalidate-wrapper owrapper ':flush nwrapper))))))
(wrapper-instance-slots-layout owrapper))
(setf (wrapper-class-slots nwrapper)
(wrapper-class-slots owrapper))
- (without-interrupts
+ (sb-sys:without-interrupts
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(invalidate-wrapper owrapper ':obsolete nwrapper)
(unless (extract-required-parameters (second constructor))
(setf (slot-value class 'defstruct-constructor) (car constructor)))
(when (and defstruct-predicate (not from-defclass-p))
- (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
+ (name-set-fdefinition pred-name (symbol-function defstruct-predicate)))
(unless (or from-defclass-p (slot-value class 'documentation))
(setf (slot-value class 'documentation)
(format nil "~S structure class made from Defstruct" name)))
(let ((,index (pvref ,pv ,pv-offset)))
(setq ,value (typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (%instance-ref ,slots ,index))))
+ `((fixnum (instance-ref ,slots ,index))))
,@(when (or (null type) (eq type ':class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
+ `((fixnum (setf (instance-ref ,slots ,index)
+ ,new-value))))
,@(when (or (null type) (eq type ':class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (not (eq (%instance-ref ,slots ,index)
- +slot-unbound+)))))
+ `((fixnum (not (and ,slots
+ (eq (instance-ref ,slots ,index)
+ +slot-unbound+))))))
,@(when (or (null type) (eq type ':class))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default)))))))
(defun get-walker-template (x)
(cond ((symbolp x)
- (or (get-walker-template-internal x)
- (get-implementation-dependent-walker-template x)))
+ (get-walker-template-internal x))
((and (listp x) (eq (car x) 'lambda))
'(lambda repeat (eval)))
(t
(error "can't get template for ~S" x))))
-;;; FIXME: This can go away in SBCL.
-(defun get-implementation-dependent-walker-template (x)
- (declare (ignore x))
- ())
\f
;;;; the actual templates
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.10.18"
+"0.6.10.19"
projects / sbcl.git / commitdiff