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

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

Work in progress.

File size: 12.7 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defstruct.lisp,v 1.39 2003-11-21 15:58:30 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    (cond ((eq *dd-type* 'list)
109           `((defun ,constructor-name ,keys
110               (list ,@elements))))
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)))
114             `((defun ,constructor-name ,keys
115                 (make-array ,(length elements)
116                             :element-type ',element-type
117                             :initial-contents (list ,@elements))))))
118          (t
119           `((defun ,constructor-name ,keys
120               (%make-structure ',*dd-name* (list ,@elements))))))))
121
122(defun default-constructor-name ()
123  (concatenate 'string "MAKE-" (symbol-name *dd-name*)))
124
125(defun define-constructors ()
126  (if *dd-constructors*
127      (let ((results ()))
128        (dolist (constructor *dd-constructors*)
129          (when (car constructor)
130            (setf results (nconc results (define-constructor constructor)))))
131        results)
132      (define-constructor (cons (default-constructor-name) nil))))
133
134(defun define-predicate ()
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*
140                 `((defun ,pred (object)
141                     (and (consp object)
142                          (> (length object) ,*dd-initial-offset*)
143                          (eq (elt object ,*dd-initial-offset*) ',*dd-name*))))
144                 `((defun ,pred (object)
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)))
149               `((defun ,pred (object)
150                   (and (vectorp object)
151                        (> (length object) ,index)
152                        (eq (aref object ,index) ',*dd-name*))))))
153            (t
154             `((defun ,pred (object)
155                 (typep object ',*dd-name*))))))))
156
157(defun get-slot-accessor (slot)
158  (when *dd-initial-offset*
159    (incf slot *dd-initial-offset*))
160  (when *dd-named*
161    (incf slot))
162  (cond ((eq *dd-type* 'list)
163         `(lambda (instance) (elt instance ,slot)))
164        ((or (eq *dd-type* 'vector)
165             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
166         `(lambda (instance) (aref instance ,slot)))
167        (t
168         (case slot
169           (0 #'%structure-ref-0)
170           (1 #'%structure-ref-1)
171           (2 #'%structure-ref-2)
172           (t
173            `(lambda (instance) (%structure-ref instance ,slot)))))))
174
175(defun get-slot-mutator (slot)
176  (when *dd-initial-offset*
177    (incf slot *dd-initial-offset*))
178  (when *dd-named*
179    (incf slot))
180  (cond ((eq *dd-type* 'list)
181         `(lambda (instance value) (%set-elt instance ,slot value)))
182        ((or (eq *dd-type* 'vector)
183             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
184         `(lambda (instance value) (%aset instance ,slot value)))
185        (t
186         (case slot
187           (0 #'%structure-set-0)
188           (1 #'%structure-set-1)
189           (2 #'%structure-set-2)
190           (t
191            `(lambda (instance value) (%structure-set instance ,slot value)))))))
192
193(defun define-access-function (slot-name index)
194  (let ((accessor
195         (if *dd-conc-name*
196             (intern (concatenate 'string (symbol-name *dd-conc-name*) (symbol-name slot-name)))
197             slot-name)))
198    `((setf (symbol-function ',accessor) ,(get-slot-accessor index))
199      (%put ',accessor 'setf-inverse ,(get-slot-mutator index )))))
200
201(defun define-access-functions ()
202  (let ((index 0)
203        (result ()))
204    (dolist (slot *dd-slots*)
205;;       (let ((slot-name (getf slot :name)))
206      (let ((slot-name (dsd-name slot)))
207        (setf result (nconc result (define-access-function slot-name index))))
208      (incf index))
209    result))
210
211(defun define-copier ()
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)))
218          (t
219           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
220
221(defun parse-1-option (option)
222  (case (car option)
223    (:conc-name
224     (setf *dd-conc-name* (if (symbolp (cadr option))
225                              (cadr option)
226                              (make-symbol (string (cadr option))))))
227    (:constructor
228     (let* ((args (cdr option))
229            (numargs (length args))
230            name arglist)
231       (case numargs
232         (0 ; Use default name.
233          (setf name (default-constructor-name))
234          (setf arglist nil)
235          (push (list name arglist) *dd-constructors*))
236         (1
237          (if (null (car args))
238              (setf name nil) ; No constructor.
239              (setf name (symbol-name (car args))))
240          (setf arglist nil)
241          (push (list name arglist) *dd-constructors*))
242         (2))))
243    (:copier
244     (let* ((args (cdr option))
245            (numargs (length args)))
246       (when (= numargs 1)
247          (setf *dd-copier* (car args)))))
248    (:include
249     (setf *dd-include* (cdr option)))
250    (:initial-offset
251     (setf *dd-initial-offset* (cadr option)))
252    (:predicate
253     (when (= (length option) 2)
254       (if (null (cadr option))
255           (setf *dd-predicate* nil)
256           (setf *dd-predicate* (symbol-name (cadr option))))))
257    (:type
258     (setf *dd-type* (cadr option)))
259    (t
260     (format t "unrecognized DEFSTRUCT option: ~S~%" (car option)))))
261
262(defun parse-name-and-options (name-and-options)
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"))
267  (let ((options (cdr name-and-options)))
268    (dolist (option options)
269      (cond ((consp option)
270             (parse-1-option option))
271            ((eq option :named)
272             (setf *dd-named* t))
273            ((member option '(:constructor :copier :predicate :named
274                              :conc-name))
275             (parse-1-option (list option)))
276            (t
277             (error "unrecognized DEFSTRUCT option: ~S" option))))))
278
279(defmacro defstruct (name-and-options &rest 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* ()))
292    (parse-name-and-options (if (atom name-and-options)
293                                (list name-and-options)
294                                name-and-options))
295    (when (stringp (car slots))
296      (setf (documentation *dd-name* 'structure) (pop slots)))
297    (dolist (slot slots)
298      (let ((slot-description (if (atom slot)
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*))
312    `(progn
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*)
327       ,@(define-constructors)
328       ,@(define-predicate)
329       ,@(define-access-functions)
330       ,@(define-copier)
331       ',*dd-name*)))
Note: See TracBrowser for help on using the repository browser.