home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / defstruct.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  24.8 KB  |  735 lines
  1. ;;; -*- Log: code.log; Package: C -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: defstruct.lisp,v 1.34 92/06/14 07:29:18 ram Locked $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Defstruct structure definition package (Mark II).
  15. ;;; Written by Skef Wholey and Rob MacLachlan.
  16. ;;;
  17. (in-package 'c)
  18. (export '(lisp::defstruct) "LISP")
  19.  
  20. (export '(structure-index make-structure structure-length
  21.       structure-ref structure-set))
  22.  
  23. ;;; Always compile safe.  This code isn't very careful about protecting itself.
  24. ;;;
  25. (eval-when (compile)
  26.   (declaim (optimize (safety 1))))
  27.  
  28.  
  29.  
  30. ;;;; Structure frobbing primitives.
  31.  
  32. (defun make-structure (length)
  33.   "Allocate a new structure with LENGTH data slots."
  34.   (declare (type index length))
  35.   (make-structure length))
  36.  
  37. (defun structure-length (structure)
  38.   "Given a structure, return its length."
  39.   (declare (type structure structure))
  40.   (structure-length structure))
  41.  
  42. (defun structure-ref (struct index)
  43.   "Return the value from the INDEXth slot of STRUCT.  0 corresponds to the
  44.   type.  This is SETFable."
  45.   (structure-ref struct index))
  46.  
  47. (defun structure-set (struct index new-value)
  48.   "Set the INDEXth slot of STRUCT to NEW-VALUE."
  49.   (setf (structure-ref struct index) new-value))
  50.  
  51. (defsetf structure-ref structure-set)
  52.  
  53.  
  54.  
  55. ;;; This version of Defstruct is implemented using Defstruct, and is free of
  56. ;;; Maclisp compatability nonsense.  For bootstrapping, you're on your own.
  57.  
  58. (defun print-defstruct-description (structure stream depth)
  59.   (declare (ignore depth))
  60.   (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
  61.  
  62. ;;; DSD-Name  --  Internal
  63. ;;;
  64. ;;;    Return the the name of a defstruct slot as a symbol.  We store it
  65. ;;; as a string to avoid creating lots of worthless symbols at load time.
  66. ;;;
  67. (defun dsd-name (dsd)
  68.   (intern (string (dsd-%name dsd))
  69.       (if (dsd-accessor dsd)
  70.           (symbol-package (dsd-accessor dsd))
  71.           *package*)))
  72.  
  73. (defun print-defstruct-slot-description (structure stream depth)
  74.   (declare (ignore depth))
  75.   (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
  76.  
  77.  
  78.  
  79. ;;; The legendary macro itself.
  80.  
  81. (defmacro defstruct (name-and-options &rest slot-descriptions)
  82.   "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
  83.   Define the structure type Name.  See the manual for details."
  84.   (let* ((defstruct (parse-name-and-options name-and-options))
  85.      (name (dd-name defstruct)))
  86.     (parse-slot-descriptions defstruct slot-descriptions)
  87.     (if (eq (dd-type defstruct) 'structure)
  88.     `(progn
  89.        (%defstruct ',defstruct)
  90.        (%compiler-defstruct ',defstruct)
  91.        ,@(define-constructors defstruct)
  92.        ,@(define-boa-constructors defstruct)
  93.        ;;
  94.        ;; So the print function is in the right lexical environment, and
  95.        ;; can be compiled...
  96.        ,@(let ((pf (dd-print-function defstruct)))
  97.            (when pf
  98.          `((setf (info type printer ',name)
  99.              ,(if (symbolp pf)
  100.                   `',pf
  101.                   `#',pf)))))
  102.        ,@(let ((mlff (dd-make-load-form-fun defstruct)))
  103.            (when mlff
  104.          `((setf (info type load-form-maker ',name)
  105.              ,(if (symbolp mlff)
  106.                   `',mlff
  107.                   `#',mlff)))))
  108.        ',name)
  109.     `(progn
  110.        (eval-when (compile load eval)
  111.          (setf (info type kind ',name) nil)
  112.          (setf (info type structure-info ',name) ',defstruct))
  113.        ,@(define-constructors defstruct)
  114.        ,@(define-boa-constructors defstruct)
  115.        ,@(define-predicate defstruct)
  116.        ,@(define-accessors defstruct)
  117.        ,@(define-copier defstruct)
  118.        ',name))))
  119.        
  120.  
  121. ;;;; Parsing:
  122.  
  123. (defun parse-name-and-options (name-and-options)
  124.   (if (atom name-and-options)
  125.       (setq name-and-options (list name-and-options)))
  126.   (do* ((options (cdr name-and-options) (cdr options))
  127.     (name (car name-and-options))
  128.     (print-function nil)
  129.     (pf-supplied-p)
  130.     (conc-name (concat-pnames name '-))
  131.     (constructors '())
  132.     (constructor-opt-p nil)
  133.     (boa-constructors '())
  134.     (copier (concat-pnames 'copy- name))
  135.     (predicate (concat-pnames name '-p))
  136.     (include)
  137.     (saw-type)
  138.     (type 'structure)
  139.     (saw-named)
  140.     (offset 0)
  141.     (make-load-form-fun nil)
  142.     (make-load-form-fun-p nil))
  143.        ((null options)
  144.     (let ((named (if saw-type saw-named t)))
  145.       (make-defstruct-description
  146.        :name name
  147.        :conc-name conc-name
  148.        :constructors
  149.        (if constructor-opt-p
  150.            (nreverse constructors)
  151.            (list (concat-pnames 'make- name)))
  152.        :boa-constructors boa-constructors
  153.        :copier copier
  154.        :predicate predicate
  155.        :include include
  156.        :print-function print-function
  157.        :type type
  158.        :length (if named 1 0)
  159.        :lisp-type (cond ((eq type 'structure) 'simple-vector)
  160.                 ((eq type 'vector) 'simple-vector)
  161.                 ((eq type 'list) 'list)
  162.                 ((and (listp type) (eq (car type) 'vector))
  163.                  (cons 'simple-array (cdr type)))
  164.                 (t (error "~S is a bad :TYPE for Defstruct." type)))
  165.        :named named
  166.        :offset offset
  167.        :make-load-form-fun make-load-form-fun)))
  168.     (if (atom (car options))
  169.     (case (car options)
  170.       (:constructor
  171.        (setf constructor-opt-p t)
  172.        (setf constructors (list (concat-pnames 'make- name))))
  173.       (:copier)
  174.       (:predicate)
  175.       (:named (setq saw-named t))
  176.       (t (error "The Defstruct option ~S cannot be used with 0 arguments."
  177.             (car options))))
  178.     (let ((option (caar options))
  179.           (args (cdar options)))
  180.       (case option
  181.         (:conc-name
  182.          (setq conc-name (car args))
  183.          (unless (symbolp conc-name)
  184.            (setq conc-name (make-symbol (string conc-name)))))
  185.         (:constructor
  186.          (setf constructor-opt-p t)
  187.          (let ((lambda-list (cdr args))
  188.            (constructor-name (car args))
  189.            (no-explicit-nil-name (not args)))
  190.            ;; Constructor-name may be nil because args has one element, the
  191.            ;; explicit name of nil.  In this situation, don't make a
  192.            ;; default constructor.  If args itself is nil, then we make a
  193.            ;; default constructor.
  194.            (cond (lambda-list
  195.               (push args boa-constructors))
  196.              (constructor-name
  197.               (push constructor-name constructors))
  198.              (no-explicit-nil-name
  199.               (push (concat-pnames 'make- name) constructors)))))
  200.         (:copier (setq copier (car args)))
  201.         (:predicate (setq predicate (car args)))
  202.         (:include
  203.          (setf include args)
  204.          (let* ((name (car include))
  205.             (included-structure
  206.              (info type structure-info name)))
  207.            (unless included-structure
  208.          (error "Cannot find description of structure ~S to use for ~
  209.                  inclusion."
  210.             name))
  211.            (unless pf-supplied-p
  212.          (setf print-function
  213.                (dd-print-function included-structure)))
  214.            (unless make-load-form-fun-p
  215.          (setf make-load-form-fun
  216.                (dd-make-load-form-fun included-structure)))))
  217.         (:print-function
  218.          (setf print-function (car args))
  219.          (setf pf-supplied-p t))
  220.         (:type (setf saw-type t type (car args)))
  221.         (:named (error "The Defstruct option :NAMED takes no arguments."))
  222.         (:initial-offset (setf offset (car args)))
  223.         (:make-load-form-fun
  224.          (setf make-load-form-fun (car args))
  225.          (setf make-load-form-fun-p t))
  226.         (t (error "~S is an unknown Defstruct option." option)))))))
  227.  
  228.  
  229.  
  230. ;;;; Stuff to parse slot descriptions.
  231.  
  232. ;;; PARSE-1-DSD  --  Internal
  233. ;;;
  234. ;;;    Parse a slot description for DEFSTRUCT and add it to the description.
  235. ;;; If supplied, ISLOT is a pre-initialized DSD that we modify to get the new
  236. ;;; slot.  This is supplied when handling included slots.  If the new accessor
  237. ;;; name is already an accessor for same slot in some included structure, then
  238. ;;; set the DSD-ACCESSOR to NIL so that we don't clobber the more general
  239. ;;; accessor.
  240. ;;;
  241. (defun parse-1-dsd (defstruct spec &optional
  242.              (islot (make-defstruct-slot-description
  243.                  :%name "" :index 0 :type t)))
  244.   (multiple-value-bind
  245.       (name default default-p type type-p read-only ro-p)
  246.       (cond
  247.        ((listp spec)
  248.     (destructuring-bind (name &optional (default nil default-p)
  249.                   &key (type nil type-p) (read-only nil ro-p))
  250.                 spec
  251.       (values name default default-p type type-p read-only ro-p)))
  252.        (t
  253.     (when (keywordp spec)
  254.       (warn "Keyword slot name indicates possible syntax ~
  255.          error in DEFSTRUCT -- ~S."
  256.         spec))
  257.     spec))
  258.     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
  259.       (error "Duplicate slot name ~S." name))
  260.     (setf (dsd-%name islot) (string name))
  261.     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
  262.  
  263.     (let* ((aname (concat-pnames (dd-conc-name defstruct) name))
  264.        (existing (info function accessor-for aname)))
  265.       (if (and existing
  266.            (string= (dsd-name (find aname (dd-slots existing)
  267.                     :key #'dsd-accessor))
  268.             name)
  269.            (member (dd-name existing) (dd-includes defstruct)))
  270.       (setf (dsd-accessor islot) nil)
  271.       (setf (dsd-accessor islot) aname)))
  272.     
  273.     (when default-p
  274.       (setf (dsd-default islot) default))
  275.     (when type-p
  276.       (setf (dsd-type islot) type))
  277.     (when ro-p
  278.       (setf (dsd-read-only islot) read-only))
  279.     (setf (dsd-index islot) (dd-length defstruct))
  280.     (incf (dd-length defstruct)))
  281.   (undefined-value))
  282.  
  283.  
  284. ;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
  285. ;;; any structure inclusion that needs to be done.
  286. ;;;
  287. (defun parse-slot-descriptions (defstruct slots)
  288.   ;; First strip off any doc string and stash it in the Defstruct.
  289.   (when (stringp (car slots))
  290.     (setf (dd-doc defstruct) (car slots))
  291.     (setq slots (cdr slots)))
  292.   ;; Then include stuff.  We add unparsed items to the start of the Slots.
  293.   (when (dd-include defstruct)
  294.     (destructuring-bind (included-name &rest modified-slots)
  295.             (dd-include defstruct)
  296.       (let ((included-thing
  297.          (or (info type structure-info included-name)
  298.          (error "Cannot find description of structure ~S ~
  299.              to use for inclusion."
  300.             included-name))))
  301.     (setf (dd-includes defstruct)
  302.           (cons (dd-name included-thing) (dd-includes included-thing)))
  303.     (incf (dd-offset defstruct) (dd-offset included-thing))
  304.     (incf (dd-length defstruct) (dd-offset defstruct))
  305.     (dolist (islot (dd-slots included-thing))
  306.       (let* ((iname (dsd-name islot))
  307.          (modified (or (find iname modified-slots
  308.                      :key #'(lambda (x) (if (atom x) x (car x)))
  309.                      :test #'string=)
  310.                    `(,iname))))
  311.         (parse-1-dsd defstruct modified
  312.              (copy-defstruct-slot-description islot)))))))
  313.   
  314.   ;; Finally parse the slots into Slot-Description objects.
  315.   (dolist (slot slots)
  316.     (parse-1-dsd defstruct slot))
  317.   (undefined-value))
  318.  
  319.  
  320. ;;;; Default structure access and copiers:
  321. ;;;
  322. ;;;    In the normal case of structures that have a real type (i.e. no :Type
  323. ;;; option was specified), we want to optimize things for space as well as
  324. ;;; speed, since there can be thousands of defined slot accesors.
  325. ;;;
  326. ;;;    What we do is defined the accessors and copier as closures over
  327. ;;; general-case code.  Since the compiler will normally open-code accesors,
  328. ;;; the (minor) efficiency penalty is not a concern.
  329.  
  330. ;;; Typep-To-Structure  --  Internal
  331. ;;;
  332. ;;;    Return true if Obj is an object of the structure type specified by Info.
  333. ;;; This is called by the accessor closures, which have a handle on the type's
  334. ;;; Defstruct-Description.
  335. ;;;
  336. #+new-compiler
  337. (proclaim '(inline typep-to-structure))
  338. #+new-compiler
  339. (defun typep-to-structure (obj info)
  340.   (declare (type defstruct-description info) (inline member))
  341.   (and (structurep obj)
  342.        (let ((name (structure-ref obj 0)))
  343.      (or (eq name (dd-name info))
  344.          (member name (dd-included-by info) :test #'eq)))))
  345.  
  346.  
  347. ;;; %REDEFINE-DEFSTRUCT  --  Internal
  348. ;;;
  349. ;;;    This function is called when we are redefining a structure from Old to
  350. ;;; New.  If the slots are different, we flame loudly, but give the luser a
  351. ;;; chance to proceed.  We flame especially loudly if there are structures that
  352. ;;; include this one.  If proceeded, we FMAKUNBOUND all the old accessors.  If
  353. ;;; the redefinition is not incompatible, we make the INCLUDED-BY of the new
  354. ;;; definition be the same as the old one.
  355. ;;;
  356. (defun %redefine-defstruct (old new)
  357.   (declare (type defstruct-description old new))
  358.   (cond
  359.    ((and (equalp (dd-slots old) (dd-slots new))
  360.      (equal (dd-includes old) (dd-includes new)))
  361.     (setf (dd-included-by new) (dd-included-by old)))
  362.    (t
  363.     (let ((name (dd-name old))
  364.       (included-by (dd-included-by old)))
  365.       (cerror
  366.        "Recklessly proceed with wanton disregard for Lisp and limb."
  367.        "Structure ~S is being incompatibly redefined.  If proceeded, you must~@
  368.        recompile all uses of this structure's accessors.~:[~;~@
  369.        ~S is included by these structures:~
  370.        ~%  ~S~@
  371.        You must also recompile these DEFSTRUCTs and all the uses of their ~
  372.        accessors.~]"
  373.        name included-by name included-by)
  374.  
  375.       (dolist (slot (dd-slots old))
  376.     (fmakunbound (dsd-accessor slot))
  377.     (unless (dsd-read-only slot)
  378.       (fmakunbound `(setf ,(dsd-accessor slot))))))))
  379.  
  380.   (undefined-value))
  381.  
  382. #+new-compiler
  383. ;;; %Defstruct  --  Internal
  384. ;;;
  385. ;;;    Do miscellaneous load-time actions for the structure described by Info.
  386. ;;; Define setters, accessors, copier, predicate, documentation, instantiate
  387. ;;; definition in load-time env.  This is only called for default structures.
  388. ;;;
  389. (defun %defstruct (info)
  390.   (declare (type defstruct-description info))
  391.   (let* ((name (dd-name info))
  392.      (old (info type defined-structure-info name)))
  393.     ;;
  394.     ;; Don't flame about dd structures, since they are hackishly defined in
  395.     ;; type-boot...
  396.     (when (and old
  397.            (not (member name '(defstruct-description
  398.                    defstruct-slot-description))))
  399.       (%redefine-defstruct old info))
  400.     
  401.     (setf (info type defined-structure-info name) info)
  402.     (dolist (include (dd-includes info))
  403.       (let ((iinfo (info type defined-structure-info include)))
  404.     (unless iinfo
  405.       (error "~S includes ~S, but it is not defined." name include))
  406.     (pushnew name (dd-included-by iinfo)))))
  407.     
  408.   (dolist (slot (dd-slots info))
  409.     (let ((dsd slot))
  410.       (when (dsd-accessor slot)
  411.     (setf (symbol-function (dsd-accessor slot))
  412.           #'(lambda (structure)
  413.           (declare (optimize (speed 3) (safety 0)))
  414.           (unless (typep-to-structure structure info)
  415.             (error "Structure for accessor ~S is not a ~S:~% ~S"
  416.                (dsd-accessor dsd) (dd-name info) structure))
  417.           (structure-ref structure (dsd-index dsd))))
  418.       
  419.     (unless (dsd-read-only slot)
  420.       (setf (fdefinition `(setf ,(dsd-accessor slot)))
  421.         #'(lambda (new-value structure)
  422.             (declare (optimize (speed 3) (safety 0)))
  423.             (unless (typep-to-structure structure info)
  424.               (error "Structure for setter ~S is not a ~S:~% ~S"
  425.                  `(setf ,(dsd-accessor dsd)) (dd-name info)
  426.                  structure))
  427.             (unless (typep new-value (dsd-type dsd))
  428.               (error "New-Value for setter ~S is not a ~S:~% ~S."
  429.                  `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
  430.                  new-value))
  431.             (setf (structure-ref structure (dsd-index dsd))
  432.               new-value)))))))
  433.  
  434.   (when (dd-predicate info)
  435.     (setf (symbol-function (dd-predicate info))
  436.       #'(lambda (object)
  437.           (declare (optimize (speed 3) (safety 0)))
  438.           (if (typep-to-structure object info) t nil))))
  439.  
  440.   (when (dd-copier info)
  441.     (setf (symbol-function (dd-copier info))
  442.       #'(lambda (structure)
  443.           (declare (optimize (speed 3) (safety 0)))
  444.           (unless (typep-to-structure structure info)
  445.         (error "Structure for copier ~S is not a ~S:~% ~S"
  446.                (dd-copier info) (dd-name info) structure))
  447.  
  448.           (let* ((len (dd-length info))
  449.              (res (make-structure len)))
  450.         (declare (type structure-index len))
  451.         (dotimes (i len)
  452.           (declare (type structure-index i))
  453.           (setf (structure-ref res i)
  454.             (structure-ref structure i)))
  455.         res))))
  456.   (when (dd-doc info)
  457.     (setf (documentation (dd-name info) 'type) (dd-doc info))))
  458.  
  459.  
  460. ;;; Define-Accessors returns a list of function definitions for accessing and
  461. ;;; setting the slots of the a typed Defstruct.  The functions are proclaimed
  462. ;;; to be inline, and the types of their arguments and results are declared as
  463. ;;; well.  We count on the compiler to do clever things with Elt.
  464.  
  465. (defun define-accessors (defstruct)
  466.   (do ((slots (dd-slots defstruct) (cdr slots))
  467.        (stuff '())
  468.        (type (dd-lisp-type defstruct)))
  469.       ((null slots) stuff)
  470.     (let* ((slot (car slots))
  471.        (name (dsd-accessor slot))
  472.        (index (dsd-index slot))
  473.        (slot-type (dsd-type slot)))
  474.       (push
  475.        `(progn
  476.       (proclaim '(inline ,name (setf ,name)))
  477.       (defun ,name (structure)
  478.         (declare (type ,type structure))
  479.         (the ,slot-type (elt structure ,index)))
  480.       ,@(unless (dsd-read-only slot)
  481.           `((defun (setf ,name) (new-value structure)
  482.           (declare (type ,type structure) (type ,slot-type new-value))
  483.           (setf (elt structure ,index) new-value)))))
  484.        stuff))))
  485.  
  486.  
  487. ;;; Define-Constructors returns a definition for the constructor function of
  488. ;;; the given Defstruct.  If the structure is implemented as a vector and is
  489. ;;; named, we structurify it.  If the structure is a vector of some specialized
  490. ;;; type, we can't use the Vector function.
  491. ;;;
  492. (defun define-constructors (defstruct)
  493.   (let ((cons-names (dd-constructors defstruct)))
  494.     (when cons-names
  495.       (let* ((name (first cons-names))
  496.          (initial-cruft
  497.           (if (dd-named defstruct)
  498.           (make-list (1+ (dd-offset defstruct))
  499.                  :initial-element `',(dd-name defstruct))
  500.           (make-list (dd-offset defstruct))))
  501.          (slots (dd-slots defstruct))
  502.          (names (mapcar #'dsd-name slots))
  503.          (args (mapcar #'(lambda (slot)
  504.                    `(,(dsd-name slot) ,(dsd-default slot)))
  505.                slots)))
  506.     `((defun ,name ,(if args `(&key ,@args))
  507.         (declare
  508.          ,@(mapcar #'(lambda (slot)
  509.                `(type ,(dsd-type slot) ,(dsd-name slot)))
  510.                slots))
  511.         ,(case (dd-type defstruct)
  512.            (list
  513.         `(list ,@initial-cruft ,@names))
  514.            (structure
  515.         (let ((temp (gensym)))
  516.           `(let ((,temp (make-structure ,(dd-length defstruct))))
  517.              (declare (type structure ,temp))
  518.              (setf (structure-ref ,temp 0) ',(dd-name defstruct))
  519.              ,@(mapcar #'(lambda (slot)
  520.                    `(setf (structure-ref ,temp
  521.                              ,(dsd-index slot))
  522.                       ,(dsd-name slot)))
  523.                    slots)
  524.              (truly-the ,(dd-name defstruct) ,temp))))
  525.            (vector
  526.         `(vector ,@initial-cruft ,@names))
  527.            (t
  528.         (do ((sluts slots (cdr sluts))
  529.              (sets '())
  530.              (temp (gensym)))
  531.             ((null sluts)
  532.              `(let ((,temp (make-array
  533.                     ,(dd-length defstruct)
  534.                     :element-type
  535.                     ',(cadr (dd-lisp-type defstruct)))))
  536.             ,@(when (dd-named defstruct)
  537.                 `(setf (aref ,temp ,(dd-offset defstruct))
  538.                    ',(dd-name defstruct)))
  539.             ,@sets
  540.             ,temp))
  541.           (let ((slot (car sluts)))
  542.             (push `(setf (aref ,temp ,(dsd-index slot))
  543.                  ,(dsd-name slot))
  544.               sets))))))
  545.       ,@(mapcar #'(lambda (other-name)
  546.             `(setf (fdefinition ',other-name) #',name))
  547.             (rest cons-names)))))))
  548.  
  549.  
  550. ;;;; Support for By-Order-Argument Constructors.
  551.  
  552. ;;; FIND-LEGAL-SLOT   --  Internal
  553. ;;;
  554. ;;;    Given a defstruct description and a slot name, return the corresponding
  555. ;;; slot if it exists, or signal an error if not.
  556. ;;;
  557. (defun find-legal-slot (defstruct name)
  558.   (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=)
  559.       (error "~S is not a defined slot name in the ~S structure."
  560.          name (dd-name defstruct))))
  561.  
  562.  
  563. ;;; Define-Boa-Constructors defines positional constructor functions.  We
  564. ;;; generate code to set each variable not specified in the arglist to the
  565. ;;; default given in the Defstruct.  We just slap required args in, as with
  566. ;;; rest args and aux args.  Optionals are treated a little differently.  Those
  567. ;;; that aren't supplied with a default in the arg list are mashed so that
  568. ;;; their default in the arglist is the corresponding default from the
  569. ;;; Defstruct.
  570. ;;;
  571. (defun define-boa-constructors (defstruct)
  572.   (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
  573.     (name (car (car boas)) (car (car boas)))
  574.     (args (copy-list (cadr (car boas))) (copy-list (cadr (car boas))))
  575.     (slots (dd-slots defstruct) (dd-slots defstruct))
  576.     (slots-in-arglist '() '())
  577.     (defuns '()))
  578.        ((null boas) defuns)
  579.     ;; Find the slots in the arglist and hack the defaultless optionals.
  580.     (do ((args args (cdr args))
  581.      (arg-kind 'required))
  582.     ((null args))
  583.       (let ((arg (car args)))
  584.     (cond ((not (atom arg))
  585.            (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
  586.           ((member arg '(&optional &rest &aux &key) :test #'eq)
  587.            (setq arg-kind arg))
  588.           (t
  589.            (case arg-kind
  590.          ((required &rest &aux)
  591.           (push (find-legal-slot defstruct arg) slots-in-arglist))
  592.          ((&optional &key)
  593.           (let ((dsd (find-legal-slot defstruct arg)))
  594.             (push dsd slots-in-arglist)
  595.             (rplaca args (list arg (dsd-default dsd))))))))))
  596.     
  597.     ;; Then make a list that can be used with a (list ...) or (vector...).
  598.     (let ((initial-cruft
  599.        (if (dd-named defstruct)
  600.            (make-list (1+ (dd-offset defstruct))
  601.               :initial-element `',(dd-name defstruct))
  602.            (make-list (dd-offset defstruct))))
  603.       (thing (mapcar #'(lambda (slot)
  604.                  (if (member slot slots-in-arglist
  605.                      :test #'eq)
  606.                  (dsd-name slot)
  607.                  (dsd-default slot)))
  608.              slots)))
  609.       (push
  610.        `(defun ,name ,args
  611.       (declare
  612.        ,@(mapcar #'(lambda (slot)
  613.              `(type ,(dsd-type slot) ,(dsd-name slot)))
  614.              slots-in-arglist))
  615.       ,(case (dd-type defstruct)
  616.          (list
  617.           `(list ,@initial-cruft ,@thing))
  618.          (structure
  619.           (let ((temp (gensym)))
  620.         `(let ((,temp (make-structure ,(dd-length defstruct))))
  621.            (declare (type structure ,temp))
  622.            (setf (structure-ref ,temp 0) ',(dd-name defstruct))
  623.            ,@(mapcar #'(lambda (slot thing)
  624.                  `(setf (structure-ref ,temp
  625.                                ,(dsd-index slot))
  626.                     ,thing))
  627.                  slots thing)
  628.            (truly-the ,(dd-name defstruct) ,temp))))
  629.          (vector
  630.           `(vector ,@initial-cruft ,@thing))
  631.          (t
  632.           (do ((things thing (cdr things))
  633.            (index 0 (1+ index))
  634.            (sets '())
  635.            (temp (gensym)))
  636.           ((null things)
  637.            `(let ((,temp (make-array
  638.                   ,(dd-length defstruct)
  639.                   :element-type
  640.                   ',(cadr (dd-lisp-type defstruct)))))
  641.               ,@(when (dd-named defstruct)
  642.               `(setf (aref ,temp ,(dd-offset defstruct))
  643.                  ',(dd-name defstruct)))
  644.               ,@sets
  645.               ,temp))
  646.         (push `(setf (aref ,temp index) ,(car things))
  647.               sets)))))
  648.        defuns))))
  649.  
  650. ;;; Define-Copier returns the definition for a copier function of a typed
  651. ;;; Defstruct if one is desired.
  652.  
  653. (defun define-copier (defstruct)
  654.   (when (dd-copier defstruct)
  655.     `((defun ,(dd-copier defstruct) (structure)
  656.     (declare (type ,(dd-lisp-type defstruct) structure))
  657.     (subseq structure 0 ,(dd-length defstruct))))))
  658.  
  659.  
  660. ;;; Define-Predicate returns a definition for a predicate function if one is
  661. ;;; desired.  This is only called for typed structures, since the default
  662. ;;; structure predicate is implemented as a closure. 
  663.  
  664. (defun define-predicate (defstruct)
  665.   (let ((name (dd-name defstruct))
  666.     (pred (dd-predicate defstruct)))
  667.     (when (and pred (dd-named defstruct))
  668.       (let ((ltype (dd-lisp-type defstruct)))
  669.     `((defun ,pred (object)
  670.         (and (typep object ',ltype)
  671.          (eq (elt (the ,ltype object) ,(dd-offset defstruct))
  672.              ',name))))))))
  673.  
  674.  
  675. ;;; Random sorts of stuff.
  676.  
  677. (defun default-structure-print (structure stream depth)
  678.   (declare (ignore depth))
  679.   (let* ((type (structure-ref structure 0))
  680.      (dd (info type defined-structure-info type)))
  681.     (if *print-pretty*
  682.     (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
  683.       (prin1 type stream)
  684.       (let ((slots (dd-slots dd)))
  685.         (when slots
  686.           (write-char #\space stream)
  687.           (pprint-indent :block 2 stream)
  688.           (pprint-newline :linear stream)
  689.           (loop
  690.         (pprint-pop)
  691.         (let ((slot (pop slots)))
  692.           (write-char #\: stream)
  693.           (output-symbol-name (dsd-%name slot) stream)
  694.           (write-char #\space stream)
  695.           (pprint-newline :miser stream)
  696.           (output-object (structure-ref structure (dsd-index slot))
  697.                  stream)
  698.           (when (null slots)
  699.             (return))
  700.           (write-char #\space stream)
  701.           (pprint-newline :linear stream))))))
  702.     (descend-into (stream)
  703.       (write-string "#S(" stream)
  704.       (prin1 type stream)
  705.       (do ((index 1 (1+ index))
  706.            (length (structure-length structure))
  707.            (slots (dd-slots dd) (cdr slots)))
  708.           ((or (= index length)
  709.            (and *print-length*
  710.             (= index *print-length*)))
  711.            (if (= index length)
  712.            (write-string ")" stream)
  713.            (write-string "...)" stream)))
  714.         (declare (type index index))
  715.         (write-char #\space stream)
  716.         (write-char #\: stream)
  717.         (output-symbol-name (dsd-%name (car slots)) stream)
  718.         (write-char #\space stream)
  719.         (output-object (structure-ref structure index) stream))))))
  720.  
  721.  
  722. (defun make-structure-load-form (structure)
  723.   (declare (type structure structure))
  724.   (let* ((type (structure-ref structure 0))
  725.      (fun (info type load-form-maker type)))
  726.     (etypecase fun
  727.       ((member :just-dump-it-normally :ignore-it)
  728.        fun)
  729.       (null
  730.        (error "Structures of type ~S cannot be dumped as constants." type))
  731.       (function
  732.        (funcall fun structure))
  733.       (symbol
  734.        (funcall (symbol-function fun) structure)))))
  735.