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 (file)
--- 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.
 
   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
 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,
 
   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:
 
 26:
   reported by Sam Steingold on the cmucl-imp mailing list 12 May 2000:
 

diff --git a/NEWS b/NEWS
index dc3063e..92c8ae4 100644 (file)
--- 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:
   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, 
 * 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 (file)
--- 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..
              "*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"
             "%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"
                    "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"
     :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 (file)
--- 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.
               (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 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1873,8 +1873,8 @@
   |#
   ;; old code
   (reduce #'type-union
   |#
   ;; 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
 
 \f
 ;;;; CONS types
 

diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp
index ac79fe5..e2c7635 100644 (file)
--- 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/iterate"
                "src/pcl/early-low"
                "src/pcl/macros"

+                "src/pcl/compiler-support"

                "src/pcl/low"
                "src/pcl/fin"
                "src/pcl/defclass"
                "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 (file)
--- 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.
 ;;; 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)
 (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)))
 (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
 ) ; 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)
   (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)
   (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))
       `(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)))))
 
         ,@(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)
          (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
   (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)
                         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))
   (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)))))
                                        ;; 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
            (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)))
                      #',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))
          `(list ,@(mapcar #'(lambda (specializer)
                               (if (consp specializer)
                                   ``(,',(car specializer)
                                      ,,(cadr specializer))
                                   `',specializer))

-                   specializers))
+                           specializers))

          unspecialized-lambda-list method-class-name
          initargs-form
          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
 
 (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))))
                                      (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))
               (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)))
               `(((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)
                    (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))))
                  (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.
           #||
           ,@(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+)))))))
           ||#
                                   .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))
     (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))
              (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.")
           (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))))
 
     (function
      (apply emf args))))
 

