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

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

:PRINT-FUNCTION

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