X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=5943a8db63033eda17475a789701e6ffb663b987;hb=0b5610d8a220a4b20cbeac958953ca4d67c00038;hp=1daa52f33d6abda034782e7700f167e7be59260c;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 1daa52f..5943a8d 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -23,28 +23,20 @@ (in-package "SB-PCL") -(eval-when (:compile-toplevel :load-toplevel :execute) - -;;; FIXME: These are non-ANSI hacks which it would be nice to get rid of. -(defvar *defclass-times* '(:load-toplevel :execute)) ; You probably have - ; to change this if you use - ; DEFCONSTRUCTOR. -(defvar *defmethod-times* '(:load-toplevel :execute)) -(defvar *defgeneric-times* '(:load-toplevel :execute)) - -) ; EVAL-WHEN - -(eval-when (:load-toplevel :execute) - (when (eq *boot-state* 'complete) - (error "Trying to load (or compile) PCL in an environment in which it~%~ - has already been loaded. This doesn't work, you will have to~%~ - get a fresh lisp (reboot) and then load PCL.")) - (when *boot-state* - (cerror "Try loading (or compiling) PCL anyways." - "Trying to load (or compile) PCL in an environment in which it~%~ - has already been partially loaded. This may not work, you may~%~ - need to get a fresh lisp (reboot) and then load PCL.")) - ) ; EVAL-WHEN +;;; (These are left over from the days when PCL was an add-on package +;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal +;;; build, of course, but they might happen if someone is experimenting +;;; and debugging, and it's probably worth complaining if they do, +;;; so we've left 'em in.) +(when (eq *boot-state* 'complete) + (error "Trying to load (or compile) PCL in an environment in which it~%~ + has already been loaded. This doesn't work, you will have to~%~ + get a fresh lisp (reboot) and then load PCL.")) +(when *boot-state* + (cerror "Try loading (or compiling) PCL anyways." + "Trying to load (or compile) PCL in an environment in which it~%~ + has already been partially loaded. This may not work, you may~%~ + need to get a fresh lisp (reboot) and then load PCL.")) ;;; comments from CMU CL version of PCL: ;;; This is like fdefinition on the Lispm. If Common Lisp had @@ -58,31 +50,14 @@ ;;; which has a 'real' function spec mechanism can use that instead ;;; and in that way get rid of setf generic function names. (defmacro parse-gspec (spec - (non-setf-var . non-setf-case) - (setf-var . setf-case)) - #+setf (declare (ignore setf-var setf-case)) - (once-only (spec) - `(cond (#-setf (symbolp ,spec) #+setf t - (let ((,non-setf-var ,spec)) ,@non-setf-case)) - #-setf - ((and (listp ,spec) - (eq (car ,spec) 'setf) - (symbolp (cadr ,spec))) - (let ((,setf-var (cadr ,spec))) ,@setf-case)) - #-setf - (t - (error - "Can't understand ~S as a generic function specifier.~%~ - It must be either a symbol which can name a function or~%~ - a list like ~S, where the car is the symbol ~S and the cadr~%~ - is a symbol which can name a generic function." - ,spec '(setf ) 'setf))))) + (non-setf-var . non-setf-case)) + `(let ((,non-setf-var ,spec)) ,@non-setf-case)) ;;; If symbol names a function which is traced or advised, return the ;;; unadvised, traced etc. definition. This lets me get at the generic ;;; function object even when it is traced. (defun unencapsulated-fdefinition (symbol) - (symbol-function symbol)) + (fdefinition symbol)) ;;; If symbol names a function which is traced or advised, redefine ;;; the `real' definition without affecting the advise. @@ -91,29 +66,23 @@ (sb-c::%%defun name new-definition nil) (sb-c::note-name-defined name :function) new-definition) - (setf (symbol-function name) new-definition)) + (setf (fdefinition name) new-definition)) (defun gboundp (spec) (parse-gspec spec - (name (fboundp name)) - (name (fboundp (get-setf-function-name name))))) + (name (fboundp name)))) (defun gmakunbound (spec) (parse-gspec spec - (name (fmakunbound name)) - (name (fmakunbound (get-setf-function-name name))))) + (name (fmakunbound name)))) (defun gdefinition (spec) (parse-gspec spec - (name (or #-setf (macro-function name) ;?? - (unencapsulated-fdefinition name))) - (name (unencapsulated-fdefinition (get-setf-function-name name))))) + (name (unencapsulated-fdefinition name)))) -(defun #-setf SETF\ SB-PCL\ GDEFINITION #+setf (setf gdefinition) (new-value - spec) +(defun (setf gdefinition) (new-value spec) (parse-gspec spec - (name (fdefine-carefully name new-value)) - (name (fdefine-carefully (get-setf-function-name name) new-value)))) + (name (fdefine-carefully name new-value)))) (declaim (special *the-class-t* *the-class-vector* *the-class-symbol* @@ -187,8 +156,8 @@ ;;; interface (defun type-from-specializer (specl) - (cond ((eq specl 't) - 't) + (cond ((eq specl t) + t) ((consp specl) (unless (member (car specl) '(class prototype class-eq eql)) (error "~S is not a legal specializer type." specl)) @@ -207,7 +176,7 @@ (declare (special *the-class-t*)) (setq type (type-from-specializer type)) (if (atom type) - (if (eq type 't) + (if (eq type t) *the-class-t* (error "bad argument to type-class")) (case (car type) @@ -424,9 +393,7 @@ (defun plist-value (object name) (getf (object-plist object) name)) -(defun #-setf SETF\ SB-PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value - object - name) +(defun (setf plist-value) (new-value object name) (if new-value (setf (getf (object-plist object) name) new-value) (progn @@ -489,25 +456,25 @@ ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set ;;; SB-PCL:*BUILT-IN-CLASSES*. -(sb-int:/show "about to set up SB-PCL::*BUILT-IN-CLASSES*") +(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*") (defvar *built-in-classes* (labels ((direct-supers (class) - (sb-int:/show "entering DIRECT-SUPERS" (sb-kernel::class-name class)) + (/show "entering DIRECT-SUPERS" (sb-kernel::class-name class)) (if (typep class 'cl:built-in-class) (sb-kernel:built-in-class-direct-superclasses class) (let ((inherits (sb-kernel:layout-inherits (sb-kernel:class-layout class)))) - (sb-int:/show inherits) + (/show inherits) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) - (sb-int:/show "entering DIRECT-SUBS" (sb-kernel::class-name class)) - (sb-int:collect ((res)) + (/show "entering DIRECT-SUBS" (sb-kernel::class-name class)) + (collect ((res)) (let ((subs (sb-kernel:class-subclasses class))) - (sb-int:/show subs) + (/show subs) (when subs - (sb-int:dohash (sub v subs) + (dohash (sub v subs) (declare (ignore v)) - (sb-int:/show sub) + (/show sub) (when (member class (direct-supers sub)) (res sub))))) (res))) @@ -535,10 +502,10 @@ ;; relevant cases. 42)))) (mapcar (lambda (kernel-bic-entry) - (sb-int:/show "setting up" kernel-bic-entry) + (/show "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) (class (cl:find-class name))) - (sb-int:/show name class) + (/show name class) `(,name ,(mapcar #'cl:class-name (direct-supers class)) ,(mapcar #'cl:class-name (direct-subs class)) @@ -558,7 +525,7 @@ sb-kernel:funcallable-instance function stream))) sb-kernel::*built-in-classes*)))) -(sb-int:/show "done setting up SB-PCL::*BUILT-IN-CLASSES*") +(/show "done setting up SB-PCL::*BUILT-IN-CLASSES*") ;;;; the classes that define the kernel of the metabraid @@ -584,7 +551,8 @@ (:metaclass structure-class)) (defstruct (dead-beef-structure-object - (:constructor |STRUCTURE-OBJECT class constructor|))) + (:constructor |STRUCTURE-OBJECT class constructor|) + (:copier nil))) (defclass std-object (slot-object) () (:metaclass std-class))