source: trunk/j/src/org/armedbear/lisp/defstruct.lisp @ 4863

Last change on this file since 4863 was 4863, checked in by piso, 18 years ago

Work in progress.

File size: 13.8 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defstruct.lisp,v 1.40 2003-11-21 18:29:28 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "SYSTEM")
21
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
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)))
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*)
91
92(defun define-constructor (constructor)
93  (let* ((constructor-name (intern (car constructor)))
94         (keys ())
95         (elements ()))
96    (dolist (slot *dd-slots*)
97      (let ((name (dsd-name slot))
98            (initform (dsd-initform slot)))
99        (push (list name initform) keys)
100        (push name elements)))
101    (setf keys (cons '&key (nreverse keys)))
102    (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
123    (cond ((eq *dd-type* 'list)
124           `((defun ,constructor-name ,keys
125               (list ,@elements))))
126          ((or (eq *dd-type* 'vector)
127               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
128           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
129             `((defun ,constructor-name ,keys
130                 (make-array ,(length elements)
131                             :element-type ',element-type
132                             :initial-contents (list ,@elements))))))
133          (t
134           `((defun ,constructor-name ,keys
135               (%make-structure ',*dd-name* (list ,@elements))))))))
136
137(defun default-constructor-name ()
138  (concatenate 'string "MAKE-" (symbol-name *dd-name*)))
139
140(defun define-constructors ()
141  (if *dd-constructors*
142      (let ((results ()))
143        (dolist (constructor *dd-constructors*)
144          (when (car constructor)
145            (setf results (nconc results (define-constructor constructor)))))
146        results)
147      (define-constructor (cons (default-constructor-name) nil))))
148
149(defun define-predicate ()
150  (when (and *dd-predicate*
151             (or *dd-named* (null *dd-type*)))
152    (let ((pred (intern *dd-predicate*)))
153      (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*))))))
161            ((or (eq *dd-type* 'vector)
162                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
163             (let ((index (or *dd-initial-offset* 0)))
164               `((defun ,pred (object)
165                   (and (vectorp object)
166                        (> (length object) ,index)
167                        (eq (aref object ,index) ',*dd-name*))))))
168            (t
169             `((defun ,pred (object)
170                 (typep object ',*dd-name*))))))))
171
172(defun get-slot-accessor (index)
173;;   (when *dd-initial-offset*
174;;     (incf index *dd-initial-offset*))
175  (when *dd-named*
176    (incf index))
177  (cond ((eq *dd-type* 'list)
178         `(lambda (instance) (elt instance ,index)))
179        ((or (eq *dd-type* 'vector)
180             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
181         `(lambda (instance) (aref instance ,index)))
182        (t
183         (case index
184           (0 #'%structure-ref-0)
185           (1 #'%structure-ref-1)
186           (2 #'%structure-ref-2)
187           (t
188            `(lambda (instance) (%structure-ref instance ,index)))))))
189
190(defun get-slot-mutator (index)
191;;   (when *dd-initial-offset*
192;;     (incf index *dd-initial-offset*))
193  (when *dd-named*
194    (incf index))
195  (cond ((eq *dd-type* 'list)
196         `(lambda (instance value) (%set-elt instance ,index value)))
197        ((or (eq *dd-type* 'vector)
198             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
199         `(lambda (instance value) (%aset instance ,index value)))
200        (t
201         (case index
202           (0 #'%structure-set-0)
203           (1 #'%structure-set-1)
204           (2 #'%structure-set-2)
205           (t
206            `(lambda (instance value) (%structure-set instance ,index value)))))))
207
208(defun define-access-function (slot-name index)
209  (let ((accessor
210         (if *dd-conc-name*
211             (intern (concatenate 'string (symbol-name *dd-conc-name*) (symbol-name slot-name)))
212             slot-name)))
213    `((setf (symbol-function ',accessor) ,(get-slot-accessor index))
214      (%put ',accessor 'setf-inverse ,(get-slot-mutator index )))))
215
216(defun define-access-functions ()
217  (let ((index 0)
218        (result ()))
219    (dolist (slot *dd-slots*)
220      (let ((slot-name (dsd-name slot))
221            (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))))
225        (setf result (nconc result (define-access-function slot-name expected))))
226      (incf index))
227    result))
228
229(defun define-copier ()
230  (when *dd-copier*
231    (cond ((eq *dd-type* 'list)
232           `((setf (fdefinition ',*dd-copier*) #'copy-list)))
233          ((or (eq *dd-type* 'vector)
234               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
235           `((setf (fdefinition ',*dd-copier*) #'copy-seq)))
236          (t
237           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
238
239(defun parse-1-option (option)
240  (case (car option)
241    (:conc-name
242     (setf *dd-conc-name* (if (symbolp (cadr option))
243                              (cadr option)
244                              (make-symbol (string (cadr option))))))
245    (:constructor
246     (let* ((args (cdr option))
247            (numargs (length args))
248            name arglist)
249       (case numargs
250         (0 ; Use default name.
251          (setf name (default-constructor-name))
252          (setf arglist nil)
253          (push (list name arglist) *dd-constructors*))
254         (1
255          (if (null (car args))
256              (setf name nil) ; No constructor.
257              (setf name (symbol-name (car args))))
258          (setf arglist nil)
259          (push (list name arglist) *dd-constructors*))
260         (2))))
261    (:copier
262     (let* ((args (cdr option))
263            (numargs (length args)))
264       (when (= numargs 1)
265          (setf *dd-copier* (car args)))))
266    (:include
267     (setf *dd-include* (cdr option)))
268    (:initial-offset
269     (setf *dd-initial-offset* (cadr option)))
270    (:predicate
271     (when (= (length option) 2)
272       (if (null (cadr option))
273           (setf *dd-predicate* nil)
274           (setf *dd-predicate* (symbol-name (cadr option))))))
275    (:type
276     (setf *dd-type* (cadr option)))
277    (t
278     (format t "unrecognized DEFSTRUCT option: ~S~%" (car option)))))
279
280(defun parse-name-and-options (name-and-options)
281  (setf *dd-name* (car name-and-options))
282  (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
283  (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
284  (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
285  (let ((options (cdr name-and-options)))
286    (dolist (option options)
287      (cond ((consp option)
288             (parse-1-option option))
289            ((eq option :named)
290             (setf *dd-named* t))
291            ((member option '(:constructor :copier :predicate :named
292                              :conc-name))
293             (parse-1-option (list option)))
294            (t
295             (error "unrecognized DEFSTRUCT option: ~S" option))))))
296
297(defmacro defstruct (name-and-options &rest slots)
298  (let ((*dd-name* nil)
299        (*dd-conc-name* nil)
300        (*dd-constructors* nil)
301        (*dd-copier* nil)
302        (*dd-include* nil)
303        (*dd-type* nil)
304        (*dd-named* nil)
305        (*dd-initial-offset* nil)
306        (*dd-predicate* nil)
307        (*dd-print-function* nil)
308        (*dd-direct-slots* ())
309        (*dd-slots* ()))
310    (parse-name-and-options (if (atom name-and-options)
311                                (list name-and-options)
312                                name-and-options))
313    (when (stringp (car slots))
314      (setf (documentation *dd-name* 'structure) (pop slots)))
315    (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*)))
324    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
325
326    (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*))
336      (when *dd-initial-offset*
337        (incf index *dd-initial-offset*))
338      (dolist (slot *dd-direct-slots*)
339        (setf (dsd-index slot) index)
340        (incf index)))
341
342    `(progn
343       (setf (get ',*dd-name* 'structure-definition)
344             (make-defstruct-description :name ',*dd-name*
345                                         :conc-name ',*dd-conc-name*
346                                         :constructors ',*dd-constructors*
347                                         :copier ',*dd-copier*
348                                         :include ',*dd-include*
349                                         :type ',*dd-type*
350                                         :named ,*dd-named*
351                                         :initial-offset ,*dd-initial-offset*
352                                         :predicate ,*dd-predicate*
353                                         :print-function ,*dd-print-function*
354                                         :direct-slots ',*dd-direct-slots*
355                                         :slots ',*dd-slots*))
356       (make-structure-class ',*dd-name* ',*dd-direct-slots* ',*dd-slots*)
357       ,@(define-constructors)
358       ,@(define-predicate)
359       ,@(define-access-functions)
360       ,@(define-copier)
361       ',*dd-name*)))
Note: See TracBrowser for help on using the repository browser.