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

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

Work in progress.

File size: 14.3 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defstruct.lisp,v 1.41 2003-11-22 02:49:10 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 13)))
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 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))
72
73(defun make-defstruct-slot-description (&key name
74                                             index
75                                             reader
76                                             initform
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
84          (dsd-initform dsd) initform
85          (dsd-type dsd) type
86          (dsd-read-only dsd) read-only)
87    dsd))
88
89(defvar *dd-name*)
90(defvar *dd-conc-name*)
91(defvar *dd-constructors*)
92(defvar *dd-copier*)
93(defvar *dd-include*)
94(defvar *dd-type*)
95(defvar *dd-named*)
96(defvar *dd-initial-offset*)
97(defvar *dd-predicate*)
98(defvar *dd-print-function*)
99(defvar *dd-direct-slots*)
100(defvar *dd-slots*)
101
102(defun define-constructor (constructor)
103  (let* ((constructor-name (intern (car constructor)))
104         (keys ())
105         (elements ()))
106    (dolist (slot *dd-slots*)
107      (let ((name (dsd-name slot))
108            (initform (dsd-initform slot)))
109        (when name
110          (push (list name initform) keys))))
111    (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))))
118    (setf elements (nreverse elements))
119    (cond ((eq *dd-type* 'list)
120           `((defun ,constructor-name ,keys
121               (list ,@elements))))
122          ((or (eq *dd-type* 'vector)
123               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
124           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
125             `((defun ,constructor-name ,keys
126                 (make-array ,(length elements)
127                             :element-type ',element-type
128                             :initial-contents (list ,@elements))))))
129          (t
130           `((defun ,constructor-name ,keys
131               (%make-structure ',*dd-name* (list ,@elements))))))))
132
133(defun default-constructor-name ()
134  (concatenate 'string "MAKE-" (symbol-name *dd-name*)))
135
136(defun define-constructors ()
137  (if *dd-constructors*
138      (let ((results ()))
139        (dolist (constructor *dd-constructors*)
140          (when (car constructor)
141            (setf results (nconc results (define-constructor constructor)))))
142        results)
143      (define-constructor (cons (default-constructor-name) nil))))
144
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
155(defun define-predicate ()
156  (when (and *dd-predicate*
157             (or *dd-named* (null *dd-type*)))
158    (let ((pred (intern *dd-predicate*)))
159      (cond ((eq *dd-type* 'list)
160             (let ((index (name-index)))
161               `((defun ,pred (object)
162                   (and (consp object)
163                        (> (length object) ,index)
164                        (eq (nth ,index object) ',*dd-name*))))))
165            ((or (eq *dd-type* 'vector)
166                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
167             (let ((index (name-index)))
168               `((defun ,pred (object)
169                   (and (vectorp object)
170                        (> (length object) ,index)
171                        (eq (aref object ,index) ',*dd-name*))))))
172            (t
173             `((defun ,pred (object)
174                 (typep object ',*dd-name*))))))))
175
176(defun get-slot-accessor (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  (cond ((eq *dd-type* 'list)
192         `(lambda (instance value) (%set-elt instance ,index value)))
193        ((or (eq *dd-type* 'vector)
194             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
195         `(lambda (instance value) (%aset instance ,index value)))
196        (t
197         (case index
198           (0 #'%structure-set-0)
199           (1 #'%structure-set-1)
200           (2 #'%structure-set-2)
201           (t
202            `(lambda (instance value) (%structure-set instance ,index value)))))))
203
204(defun define-access-function (slot-name index)
205  (let ((accessor
206         (if *dd-conc-name*
207             (intern (concatenate 'string (symbol-name *dd-conc-name*) (symbol-name slot-name)))
208             slot-name)))
209    `((setf (symbol-function ',accessor) ,(get-slot-accessor index))
210      (%put ',accessor 'setf-inverse ,(get-slot-mutator index )))))
211
212(defun define-access-functions ()
213  (let ((index 0)
214        (result ()))
215    (dolist (slot *dd-slots*)
216      (let ((slot-name (dsd-name slot))
217            (expected (dsd-index slot)))
218        (setf result (nconc result (define-access-function slot-name expected))))
219      (incf index))
220    result))
221
222(defun define-copier ()
223  (when *dd-copier*
224    (cond ((eq *dd-type* 'list)
225           `((setf (fdefinition ',*dd-copier*) #'copy-list)))
226          ((or (eq *dd-type* 'vector)
227               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
228           `((setf (fdefinition ',*dd-copier*) #'copy-seq)))
229          (t
230           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
231
232(defun parse-1-option (option)
233  (case (car option)
234    (:conc-name
235     (setf *dd-conc-name* (if (symbolp (cadr option))
236                              (cadr option)
237                              (make-symbol (string (cadr option))))))
238    (:constructor
239     (let* ((args (cdr option))
240            (numargs (length args))
241            name arglist)
242       (case numargs
243         (0 ; Use default name.
244          (setf name (default-constructor-name))
245          (setf arglist nil)
246          (push (list name arglist) *dd-constructors*))
247         (1
248          (if (null (car args))
249              (setf name nil) ; No constructor.
250              (setf name (symbol-name (car args))))
251          (setf arglist nil)
252          (push (list name arglist) *dd-constructors*))
253         (2))))
254    (:copier
255     (let* ((args (cdr option))
256            (numargs (length args)))
257       (when (= numargs 1)
258          (setf *dd-copier* (car args)))))
259    (:include
260     (setf *dd-include* (cdr option)))
261    (:initial-offset
262     (setf *dd-initial-offset* (cadr option)))
263    (:predicate
264     (when (= (length option) 2)
265       (if (null (cadr option))
266           (setf *dd-predicate* nil)
267           (setf *dd-predicate* (symbol-name (cadr option))))))
268    (:type
269     (setf *dd-type* (cadr option)))
270    (t
271     (format t "unrecognized DEFSTRUCT option: ~S~%" (car option)))))
272
273(defun parse-name-and-options (name-and-options)
274  (setf *dd-name* (car name-and-options))
275  (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
276  (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
277  (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
278  (let ((options (cdr name-and-options)))
279    (dolist (option options)
280      (cond ((consp option)
281             (parse-1-option option))
282            ((eq option :named)
283             (setf *dd-named* t))
284            ((member option '(:constructor :copier :predicate :named
285                              :conc-name))
286             (parse-1-option (list option)))
287            (t
288             (error "unrecognized DEFSTRUCT option: ~S" option))))))
289
290(defmacro defstruct (name-and-options &rest slots)
291  (let ((*dd-name* nil)
292        (*dd-conc-name* nil)
293        (*dd-constructors* nil)
294        (*dd-copier* nil)
295        (*dd-include* nil)
296        (*dd-type* nil)
297        (*dd-named* nil)
298        (*dd-initial-offset* nil)
299        (*dd-predicate* nil)
300        (*dd-print-function* nil)
301        (*dd-direct-slots* ())
302        (*dd-slots* ()))
303    (parse-name-and-options (if (atom name-and-options)
304                                (list name-and-options)
305                                name-and-options))
306    (when (stringp (car slots))
307      (setf (documentation *dd-name* 'structure) (pop slots)))
308    (dolist (slot 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*)))
320    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
321    (let ((index 0))
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))))
329      (when *dd-initial-offset*
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*)
351        (incf index)))
352    (setf *dd-slots* (nreverse *dd-slots*))
353    `(progn
354       (setf (get ',*dd-name* 'structure-definition)
355             (make-defstruct-description :name ',*dd-name*
356                                         :conc-name ',*dd-conc-name*
357                                         :constructors ',*dd-constructors*
358                                         :copier ',*dd-copier*
359                                         :include ',*dd-include*
360                                         :type ',*dd-type*
361                                         :named ,*dd-named*
362                                         :initial-offset ,*dd-initial-offset*
363                                         :predicate ,*dd-predicate*
364                                         :print-function ,*dd-print-function*
365                                         :direct-slots ',*dd-direct-slots*
366                                         :slots ',*dd-slots*))
367       (make-structure-class ',*dd-name* ',*dd-direct-slots* ',*dd-slots*)
368       ,@(define-constructors)
369       ,@(define-predicate)
370       ,@(define-access-functions)
371       ,@(define-copier)
372       ',*dd-name*)))
Note: See TracBrowser for help on using the repository browser.