projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
0.pre7.86.flaky7.26:
[sbcl.git]
/
src
/
code
/
target-defstruct.lisp
diff --git
a/src/code/target-defstruct.lisp
b/src/code/target-defstruct.lisp
index
702abbc
..
3937071
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.
@@
-222,9
+228,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
+263,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
@@
-435,7
+444,7
@@
(*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)
(default-structure-print x stream *current-level*))
(def!method print-object ((x structure-object) stream)
(default-structure-print x stream *current-level*))