Changeset 4867


Ignore:
Timestamp:
11/22/03 02:49:10 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4863 r4867  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.40 2003-11-21 18:29:28 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.41 2003-11-22 02:49:10 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    3636
    3737(defun make-defstruct-description (&key name
    38                                        conc-name
    39                                        constructors
    40                                        copier
    41                                        include
    42                                        type
    43                                        named
    44                                        initial-offset
    45                                        predicate
    46                                        print-function
    47                                        direct-slots
    48                                        slots)
    49   (let ((dd (make-array 12)))
     38                                        conc-name
     39                                        constructors
     40                                        copier
     41                                        include
     42                                        type
     43                                        named
     44                                        initial-offset
     45                                        predicate
     46                                        print-function
     47                                        direct-slots
     48                                        slots)
     49  (let ((dd (make-array 13)))
    5050    (setf (dd-name dd) name
    5151          (dd-conc-name dd) conc-name
     
    6464;;; DEFSTRUCT-SLOT-DESCRIPTION
    6565
    66 (defmacro dsd-name (x)     `(aref ,x 0))
    67 (defmacro dsd-initform (x) `(aref ,x 1))
    68 (defmacro dsd-index (x)    `(aref ,x 2))
     66(defmacro dsd-name (x)      `(aref ,x 1))
     67(defmacro dsd-index (x)     `(aref ,x 2))
     68(defmacro dsd-reader (x)    `(aref ,x 3))
     69(defmacro dsd-initform (x)  `(aref ,x 4))
     70(defmacro dsd-type (x)      `(aref ,x 5))
     71(defmacro dsd-read-only (x) `(aref ,x 6))
    6972
    7073(defun make-defstruct-slot-description (&key name
     74                                             index
     75                                             reader
    7176                                             initform
    72                                              index)
    73   (let ((dsd (make-array 3)))
    74     (setf (dsd-name dsd) name
     77                                             (type t)
     78                                             read-only)
     79  (let ((dsd (make-array 7)))
     80    (setf (aref dsd 0) 'defstruct-slot-description
     81          (dsd-name dsd) name
     82          (dsd-index dsd) index
     83          (dsd-reader dsd) reader
    7584          (dsd-initform dsd) initform
    76           (dsd-index dsd) index)
     85          (dsd-type dsd) type
     86          (dsd-read-only dsd) read-only)
    7787    dsd))
    7888
     
    97107      (let ((name (dsd-name slot))
    98108            (initform (dsd-initform slot)))
    99         (push (list name initform) keys)
    100         (push name elements)))
     109        (when name
     110          (push (list name initform) keys))))
    101111    (setf keys (cons '&key (nreverse keys)))
     112    (dolist (dsd *dd-slots*)
     113      (let ((name (dsd-name dsd))
     114            (initform (dsd-initform dsd)))
     115        (if name
     116            (push name elements)
     117            (push initform elements))))
    102118    (setf elements (nreverse elements))
    103     (when *dd-named*
    104       (push (list 'quote *dd-name*) elements))
    105 ;;     (when *dd-initial-offset*
    106 ;;       (dotimes (i *dd-initial-offset*)
    107 ;;         (push nil elements)))
    108     (setf elements ())
    109     (let ((index 0))
    110       (dolist (slot *dd-slots*)
    111         (loop
    112           (when (= index (dsd-index slot))
    113             (return))
    114 ;;           (format t "index = ~S slot = ~S dsd-index = ~S~%" index (dsd-name slot) (dsd-index slot))
    115           (push nil elements)
    116           (incf index))
    117         (push (dsd-name slot) elements)
    118         (incf index)))
    119     (setf elements (nreverse elements))
    120     (when *dd-named*
    121       (push (list 'quote *dd-name*) elements))
    122 
    123119    (cond ((eq *dd-type* 'list)
    124120           `((defun ,constructor-name ,keys
     
    147143      (define-constructor (cons (default-constructor-name) nil))))
    148144
     145(defun name-index ()
     146  (dolist (dsd *dd-slots*)
     147    (let ((name (dsd-name dsd))
     148          (initform (dsd-initform dsd)))
     149      (when (and (null name)
     150                 (equal initform (list 'quote *dd-name*)))
     151        (return-from name-index (dsd-index dsd)))))
     152  ;; We shouldn't get here.
     153  nil)
     154
    149155(defun define-predicate ()
    150156  (when (and *dd-predicate*
     
    152158    (let ((pred (intern *dd-predicate*)))
    153159      (cond ((eq *dd-type* 'list)
    154              (if *dd-initial-offset*
    155                  `((defun ,pred (object)
    156                      (and (consp object)
    157                           (> (length object) ,*dd-initial-offset*)
    158                           (eq (elt object ,*dd-initial-offset*) ',*dd-name*))))
    159                  `((defun ,pred (object)
    160                      (and (consp object) (eq (car object) ',*dd-name*))))))
     160             (let ((index (name-index)))
     161               `((defun ,pred (object)
     162                   (and (consp object)
     163                        (> (length object) ,index)
     164                        (eq (nth ,index object) ',*dd-name*))))))
    161165            ((or (eq *dd-type* 'vector)
    162166                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    163              (let ((index (or *dd-initial-offset* 0)))
     167             (let ((index (name-index)))
    164168               `((defun ,pred (object)
    165169                   (and (vectorp object)
     
    171175
    172176(defun get-slot-accessor (index)
    173 ;;   (when *dd-initial-offset*
    174 ;;     (incf index *dd-initial-offset*))
    175   (when *dd-named*
    176     (incf index))
    177177  (cond ((eq *dd-type* 'list)
    178178         `(lambda (instance) (elt instance ,index)))
     
    189189
    190190(defun get-slot-mutator (index)
    191 ;;   (when *dd-initial-offset*
    192 ;;     (incf index *dd-initial-offset*))
    193   (when *dd-named*
    194     (incf index))
    195191  (cond ((eq *dd-type* 'list)
    196192         `(lambda (instance value) (%set-elt instance ,index value)))
     
    220216      (let ((slot-name (dsd-name slot))
    221217            (expected (dsd-index slot)))
    222         (unless (eql index expected)
    223           (format t "index = ~S expected = ~S~%" index expected))
    224 ;;         (setf result (nconc result (define-access-function slot-name index))))
    225218        (setf result (nconc result (define-access-function slot-name expected))))
    226219      (incf index))
     
    314307      (setf (documentation *dd-name* 'structure) (pop slots)))
    315308    (dolist (slot slots)
    316       (let ((slot-description (if (atom slot)
    317                                   (make-defstruct-slot-description :name slot
    318                                                                    :initform nil
    319                                                                    :index 0)
    320                                   (make-defstruct-slot-description :name (car slot)
    321                                                                    :initform (cadr slot)
    322                                                                    :index 0))))
    323         (push slot-description *dd-direct-slots*)))
     309      (let* ((name (if (atom slot) slot (car slot)))
     310             (reader (if *dd-conc-name*
     311                         (intern (concatenate 'string
     312                                              (symbol-name *dd-conc-name*)
     313                                              (symbol-name name)))
     314                         name))
     315             (initform (if (atom slot) nil (cadr slot)))
     316             (dsd (make-defstruct-slot-description :name name
     317                                                   :reader reader
     318                                                   :initform initform)))
     319        (push dsd *dd-direct-slots*)))
    324320    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
    325 
    326321    (let ((index 0))
    327       (if *dd-include*
    328           (let* ((dd (get (car *dd-include*) 'structure-definition))
    329                  (initial-offset (dd-initial-offset dd))
    330                  (included-slots (dd-slots dd)))
    331             (when initial-offset
    332               (incf index initial-offset))
    333             (setf *dd-slots* (append included-slots *dd-direct-slots*))
    334             (incf index (length included-slots)))
    335           (setf *dd-slots* *dd-direct-slots*))
     322      (when *dd-include*
     323        (let* ((dd (get (car *dd-include*) 'structure-definition))
     324               (included-slots (dd-slots dd)))
     325          (dolist (dsd included-slots)
     326            (setf (dsd-index dsd) index)
     327            (push dsd *dd-slots*)
     328            (incf index))))
    336329      (when *dd-initial-offset*
    337         (incf index *dd-initial-offset*))
    338       (dolist (slot *dd-direct-slots*)
    339         (setf (dsd-index slot) index)
     330        (dotimes (i *dd-initial-offset*)
     331          (push (make-defstruct-slot-description :name nil
     332                                                 :index index
     333                                                 :reader nil
     334                                                 :initform nil
     335                                                 :type t
     336                                                 :read-only t)
     337                *dd-slots*)
     338          (incf index)))
     339      (when *dd-named*
     340        (push (make-defstruct-slot-description :name nil
     341                                               :index index
     342                                               :reader nil
     343                                               :initform (list 'quote *dd-name*)
     344                                               :type t
     345                                               :read-only t)
     346              *dd-slots*)
     347        (incf index))
     348      (dolist (dsd *dd-direct-slots*)
     349        (setf (dsd-index dsd) index)
     350        (push dsd *dd-slots*)
    340351        (incf index)))
    341 
     352    (setf *dd-slots* (nreverse *dd-slots*))
    342353    `(progn
    343354       (setf (get ',*dd-name* 'structure-definition)
Note: See TracChangeset for help on using the changeset viewer.