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

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

Work in progress.

File size: 9.1 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defstruct.lisp,v 1.35 2003-11-20 18:42:09 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(defvar *ds-name*)
23(defvar *ds-conc-name*)
24(defvar *ds-constructors*)
25(defvar *ds-copier*)
26(defvar *ds-type*)
27(defvar *ds-named*)
28(defvar *ds-initial-offset*)
29(defvar *ds-predicate*)
30(defvar *ds-print-function*)
31(defvar *ds-slot-descriptions*)
32
33(defun define-constructor (constructor slots)
34  (let* ((constructor-name (intern (car constructor)))
35         (slot-names (mapcar #'(lambda (x) (if (atom x) x (car x))) slots))
36         (inits (mapcar #'(lambda (x) (if (atom x) nil (cadr x))) slots))
37         (slot-descriptions (mapcar #'(lambda (x y) (list x y)) slot-names inits))
38         (keys (cons '&key slot-descriptions))
39         (elements slot-names))
40    (when *ds-named*
41      (push (list 'quote *ds-name*) elements))
42    (when *ds-initial-offset*
43      (dotimes (i *ds-initial-offset*)
44        (push nil elements)))
45    (cond ((eq *ds-type* 'list)
46           `((defun ,constructor-name ,keys
47               (list ,@elements))))
48          ((or (eq *ds-type* 'vector)
49               (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
50           (let ((element-type (if (consp *ds-type*) (cadr *ds-type*) t)))
51             `((defun ,constructor-name ,keys
52                 (make-array ,(length elements)
53                             :element-type ',element-type
54                             :initial-contents (list ,@elements))))))
55          (t
56           `((defun ,constructor-name ,keys
57               (%make-structure ',*ds-name* (list ,@slot-names))))))))
58
59(defun default-constructor-name ()
60  (concatenate 'string "MAKE-" (symbol-name *ds-name*)))
61
62(defun define-constructors (slots)
63  (if *ds-constructors*
64      (let ((results ()))
65        (dolist (constructor *ds-constructors*)
66          (when (car constructor)
67            (setf results (nconc results (define-constructor constructor slots)))))
68        results)
69      (define-constructor (cons (default-constructor-name) nil) slots)))
70
71(defun define-predicate ()
72  (when (and *ds-predicate*
73             (or *ds-named* (null *ds-type*)))
74    (let ((pred (intern *ds-predicate*)))
75      (cond ((eq *ds-type* 'list)
76             (if *ds-initial-offset*
77                 `((defun ,pred (object)
78                     (and (consp object)
79                          (> (length object) ,*ds-initial-offset*)
80                          (eq (elt object ,*ds-initial-offset*) ',*ds-name*))))
81                 `((defun ,pred (object)
82                     (and (consp object) (eq (car object) ',*ds-name*))))))
83            ((or (eq *ds-type* 'vector)
84                 (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
85             (let ((index (or *ds-initial-offset* 0)))
86               `((defun ,pred (object)
87                   (and (vectorp object)
88                        (> (length object) ,index)
89                        (eq (aref object ,index) ',*ds-name*))))))
90            (t
91             `((defun ,pred (object)
92                 (typep object ',*ds-name*))))))))
93
94(defun get-slot-accessor (slot)
95  (when *ds-initial-offset*
96    (incf slot *ds-initial-offset*))
97  (when *ds-named*
98    (incf slot))
99  (cond ((eq *ds-type* 'list)
100         `(lambda (instance) (elt instance ,slot)))
101        ((or (eq *ds-type* 'vector)
102             (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
103         `(lambda (instance) (aref instance ,slot)))
104        (t
105         (case slot
106           (0 #'%structure-ref-0)
107           (1 #'%structure-ref-1)
108           (2 #'%structure-ref-2)
109           (t
110            `(lambda (instance) (%structure-ref instance ,slot)))))))
111
112(defun get-slot-mutator (slot)
113  (when *ds-initial-offset*
114    (incf slot *ds-initial-offset*))
115  (when *ds-named*
116    (incf slot))
117  (cond ((eq *ds-type* 'list)
118         `(lambda (instance value) (%set-elt instance ,slot value)))
119        ((or (eq *ds-type* 'vector)
120             (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
121         `(lambda (instance value) (%aset instance ,slot value)))
122        (t
123         (case slot
124           (0 #'%structure-set-0)
125           (1 #'%structure-set-1)
126           (2 #'%structure-set-2)
127           (t
128            `(lambda (instance value) (%structure-set instance ,slot value)))))))
129
130(defun define-access-function (slot-name index)
131  (let ((accessor
132         (if *ds-conc-name*
133             (intern (concatenate 'string (symbol-name *ds-conc-name*) (symbol-name slot-name)))
134             slot-name)))
135    `((setf (symbol-function ',accessor) ,(get-slot-accessor index))
136      (%put ',accessor 'setf-inverse ,(get-slot-mutator index )))))
137
138(defun define-access-functions (slots)
139  (let ((index 0)
140        (result ()))
141    (dolist (slot slots)
142      (let ((slot-name (if (atom slot) slot (car slot))))
143        (setf result (nconc result (define-access-function slot-name index))))
144      (incf index))
145    result))
146
147(defun define-copier ()
148  (when *ds-copier*
149    (cond ((eq *ds-type* 'list)
150           `((setf (fdefinition ',*ds-copier*) #'copy-list)))
151          ((or (eq *ds-type* 'vector)
152               (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
153           `((setf (fdefinition ',*ds-copier*) #'copy-seq)))
154          (t
155           `((setf (fdefinition ',*ds-copier*) #'copy-structure))))))
156
157(defun parse-1-option (option)
158  (case (car option)
159    (:conc-name
160     (setf *ds-conc-name* (if (symbolp (cadr option))
161                              (cadr option)
162                              (make-symbol (string (cadr option))))))
163    (:constructor
164     (let* ((args (cdr option))
165            (numargs (length args))
166            name arglist)
167       (case numargs
168         (0 ; Use default name.
169          (setf name (default-constructor-name))
170          (setf arglist nil)
171          (push (list name arglist) *ds-constructors*))
172         (1
173          (if (null (car args))
174              (setf name nil) ; No constructor.
175              (setf name (symbol-name (car args))))
176          (setf arglist nil)
177          (push (list name arglist) *ds-constructors*))
178         (2))))
179    (:copier
180     (let* ((args (cdr option))
181            (numargs (length args)))
182       (when (= numargs 1)
183          (setf *ds-copier* (car args)))))
184    (:initial-offset
185     (setf *ds-initial-offset* (cadr option)))
186    (:predicate
187     (when (= (length option) 2)
188       (if (null (cadr option))
189           (setf *ds-predicate* nil)
190           (setf *ds-predicate* (symbol-name (cadr option))))))
191    (:type
192     (setf *ds-type* (cadr option)))
193    (t
194     (format t "unrecognized DEFSTRUCT option: ~S~%" (car option)))))
195
196(defun parse-name-and-options (name-and-options)
197  (setf *ds-name* (car name-and-options))
198  (setf *ds-conc-name* (make-symbol (concatenate 'string (symbol-name *ds-name*) "-")))
199  (setf *ds-copier* (intern (concatenate 'string "COPY-" (symbol-name *ds-name*))))
200  (setf *ds-predicate* (concatenate 'string (symbol-name *ds-name*) "-P"))
201  (let ((options (cdr name-and-options)))
202    (dolist (option options)
203      (cond ((consp option)
204             (parse-1-option option))
205            ((eq option :named)
206             (setf *ds-named* t))
207            ((member option '(:constructor :copier :predicate :named
208                              :conc-name))
209             (parse-1-option (list option)))
210            (t
211             (error "unrecognized DEFSTRUCT option: ~S" option))))))
212
213(defmacro defstruct (name-and-options &rest slots)
214  (let ((*ds-name* nil)
215        (*ds-conc-name* nil)
216        (*ds-constructors* nil)
217        (*ds-copier* nil)
218        (*ds-type* nil)
219        (*ds-named* nil)
220        (*ds-initial-offset* nil)
221        (*ds-predicate* nil)
222        (*ds-print-function* nil)
223        (*ds-slot-descriptions* ()))
224    (parse-name-and-options (if (atom name-and-options)
225                                (list name-and-options)
226                                name-and-options))
227    (when (stringp (car slots))
228      (setf (documentation *ds-name* 'structure) (pop slots)))
229    (dolist (slot slots)
230      (let ((slot-description (if (atom slot)
231                                  (list :name slot :initform nil)
232                                  (list :name (car slot) :initform (cadr slot)))))
233        (push slot-description *ds-slot-descriptions*)))
234    (setf *ds-slot-descriptions* (nreverse *ds-slot-descriptions*))
235    `(progn
236       (make-structure-class ',*ds-name* ',*ds-slot-descriptions*)
237       ,@(define-constructors slots)
238       ,@(define-predicate)
239       ,@(define-access-functions slots)
240       ,@(define-copier)
241       ',*ds-name*)))
Note: See TracBrowser for help on using the repository browser.