@@ -1116,24 +1094,16 @@ bootstrapping.
                                (setq closurep t)
                                form)
                               (t nil))))
                                (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)))
                         (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)
                   ((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*)
 
          *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*)
     (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 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))
 
     (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)
 
 (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))))
   (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)
 (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))
   (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))
   (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
           (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"
                                     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))
                                  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
           (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)
           (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)
 
     (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)
 
     (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))
                                         (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
                                         (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,~%~
             ;; "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
                   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 (file)
--- 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)
   `(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)
     (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)))
      (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*)))
 ;;; 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))
       (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*)))
 
 (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")
       (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)
 (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)
     (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))
                             &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))
     (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 (file)
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")
+\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>"))))

diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp
index b711ac6..bb1a24c 100644 (file)
--- 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))
        ;;   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)
 
 (defun load-constructor (class-name metaclass-name constructor-name
                         supplied-initarg-names code-generators)

@@ -632,23 +630,23 @@
                        (.initargs. .constant-initargs.))
                   .positions.
 
                        (.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)
 
                   ,@(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.))
                         (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.)
                                               .value.)))))))
 
                   (dolist (fn .shared-initfns.)

@@ -786,7 +784,7 @@
                   (dolist (entry .initfns-and-positions.)
                     (let ((val (funcall (car entry))))
                       (dolist (pos (cdr entry))
                   (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
 
                   ,@(gathering1 (collecting)
                       (doplist (initarg value) supplied-initargs

@@ -794,7 +792,7 @@
                           (gather1
                             `(let ((.value. ,value))
                                (dolist (.p. (pop .positions.))
                           (gather1
                             `(let ((.value. ,value))
                                (dolist (.p. (pop .positions.))

-                                 (setf (%instance-ref .slots. .p.) .value.)))))))
+                                 (setf (instance-ref .slots. .p.) .value.)))))))

 
                   .instance.))))))))
 
 
                   .instance.))))))))
 

@@ -916,8 +914,8 @@
                             (gather1
                               `(let ((.value. ,value))
                                  (dolist (.p. (pop .positions.))
                             (gather1
                               `(let ((.value. ,value))
                                  (dolist (.p. (pop .positions.))

-                                   (setf (%instance-ref .slots. .p.)
-                                         .value.)))))))
+                                   (setf (instance-ref .slots. .p.)
+                                            .value.)))))))

 
                     .instance.))))))))))
 
 
                     .instance.))))))))))
 

@@ -999,4 +997,3 @@
                 (bail-out)))))
 
       (values constants (nreverse supplied-initarg-positions)))))
                 (bail-out)))))
 
       (values constants (nreverse supplied-initarg-positions)))))

-

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 2d1476b..022f979 100644 (file)
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -23,27 +23,6 @@
 
 (in-package "SB-PCL")
 \f
 
 (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))
 
 (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.
   ;; 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))
   (setq supers  (copy-tree supers)
        slots   (copy-tree slots)
        options (copy-tree options))

@@ -95,10 +74,9 @@
            (return t))))
 
     (let ((*initfunctions* ())
            (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))
       (let ((canonical-slots
              (mapcar #'(lambda (spec)
                          (canonicalize-slot-specification name spec))

@@ -112,29 +90,24 @@
                                (and mclass
                                     (*subtypep mclass
                                                *the-class-structure-class*))))))
                                (and mclass
                                     (*subtypep mclass
                                                *the-class-structure-class*))))))

-       (do-standard-defsetfs-for-defclass *accessors*)

        (let ((defclass-form
        (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..
          (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
                   ,(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)))))))
 
                  (inform-type-system-about-std-class name))
                defclass-form)))))))
 

@@ -168,7 +140,7 @@
           (cadr entry)))))
 
 (defun canonicalize-slot-specification (class-name spec)
           (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))))
   (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
                (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))
                          (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)))
 (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 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))
   (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
   (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 (file)
--- 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)))
           (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*)
 
 (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-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))
 
 
 (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 (file)
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -23,16 +23,6 @@
 
 (in-package "SB-PCL")
 \f
 
 (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)
 
 (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
 ;;;   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)
 
 ;;; 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.
 
 ;;; 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)
     (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
 
 (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
 
 (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
 
 (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
   (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*
 \f
 (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 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
   (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 (file)
--- 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*)
   (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)
        (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
                         (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.
 \f
 ;;; 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 (file)
--- a/src/pcl/dlisp.lisp
+++ b/src/pcl/dlisp.lisp
@@ -106,7 +106,7 @@
                          ,form)))))
     (values (if *precompiling-lap*
                `#',lambda
                          ,form)))))
     (values (if *precompiling-lap*
                `#',lambda

-               (compile-lambda lambda))
+               (compile nil lambda))

            nil)))
 
 ;;; note on implementation for CMU 17 and later (including SBCL):
            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)
 (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))
 
 (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)
         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))
     (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)
 
 (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 (file)
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -103,9 +103,9 @@
 
 (defun trace-method-internal (ofunction name options)
   (eval `(untrace ,name))
 
 (defun trace-method-internal (ofunction name options)
   (eval `(untrace ,name))

-  (setf (symbol-function name) ofunction)
+  (name-set-fdefinition name ofunction)

   (eval `(trace ,name ,@options))
   (eval `(trace ,name ,@options))

-  (symbol-function name))
+  (name-get-fdefinition name))

 |#
 \f
 ;;;; MAKE-LOAD-FORM
 |#
 \f
 ;;;; MAKE-LOAD-FORM

diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp
index 45303b4..85400fe 100644 (file)
--- 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))
                        (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))))
            (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)
                               :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)
 
 (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
                                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
                 (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
                           ,(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)
                            (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
   (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
                   ;; 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 (file)
--- a/src/pcl/fngen.lisp
+++ b/src/pcl/fngen.lisp
@@ -24,7 +24,7 @@
 (in-package "SB-PCL")
 \f
 ;;; GET-FUNCTION is the main user interface to this code. It is like
 (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
 ;;; 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.
 ;;;
 ;;;   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-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)
 (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)))
           (fgen (make-fgen test gensyms generator generator-lambda nil)))
       (store-fgen fgen)
       generator)))

@@ -176,22 +173,19 @@
                                           f)))))))))
 \f
 (defmacro precompile-function-generators (&optional system)
                                           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)))
 
 (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 (file)
--- 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)
   t)
 
 (defmethod pcl-close ((stream fundamental-stream) &key abort)

+  (declare (ignore abort))

   (setf (stream-open-p stream) nil)
   t)
 
   (setf (stream-open-p stream) nil)
   t)
 

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index e1c976b..1de5266 100644 (file)
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -41,66 +41,19 @@
 (defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
 ) ; EVAL-WHEN
 
 (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
 (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))
 
 (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))
 ;;; 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)))
 \f
 (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
 ;;;
 
 ;;; SET-FUNCTION-NAME
 ;;;

@@ -216,36 +162,6 @@
                   (format nil "~S" name))
                 *pcl-package*))))
 \f
                   (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
 ;;; 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)
 \f
 
 (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))
 ;;; 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)))))
 \f
 ;;;; structure-instance stuff
           (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)
 ;;; 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))
 
 (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>"))))

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index 5de7562..4025d9b 100644 (file)
--- 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))
 
          ;; 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)
 ;;; 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))
 
                    (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)
 ;;; 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))
 
                          (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)
   (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)
                  (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))
          (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)))
 
        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)
   (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)))
 
 (defun find-wrapper (symbol)
   (class-wrapper (find-class symbol)))

@@ -341,112 +292,8 @@
 (defmacro function-apply (form &rest args)
   `(apply (the function ,form) ,@args))
 \f
 (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)
 
 (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)
 
 (defsetf slot-value set-slot-value)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 4fe14b3..807b45b 100644 (file)
--- 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
     (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
           (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)
                              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))
                      '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 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -141,12 +141,12 @@
    (etypecase index
      (fixnum (if fsc-p
                 #'(lambda (instance)
    (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)
                       (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)))))
                       (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)
    (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)
                 #'(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))))
      (cons   #'(lambda (nv instance)
                 (declare (ignore instance))
                 (setf (cdr index) nv))))

