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

Last change on this file since 8176 was 8176, checked in by piso, 17 years ago

DEFINE-PREDICATE: TYPEP => SYS:SIMPLE-TYPEP

File size: 21.5 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: defstruct.lisp,v 1.58 2004-11-21 05:37:26 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(require :source-transform)
23
24;;; DEFSTRUCT-DESCRIPTION
25
26(defmacro dd-name (x)           `(aref ,x  0))
27(defmacro dd-conc-name (x)      `(aref ,x  1))
28(defmacro dd-constructors (x)   `(aref ,x  2))
29(defmacro dd-copier (x)         `(aref ,x  3))
30(defmacro dd-include (x)        `(aref ,x  4))
31(defmacro dd-type (x)           `(aref ,x  5))
32(defmacro dd-named (x)          `(aref ,x  6))
33(defmacro dd-initial-offset (x) `(aref ,x  7))
34(defmacro dd-predicate (x)      `(aref ,x  8))
35(defmacro dd-print-function (x) `(aref ,x  9))
36(defmacro dd-direct-slots (x)   `(aref ,x 10))
37(defmacro dd-slots (x)          `(aref ,x 11))
38
39(defun make-defstruct-description (&key name
40                                        conc-name
41                                        constructors
42                                        copier
43                                        include
44                                        type
45                                        named
46                                        initial-offset
47                                        predicate
48                                        print-function
49                                        direct-slots
50                                        slots)
51  (let ((dd (make-array 13)))
52    (setf (dd-name dd) name
53          (dd-conc-name dd) conc-name
54          (dd-constructors dd) constructors
55          (dd-copier dd) copier
56          (dd-include dd) include
57          (dd-type dd) type
58          (dd-named dd) named
59          (dd-initial-offset dd) initial-offset
60          (dd-predicate dd) predicate
61          (dd-print-function dd) print-function
62          (dd-direct-slots dd) direct-slots
63          (dd-slots dd) slots)
64    dd))
65
66;;; DEFSTRUCT-SLOT-DESCRIPTION
67
68(defmacro dsd-name (x)      `(aref ,x 1))
69(defmacro dsd-index (x)     `(aref ,x 2))
70(defmacro dsd-reader (x)    `(aref ,x 3))
71(defmacro dsd-initform (x)  `(aref ,x 4))
72(defmacro dsd-type (x)      `(aref ,x 5))
73(defmacro dsd-read-only (x) `(aref ,x 6))
74
75(defun make-defstruct-slot-description (&key name
76                                             index
77                                             reader
78                                             initform
79                                             (type t)
80                                             read-only)
81  (let ((dsd (make-array 7)))
82    (setf (aref dsd 0) 'defstruct-slot-description
83          (dsd-name dsd) name
84          (dsd-index dsd) index
85          (dsd-reader dsd) reader
86          (dsd-initform dsd) initform
87          (dsd-type dsd) type
88          (dsd-read-only dsd) read-only)
89    dsd))
90
91(defvar *dd-name*)
92(defvar *dd-conc-name*)
93(defvar *dd-constructors*)
94(defvar *dd-copier*)
95(defvar *dd-include*)
96(defvar *dd-type*)
97(defvar *dd-named*)
98(defvar *dd-initial-offset*)
99(defvar *dd-predicate*)
100(defvar *dd-print-function*)
101(defvar *dd-direct-slots*)
102(defvar *dd-slots*)
103
104(defun keywordify (symbol)
105  (intern (symbol-name symbol) *keyword-package*))
106
107(defun define-keyword-constructor (constructor)
108  (let* ((constructor-name (intern (car constructor)))
109         (keys ())
110         (values ()))
111    (dolist (slot *dd-slots*)
112      (let ((name (dsd-name slot))
113            (initform (dsd-initform slot)))
114        (if name
115            (progn
116              (push (list (list (keywordify name) name) initform) keys)
117              (push name values))
118            (push initform values))))
119    (setf keys (cons '&key (nreverse keys))
120          values (nreverse values))
121    (cond ((eq *dd-type* 'list)
122           `((defun ,constructor-name ,keys
123               (list ,@values))))
124          ((or (eq *dd-type* 'vector)
125               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
126           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
127             `((defun ,constructor-name ,keys
128                 (make-array ,(length values)
129                             :element-type ',element-type
130                             :initial-contents (list ,@values))))))
131          (t
132           `((defun ,constructor-name ,keys
133               (%make-structure ',*dd-name* (list ,@values))))))))
134
135(defun find-dsd (name)
136  (dolist (dsd *dd-slots*)
137    (when (string= name (dsd-name dsd))
138      (return dsd))))
139
140(defun get-slot (name)
141;;   (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name)))
142  (let ((res nil))
143    (dolist (dsd *dd-slots*)
144      (when (string= name (dsd-name dsd))
145        (setf res dsd)
146        (return)))
147    (if res
148        (values (dsd-type res) (dsd-initform res))
149        (values t nil))))
150
151(defun define-boa-constructor (constructor)
152  (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
153    (parse-lambda-list (cadr constructor))
154    (let ((arglist ())
155          (vars ())
156          (types ())
157          (skipped-vars ()))
158      (dolist (arg req)
159        (push arg arglist)
160        (push arg vars)
161        (push (get-slot arg) types))
162      (when opt
163        (push '&optional arglist)
164        (dolist (arg opt)
165          (cond ((consp arg)
166                 (destructuring-bind
167                  (name
168                   &optional
169                   (def (nth-value 1 (get-slot name)))
170                   (supplied-test nil supplied-test-p))
171                  arg
172                  (push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist)
173                  (push name vars)
174                  (push (get-slot name) types)))
175                (t
176                 (multiple-value-bind (type default) (get-slot arg)
177                   (push `(,arg ,default) arglist)
178                   (push arg vars)
179                   (push type types))))))
180      (when restp
181        (push '&rest arglist)
182        (push rest arglist)
183        (push rest vars)
184        (push 'list types))
185      (when keyp
186        (push '&key arglist)
187        (dolist (key keys)
188          (if (consp key)
189              (destructuring-bind (wot
190                                   &optional
191                                   (def nil def-p)
192                                   (supplied-test nil supplied-test-p))
193                                  key
194                                  (let ((name (if (consp wot)
195                                                  (destructuring-bind (key var) wot
196                                                                      (declare (ignore key))
197                                                                      var)
198                                                  wot)))
199                                    (multiple-value-bind (type slot-def)
200                                      (get-slot name)
201                                      (push `(,wot ,(if def-p def slot-def)
202                                                   ,@(if supplied-test-p `(,supplied-test) nil))
203                                            arglist)
204                                      (push name vars)
205                                      (push type types))))
206              (multiple-value-bind (type default) (get-slot key)
207                (push `(,key ,default) arglist)
208                (push key vars)
209                (push type types)))))
210      (when allowp
211        (push '&allow-other-keys arglist))
212      (when auxp
213        (push '&aux arglist)
214        (dolist (arg aux)
215          (push arg arglist)
216          (if (and (consp arg) (= (length arg) 2))
217              (let ((var (first arg)))
218                (push var vars)
219                (push (get-slot var) types))
220              (push (if (consp arg) (first arg) arg) skipped-vars))))
221      (setf arglist (nreverse arglist)
222            var (nreverse vars)
223            types (nreverse types)
224            skipped-vars (nreverse skipped-vars))
225      (let ((values ()))
226        (dolist (dsd *dd-slots*)
227          (let ((name (dsd-name dsd))
228                var)
229            (cond ((find name skipped-vars :test #'string=)
230                   (push nil values))
231                  ((setf var (find name vars :test #'string=))
232                   (push var values))
233                  (t
234                   (push (dsd-initform dsd) values)))))
235        (setf values (nreverse values))
236        (let* ((constructor-name (intern (car constructor))))
237          (cond ((eq *dd-type* 'list)
238                 `((defun ,constructor-name ,arglist
239                     (list ,@values))))
240                ((or (eq *dd-type* 'vector)
241                     (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
242                 (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
243                   `((defun ,constructor-name ,arglist
244                       (make-array ,(length values)
245                                   :element-type ',element-type
246                                   :initial-contents (list ,@values))))))
247                (t
248                 `((defun ,constructor-name ,arglist
249                     (%make-structure ',*dd-name* (list ,@values)))))))))))
250
251(defun default-constructor-name ()
252  (concatenate 'string "MAKE-" (symbol-name *dd-name*)))
253
254(defun define-constructors ()
255  (if *dd-constructors*
256      (let ((results ()))
257        (dolist (constructor *dd-constructors*)
258          (when (car constructor)
259            (setf results (nconc results
260                                 (if (cadr constructor)
261                                     (define-boa-constructor constructor)
262                                     (define-keyword-constructor constructor))))))
263        results)
264      (define-keyword-constructor (cons (default-constructor-name) nil))))
265
266(defun name-index ()
267  (dolist (dsd *dd-slots*)
268    (let ((name (dsd-name dsd))
269          (initform (dsd-initform dsd)))
270      (when (and (null name)
271                 (equal initform (list 'quote *dd-name*)))
272        (return-from name-index (dsd-index dsd)))))
273  ;; We shouldn't get here.
274  nil)
275
276(defun define-predicate ()
277  (when (and *dd-predicate*
278             (or *dd-named* (null *dd-type*)))
279    (let ((pred (intern *dd-predicate*)))
280      (cond ((eq *dd-type* 'list)
281             (let ((index (name-index)))
282               `((defun ,pred (object)
283                   (and (consp object)
284                        (> (length object) ,index)
285                        (eq (nth ,index object) ',*dd-name*))))))
286            ((or (eq *dd-type* 'vector)
287                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
288             (let ((index (name-index)))
289               `((defun ,pred (object)
290                   (and (vectorp object)
291                        (> (length object) ,index)
292                        (eq (aref object ,index) ',*dd-name*))))))
293            (t
294             `((defun ,pred (object)
295                 (simple-typep object ',*dd-name*))))))))
296
297(defun define-reader (slot)
298  (let ((accessor-name (if *dd-conc-name*
299                           (intern (concatenate 'string
300                                                (symbol-name *dd-conc-name*)
301                                                (symbol-name (dsd-name slot))))
302                           (dsd-name slot)))
303        (index (dsd-index slot)))
304    (cond ((eq *dd-type* 'list)
305           `((defun ,accessor-name (instance) (elt instance ,index))))
306          ((or (eq *dd-type* 'vector)
307               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
308           `((defun ,accessor-name (instance) (aref instance ,index))))
309          (t
310           `((defun ,accessor-name (instance) (%structure-ref instance ,index))
311             (define-source-transform ,accessor-name (instance)
312               `(%structure-ref ,instance ,,index)))))))
313
314(defun define-writer (slot)
315  (let ((accessor-name (if *dd-conc-name*
316                           (intern (concatenate 'string
317                                                (symbol-name *dd-conc-name*)
318                                                (symbol-name (dsd-name slot))))
319                           (dsd-name slot)))
320        (index (dsd-index slot)))
321    (cond ((eq *dd-type* 'list)
322           `((defun (setf ,accessor-name) (value instance)
323               (%set-elt instance ,index value))))
324          ((or (eq *dd-type* 'vector)
325               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
326           `((defun (setf ,accessor-name) (value instance)
327               (%aset instance ,index value))))
328          (t
329           `((defun (setf ,accessor-name) (value instance)
330               (%structure-set instance ,index value))
331             (define-source-transform (setf ,accessor-name) (value instance)
332               `(%structure-set ,instance ,,index ,value)))))))
333
334(defun define-access-functions ()
335  (let ((result ()))
336    (dolist (slot *dd-slots*)
337      (setf result (nconc result (define-reader slot)))
338      (unless (dsd-read-only slot)
339        (setf result (nconc result (define-writer slot)))))
340    result))
341
342(defun define-copier ()
343  (when *dd-copier*
344    (cond ((eq *dd-type* 'list)
345           `((setf (fdefinition ',*dd-copier*) #'copy-list)))
346          ((or (eq *dd-type* 'vector)
347               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
348           `((setf (fdefinition ',*dd-copier*) #'copy-seq)))
349          (t
350           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
351
352(defun parse-1-option (option)
353  (case (car option)
354    (:conc-name
355     (setf *dd-conc-name* (if (symbolp (cadr option))
356                              (cadr option)
357                              (make-symbol (string (cadr option))))))
358    (:constructor
359     (let* ((args (cdr option))
360            (numargs (length args))
361            name arglist)
362       (case numargs
363         (0 ; Use default name.
364          (setf name (default-constructor-name)
365                arglist nil)
366          (push (list name arglist) *dd-constructors*))
367         (1
368          (if (null (car args))
369              (setf name nil) ; No constructor.
370              (setf name (symbol-name (car args))))
371          (setf arglist nil)
372          (push (list name arglist) *dd-constructors*))
373         (2
374          (setf name (symbol-name (car args))
375                arglist (cadr args))
376          (push (list name arglist) *dd-constructors*)))))
377    (:copier
378     (let* ((args (cdr option))
379            (numargs (length args)))
380       (when (= numargs 1)
381          (setf *dd-copier* (car args)))))
382    (:include
383     (setf *dd-include* (cdr option)))
384    (:initial-offset
385     (setf *dd-initial-offset* (cadr option)))
386    (:predicate
387     (when (= (length option) 2)
388       (if (null (cadr option))
389           (setf *dd-predicate* nil)
390           (setf *dd-predicate* (symbol-name (cadr option))))))
391    (:type
392     (setf *dd-type* (cadr option)))))
393
394(defun parse-name-and-options (name-and-options)
395  (setf *dd-name* (car name-and-options))
396  (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
397  (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
398  (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
399  (let ((options (cdr name-and-options)))
400    (dolist (option options)
401      (cond ((consp option)
402             (parse-1-option option))
403            ((eq option :named)
404             (setf *dd-named* t))
405            ((member option '(:constructor :copier :predicate :named
406                              :conc-name))
407             (parse-1-option (list option)))
408            (t
409             (error "Unrecognized DEFSTRUCT option: ~S." option))))))
410
411(defmacro defstruct (name-and-options &rest slots)
412  (let ((*dd-name* nil)
413        (*dd-conc-name* nil)
414        (*dd-constructors* nil)
415        (*dd-copier* nil)
416        (*dd-include* nil)
417        (*dd-type* nil)
418        (*dd-named* nil)
419        (*dd-initial-offset* nil)
420        (*dd-predicate* nil)
421        (*dd-print-function* nil)
422        (*dd-direct-slots* ())
423        (*dd-slots* ()))
424    (parse-name-and-options (if (atom name-and-options)
425                                (list name-and-options)
426                                name-and-options))
427    (when (stringp (car slots))
428      (%set-documentation *dd-name* 'structure (pop slots)))
429    (dolist (slot slots)
430      (let* ((name (if (atom slot) slot (car slot)))
431             (reader (if *dd-conc-name*
432                         (intern (concatenate 'string
433                                              (symbol-name *dd-conc-name*)
434                                              (symbol-name name)))
435                         name))
436             (initform (if (atom slot) nil (cadr slot)))
437             (dsd (apply #'make-defstruct-slot-description
438                         :name name
439                         :reader reader
440                         :initform initform
441                         (if (atom slot) nil (cddr slot)))))
442        (push dsd *dd-direct-slots*)))
443    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
444    (let ((index 0))
445      (when *dd-include*
446        (let ((dd (get (car *dd-include*) 'structure-definition)))
447          (unless dd
448            (error 'simple-error
449                   :format-control "Class ~S is undefined."
450                   :format-arguments (list (car *dd-include*))))
451          (dolist (dsd (dd-slots dd))
452            (setf (dsd-index dsd) index)
453            (push dsd *dd-slots*)
454            (incf index)))
455        (when (cdr *dd-include*)
456          (dolist (slot (cdr *dd-include*))
457            (let* ((name (if (atom slot) slot (car slot)))
458                   (initform (if (atom slot) nil (cadr slot)))
459                   (dsd (find-dsd name)))
460              (when dsd
461                (setf (dsd-initform dsd) initform))))))
462      (when *dd-initial-offset*
463        (dotimes (i *dd-initial-offset*)
464          (push (make-defstruct-slot-description :name nil
465                                                 :index index
466                                                 :reader nil
467                                                 :initform nil
468                                                 :type t
469                                                 :read-only t)
470                *dd-slots*)
471          (incf index)))
472      (when *dd-named*
473        (push (make-defstruct-slot-description :name nil
474                                               :index index
475                                               :reader nil
476                                               :initform (list 'quote *dd-name*)
477                                               :type t
478                                               :read-only t)
479              *dd-slots*)
480        (incf index))
481      (dolist (dsd *dd-direct-slots*)
482        (setf (dsd-index dsd) index)
483        (push dsd *dd-slots*)
484        (incf index)))
485    (setf *dd-slots* (nreverse *dd-slots*))
486    (if (or (null *dd-type*) *dd-named*)
487        `(progn
488           (eval-when (:compile-toplevel :load-toplevel :execute)
489             (setf (get ',*dd-name* 'structure-definition)
490                   (make-defstruct-description :name ',*dd-name*
491                                               :conc-name ',*dd-conc-name*
492                                               :constructors ',*dd-constructors*
493                                               :copier ',*dd-copier*
494                                               :include ',*dd-include*
495                                               :type ',*dd-type*
496                                               :named ,*dd-named*
497                                               :initial-offset ,*dd-initial-offset*
498                                               :predicate ,*dd-predicate*
499                                               :print-function ,*dd-print-function*
500                                               :direct-slots ',*dd-direct-slots*
501                                               :slots ',*dd-slots*))
502             (make-structure-class ',*dd-name* ',*dd-direct-slots* ',*dd-slots*
503                                   ',(car *dd-include*)))
504           ,@(define-constructors)
505           ,@(define-predicate)
506           ,@(define-access-functions)
507           ,@(define-copier)
508           ',*dd-name*)
509        `(progn
510           (eval-when (:compile-toplevel :load-toplevel :execute)
511             (setf (get ',*dd-name* 'structure-definition)
512                   (make-defstruct-description :name ',*dd-name*
513                                               :conc-name ',*dd-conc-name*
514                                               :constructors ',*dd-constructors*
515                                               :copier ',*dd-copier*
516                                               :include ',*dd-include*
517                                               :type ',*dd-type*
518                                               :named ,*dd-named*
519                                               :initial-offset ,*dd-initial-offset*
520                                               :predicate ,*dd-predicate*
521                                               :print-function ,*dd-print-function*
522                                               :direct-slots ',*dd-direct-slots*
523                                               :slots ',*dd-slots*)))
524           ,@(define-constructors)
525           ,@(define-predicate)
526           ,@(define-access-functions)
527           ,@(define-copier)
528           ',*dd-name*))))
Note: See TracBrowser for help on using the repository browser.