X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=8f35d3ccfaf408f733457cbf40259a8b6247bf69;hb=2db3b6b4cb740d5b6512459c223859f747807b09;hp=07a312416faecf1e59349a6227f6439de689a75b;hpb=bed279acc9bd04eb1bbf56acb0dcaa3b1acf04f0;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 07a3124..8f35d3c 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -133,8 +133,14 @@ (if (funcallable-instance-p new-value) (%funcallable-instance-lexenv new-value) new-value))) + +;;; service function for structure constructors +(defun %make-instance-with-layout (layout) + (let ((result (%make-instance (layout-length layout)))) + (setf (%instance-layout result) layout) + result)) -;;;; target-only parts of the DEFSTRUCT top-level code +;;;; target-only parts of the DEFSTRUCT top level code ;;; Catch attempts to mess up definitions of symbols in the CL package. (defun protect-cl (symbol) @@ -171,19 +177,22 @@ (dolist (dsd (dd-slots dd)) (/show0 "doing FDEFINITION for slot accessor") (let ((accessor-name (dsd-accessor-name dsd))) - (/show0 "ACCESSOR-NAME=..") - (/hexstr accessor-name) - (protect-cl accessor-name) - (/hexstr "getting READER-FUN and WRITER-FUN") - (multiple-value-bind (reader-fun writer-fun) (slot-accessor-funs dd dsd) - (declare (type function reader-fun writer-fun)) - (/show0 "got READER-FUN and WRITER-FUN=..") - (/hexstr reader-fun) - (setf (symbol-function accessor-name) reader-fun) - (unless (dsd-read-only dsd) - (/show0 "setting FDEFINITION for WRITER-FUN=..") - (/hexstr writer-fun) - (setf (fdefinition `(setf ,accessor-name)) writer-fun))))) + ;; We mustn't step on any inherited accessors + (unless (accessor-inherited-data accessor-name dd) + (/show0 "ACCESSOR-NAME=..") + (/hexstr accessor-name) + (protect-cl accessor-name) + (/hexstr "getting READER-FUN and WRITER-FUN") + (multiple-value-bind (reader-fun writer-fun) + (slot-accessor-funs dd dsd) + (declare (type function reader-fun writer-fun)) + (/show0 "got READER-FUN and WRITER-FUN=..") + (/hexstr reader-fun) + (setf (symbol-function accessor-name) reader-fun) + (unless (dsd-read-only dsd) + (/show0 "setting FDEFINITION for WRITER-FUN=..") + (/hexstr writer-fun) + (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))) ;; Set FDEFINITION for copier. (when (dd-copier-name dd) @@ -207,11 +216,12 @@ ((structure funcallable-structure) (/show0 "with-LAYOUT case") (lambda (object) - (declare (optimize (speed 3) (safety 0))) - (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") - (/nohexstr object) - (/nohexstr layout) - (typep-to-layout object layout))) + (locally ; <- to keep SAFETY 0 from affecting arg count checking + (declare (optimize (speed 3) (safety 0))) + (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") + (/nohexstr object) + (/nohexstr layout) + (typep-to-layout object layout)))) ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST) ;; ;; FIXME: should handle the :NAMED T case in these cases @@ -257,7 +267,7 @@ (dsd-raw-type (dsd-raw-type dsd))) #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code") ;; Map over all the possible RAW-TYPEs, compiling - ;; a different closure-function for each one, so + ;; a different closure function for each one, so ;; that once the COND over RAW-TYPEs happens (at ;; the time closure is allocated) there are no ;; more decisions to be made and things execute @@ -291,8 +301,7 @@ *raw-slot-data-list*) ;; oops (t - (error "internal error: unexpected DSD-RAW-TYPE ~S" - dsd-raw-type)))))) + (bug "unexpected DSD-RAW-TYPE ~S" dsd-raw-type)))))) ;; code shared between DEFSTRUCT :TYPE LIST and ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed ;; structure" case, with no LAYOUTs and no raw slots. @@ -381,7 +390,7 @@ (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (class-name (layout-class layout))) (dd (layout-info layout))) (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) @@ -407,7 +416,7 @@ (pprint-newline :linear stream)))))))) (defun %default-structure-ugly-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (class-name (layout-class layout))) (dd (layout-info layout))) (descend-into (stream) (write-string "#S(" stream) @@ -438,15 +447,15 @@ (*print-pretty* (%default-structure-pretty-print structure stream)) (t - (%default-structure-ugly-print structure-stream)))) + (%default-structure-ugly-print structure stream)))) (def!method print-object ((x structure-object) stream) - (default-structure-print x stream *current-level*)) + (default-structure-print x stream *current-level-in-print*)) (defun make-load-form-saving-slots (object &key slot-names environment) (declare (ignore object environment)) (if slot-names - (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE - :just-dump-it-normally)) + (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE + :sb-just-dump-it-normally)) ;;;; testing structure types @@ -455,9 +464,11 @@ ;;; which have a handle on the type's LAYOUT. ;;; ;;; FIXME: This is fairly big, so it should probably become -;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so -;;; that the things which call it are all closures, so that it's -;;; expanded only in a small number of places. +;;; MAYBE-INLINE instead of INLINE, or its inlineness should become +;;; conditional (probably through DEFTRANSFORM) on (> SPEED SPACE). Or +;;; else we could fix things up so that the things which call it are +;;; all closures, so that it's expanded only in a small number of +;;; places. #!-sb-fluid (declaim (inline typep-to-layout)) (defun typep-to-layout (obj layout) (declare (type layout layout) (optimize (speed 3) (safety 0)))