src/code/defbangstruct.lisp

   1 ;;;; DEF!STRUCT = bootstrap DEFSTRUCT, a wrapper around DEFSTRUCT which
   2 ;;;; provides special features to help at bootstrap time:
   3 ;;;;  1. Layout information, inheritance information, and so forth is
   4 ;;;;     retained in such a way that we can get to it even on vanilla
   5 ;;;;     ANSI Common Lisp at cross-compiler build time.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!KERNEL")
  17
  18 ;;; Has the type system been properly initialized? (I.e. is it OK to
  19 ;;; use it?)
  20 (!defglobal *type-system-initialized* nil)
  21
  22 ;;; machinery used in the implementation of DEF!STRUCT
  23 #+sb-xc-host
  24 (eval-when (:compile-toplevel :load-toplevel :execute)
  25   ;; a description of a DEF!STRUCT call to be stored until we get
  26   ;; enough of the system running to finish processing it
  27   (defstruct delayed-def!struct
  28     (args (missing-arg) :type cons)
  29     (package (sane-package) :type package))
  30   ;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
  31   ;; working fully so that we can apply it to them then. After
  32   ;; DEF!STRUCT is made to work fully, this list is processed, then
  33   ;; made unbound, and should no longer be used.
  34   (defvar *delayed-def!structs* nil))
  35 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  36   ;; Parse the arguments for a DEF!STRUCT call, and return
  37   ;;   (VALUES NAME DEFSTRUCT-ARGS DEF!STRUCT-SUPERTYPE),
  38   ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
  39   ;; munged result suitable for passing on to DEFSTRUCT,
  40   ;; and DEF!STRUCT-SUPERTYPE is the direct supertype of
  41   ;; the type if it is another DEF!STRUCT-defined type, or NIL
  42   ;; otherwise.
  43   (defun parse-def!struct-args (nameoid &rest rest)
  44     (multiple-value-bind (name options) ; Note: OPTIONS can change below.
  45         (if (consp nameoid)
  46             (values (first nameoid) (rest nameoid))
  47             (values nameoid nil))
  48       (declare (type list options))
  49       (let* ((include-clause (find :include options :key #'first))
  50              (def!struct-supertype nil)) ; may change below
  51         (when (find :type options :key #'first)
  52           (error "can't use :TYPE option in DEF!STRUCT"))
  53         (when include-clause
  54           (setf def!struct-supertype (second include-clause)))
  55         (if (eq name 'structure!object) ; if root of hierarchy
  56             (aver (not include-clause))
  57             (unless include-clause
  58               (setf def!struct-supertype 'structure!object)
  59               (push `(:include ,def!struct-supertype) options)))
  60         (values name `((,name ,@options) ,@rest) def!struct-supertype)))))
  61
  62 ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
  63 ;;; DEFSTRUCT-style arguments with any class names in the SB!XC
  64 ;;; package (i.e. the name of the class being defined, and/or the
  65 ;;; names of classes in :INCLUDE clauses) converted from SB!XC::FOO to
  66 ;;; CL::FOO.
  67 #+sb-xc-host
  68 (eval-when (:compile-toplevel :load-toplevel :execute)
  69   (defun uncross-defstruct-args (defstruct-args)
  70     (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args
  71       (multiple-value-bind (name options)
  72           (if (symbolp name-and-options)
  73               (values name-and-options nil)
  74               (values (first name-and-options)
  75                       (rest name-and-options)))
  76         (flet ((uncross-option (option)
  77                  (if (eq (first option) :include)
  78                      (destructuring-bind
  79                          (include-keyword included-name &rest rest)
  80                          option
  81                        `(,include-keyword
  82                          ,(uncross included-name)
  83                          ,@rest))
  84                    option)))
  85           `((,(uncross name)
  86              ,@(mapcar #'uncross-option options))
  87             ,@slots-and-doc))))))
  88
  89 ;;; DEF!STRUCT's arguments are like DEFSTRUCT's arguments.
  90 ;;; DEF!STRUCT also does some magic to ensure that anything it defines
  91 ;;; includes STRUCTURE!OBJECT.
  92 (defmacro def!struct (&rest args)
  93   (multiple-value-bind (name defstruct-args def!struct-supertype)
  94       (apply #'parse-def!struct-args args)
  95     `(progn
  96        ;; There are two valid cases here: creating the
  97        ;; STRUCTURE!OBJECT root of the inheritance hierarchy, or
  98        ;; inheriting from STRUCTURE!OBJECT somehow.
  99        ;;
 100        ;; The invalid case that we want to exclude is when an :INCLUDE
 101        ;; clause was used, and the included class didn't inherit from
 102        ;; STRUCTURE!OBJECT.
 103        ,@(if (eq name 'structure!object)
 104              (aver (null def!struct-supertype))
 105              `((aver (subtypep ',def!struct-supertype 'structure!object))))
 106        (defstruct ,@defstruct-args)
 107        #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
 108                        (if (boundp '*delayed-def!structs*)
 109                            `(push (make-delayed-def!struct :args ',u)
 110                                   *delayed-def!structs*)
 111                            `(sb!xc:defstruct ,@u)))
 112        ',name)))
 113
 114 ;;; When building the cross-compiler, this function has to be called
 115 ;;; some time after SB!XC:DEFSTRUCT is set up, in order to take care
 116 ;;; of any processing which had to be delayed until then.
 117 #+sb-xc-host
 118 (defun force-delayed-def!structs ()
 119   (if (boundp '*delayed-def!structs*)
 120       (progn
 121         (mapcar (lambda (x)
 122                   (let ((*package* (delayed-def!struct-package x)))
 123                     ;; KLUDGE(?): EVAL is almost always the wrong thing.
 124                     ;; However, since we have to map DEFSTRUCT over the
 125                     ;; list, and since ANSI declined to specify any
 126                     ;; functional primitives corresponding to the
 127                     ;; DEFSTRUCT macro, it seems to me that EVAL is
 128                     ;; required in there somewhere..
 129                     (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x)))))
 130                 (reverse *delayed-def!structs*))
 131         ;; We shouldn't need this list any more. Making it unbound
 132         ;; serves as a signal to DEF!STRUCT that it needn't delay
 133         ;; DEF!STRUCTs any more. It is also generally a good thing for
 134         ;; other reasons: it frees garbage, and it discourages anyone
 135         ;; else from pushing anything else onto the list later.
 136         (makunbound '*delayed-def!structs*))
 137       ;; This condition is probably harmless if it comes up when
 138       ;; interactively experimenting with the system by loading a source
 139       ;; file into it more than once. But it's worth warning about it
 140       ;; because it definitely shouldn't come up in an ordinary build
 141       ;; process.
 142       (warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
 143
 144 ;;; The STRUCTURE!OBJECT abstract class is the base of the type
 145 ;;; hierarchy for objects which have/use DEF!STRUCT functionality.
 146 ;;; (The extra hackery in DEF!STRUCT-defined things isn't needed for
 147 ;;; STRUCTURE-OBJECTs defined by ordinary, post-warm-init programs, so
 148 ;;; it's only put into STRUCTURE-OBJECTs which inherit from
 149 ;;; STRUCTURE!OBJECT.)
 150 (def!struct (structure!object (:constructor nil) (:copier nil) (:predicate nil)))