home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / defstruct.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  30.6 KB  |  879 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;    DEFSTRUCT.LSP
  21. ;;;;
  22. ;;;;        The structure routines.
  23.  
  24.  
  25. (in-package 'lisp)
  26. (export 'defstruct)
  27.  
  28.  
  29. (in-package 'system)
  30.  
  31.  
  32. (proclaim '(optimize (safety 2) (space 3)))
  33.  
  34.  
  35.  
  36. (in-package 'system)
  37.  
  38.  
  39.  
  40. (defvar *accessors* (make-array 10 :adjustable t))
  41. (defvar *list-accessors* (make-array 2 :adjustable t))
  42. (defvar *vector-accessors* (make-array 2 :adjustable t))
  43.  
  44. (or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
  45.                    #'(lambda (&rest l) l nil)))
  46.  
  47. (defun make-access-function (name conc-name type named include no-fun
  48.                   ;; from apply
  49.                   slot-name default-init slot-type read-only
  50.                   offset &optional predicate ) 
  51.   (declare (ignore named default-init predicate ))
  52.   
  53.   (let ((access-function
  54.       (intern (si:string-concatenate (string conc-name)
  55.                      (string slot-name))))
  56.     accsrs dont-overwrite)
  57.     (ecase type
  58.       ((nil)
  59.        (setf accsrs *accessors*))
  60.       (list
  61.     (setf accsrs *list-accessors*))
  62.       (vector
  63.     (setf accsrs *vector-accessors*)))
  64.     (or (> (length  accsrs) offset)
  65.     (adjust-array accsrs (+ offset 10)))
  66.     (unless
  67.      dont-overwrite
  68.      (record-fn access-function 'defun '(t) slot-type)
  69.      (or no-fun
  70.      (and (fboundp access-function)
  71.           (eq (aref accsrs offset) (symbol-function access-function)))
  72.      (setf (symbol-function access-function)
  73.        (or (aref accsrs offset)
  74.            (setf (aref accsrs offset)
  75.              (cond  ((eq accsrs *accessors*)
  76.                 #'(lambda (x)
  77.                     (or (structurep x)
  78.                     (error "~a is not a structure" x))
  79.                     (structure-ref1 x offset)))
  80.                    ((eq accsrs *list-accessors*)
  81.                 #'(lambda(x)
  82.                     (si:list-nth offset x)))
  83.                    ((eq accsrs *vector-accessors*)
  84.                 #'(lambda(x)
  85.                     (aref x offset)))))))))
  86.     (cond (read-only
  87.         (remprop access-function 'structure-access)
  88.         (setf (get access-function 'struct-read-only) t))
  89.       (t (remprop access-function 'setf-update-fn)
  90.          (remprop access-function 'setf-lambda)
  91.          (remprop access-function 'setf-documentation)
  92.          (let ((tem (get access-function 'structure-access)))
  93.            (cond ((and (consp tem) include
  94.                (subtypep include (car tem))
  95.                (eql (cdr tem) offset))
  96.               ;; don't change overwrite accessor of subtype.
  97.               (setq dont-overwrite t)
  98.               )
  99.              (t  (setf (get access-function 'structure-access)
  100.                    (cons (if type type name) offset)))))))
  101.     nil))
  102.  
  103.  
  104. (defun make-constructor (name constructor type named
  105.                          slot-descriptions)
  106.   (declare (ignore named))
  107.   (let ((slot-names
  108.          ;; Collect the slot-names.
  109.          (mapcar #'(lambda (x)
  110.                      (cond ((null x)
  111.                             ;; If the slot-description is NIL,
  112.                             ;;  it is in the padding of initial-offset.
  113.                             nil)
  114.                            ((null (car x))
  115.                             ;; If the slot name is NIL,
  116.                             ;;  it is the structure name.
  117.                             ;;  This is for typed structures with names.
  118.                             (list 'quote (cadr x)))
  119.                            (t (car x))))
  120.                  slot-descriptions))
  121.         (keys
  122.          ;; Make the keyword parameters.
  123.          (mapcan #'(lambda (x)
  124.                      (cond ((null x) nil)
  125.                            ((null (car x)) nil)
  126.                            ((null (cadr x)) (list (car x)))
  127.                            (t (list (list  (car x) (cadr x))))))
  128.                  slot-descriptions)))
  129.     (cond ((consp constructor)
  130.            ;; The case for a BOA constructor.
  131.            ;; Dirty code!!
  132.            ;; We must add an initial value for an optional parameter,
  133.            ;;  if the default value is not specified
  134.            ;;  in the given parameter list and yet the initial value
  135.            ;;  is supplied in the slot description.
  136.            (do ((a (cadr constructor) (cdr a)) (l nil) (vs nil))
  137.                ((endp a)
  138.                 ;; Add those options that do not appear in the parameter list
  139.                 ;;  as auxiliary paramters.
  140.                 ;; The parameters are accumulated in the variable VS.
  141.                 (setq keys
  142.                       (nreconc (cons '&aux l)
  143.                                (mapcan #'(lambda (k)
  144.                                            (if (member (if (atom k) k (car k))
  145.                                                        vs)
  146.                                                nil
  147.                                                (list k)))
  148.                                        keys))))
  149.              ;; Skip until &OPTIONAL appears.
  150.          (when (member (car a) lambda-list-keywords)
  151.            (or (eq (car a) '&optional) (push '&optional a)))
  152.              (cond ((eq (car a) '&optional)
  153.                     (setq l (cons '&optional l))
  154.                     (do ((aa (cdr a) (cdr aa)) (ov) (y))
  155.                         ((endp aa)
  156.                          ;; Add those options that do not appear in the
  157.                          ;;  parameter list.
  158.                          (setq keys
  159.                                (nreconc (cons '&aux l)
  160.                                         (mapcan #'(lambda (k)
  161.                                                     (if (member (if (atom k)
  162.                                                                     k
  163.                                                                     (car k))
  164.                                                                 vs)
  165.                                                         nil
  166.                                                         (list k)))
  167.                                                 keys)))
  168.                          (return nil))
  169.                       (when (member (car aa) lambda-list-keywords)
  170.                             (when (eq (car aa) '&rest)
  171.                                   ;; &REST is found.
  172.                                   (setq l (cons '&rest l))
  173.                                   (setq aa (cdr aa))
  174.                                   (unless (and (not (endp aa))
  175.                                                (symbolp (car aa)))
  176.                                           (illegal-boa))
  177.                                   (setq vs (cons (car aa) vs))
  178.                                   (setq l (cons (car aa) l))
  179.                                   (setq aa (cdr aa))
  180.                                   (when (endp aa)
  181.                                         (setq keys
  182.                                               (nreconc
  183.                                                (cons '&aux l)
  184.                                                (mapcan
  185.                                                 #'(lambda (k)
  186.                                                     (if (member (if (atom k)
  187.                                                                     k
  188.                                                                     (car k))
  189.                                                                 vs)
  190.                                                         nil
  191.                                                         (list k)))
  192.                                                 keys)))
  193.                                         (return nil)))
  194.                             ;; &AUX should follow.
  195.                             (unless (eq (car aa) '&aux)
  196.                                     (illegal-boa))
  197.                             (setq l (cons '&aux l))
  198.                             (do ((aaa (cdr aa) (cdr aaa)))
  199.                                 ((endp aaa))
  200.                               (setq l (cons (car aaa) l))
  201.                               (cond ((and (atom (car aaa))
  202.                                           (symbolp (car aaa)))
  203.                                      (setq vs (cons (car aaa) vs)))
  204.                                     ((and (symbolp (caar aaa))
  205.                                           (or (endp (cdar aaa))
  206.                                               (endp (cddar aaa))))
  207.                                      (setq vs (cons (caar aaa) vs)))
  208.                                     (t (illegal-boa))))
  209.                             ;; End of the parameter list.
  210.                             (setq keys
  211.                                   (nreconc l
  212.                                            (mapcan
  213.                                             #'(lambda (k)
  214.                                                 (if (member (if (atom k)
  215.                                                                 k
  216.                                                                 (car k))
  217.                                                             vs)
  218.                                                     nil
  219.                                                     (list k)))
  220.                                             keys)))
  221.                             (return nil))
  222.                       ;; Checks if the optional paramter without a default
  223.                       ;;  value has a default value in the slot-description.
  224.                       (if (and (cond ((atom (car aa)) (setq ov (car aa)) t)
  225.                                      ((endp (cdar aa)) (setq ov (caar aa)) t)
  226.                                      (t nil))
  227.                                (setq y (member ov
  228.                                                keys
  229.                                                :key
  230.                                                #'(lambda (x)
  231.                                                    (if (consp x)
  232.                                                        ;; With default value.
  233.                                                        (car x))))))
  234.                           ;; If no default value is supplied for
  235.                           ;;  the optional parameter and yet appears
  236.                           ;;  in KEYS with a default value,
  237.                           ;;  then cons the pair to L,
  238.                           (setq l (cons (car y) l))
  239.                           ;;  otherwise cons just the parameter to L.
  240.                           (setq l (cons (car aa) l)))
  241.                       ;; Checks the form of the optional parameter.
  242.                       (cond ((atom (car aa))
  243.                              (unless (symbolp (car aa))
  244.                                      (illegal-boa))
  245.                              (setq vs (cons (car aa) vs)))
  246.                             ((not (symbolp (caar aa)))
  247.                              (illegal-boa))
  248.                             ((or (endp (cdar aa)) (endp (cddar aa)))
  249.                              (setq vs (cons (caar aa) vs)))
  250.                             ((not (symbolp (caddar aa)))
  251.                              (illegal-boa))
  252.                             ((not (endp (cdddar aa)))
  253.                              (illegal-boa))
  254.                             (t
  255.                              (setq vs (cons (caar aa) vs))
  256.                              (setq vs (cons (caddar aa) vs)))))
  257.                     ;; RETURN from the outside DO.
  258.                     (return nil))
  259.                    (t
  260.                     (unless (symbolp (car a))
  261.                             (illegal-boa))
  262.                     (setq l (cons (car a) l))
  263.                     (setq vs (cons (car a) vs)))))
  264.            (setq constructor (car constructor)))
  265.           (t
  266.            ;; If not a BOA constructor, just cons &KEY.
  267.            (setq keys (cons '&key keys))))
  268.     (cond ((null type)
  269.            `(defun ,constructor ,keys
  270.               (si:make-structure ',name ,@slot-names)))
  271.           ((or (eq type 'vector)
  272.                (and (consp type) (eq (car type) 'vector)))
  273.            `(defun ,constructor ,keys
  274.               (vector ,@slot-names)))
  275.           ((eq type 'list)
  276.            `(defun ,constructor ,keys
  277.               (list ,@slot-names)))
  278.           ((error "~S is an illegal structure type" type)))))
  279.  
  280. (defun illegal-boa ()
  281.   (error "An illegal BOA constructor."))
  282.  
  283. (defun make-predicate (name predicate type named name-offset)
  284.   (cond ((null type))
  285.      ; done in define-structure
  286.         ((or (eq type 'vector)
  287.              (and (consp type) (eq (car type) 'vector)))
  288.          ;; The name is at the NAME-OFFSET in the vector.
  289.          (unless named (error "The structure should be named."))
  290.          `(defun ,predicate (x)
  291.             (and (vectorp x)
  292.                  (> (the fixnum (length x)) ,name-offset)
  293.                  (eq (aref (the (vector t) x) ,name-offset) ',name))))
  294.         ((eq type 'list)
  295.          ;; The name is at the NAME-OFFSET in the list.
  296.          (unless named (error "The structure should be named."))
  297.          (if (= name-offset 0)
  298.              `(defun ,predicate (x)
  299.                      (and (consp x)
  300.                           (eq (car x) ',name)))
  301.              `(defun ,predicate (x)
  302.                      (do ((i ,name-offset (1- i))
  303.                           (y x (cdr y)))
  304.                          ((= i 0) (and (consp y) (eq (car y) ',name)))
  305.              (declare (fixnum i))
  306.                        (unless (consp y) (return nil))))))
  307.         ((error "~S is an illegal structure type."))))
  308.  
  309.  
  310. ;;; PARSE-SLOT-DESCRIPTION parses the given slot-description
  311. ;;;  and returns a list of the form:
  312. ;;;        (slot-name default-init slot-type read-only offset)
  313.  
  314. (defun parse-slot-description (slot-description offset)
  315.   (let (slot-name default-init slot-type read-only)
  316.     (cond ((atom slot-description)
  317.            (setq slot-name slot-description))
  318.           ((endp (cdr slot-description))
  319.            (setq slot-name (car slot-description)))
  320.           (t
  321.            (setq slot-name (car slot-description))
  322.            (setq default-init (cadr slot-description))
  323.            (do ((os (cddr slot-description) (cddr os)) (o) (v))
  324.                ((endp os))
  325.              (setq o (car os))
  326.              (when (endp (cdr os))
  327.                    (error "~S is an illegal structure slot option."
  328.                           os))
  329.              (setq v (cadr os))
  330.              (case o
  331.                (:type (setq slot-type v))
  332.                (:read-only (setq read-only v))
  333.                (t
  334.                 (error "~S is an illegal structure slot option."
  335.                          os))))))
  336.     (list slot-name default-init slot-type read-only offset)))
  337.  
  338.  
  339. ;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
  340. ;;;  with the new descriptions which are specified in the
  341. ;;;  :include defstruct option.
  342.  
  343. (defun overwrite-slot-descriptions (news olds)
  344.   (if (null olds)
  345.       nil
  346.       (let ((sds (member (caar olds) news :key #'car)))
  347.         (cond (sds
  348.                (when (and (null (cadddr (car sds)))
  349.                           (cadddr (car olds)))
  350.                      ;; If read-only is true in the old
  351.                      ;;  and false in the new, signal an error.
  352.                      (error "~S is an illegal include slot-description."
  353.                             sds))
  354.            ;; If
  355.            (setf (caddr (car sds))
  356.              (best-array-element-type (caddr (car sds))))
  357.            (when (not  (equal (normalize-type (or (caddr (car sds)) t))
  358.                  (normalize-type (or (caddr (car olds)) t))))
  359.              (error "Type mismmatch for included slot ~a" (car sds)))
  360.              (cons (list (caar sds)
  361.                            (cadar sds)
  362.                            (caddar sds)
  363.                            (cadddr (car sds))
  364.                            ;; The offset if from the old.
  365.                            (car (cddddr (car olds))))
  366.                      (overwrite-slot-descriptions news (cdr olds))))
  367.               (t
  368.                (cons (car olds)
  369.                      (overwrite-slot-descriptions news (cdr olds))))))))
  370.  
  371. (defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))
  372.  
  373. (defun make-t-type (n include slot-descriptions &aux i)
  374.   (let ((res  (make-array n :element-type 'unsigned-char :static t)))
  375.     (when include
  376.       (let ((tem (get include 's-data))raw)
  377.         (or tem (error "Included structure undefined ~a" include))
  378.         (setq raw (s-data-raw tem))
  379.       (dotimes (i (min n (length raw)))
  380.            (setf (aref res i) (aref raw i)))))
  381.     (dolist (v slot-descriptions)
  382.         (setq i (nth 4 v))
  383.         (let ((type (third v)))
  384.           (cond ((<= (the fixnum (alignment type)) #. (alignment t))
  385.              (setf (aref res i) (aet-type type))))))
  386.     (cond ((< n (length *all-t-s-type*))
  387.        (dotimes (i n)
  388.           (cond ((not (eql (the fixnum (aref res i)) 0))
  389.              (return-from make-t-type res))))
  390.        *all-t-s-type*)
  391.       (t res))))
  392.  
  393. (defvar *standard-slot-positions*
  394.   (let ((ar (make-array 50 :element-type 'unsigned-short
  395.             :static t))) 
  396.     (dotimes (i 50)
  397.          (declare (fixnum i))
  398.          (setf (aref ar i)(* #. (size-of t) i)))
  399.     ar))
  400.  
  401. (eval-when (compile )
  402. (proclaim '(function round-up (fixnum fixnum ) fixnum))
  403. )
  404.  
  405. (defun round-up (a b)
  406.   (declare (fixnum a b))
  407.   (setq a (ceiling a b))
  408.   (the fixnum (* a b)))
  409.  
  410.  
  411. (defun get-slot-pos (leng include slot-descriptions &aux type small-types
  412.               has-holes) 
  413.   (declare (special *standard-slot-positions*)) include
  414.   (dolist (v slot-descriptions)
  415.       (when (and v (car v))
  416.         (setf type 
  417.               (best-array-element-type (caddr v))
  418.               (caddr v) type)
  419.         (let ((val (second v)))
  420.           (unless (typep val type)
  421.               (if (and (symbolp val)
  422.                    (constantp val))
  423.                   (setf val (symbol-value val)))
  424.               (and (constantp val)
  425.                    (setf (cadr v) (coerce val type)))))
  426.         (cond ((memq type '(signed-char unsigned-char
  427.                         short unsigned-short
  428.                      long-float
  429.                      bit))
  430.                (setq small-types t)))))
  431.   (cond ((and (null small-types)
  432.           (< leng (length *standard-slot-positions*))
  433.           (list  *standard-slot-positions* (* leng #. (size-of t)) nil)))
  434.     (t (let ((ar (make-array leng :element-type 'unsigned-short
  435.                  :static t))
  436.          (pos 0)(i 0)(align 0)type (next-pos 0))
  437.          (declare (fixnum pos i align next-pos))
  438.          ;; A default array.
  439.            
  440.          (dolist
  441.            (v slot-descriptions)
  442.            (setq type (caddr v))
  443.            (setq align (alignment type))
  444.            (unless (<= align #. (alignment t))
  445.                (setq type t)
  446.                (setf (caddr v) t)
  447.                (setq align #. (alignment t))
  448.                (setq v (nconc v '(t))))
  449.            (setq next-pos (round-up pos align))    
  450.            (or (eql pos next-pos) (setq has-holes t))
  451.            (setq pos next-pos)
  452.            (setf (aref ar i) pos)
  453.            (incf pos (size-of type))
  454.            (incf i))
  455.          (list ar (round-up pos (size-of t)) has-holes)
  456.          ))))
  457.  
  458.  
  459.  
  460.  
  461.            
  462.                
  463.                
  464.                
  465.                
  466.                
  467.                
  468.              
  469.          
  470.      
  471.      
  472.  
  473.  
  474.                             
  475.                 
  476.                   
  477.            
  478.      
  479.  
  480. (defun define-structure (name conc-name type named slot-descriptions copier
  481.                   static include print-function constructors
  482.                   offset predicate &optional documentation no-funs
  483.                   &aux def leng)
  484.   (and (consp type) (eq (car type) 'vector)(setq type 'vector))
  485.   (setq leng(length slot-descriptions))
  486.   (dolist (x slot-descriptions)
  487.        (and x (car x)
  488.         (apply #'make-access-function
  489.                                      name conc-name type named include no-funs
  490.                                      x )))
  491.   (when (and copier (not no-funs))
  492.     (setf (symbol-function copier)
  493.           (ecase type
  494.         ((nil) #'si::copy-structure)
  495.         (list #'copy-list)
  496.         (vector #'copy-seq))))
  497.         
  498.  
  499.   (cond ((and (null type)
  500.           (eq name 's-data))
  501.      ;bootstrapping code!
  502.      (setq def (make-s-data-structure
  503.              (make-array leng
  504.                  :element-type 'fixnum :static t)
  505.              (make-t-type leng nil slot-descriptions)
  506.              *standard-slot-positions*
  507.              slot-descriptions
  508.              t
  509.              ))
  510.      )
  511.     (t
  512.       (let (slot-position
  513.          (size 0) has-holes
  514.          (include-str (and include
  515.                    (get include 's-data))))
  516.         (when include-str
  517.           (cond ((and (s-data-frozen include-str)
  518.                   (or (not (s-data-included include-str))
  519.                   (not (let ((te (get name 's-data)))
  520.                      (and te
  521.                           (eq (s-data-includes 
  522.                             te)
  523.                           include-str))))))
  524.              (warn " ~a was frozen but now included"
  525.                    include)))
  526.           (pushnew name (s-data-included include-str)))
  527.         (when (null type)
  528.          (setf slot-position
  529.                (get-slot-pos leng include slot-descriptions))
  530.          (setf size (cadr slot-position)
  531.                has-holes (caddr slot-position)
  532.                slot-position (car slot-position)
  533.                ))
  534.       (setf def (make-s-data
  535.                :name name
  536.                :length leng
  537.                :raw
  538.                (and (null type)
  539.                 (make-t-type leng include slot-descriptions))
  540.                :slot-position slot-position
  541.                :size size
  542.                :has-holes has-holes
  543.                :staticp static
  544.                :includes include-str
  545.                :print-function print-function
  546.                :slot-descriptions slot-descriptions
  547.                :constructors constructors
  548.                :offset offset
  549.                :type type
  550.                :named named
  551.                :documentation documentation
  552.                :conc-name conc-name)))))
  553.   (let ((tem (get name 's-data)))
  554.     (cond ((eq name 's-data)
  555.        (if tem (warn "not replacing s-data property"))
  556.        (or tem (setf (get name 's-data) def)))
  557.       (tem 
  558.        (check-s-data tem def name))
  559.       (t  (setf (get name 's-data) def)))
  560.     (when documentation
  561.       (setf (get name 'structure-documentation)
  562.         documentation))
  563.     (when (and  (null type)  predicate)
  564.       (record-fn predicate 'defun '(t) t)
  565.       (or no-funs
  566.           (setf (symbol-function predicate)
  567.             #'(lambda (x)
  568.             (si::structure-subtype-p x name))))
  569.       (setf (get predicate 'compiler::co1)
  570.         'compiler::co1structure-predicate)
  571.       (setf (get predicate 'struct-predicate) name)
  572.       )
  573.   ) nil)
  574.  
  575.           
  576. (defmacro defstruct (name &rest slots)
  577.   (let ((slot-descriptions slots)
  578.         options
  579.         conc-name
  580.         constructors default-constructor no-constructor
  581.         copier
  582.         predicate predicate-specified
  583.         include
  584.         print-function type named initial-offset
  585.         offset name-offset
  586.         documentation
  587.     static)
  588.  
  589.     (when (consp name)
  590.       ;; The defstruct options are supplied.
  591.           (setq options (cdr name))
  592.           (setq name (car name)))
  593.  
  594.     ;; The default conc-name.
  595.     (setq conc-name (si:string-concatenate (string name) "-"))
  596.  
  597.     ;; The default constructor.
  598.     (setq default-constructor
  599.           (intern (si:string-concatenate "MAKE-" (string name))))
  600.  
  601.     ;; The default copier and predicate.
  602.     (setq copier
  603.           (intern (si:string-concatenate "COPY-" (string name)))
  604.           predicate
  605.           (intern (si:string-concatenate (string name) "-P")))
  606.  
  607.     ;; Parse the defstruct options.
  608.     (do ((os options (cdr os)) (o) (v))
  609.         ((endp os))
  610.     (cond ((and (consp (car os)) (not (endp (cdar os))))
  611.            (setq o (caar os) v (cadar os))
  612.            (case o
  613.          (:conc-name
  614.            (if (null v)
  615.                (setq conc-name "")
  616.              (setq conc-name v)))
  617.          (:constructor
  618.            (if (null v)
  619.                (setq no-constructor t)
  620.              (if (endp (cddar os))
  621.              (setq constructors (cons v constructors))
  622.                (setq constructors (cons (cdar os) constructors)))))
  623.          (:copier (setq copier v))
  624.          (:static (setq static v))
  625.          (:predicate
  626.            (setq predicate v)
  627.            (setq predicate-specified t))
  628.          (:include
  629.            (setq include (cdar os))
  630.            (unless (get v 's-data)
  631.                (error "~S is an illegal included structure." v)))
  632.          (:print-function
  633.           (and (consp v) (eq (car v) 'function)
  634.                (setq v (second v)))
  635.           (setq print-function v))
  636.          (:type (setq type v))
  637.          (:initial-offset (setq initial-offset v))
  638.          (t (error "~S is an illegal defstruct option." o))))
  639.           (t
  640.         (if (consp (car os))
  641.             (setq o (caar os))
  642.           (setq o (car os)))
  643.         (case o
  644.           (:constructor
  645.             (setq constructors
  646.               (cons default-constructor constructors)))
  647.           ((:conc-name :copier :predicate :print-function))
  648.           (:named (setq named t))
  649.           (t (error "~S is an illegal defstruct option." o))))))
  650.  
  651.     (setq conc-name (intern (string conc-name)))
  652.  
  653.     (and include (not print-function)
  654.      (setq print-function (s-data-print-function (get (car include)  's-data))))
  655.  
  656.     ;; Skip the documentation string.
  657.     (when (and (not (endp slot-descriptions))
  658.                (stringp (car slot-descriptions)))
  659.           (setq documentation (car slot-descriptions))
  660.           (setq slot-descriptions (cdr slot-descriptions)))
  661.     
  662.     ;; Check the include option.
  663.     (when include
  664.           (unless (equal type
  665.              (s-data-type (get  (car include) 's-data)))
  666.                   (error "~S is an illegal structure include."
  667.                          (car include))))
  668.  
  669.     ;; Set OFFSET.
  670.     (cond ((null include)
  671.            (setq offset 0))
  672.           (t 
  673.         (setq offset (s-data-offset (get (car include) 's-data)))))
  674.  
  675.     ;; Increment OFFSET.
  676.     (when (and type initial-offset)
  677.           (setq offset (+ offset initial-offset)))
  678.     (when (and type named)
  679.           (setq name-offset offset)
  680.           (setq offset (1+ offset)))
  681.  
  682.     ;; Parse slot-descriptions, incrementing OFFSET for each one.
  683.     (do ((ds slot-descriptions (cdr ds))
  684.          (sds nil))
  685.         ((endp ds)
  686.          (setq slot-descriptions (nreverse sds)))
  687.     (setq sds (cons (parse-slot-description (car ds) offset) sds))
  688.     (setq offset (1+ offset)))
  689.  
  690.     ;; If TYPE is non-NIL and structure is named,
  691.     ;;  add the slot for the structure-name to the slot-descriptions.
  692.     (when (and type named)
  693.           (setq slot-descriptions
  694.                 (cons (list nil name) slot-descriptions)))
  695.  
  696.     ;; Pad the slot-descriptions with the initial-offset number of NILs.
  697.     (when (and type initial-offset)
  698.           (setq slot-descriptions
  699.                 (append (make-list initial-offset) slot-descriptions)))
  700.  
  701.     ;; Append the slot-descriptions of the included structure.
  702.     ;; The slot-descriptions in the include option are also counted.
  703.     (cond ((null include))
  704.           ((endp (cdr include))
  705.            (setq slot-descriptions
  706.                  (append (s-data-slot-descriptions
  707.                (get (car include) 's-data))
  708.                          slot-descriptions)))
  709.           (t
  710.         (setq slot-descriptions
  711.           (append (overwrite-slot-descriptions
  712.                 (mapcar #'(lambda (sd)
  713.                     (parse-slot-description sd 0))
  714.                     (cdr include))
  715.                 (s-data-slot-descriptions
  716.                   (get (car include) 's-data)
  717.                               ))
  718.               slot-descriptions))))
  719.  
  720.     (cond (no-constructor
  721.         ;; If a constructor option is NIL,
  722.         ;;  no constructor should have been specified.
  723.         (when constructors
  724.           (error "Contradictory constructor options.")))
  725.           ((null constructors)
  726.        ;; If no constructor is specified,
  727.        ;;  the default-constructor is made.
  728.            (setq constructors (list default-constructor))))
  729.  
  730.     ;; We need a default constructor for the sharp-s-reader
  731.     (or (member t (mapcar 'symbolp  constructors))
  732.     (push (intern (string-concatenate "__si::" default-constructor))
  733.               constructors))
  734.  
  735.     ;; Check the named option and set the predicate.
  736.     (when (and type (not named))
  737.           (when predicate-specified
  738.                 (error "~S is an illegal structure predicate."
  739.                        predicate))
  740.           (setq predicate nil))
  741.  
  742.     (when include (setq include (car include)))
  743.  
  744.     ;; Check the print-function.
  745.     (when (and print-function type)
  746.           (error "A print function is supplied to a typed structure."))
  747.     
  748.     `(progn
  749.        (define-structure ',name  ',conc-name ',type
  750.      ',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors 
  751.      ',offset ',predicate ',documentation 
  752.      )
  753.  
  754.        ,@(mapcar #'(lambda (constructor)
  755.              (make-constructor name constructor type named
  756.                        slot-descriptions))
  757.          constructors)
  758.        ,@(if (and type predicate)
  759.          (list (make-predicate name predicate type named
  760.                    name-offset)))
  761.        ',name
  762.        )))
  763.  
  764. ;; First several fields of this must coincide with the C structure
  765. ;; s_data (see object.h).
  766.  
  767.  
  768. (defstruct s-data name
  769.          (length 0 :type fixnum)
  770.          raw
  771.          included
  772.          includes
  773.          staticp
  774.          print-function
  775.          slot-descriptions
  776.          slot-position 
  777.          (size 0 :type fixnum)
  778.          has-holes
  779.          frozen
  780.          documentation
  781.          constructors
  782.          offset
  783.          named
  784.          type
  785.          conc-name
  786.          )
  787.  
  788.  
  789. (defun check-s-data (tem def name)
  790.   (cond ((s-data-included tem)
  791.      (setf (s-data-included def)(s-data-included tem))))
  792.   (cond ((s-data-frozen tem)
  793.      (setf (s-data-frozen def) t)))
  794.   (unless (equalp def tem)
  795.       (warn "structure ~a is changing" name)
  796.       (setf (get name 's-data) def)))
  797. (defun freeze-defstruct (name)
  798.   (let ((tem (and (symbolp name) (get name 's-data))))
  799.     (if tem (setf (s-data-frozen tem) t))))
  800.  
  801.  
  802. ;;; The #S reader.
  803.  
  804. (defun sharp-s-reader (stream subchar arg)
  805.   (declare (ignore subchar))
  806.   (when (and arg (null *read-suppress*))
  807.         (error "An extra argument was supplied for the #S readmacro."))
  808.   (let* ((l (prog1 (read stream t nil t)
  809.           (if *read-suppress*
  810.           (return-from sharp-s-reader nil))))
  811.      (sd
  812.        (or (get (car l) 's-data)
  813.            
  814.            (error "~S is not a structure." (car l)))))
  815.     
  816.     ;; Intern keywords in the keyword package.
  817.     (do ((ll (cdr l) (cddr ll)))
  818.         ((endp ll)
  819.          ;; Find an appropriate construtor.
  820.          (do ((cs (s-data-constructors sd) (cdr cs)))
  821.              ((endp cs)
  822.               (error "The structure ~S has no structure constructor."
  823.                      (car l)))
  824.            (when (symbolp (car cs))
  825.                  (return (apply (car cs) (cdr l))))))
  826.       (rplaca ll (intern (string (car ll)) 'keyword)))))
  827.  
  828.  
  829. ;; Set the dispatch macro.
  830. (set-dispatch-macro-character #\# #\s 'sharp-s-reader)
  831. (set-dispatch-macro-character #\# #\S 'sharp-s-reader)
  832.  
  833. ;; Examples from Common Lisp Reference Manual.
  834.  
  835. #|
  836. (defstruct ship
  837.   x-position
  838.   y-position
  839.   x-velocity
  840.   y-velocity
  841.   mass)
  842.  
  843. (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
  844.                             sex)
  845. (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
  846.                             sex)
  847. (defstruct person1 name (age 20 :type fixnum)
  848.                             sex)
  849.  
  850. (defstruct joe a (a1 0 :type (mod  30)) (a2 0 :type (mod  30))
  851.   (a3 0 :type (mod  30)) (a4 0 :type (mod 30)) )
  852.  
  853. ;(defstruct person name age sex)
  854.  
  855. (defstruct (astronaut (:include person (age 45 :type fixnum))
  856.                       (:conc-name astro-))
  857.   helmet-size
  858.   (favorite-beverage 'tang))
  859.  
  860. (defstruct (foo (:constructor create-foo (a
  861.                                           &optional b (c 'sea)
  862.                                           &rest d
  863.                                           &aux e (f 'eff))))
  864.   a (b 'bee) c d e f)
  865.  
  866. (defstruct (binop (:type list) :named (:initial-offset 2))
  867.   (operator '?)
  868.   operand-1
  869.   operand-2)
  870.  
  871. (defstruct (annotated-binop (:type list)
  872.                             (:initial-offset 3)
  873.                             (:include binop))
  874.   commutative
  875.   associative
  876.   identity)
  877.  
  878. |#
  879.