From: William Harold Newman Date: Thu, 22 Feb 2001 13:44:56 +0000 (+0000) Subject: 0.6.10.19: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git 0.6.10.19: 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) --- diff --git a/BUGS b/BUGS index eb72b94..8a88aeb 100644 --- a/BUGS +++ b/BUGS @@ -92,12 +92,6 @@ WORKAROUND: 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 @@ -245,35 +239,6 @@ WORKAROUND: 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 - -# - 26: reported by Sam Steingold on the cmucl-imp mailing list 12 May 2000: diff --git a/NEWS b/NEWS index dc3063e..92c8ae4 100644 --- a/NEWS +++ b/NEWS @@ -642,6 +642,8 @@ changes in sbcl-0.6.10 relative to sbcl-0.6.9: 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, diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 5f7a98c..9183236 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -674,7 +674,7 @@ retained, possibly temporariliy, because it might be used internally." "*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" @@ -1292,7 +1292,8 @@ definitely not guaranteed to be present in later versions of SBCL." "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" diff --git a/src/code/boot-extensions.lisp b/src/code/boot-extensions.lisp index 5f0ae6a..45de9a0 100644 --- a/src/code/boot-extensions.lisp +++ b/src/code/boot-extensions.lisp @@ -228,3 +228,17 @@ (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))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 1cfe57e..4e9190a 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1873,8 +1873,8 @@ |# ;; old code (reduce #'type-union - (mapcar #'specifier-type type-specifiers) - :initial-value *empty-type*)) + (mapcar #'specifier-type type-specifiers) + :initial-value *empty-type*)) ;;;; CONS types diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index ac79fe5..e2c7635 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -159,6 +159,7 @@ "src/pcl/iterate" "src/pcl/early-low" "src/pcl/macros" + "src/pcl/compiler-support" "src/pcl/low" "src/pcl/fin" "src/pcl/defclass" diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index eaa6513..c698023 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -105,25 +105,16 @@ bootstrapping. ;;; 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 @@ -172,8 +163,6 @@ bootstrapping. (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) @@ -223,10 +212,7 @@ bootstrapping. `(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))))) @@ -239,8 +225,6 @@ bootstrapping. (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 @@ -311,8 +295,6 @@ bootstrapping. 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)) @@ -405,7 +387,7 @@ bootstrapping. ;; 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 @@ -415,20 +397,17 @@ bootstrapping. #',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 @@ -624,15 +603,12 @@ bootstrapping. (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)) @@ -841,7 +817,7 @@ bootstrapping. `(((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) @@ -851,15 +827,15 @@ bootstrapping. (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+))))))) ||# @@ -911,20 +887,22 @@ bootstrapping. (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)))) @@ -1116,24 +1094,16 @@ bootstrapping. (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) @@ -1186,8 +1156,7 @@ bootstrapping. *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*) @@ -1202,8 +1171,7 @@ bootstrapping. (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)) @@ -1221,7 +1189,6 @@ bootstrapping. (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)))) @@ -1233,20 +1200,16 @@ bootstrapping. (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" @@ -1371,14 +1334,14 @@ bootstrapping. 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) @@ -2046,7 +2009,7 @@ bootstrapping. (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) @@ -2057,7 +2020,7 @@ bootstrapping. (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 @@ -2194,8 +2157,7 @@ bootstrapping. ;; "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 diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index d40141f..6c2c45f 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -115,13 +115,13 @@ `(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))) @@ -175,7 +175,7 @@ ;;; 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)) @@ -189,7 +189,7 @@ (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") @@ -510,7 +510,8 @@ (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) @@ -534,7 +535,8 @@ &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)) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp new file mode 100644 index 0000000..41951e0 --- /dev/null +++ b/src/pcl/compiler-support.lisp @@ -0,0 +1,56 @@ +;;;; 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") + +;;;; 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 "")))) diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp index b711ac6..bb1a24c 100644 --- a/src/pcl/construct.lisp +++ b/src/pcl/construct.lisp @@ -126,26 +126,24 @@ ;; 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) @@ -632,23 +630,23 @@ (.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.) @@ -786,7 +784,7 @@ (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 @@ -794,7 +792,7 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) .value.))))))) + (setf (instance-ref .slots. .p.) .value.))))))) .instance.)))))))) @@ -916,8 +914,8 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) - .value.))))))) + (setf (instance-ref .slots. .p.) + .value.))))))) .instance.)))))))))) @@ -999,4 +997,3 @@ (bail-out))))) (values constants (nreverse supplied-initarg-positions))))) - diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 2d1476b..022f979 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -23,27 +23,6 @@ (in-package "SB-PCL") -;;; 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)) @@ -73,7 +52,7 @@ ;; 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)) @@ -95,10 +74,9 @@ (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)) @@ -112,29 +90,24 @@ (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.. @@ -142,8 +115,7 @@ ,(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))))))) @@ -168,7 +140,7 @@ (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)))) @@ -190,8 +162,7 @@ (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)) @@ -365,18 +336,16 @@ (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 diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 342f98f..ba355be 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -73,10 +73,8 @@ (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*) @@ -189,9 +187,7 @@ (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)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 1daa52f..dcaa9eb 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -23,16 +23,6 @@ (in-package "SB-PCL") -(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) @@ -58,31 +48,14 @@ ;;; 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 ) '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. @@ -91,29 +64,23 @@ (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)))) (declaim (special *the-class-t* *the-class-vector* *the-class-symbol* @@ -424,9 +391,7 @@ (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 diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 0879c32..95c2c3a 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -112,7 +112,7 @@ And so, we are saved. (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) @@ -161,15 +161,12 @@ And so, we are saved. (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))))))))))) ;;; When all the methods of a generic function are automatically generated ;;; reader or writer methods a number of special optimizations are possible. diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index da57d57..0f4d06b 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -106,7 +106,7 @@ ,form))))) (values (if *precompiling-lap* `#',lambda - (compile-lambda lambda)) + (compile nil lambda)) nil))) ;;; note on implementation for CMU 17 and later (including SBCL): @@ -163,7 +163,12 @@ (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)) @@ -172,10 +177,12 @@ 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) diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index dec5e0b..459f9a7 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -103,9 +103,9 @@ (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)) |# ;;;; MAKE-LOAD-FORM diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 45303b4..85400fe 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -692,7 +692,7 @@ (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)))) @@ -718,22 +718,18 @@ :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) @@ -830,7 +826,9 @@ 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 @@ -846,8 +844,9 @@ ,(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) @@ -911,7 +910,7 @@ (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 diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index cda7f43..08d8bdd 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -24,7 +24,7 @@ (in-package "SB-PCL") ;;; 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 @@ -44,9 +44,6 @@ ;;; 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) @@ -121,7 +118,7 @@ (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))) @@ -176,22 +173,19 @@ 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))) diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp index 8afe99d..f4b4076 100644 --- a/src/pcl/gray-streams.lisp +++ b/src/pcl/gray-streams.lisp @@ -55,6 +55,7 @@ t) (defmethod pcl-close ((stream fundamental-stream) &key abort) + (declare (ignore abort)) (setf (stream-open-p stream) nil) t) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index e1c976b..1de5266 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -41,66 +41,19 @@ (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)) -;;;; 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)) @@ -139,13 +92,6 @@ (defmacro std-instance-class (instance) `(wrapper-class* (std-instance-wrapper ,instance))) -;;;; 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 ;;; @@ -216,36 +162,6 @@ (format nil "~S" name)) *pcl-package*)))) -;;;; 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 @@ -264,26 +180,6 @@ (defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) -;;;; 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)) - ;;; This definition is for interpreted code. (defun pcl-instance-p (x) (typep (sb-kernel:layout-of x) 'wrapper)) @@ -328,11 +224,6 @@ (fsc-instance-slots ,n-inst))))) ;;;; 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) @@ -368,14 +259,3 @@ (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 "")))) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 5de7562..4025d9b 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -37,62 +37,26 @@ ;; 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 "'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 "'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) @@ -258,14 +222,7 @@ (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) @@ -273,7 +230,7 @@ (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)) @@ -283,17 +240,11 @@ 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))) @@ -341,112 +292,8 @@ (defmacro function-apply (form &rest args) `(apply (the function ,form) ,@args)) -;;;; 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 ), 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) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 4fe14b3..807b45b 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -291,7 +291,7 @@ (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 @@ -312,7 +312,7 @@ 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)) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 7fdd212..4129a81 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -141,12 +141,12 @@ (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))))) @@ -163,9 +163,9 @@ (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)))) @@ -177,11 +177,11 @@ (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) @@ -242,14 +242,14 @@ #'(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))))) @@ -268,10 +268,10 @@ (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))))) @@ -284,12 +284,12 @@ (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) @@ -317,7 +317,7 @@ (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))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 5d2e4de..27bc917 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -58,7 +58,7 @@ (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))) @@ -181,10 +181,10 @@ default)) (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) @@ -198,12 +198,12 @@ (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)) @@ -226,13 +226,13 @@ (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)) @@ -252,12 +252,12 @@ (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)) @@ -278,13 +278,13 @@ (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+)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 67c2c0d..ecbc785 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -308,8 +308,7 @@ (declare (ignore slot-names)) (setf (slot-value specl 'type) `(eql ,(specializer-object specl)))) -(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 @@ -546,7 +545,7 @@ `(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)) @@ -1000,7 +999,7 @@ (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)))))) @@ -1020,7 +1019,7 @@ (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) diff --git a/src/pcl/structure-class.lisp b/src/pcl/structure-class.lisp index ea9fd06..a861540 100644 --- a/src/pcl/structure-class.lisp +++ b/src/pcl/structure-class.lisp @@ -129,7 +129,7 @@ (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))) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index dbf5fa8..212a182 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -663,7 +663,7 @@ (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+))) @@ -697,7 +697,8 @@ (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))))))) @@ -743,8 +744,9 @@ (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))))))) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index ab7aef8..4b5691a 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -309,17 +309,12 @@ (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)) - ()) ;;;; the actual templates diff --git a/version.lisp-expr b/version.lisp-expr index 4149a54..c4d0b34 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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"