X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Flow.lisp;h=d59c7bbbe6ae7eaca9fdc21b8607d3ec35e4f3ab;hb=c713eb2b521b048ff2c927ec52b861787d289f85;hp=383d113426964533c418ec569f19893e32c663b5;hpb=e27303999070c06c788a0e1359ee4b0900186aa1;p=sbcl.git diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 383d113..d59c7bb 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -38,7 +38,8 @@ (in-package "SB-PCL") (eval-when (:compile-toplevel :load-toplevel :execute) -(defvar *optimize-speed* '(optimize (speed 3) (safety 0))) +(defvar *optimize-speed* + '(optimize (speed 3) (safety 0))) ) ; EVAL-WHEN (defmacro dotimes-fixnum ((var count &optional (result nil)) &body body) @@ -46,22 +47,53 @@ (declare (fixnum ,var)) ,@body)) +;;;; early definition of WRAPPER +;;;; +;;;; Most WRAPPER stuff is defined later, but the DEFSTRUCT itself +;;;; is here early so that things like (TYPEP .. 'WRAPPER) can be +;;;; compiled efficiently. + +;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or +;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but +;;; this shouldn't matter, since the only two slots that WRAPPER adds +;;; are meaningless in those cases. +(defstruct (wrapper + (:include sb-kernel:layout + ;; KLUDGE: In CMU CL, the initialization default + ;; for LAYOUT-INVALID was NIL. In SBCL, that has + ;; changed to :UNINITIALIZED, but PCL code might + ;; still expect NIL for the initialization + ;; default of WRAPPER-INVALID. Instead of trying + ;; to find out, I just overrode the LAYOUT + ;; default here. -- WHN 19991204 + (invalid nil)) + (:conc-name %wrapper-) + (:constructor make-wrapper-internal) + (:copier nil)) + (instance-slots-layout nil :type list) + (class-slots nil :type list)) +#-sb-fluid (declaim (sb-ext:freeze-type wrapper)) + ;;;; PCL's view of funcallable instances -(defstruct (pcl-funcallable-instance - (:alternate-metaclass sb-kernel:funcallable-instance - sb-kernel:random-pcl-class - sb-kernel:make-random-pcl-class) - (:type sb-kernel:funcallable-structure) - (:constructor allocate-funcallable-instance-1 ()) - (:copier nil) - (:conc-name nil)) - ;; Note: The PCL wrapper is in the layout slot. - - ;; PCL data vector. - (pcl-funcallable-instance-slots nil) - ;; The debug-name for this function. - (funcallable-instance-name nil)) +(sb-kernel:!defstruct-with-alternate-metaclass pcl-funcallable-instance + ;; KLUDGE: Note that neither of these slots is ever accessed by its + ;; accessor name as of sbcl-0.pre7.63. Presumably everything works + ;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30 + :slot-names (clos-slots name) + :boa-constructor %make-pcl-funcallable-instance + :superclass-name sb-kernel:funcallable-instance + :metaclass-name sb-kernel:random-pcl-class + :metaclass-constructor sb-kernel:make-random-pcl-class + :dd-type sb-kernel:funcallable-structure + ;; Only internal implementation code will access these, and these + ;; accesses (slot readers in particular) could easily be a + ;; bottleneck, so it seems reasonable to suppress runtime type + ;; checks. + ;; + ;; (Except note KLUDGE above that these accessors aren't used at all + ;; (!) as of sbcl-0.pre7.63, so for now it's academic.) + :runtime-type-checks-p nil) (import 'sb-kernel:funcallable-instance-p) @@ -78,10 +110,10 @@ ;;; portable to other implementations of Common Lisp, all the ;;; funcallable instance wrapper logic here can go away in favor ;;; of direct calls to native SBCL funcallable instance operations. -(defun set-funcallable-instance-function (fin new-value) +(defun set-funcallable-instance-fun (fin new-value) (declare (type function new-value)) (aver (funcallable-instance-p fin)) - (setf (sb-kernel:funcallable-instance-function fin) new-value)) + (setf (sb-kernel:funcallable-instance-fun fin) new-value)) (defmacro fsc-instance-p (fin) `(funcallable-instance-p ,fin)) (defmacro fsc-instance-class (fin) @@ -145,34 +177,29 @@ ;;; NEW-NAME. Note that NEW-NAME is sometimes a list. Some lisps ;;; get the upset in the tummy when they start thinking about ;;; functions which have lists as names. To deal with that there is -;;; SET-FUNCTION-NAME-INTERN which takes a list spec for a function +;;; SET-FUN-NAME-INTERN which takes a list spec for a function ;;; name and turns it into a symbol if need be. ;;; -;;; When given a funcallable instance, SET-FUNCTION-NAME *must* +;;; When given a funcallable instance, SET-FUN-NAME *must* ;;; side-effect that FIN to give it the name. When given any other -;;; kind of function SET-FUNCTION-NAME is allowed to return a new +;;; kind of function SET-FUN-NAME is allowed to return a new ;;; function which is "the same" except that it has the name. ;;; -;;; In all cases, SET-FUNCTION-NAME must return the new (or same) +;;; In all cases, SET-FUN-NAME must return the new (or same) ;;; function. (Unlike other functions to set stuff, it does not return ;;; the new value.) -(defun set-function-name (fcn new-name) +(defun set-fun-name (fcn new-name) #+sb-doc "Set the name of a compiled function object. Return the function." (declare (special *boot-state* *the-class-standard-generic-function*)) (cond ((symbolp fcn) - (set-function-name (symbol-function fcn) new-name)) + (set-fun-name (symbol-function fcn) new-name)) ((funcallable-instance-p fcn) (if (if (eq *boot-state* 'complete) (typep fcn 'generic-function) (eq (class-of fcn) *the-class-standard-generic-function*)) (setf (sb-kernel:%funcallable-instance-info fcn 1) new-name) - (etypecase fcn - (sb-kernel:byte-closure - (set-function-name (sb-kernel:byte-closure-function fcn) - new-name)) - (sb-kernel:byte-function - (setf (sb-kernel:byte-function-name fcn) new-name)))) + (bug "unanticipated function type")) fcn) (t ;; pw-- This seems wrong and causes trouble. Tests show @@ -191,13 +218,13 @@ ;; it loses some info of potential hacking value. So, ;; lets not do this... #+nil - (let ((header (sb-kernel:%closure-function fcn))) - (setf (sb-kernel:%function-name header) new-name)) + (let ((header (sb-kernel:%closure-fun fcn))) + (setf (sb-kernel:%simple-fun-name header) new-name)) ;; XXX Maybe add better scheme here someday. fcn))) -(defun intern-function-name (name) +(defun intern-fun-name (name) (cond ((symbolp name) name) ((listp name) (intern (let ((*package* *pcl-package*) @@ -223,16 +250,28 @@ (defun pcl-instance-p (x) (typep (sb-kernel:layout-of x) 'wrapper)) -;;; We define this as STANDARD-INSTANCE, since we're going to clobber -;;; the layout with some standard-instance layout as soon as we make -;;; it, and we want the accessor to still be type-correct. +;;; CMU CL comment: +;;; We define this as STANDARD-INSTANCE, since we're going to +;;; clobber the layout with some standard-instance layout as soon as +;;; we make it, and we want the accessor to still be type-correct. +#| (defstruct (standard-instance (:predicate nil) (:constructor %%allocate-instance--class ()) (:copier nil) - (:alternate-metaclass sb-kernel:instance cl:standard-class + (:alternate-metaclass sb-kernel:instance + cl:standard-class sb-kernel:make-standard-class)) (slots nil)) +|# +(sb-kernel:!defstruct-with-alternate-metaclass standard-instance + :slot-names (slots) + :boa-constructor %make-standard-instance + :superclass-name sb-kernel:instance + :metaclass-name cl:standard-class + :metaclass-constructor sb-kernel:make-standard-class + :dd-type structure + :runtime-type-checks-p nil) ;;; Both of these operations "work" on structures, which allows the above ;;; weakening of STD-INSTANCE-P.