@@ -177,11 +177,11 @@
    (etypecase index
      (fixnum (if fsc-p
                 #'(lambda (instance)
    (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)
                                             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)
                                             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"))
                #'(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"))
                      (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)))))
                      (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))
     (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))
                #'(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)))))
     (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))
     (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))
                                            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)
                                            index)
                             +slot-unbound+ )))))
     (cons   #'(lambda (class instance slotd)

@@ -317,7 +317,7 @@
                                    (assq slot-name (wrapper-class-slots wrapper)))))
                    (typecase index
                      (fixnum   
                                    (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)))
                         (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 (file)
--- 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)
         (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)))
    (cond ((std-instance-p i1)
          (let ((w1 (std-instance-wrapper i1))
                (s1 (std-instance-slots i1)))

@@ -181,10 +181,10 @@
       default))
 \f
 (defun standard-instance-access (instance location)
       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)
 
 (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)
 
 (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))
                          (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))
                         ((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))
                         (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))
        (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))
             ((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))
             (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))
                          (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))
                         ((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))
                         (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))
        (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))
             ((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+))
             (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 (file)
--- 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))))
 \f
   (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
   (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
               `(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))
        (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))
              (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))))))
          (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))
            (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)
        (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 (file)
--- 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))
     (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)))
     (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 (file)
--- 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))
          (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+)))
                           ,@(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))
          (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)))))))
              ,@(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))
          (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)))))))
              ,@(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 (file)
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -309,17 +309,12 @@
 
 (defun get-walker-template (x)
   (cond ((symbolp x)
 
 (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))))
 
        ((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
 
 \f
 ;;;; the actual templates
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 4149a54..c4d0b34 100644 (file)
--- 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.
 
 ;;; 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"