projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
0.7.9.7:
[sbcl.git]
/
src
/
code
/
target-defstruct.lisp
diff --git
a/src/code/target-defstruct.lisp
b/src/code/target-defstruct.lisp
index
803a61f
..
858e452
100644
(file)
--- 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)))
(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))
\f
\f
-;;;; 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)
;;; Catch attempts to mess up definitions of symbols in the CL package.
(defun protect-cl (symbol)
@@
-148,9
+154,7
@@
(/show0 "leaving PROTECT-CL")
(values))
(/show0 "leaving PROTECT-CL")
(values))
-;;; the part of %DEFSTRUCT which sets up out-of-line implementations
-;;; of those structure functions which are sufficiently similar
-;;; between structures that they can be closures
+;;; the part of %DEFSTRUCT which makes sense only on the target SBCL
;;;
;;; (The "static" in the name is because it needs to be done not only
;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as
;;;
;;; (The "static" in the name is because it needs to be done not only
;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as
@@
-162,9
+166,11
@@
(/show0 "entering %TARGET-DEFSTRUCT")
(/show0 "entering %TARGET-DEFSTRUCT")
+ (remhash (dd-name dd) *typecheckfuns*)
+
;; (Constructors aren't set up here, because constructors are
;; varied enough (possibly parsing any specified argument list)
;; (Constructors aren't set up here, because constructors are
;; varied enough (possibly parsing any specified argument list)
- ;; that we can't reasonably implement them as closures, and so
+ ;; that we can't reasonably implement them as closures, so we
;; implement them with DEFUN instead.)
;; Set FDEFINITIONs for slot accessors.
;; implement them with DEFUN instead.)
;; Set FDEFINITIONs for slot accessors.
@@
-207,11
+213,12
@@
((structure funcallable-structure)
(/show0 "with-LAYOUT case")
(lambda (object)
((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
;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST)
;;
;; FIXME: should handle the :NAMED T case in these cases
@@
-222,9
+229,12
@@
(/show0 ":TYPE LIST case")
#'listp))))
(/show0 ":TYPE LIST case")
#'listp))))
+ (when (dd-doc dd)
+ (setf (fdocumentation (dd-name dd) 'type)
+ (dd-doc dd)))
+
(/show0 "leaving %TARGET-DEFSTRUCT")
(values))
(/show0 "leaving %TARGET-DEFSTRUCT")
(values))
-
\f
;;;; generating out-of-line slot accessor functions
\f
;;;; generating out-of-line slot accessor functions
@@
-254,7
+264,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
(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
;; 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
@@
-267,24
+277,28
@@
(,dd-ref-fun-name instance dsd-index)
,instance-type-check-form))
;; raw slot cases
(,dd-ref-fun-name instance dsd-index)
,instance-type-check-form))
;; raw slot cases
- ,@(mapcar (lambda (raw-type-and-rawref-fun-name)
- (destructuring-bind (raw-type
- . rawref-fun-name)
- raw-type-and-rawref-fun-name
+ ,@(mapcar (lambda (rtd)
+ (let ((raw-type (raw-slot-data-raw-type rtd))
+ (accessor-name
+ (raw-slot-data-accessor-name rtd))
+ (n-words (raw-slot-data-n-words rtd)))
`((equal dsd-raw-type ',raw-type)
#+sb-xc (/show0 "in raw slot case")
(let ((raw-index (dd-raw-index dd)))
`((equal dsd-raw-type ',raw-type)
#+sb-xc (/show0 "in raw slot case")
(let ((raw-index (dd-raw-index dd)))
- (%slotplace-accessor-funs
- (,rawref-fun-name (,dd-ref-fun-name
+ (multiple-value-bind (scaled-dsd-index
+ misalignment)
+ (floor dsd-index ,n-words)
+ (aver (zerop misalignment))
+ (%slotplace-accessor-funs
+ (,accessor-name (,dd-ref-fun-name
instance
raw-index)
instance
raw-index)
- dsd-index)
- ,instance-type-check-form)))))
- *raw-type->rawref-fun-name*)
+ scaled-dsd-index)
+ ,instance-type-check-form))))))
+ *raw-slot-data-list*)
;; oops
(t
;; 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.
;; code shared between DEFSTRUCT :TYPE LIST and
;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed
;; structure" case, with no LAYOUTs and no raw slots.
@@
-430,15
+444,15
@@
(*print-pretty*
(%default-structure-pretty-print structure stream))
(t
(*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)
(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
(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))
\f
;;;; testing structure types
\f
;;;; testing structure types
@@
-447,9
+461,11
@@
;;; which have a handle on the type's LAYOUT.
;;;
;;; FIXME: This is fairly big, so it should probably become
;;; 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)))
#!-sb-fluid (declaim (inline typep-to-layout))
(defun typep-to-layout (obj layout)
(declare (type layout layout) (optimize (speed 3) (safety 0)))