Changeset 4860


Ignore:
Timestamp:
11/21/03 15:58:30 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/defstruct.lisp

    r4858 r4860  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.38 2003-11-21 02:41:22 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.39 2003-11-21 15:58:30 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2020(in-package "SYSTEM")
    2121
    22 (defmacro ds-name (x)           `(aref ,x  0))
    23 (defmacro ds-conc-name (x)      `(aref ,x  1))
    24 (defmacro ds-constructors (x)   `(aref ,x  2))
    25 (defmacro ds-copier (x)         `(aref ,x  3))
    26 (defmacro ds-include (x)        `(aref ,x  4))
    27 (defmacro ds-type (x)           `(aref ,x  5))
    28 (defmacro ds-named (x)          `(aref ,x  6))
    29 (defmacro ds-initial-offset (x) `(aref ,x  7))
    30 (defmacro ds-predicate (x)      `(aref ,x  8))
    31 (defmacro ds-print-function (x) `(aref ,x  9))
    32 (defmacro ds-direct-slots (x)   `(aref ,x 10))
    33 (defmacro ds-slots (x)          `(aref ,x 11))
    34 
    35 (defun make-defstruct-definition (&key name
     22;;; DEFSTRUCT-DESCRIPTION
     23
     24(defmacro dd-name (x)           `(aref ,x  0))
     25(defmacro dd-conc-name (x)      `(aref ,x  1))
     26(defmacro dd-constructors (x)   `(aref ,x  2))
     27(defmacro dd-copier (x)         `(aref ,x  3))
     28(defmacro dd-include (x)        `(aref ,x  4))
     29(defmacro dd-type (x)           `(aref ,x  5))
     30(defmacro dd-named (x)          `(aref ,x  6))
     31(defmacro dd-initial-offset (x) `(aref ,x  7))
     32(defmacro dd-predicate (x)      `(aref ,x  8))
     33(defmacro dd-print-function (x) `(aref ,x  9))
     34(defmacro dd-direct-slots (x)   `(aref ,x 10))
     35(defmacro dd-slots (x)          `(aref ,x 11))
     36
     37(defun make-defstruct-description (&key name
    3638                                       conc-name
    3739                                       constructors
     
    4547                                       direct-slots
    4648                                       slots)
    47   (let ((def (make-array 12)))
    48     (setf (ds-name def) name
    49           (ds-conc-name def) conc-name
    50           (ds-constructors def) constructors
    51           (ds-copier def) copier
    52           (ds-include def) include
    53           (ds-type def) type
    54           (ds-named def) named
    55           (ds-initial-offset def) initial-offset
    56           (ds-predicate def) predicate
    57           (ds-print-function def) print-function
    58           (ds-direct-slots def) direct-slots
    59           (ds-slots def) slots)
    60     def))
    61 
    62 (defvar *ds-name*)
    63 (defvar *ds-conc-name*)
    64 (defvar *ds-constructors*)
    65 (defvar *ds-copier*)
    66 (defvar *ds-include*)
    67 (defvar *ds-type*)
    68 (defvar *ds-named*)
    69 (defvar *ds-initial-offset*)
    70 (defvar *ds-predicate*)
    71 (defvar *ds-print-function*)
    72 (defvar *ds-direct-slots*)
    73 (defvar *ds-slots*)
     49  (let ((dd (make-array 12)))
     50    (setf (dd-name dd) name
     51          (dd-conc-name dd) conc-name
     52          (dd-constructors dd) constructors
     53          (dd-copier dd) copier
     54          (dd-include dd) include
     55          (dd-type dd) type
     56          (dd-named dd) named
     57          (dd-initial-offset dd) initial-offset
     58          (dd-predicate dd) predicate
     59          (dd-print-function dd) print-function
     60          (dd-direct-slots dd) direct-slots
     61          (dd-slots dd) slots)
     62    dd))
     63
     64;;; DEFSTRUCT-SLOT-DESCRIPTION
     65
     66(defmacro dsd-name (x)     `(aref ,x 0))
     67(defmacro dsd-initform (x) `(aref ,x 1))
     68(defmacro dsd-index (x)    `(aref ,x 2))
     69
     70(defun make-defstruct-slot-description (&key name
     71                                             initform
     72                                             index)
     73  (let ((dsd (make-array 3)))
     74    (setf (dsd-name dsd) name
     75          (dsd-initform dsd) initform
     76          (dsd-index dsd) index)
     77    dsd))
     78
     79(defvar *dd-name*)
     80(defvar *dd-conc-name*)
     81(defvar *dd-constructors*)
     82(defvar *dd-copier*)
     83(defvar *dd-include*)
     84(defvar *dd-type*)
     85(defvar *dd-named*)
     86(defvar *dd-initial-offset*)
     87(defvar *dd-predicate*)
     88(defvar *dd-print-function*)
     89(defvar *dd-direct-slots*)
     90(defvar *dd-slots*)
    7491
    7592(defun define-constructor (constructor)
     
    7794         (keys ())
    7895         (elements ()))
    79     (dolist (slot *ds-slots*)
    80       (let ((name (getf slot :name))
    81             (initform (getf slot :initform)))
     96    (dolist (slot *dd-slots*)
     97      (let ((name (dsd-name slot))
     98            (initform (dsd-initform slot)))
    8299        (push (list name initform) keys)
    83100        (push name elements)))
    84101    (setf keys (cons '&key (nreverse keys)))
    85102    (setf elements (nreverse elements))
    86     (when *ds-named*
    87       (push (list 'quote *ds-name*) elements))
    88     (when *ds-initial-offset*
    89       (dotimes (i *ds-initial-offset*)
     103    (when *dd-named*
     104      (push (list 'quote *dd-name*) elements))
     105    (when *dd-initial-offset*
     106      (dotimes (i *dd-initial-offset*)
    90107        (push nil elements)))
    91     (cond ((eq *ds-type* 'list)
     108    (cond ((eq *dd-type* 'list)
    92109           `((defun ,constructor-name ,keys
    93110               (list ,@elements))))
    94           ((or (eq *ds-type* 'vector)
    95                (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
    96            (let ((element-type (if (consp *ds-type*) (cadr *ds-type*) t)))
     111          ((or (eq *dd-type* 'vector)
     112               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
     113           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
    97114             `((defun ,constructor-name ,keys
    98115                 (make-array ,(length elements)
     
    101118          (t
    102119           `((defun ,constructor-name ,keys
    103                (%make-structure ',*ds-name* (list ,@elements))))))))
     120               (%make-structure ',*dd-name* (list ,@elements))))))))
    104121
    105122(defun default-constructor-name ()
    106   (concatenate 'string "MAKE-" (symbol-name *ds-name*)))
     123  (concatenate 'string "MAKE-" (symbol-name *dd-name*)))
    107124
    108125(defun define-constructors ()
    109   (if *ds-constructors*
     126  (if *dd-constructors*
    110127      (let ((results ()))
    111         (dolist (constructor *ds-constructors*)
     128        (dolist (constructor *dd-constructors*)
    112129          (when (car constructor)
    113130            (setf results (nconc results (define-constructor constructor)))))
     
    116133
    117134(defun define-predicate ()
    118   (when (and *ds-predicate*
    119              (or *ds-named* (null *ds-type*)))
    120     (let ((pred (intern *ds-predicate*)))
    121       (cond ((eq *ds-type* 'list)
    122              (if *ds-initial-offset*
     135  (when (and *dd-predicate*
     136             (or *dd-named* (null *dd-type*)))
     137    (let ((pred (intern *dd-predicate*)))
     138      (cond ((eq *dd-type* 'list)
     139             (if *dd-initial-offset*
    123140                 `((defun ,pred (object)
    124141                     (and (consp object)
    125                           (> (length object) ,*ds-initial-offset*)
    126                           (eq (elt object ,*ds-initial-offset*) ',*ds-name*))))
     142                          (> (length object) ,*dd-initial-offset*)
     143                          (eq (elt object ,*dd-initial-offset*) ',*dd-name*))))
    127144                 `((defun ,pred (object)
    128                      (and (consp object) (eq (car object) ',*ds-name*))))))
    129             ((or (eq *ds-type* 'vector)
    130                  (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
    131              (let ((index (or *ds-initial-offset* 0)))
     145                     (and (consp object) (eq (car object) ',*dd-name*))))))
     146            ((or (eq *dd-type* 'vector)
     147                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
     148             (let ((index (or *dd-initial-offset* 0)))
    132149               `((defun ,pred (object)
    133150                   (and (vectorp object)
    134151                        (> (length object) ,index)
    135                         (eq (aref object ,index) ',*ds-name*))))))
     152                        (eq (aref object ,index) ',*dd-name*))))))
    136153            (t
    137154             `((defun ,pred (object)
    138                  (typep object ',*ds-name*))))))))
     155                 (typep object ',*dd-name*))))))))
    139156
    140157(defun get-slot-accessor (slot)
    141   (when *ds-initial-offset*
    142     (incf slot *ds-initial-offset*))
    143   (when *ds-named*
     158  (when *dd-initial-offset*
     159    (incf slot *dd-initial-offset*))
     160  (when *dd-named*
    144161    (incf slot))
    145   (cond ((eq *ds-type* 'list)
     162  (cond ((eq *dd-type* 'list)
    146163         `(lambda (instance) (elt instance ,slot)))
    147         ((or (eq *ds-type* 'vector)
    148              (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
     164        ((or (eq *dd-type* 'vector)
     165             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    149166         `(lambda (instance) (aref instance ,slot)))
    150167        (t
     
    157174
    158175(defun get-slot-mutator (slot)
    159   (when *ds-initial-offset*
    160     (incf slot *ds-initial-offset*))
    161   (when *ds-named*
     176  (when *dd-initial-offset*
     177    (incf slot *dd-initial-offset*))
     178  (when *dd-named*
    162179    (incf slot))
    163   (cond ((eq *ds-type* 'list)
     180  (cond ((eq *dd-type* 'list)
    164181         `(lambda (instance value) (%set-elt instance ,slot value)))
    165         ((or (eq *ds-type* 'vector)
    166              (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
     182        ((or (eq *dd-type* 'vector)
     183             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    167184         `(lambda (instance value) (%aset instance ,slot value)))
    168185        (t
     
    176193(defun define-access-function (slot-name index)
    177194  (let ((accessor
    178          (if *ds-conc-name*
    179              (intern (concatenate 'string (symbol-name *ds-conc-name*) (symbol-name slot-name)))
     195         (if *dd-conc-name*
     196             (intern (concatenate 'string (symbol-name *dd-conc-name*) (symbol-name slot-name)))
    180197             slot-name)))
    181198    `((setf (symbol-function ',accessor) ,(get-slot-accessor index))
     
    185202  (let ((index 0)
    186203        (result ()))
    187     (dolist (slot *ds-slots*)
    188       (let ((slot-name (getf slot :name)))
     204    (dolist (slot *dd-slots*)
     205;;       (let ((slot-name (getf slot :name)))
     206      (let ((slot-name (dsd-name slot)))
    189207        (setf result (nconc result (define-access-function slot-name index))))
    190208      (incf index))
     
    192210
    193211(defun define-copier ()
    194   (when *ds-copier*
    195     (cond ((eq *ds-type* 'list)
    196            `((setf (fdefinition ',*ds-copier*) #'copy-list)))
    197           ((or (eq *ds-type* 'vector)
    198                (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
    199            `((setf (fdefinition ',*ds-copier*) #'copy-seq)))
     212  (when *dd-copier*
     213    (cond ((eq *dd-type* 'list)
     214           `((setf (fdefinition ',*dd-copier*) #'copy-list)))
     215          ((or (eq *dd-type* 'vector)
     216               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
     217           `((setf (fdefinition ',*dd-copier*) #'copy-seq)))
    200218          (t
    201            `((setf (fdefinition ',*ds-copier*) #'copy-structure))))))
     219           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
    202220
    203221(defun parse-1-option (option)
    204222  (case (car option)
    205223    (:conc-name
    206      (setf *ds-conc-name* (if (symbolp (cadr option))
     224     (setf *dd-conc-name* (if (symbolp (cadr option))
    207225                              (cadr option)
    208226                              (make-symbol (string (cadr option))))))
     
    215233          (setf name (default-constructor-name))
    216234          (setf arglist nil)
    217           (push (list name arglist) *ds-constructors*))
     235          (push (list name arglist) *dd-constructors*))
    218236         (1
    219237          (if (null (car args))
     
    221239              (setf name (symbol-name (car args))))
    222240          (setf arglist nil)
    223           (push (list name arglist) *ds-constructors*))
     241          (push (list name arglist) *dd-constructors*))
    224242         (2))))
    225243    (:copier
     
    227245            (numargs (length args)))
    228246       (when (= numargs 1)
    229           (setf *ds-copier* (car args)))))
     247          (setf *dd-copier* (car args)))))
    230248    (:include
    231      (setf *ds-include* (cdr option)))
     249     (setf *dd-include* (cdr option)))
    232250    (:initial-offset
    233      (setf *ds-initial-offset* (cadr option)))
     251     (setf *dd-initial-offset* (cadr option)))
    234252    (:predicate
    235253     (when (= (length option) 2)
    236254       (if (null (cadr option))
    237            (setf *ds-predicate* nil)
    238            (setf *ds-predicate* (symbol-name (cadr option))))))
     255           (setf *dd-predicate* nil)
     256           (setf *dd-predicate* (symbol-name (cadr option))))))
    239257    (:type
    240      (setf *ds-type* (cadr option)))
     258     (setf *dd-type* (cadr option)))
    241259    (t
    242260     (format t "unrecognized DEFSTRUCT option: ~S~%" (car option)))))
    243261
    244262(defun parse-name-and-options (name-and-options)
    245   (setf *ds-name* (car name-and-options))
    246   (setf *ds-conc-name* (make-symbol (concatenate 'string (symbol-name *ds-name*) "-")))
    247   (setf *ds-copier* (intern (concatenate 'string "COPY-" (symbol-name *ds-name*))))
    248   (setf *ds-predicate* (concatenate 'string (symbol-name *ds-name*) "-P"))
     263  (setf *dd-name* (car name-and-options))
     264  (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
     265  (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
     266  (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
    249267  (let ((options (cdr name-and-options)))
    250268    (dolist (option options)
     
    252270             (parse-1-option option))
    253271            ((eq option :named)
    254              (setf *ds-named* t))
     272             (setf *dd-named* t))
    255273            ((member option '(:constructor :copier :predicate :named
    256274                              :conc-name))
     
    260278
    261279(defmacro defstruct (name-and-options &rest slots)
    262   (let ((*ds-name* nil)
    263         (*ds-conc-name* nil)
    264         (*ds-constructors* nil)
    265         (*ds-copier* nil)
    266         (*ds-include* nil)
    267         (*ds-type* nil)
    268         (*ds-named* nil)
    269         (*ds-initial-offset* nil)
    270         (*ds-predicate* nil)
    271         (*ds-print-function* nil)
    272         (*ds-direct-slots* ())
    273         (*ds-slots* ()))
     280  (let ((*dd-name* nil)
     281        (*dd-conc-name* nil)
     282        (*dd-constructors* nil)
     283        (*dd-copier* nil)
     284        (*dd-include* nil)
     285        (*dd-type* nil)
     286        (*dd-named* nil)
     287        (*dd-initial-offset* nil)
     288        (*dd-predicate* nil)
     289        (*dd-print-function* nil)
     290        (*dd-direct-slots* ())
     291        (*dd-slots* ()))
    274292    (parse-name-and-options (if (atom name-and-options)
    275293                                (list name-and-options)
    276294                                name-and-options))
    277295    (when (stringp (car slots))
    278       (setf (documentation *ds-name* 'structure) (pop slots)))
     296      (setf (documentation *dd-name* 'structure) (pop slots)))
    279297    (dolist (slot slots)
    280298      (let ((slot-description (if (atom slot)
    281                                   (list :name slot :initform nil)
    282                                   (list :name (car slot) :initform (cadr slot)))))
    283         (push slot-description *ds-direct-slots*)))
    284     (setf *ds-direct-slots* (nreverse *ds-direct-slots*))
    285     (if *ds-include*
    286         (let* ((def (get (car *ds-include*) 'structure-definition))
    287                (included-slots (ds-slots def)))
    288           (setf *ds-slots* (append included-slots *ds-direct-slots*)))
    289         (setf *ds-slots* *ds-direct-slots*))
     299                                  (make-defstruct-slot-description :name slot
     300                                                                   :initform nil
     301                                                                   :index 0)
     302                                  (make-defstruct-slot-description :name (car slot)
     303                                                                   :initform (cadr slot)
     304                                                                   :index 0))))
     305        (push slot-description *dd-direct-slots*)))
     306    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
     307    (if *dd-include*
     308        (let* ((def (get (car *dd-include*) 'structure-definition))
     309               (included-slots (dd-slots def)))
     310          (setf *dd-slots* (append included-slots *dd-direct-slots*)))
     311        (setf *dd-slots* *dd-direct-slots*))
    290312    `(progn
    291        (setf (get ',*ds-name* 'structure-definition)
    292              (make-defstruct-definition :name ',*ds-name*
    293                                         :conc-name ',*ds-conc-name*
    294                                         :constructors ',*ds-constructors*
    295                                         :copier ',*ds-copier*
    296                                         :include ',*ds-include*
    297                                         :type ',*ds-type*
    298                                         :named ,*ds-named*
    299                                         :initial-offset ,*ds-initial-offset*
    300                                         :predicate ,*ds-predicate*
    301                                         :print-function ,*ds-print-function*
    302                                         :direct-slots ',*ds-direct-slots*
    303                                         :slots ',*ds-slots*))
    304        (make-structure-class ',*ds-name* ',*ds-direct-slots* ',*ds-slots*)
     313       (setf (get ',*dd-name* 'structure-definition)
     314             (make-defstruct-description :name ',*dd-name*
     315                                         :conc-name ',*dd-conc-name*
     316                                         :constructors ',*dd-constructors*
     317                                         :copier ',*dd-copier*
     318                                         :include ',*dd-include*
     319                                         :type ',*dd-type*
     320                                         :named ,*dd-named*
     321                                         :initial-offset ,*dd-initial-offset*
     322                                         :predicate ,*dd-predicate*
     323                                         :print-function ,*dd-print-function*
     324                                         :direct-slots ',*dd-direct-slots*
     325                                         :slots ',*dd-slots*))
     326       (make-structure-class ',*dd-name* ',*dd-direct-slots* ',*dd-slots*)
    305327       ,@(define-constructors)
    306328       ,@(define-predicate)
    307329       ,@(define-access-functions)
    308330       ,@(define-copier)
    309        ',*ds-name*)))
     331       ',*dd-name*)))
Note: See TracChangeset for help on using the changeset viewer.