(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
-;;;; 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)
(/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
(/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)
- ;; 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.
(/show0 ":TYPE LIST case")
#'listp))))
+ (when (dd-doc dd)
+ (setf (fdocumentation (dd-name dd) 'type)
+ (dd-doc dd)))
+
(/show0 "leaving %TARGET-DEFSTRUCT")
(values))
-
\f
;;;; generating out-of-line slot accessor functions
(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
(*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*))