/[gcl]/gcl/lsp/gcl_defstruct.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_defstruct.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:05 2003 UTC
# Line 0  Line 1 
1    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
2    
3    ;; This file is part of GNU Common Lisp, herein referred to as GCL
4    ;;
5    ;; GCL is free software; you can redistribute it and/or modify it under
6    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7    ;; the Free Software Foundation; either version 2, or (at your option)
8    ;; any later version.
9    ;;
10    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
11    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
13    ;; License for more details.
14    ;;
15    ;; You should have received a copy of the GNU Library General Public License
16    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
17    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
18    
19    
20    ;;;;    DEFSTRUCT.LSP
21    ;;;;
22    ;;;;        The structure routines.
23    
24    
25    (in-package 'lisp)
26    (export 'defstruct)
27    
28    
29    (in-package 'system)
30    
31    
32    (proclaim '(optimize (safety 2) (space 3)))
33    
34    
35    
36    ;(in-package 'system)
37    
38    
39    
40    (defvar *accessors* (make-array 10 :adjustable t))
41    (defvar *list-accessors* (make-array 2 :adjustable t))
42    (defvar *vector-accessors* (make-array 2 :adjustable t))
43    
44    (or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
45                                   #'(lambda (&rest l) l nil)))
46    
47    (defun make-access-function (name conc-name no-conc type named include no-fun
48                                      ;; from apply
49                                      slot-name default-init slot-type read-only
50                                      offset &optional predicate )
51      (declare (ignore named default-init predicate ))
52      
53      (let ((access-function
54             (if no-conc
55                 slot-name
56               (intern (si:string-concatenate (string conc-name)
57                                              (string slot-name)))))
58            accsrs dont-overwrite)
59        (ecase type
60          ((nil)
61           (setf accsrs *accessors*))
62          (list
63            (setf accsrs *list-accessors*))
64          (vector
65            (setf accsrs *vector-accessors*)))
66        (or (> (length  accsrs) offset)
67            (adjust-array accsrs (+ offset 10)))
68        (unless
69         dont-overwrite
70         (record-fn access-function 'defun '(t) slot-type)
71         (or no-fun
72             (and (fboundp access-function)
73                  (eq (aref accsrs offset) (symbol-function access-function)))
74             (setf (symbol-function access-function)
75               (or (aref accsrs offset)
76                   (setf (aref accsrs offset)
77                         (cond  ((eq accsrs *accessors*)
78                                    #'(lambda (x)
79                                        (or (structurep x)
80                                            (error "~a is not a structure" x))
81                                        (structure-ref1 x offset)))
82                                   ((eq accsrs *list-accessors*)
83                                    #'(lambda(x)
84                                        (si:list-nth offset x)))
85                                   ((eq accsrs *vector-accessors*)
86                                    #'(lambda(x)
87                                        (aref x offset)))))))))
88        (cond (read-only
89                (remprop access-function 'structure-access)
90                (setf (get access-function 'struct-read-only) t))
91              (t (remprop access-function 'setf-update-fn)
92                 (remprop access-function 'setf-lambda)
93                 (remprop access-function 'setf-documentation)
94                 (let ((tem (get access-function 'structure-access)))
95                   (cond ((and (consp tem) include
96                               (subtypep include (car tem))
97                               (eql (cdr tem) offset))
98                          ;; don't change overwrite accessor of subtype.
99                          (setq dont-overwrite t)
100                          )
101                         (t  (setf (get access-function 'structure-access)
102                                   (cons (if type type name) offset)))))))
103        nil))
104    
105    
106    (defun make-constructor (name constructor type named
107                             slot-descriptions)
108      (declare (ignore named))
109      (let ((slot-names
110             ;; Collect the slot-names.
111             (mapcar #'(lambda (x)
112                         (cond ((null x)
113                                ;; If the slot-description is NIL,
114                                ;;  it is in the padding of initial-offset.
115                                nil)
116                               ((null (car x))
117                                ;; If the slot name is NIL,
118                                ;;  it is the structure name.
119                                ;;  This is for typed structures with names.
120                                (list 'quote (cadr x)))
121                               (t (car x))))
122                     slot-descriptions))
123            (keys
124             ;; Make the keyword parameters.
125             (mapcan #'(lambda (x)
126                         (cond ((null x) nil)
127                               ((null (car x)) nil)
128                               ((null (cadr x)) (list (car x)))
129                               (t (list (list  (car x) (cadr x))))))
130                     slot-descriptions)))
131        (cond ((consp constructor)
132               ;; The case for a BOA constructor.
133               ;; Dirty code!!
134               ;; We must add an initial value for an optional parameter,
135               ;;  if the default value is not specified
136               ;;  in the given parameter list and yet the initial value
137               ;;  is supplied in the slot description.
138               (do ((a (cadr constructor) (cdr a)) (l nil) (vs nil))
139                   ((endp a)
140                    ;; Add those options that do not appear in the parameter list
141                    ;;  as auxiliary paramters.
142                    ;; The parameters are accumulated in the variable VS.
143                    (setq keys
144                          (nreconc (cons '&aux l)
145                                   (mapcan #'(lambda (k)
146                                               (if (member (if (atom k) k (car k))
147                                                           vs)
148                                                   nil
149                                                   (list k)))
150                                           keys))))
151                 ;; Skip until &OPTIONAL appears.
152                 (when (member (car a) lambda-list-keywords)
153                   (or (eq (car a) '&optional) (push '&optional a)))
154                 (cond ((eq (car a) '&optional)
155                        (setq l (cons '&optional l))
156                        (do ((aa (cdr a) (cdr aa)) (ov) (y))
157                            ((endp aa)
158                             ;; Add those options that do not appear in the
159                             ;;  parameter list.
160                             (setq keys
161                                   (nreconc (cons '&aux l)
162                                            (mapcan #'(lambda (k)
163                                                        (if (member (if (atom k)
164                                                                        k
165                                                                        (car k))
166                                                                    vs)
167                                                            nil
168                                                            (list k)))
169                                                    keys)))
170                             (return nil))
171                          (when (member (car aa) lambda-list-keywords)
172                                (when (eq (car aa) '&rest)
173                                      ;; &REST is found.
174                                      (setq l (cons '&rest l))
175                                      (setq aa (cdr aa))
176                                      (unless (and (not (endp aa))
177                                                   (symbolp (car aa)))
178                                              (illegal-boa))
179                                      (setq vs (cons (car aa) vs))
180                                      (setq l (cons (car aa) l))
181                                      (setq aa (cdr aa))
182                                      (when (endp aa)
183                                            (setq keys
184                                                  (nreconc
185                                                   (cons '&aux l)
186                                                   (mapcan
187                                                    #'(lambda (k)
188                                                        (if (member (if (atom k)
189                                                                        k
190                                                                        (car k))
191                                                                    vs)
192                                                            nil
193                                                            (list k)))
194                                                    keys)))
195                                            (return nil)))
196                                ;; &AUX should follow.
197                                (unless (eq (car aa) '&aux)
198                                        (illegal-boa))
199                                (setq l (cons '&aux l))
200                                (do ((aaa (cdr aa) (cdr aaa)))
201                                    ((endp aaa))
202                                  (setq l (cons (car aaa) l))
203                                  (cond ((and (atom (car aaa))
204                                              (symbolp (car aaa)))
205                                         (setq vs (cons (car aaa) vs)))
206                                        ((and (symbolp (caar aaa))
207                                              (or (endp (cdar aaa))
208                                                  (endp (cddar aaa))))
209                                         (setq vs (cons (caar aaa) vs)))
210                                        (t (illegal-boa))))
211                                ;; End of the parameter list.
212                                (setq keys
213                                      (nreconc l
214                                               (mapcan
215                                                #'(lambda (k)
216                                                    (if (member (if (atom k)
217                                                                    k
218                                                                    (car k))
219                                                                vs)
220                                                        nil
221                                                        (list k)))
222                                                keys)))
223                                (return nil))
224                          ;; Checks if the optional paramter without a default
225                          ;;  value has a default value in the slot-description.
226                          (if (and (cond ((atom (car aa)) (setq ov (car aa)) t)
227                                         ((endp (cdar aa)) (setq ov (caar aa)) t)
228                                         (t nil))
229                                   (setq y (member ov
230                                                   keys
231                                                   :key
232                                                   #'(lambda (x)
233                                                       (if (consp x)
234                                                           ;; With default value.
235                                                           (car x))))))
236                              ;; If no default value is supplied for
237                              ;;  the optional parameter and yet appears
238                              ;;  in KEYS with a default value,
239                              ;;  then cons the pair to L,
240                              (setq l (cons (car y) l))
241                              ;;  otherwise cons just the parameter to L.
242                              (setq l (cons (car aa) l)))
243                          ;; Checks the form of the optional parameter.
244                          (cond ((atom (car aa))
245                                 (unless (symbolp (car aa))
246                                         (illegal-boa))
247                                 (setq vs (cons (car aa) vs)))
248                                ((not (symbolp (caar aa)))
249                                 (illegal-boa))
250                                ((or (endp (cdar aa)) (endp (cddar aa)))
251                                 (setq vs (cons (caar aa) vs)))
252                                ((not (symbolp (caddar aa)))
253                                 (illegal-boa))
254                                ((not (endp (cdddar aa)))
255                                 (illegal-boa))
256                                (t
257                                 (setq vs (cons (caar aa) vs))
258                                 (setq vs (cons (caddar aa) vs)))))
259                        ;; RETURN from the outside DO.
260                        (return nil))
261                       (t
262                        (unless (symbolp (car a))
263                                (illegal-boa))
264                        (setq l (cons (car a) l))
265                        (setq vs (cons (car a) vs)))))
266               (setq constructor (car constructor)))
267              (t
268               ;; If not a BOA constructor, just cons &KEY.
269               (setq keys (cons '&key keys))))
270        (cond ((null type)
271               `(defun ,constructor ,keys
272                  (si:make-structure ',name ,@slot-names)))
273              ((or (eq type 'vector)
274                   (and (consp type) (eq (car type) 'vector)))
275               `(defun ,constructor ,keys
276                  (vector ,@slot-names)))
277              ((eq type 'list)
278               `(defun ,constructor ,keys
279                  (list ,@slot-names)))
280              ((error "~S is an illegal structure type" type)))))
281    
282    (defun illegal-boa ()
283      (error "An illegal BOA constructor."))
284    
285    (defun make-predicate (name predicate type named name-offset)
286      (cond ((null type))
287             ; done in define-structure
288            ((or (eq type 'vector)
289                 (and (consp type) (eq (car type) 'vector)))
290             ;; The name is at the NAME-OFFSET in the vector.
291             (unless named (error "The structure should be named."))
292             `(defun ,predicate (x)
293                (and (vectorp x)
294                     (> (the fixnum (length x)) ,name-offset)
295                     (eq (aref (the (vector t) x) ,name-offset) ',name))))
296            ((eq type 'list)
297             ;; The name is at the NAME-OFFSET in the list.
298             (unless named (error "The structure should be named."))
299             (if (= name-offset 0)
300                 `(defun ,predicate (x)
301                         (and (consp x)
302                              (eq (car x) ',name)))
303                 `(defun ,predicate (x)
304                         (do ((i ,name-offset (1- i))
305                              (z x (cdr z)))
306                             ((= i 0) (and (consp z) (eq (car z) ',name)))
307                             (declare (fixnum i))
308                           (unless (consp z) (return nil))))))
309            ((error "~S is an illegal structure type."))))
310    
311    
312    ;;; PARSE-SLOT-DESCRIPTION parses the given slot-description
313    ;;;  and returns a list of the form:
314    ;;;        (slot-name default-init slot-type read-only offset)
315    
316    (defun parse-slot-description (slot-description offset)
317      (let (slot-name default-init slot-type read-only)
318        (cond ((atom slot-description)
319               (setq slot-name slot-description))
320              ((endp (cdr slot-description))
321               (setq slot-name (car slot-description)))
322              (t
323               (setq slot-name (car slot-description))
324               (setq default-init (cadr slot-description))
325               (do ((os (cddr slot-description) (cddr os)) (o) (v))
326                   ((endp os))
327                 (setq o (car os))
328                 (when (endp (cdr os))
329                       (error "~S is an illegal structure slot option."
330                              os))
331                 (setq v (cadr os))
332                 (case o
333                   (:type (setq slot-type v))
334                   (:read-only (setq read-only v))
335                   (t
336                    (error "~S is an illegal structure slot option."
337                             os))))))
338        (list slot-name default-init slot-type read-only offset)))
339    
340    
341    ;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
342    ;;;  with the new descriptions which are specified in the
343    ;;;  :include defstruct option.
344    
345    (defun overwrite-slot-descriptions (news olds)
346      (if (null olds)
347          nil
348          (let ((sds (member (caar olds) news :key #'car)))
349            (cond (sds
350                   (when (and (null (cadddr (car sds)))
351                              (cadddr (car olds)))
352                         ;; If read-only is true in the old
353                         ;;  and false in the new, signal an error.
354                         (error "~S is an illegal include slot-description."
355                                sds))
356                   ;; If
357                   (setf (caddr (car sds))
358                         (best-array-element-type (caddr (car sds))))
359                   (when (not  (equal (normalize-type (or (caddr (car sds)) t))
360                                     (normalize-type (or (caddr (car olds)) t))))
361                         (error "Type mismmatch for included slot ~a" (car sds)))
362                         (cons (list (caar sds)
363                               (cadar sds)
364                               (caddar sds)
365                               (cadddr (car sds))
366                               ;; The offset if from the old.
367                               (car (cddddr (car olds))))
368                         (overwrite-slot-descriptions news (cdr olds))))
369                  (t
370                   (cons (car olds)
371                         (overwrite-slot-descriptions news (cdr olds))))))))
372    
373    (defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))
374    (defvar *alignment-t* (alignment t))
375    
376    (defun make-t-type (n include slot-descriptions &aux i)
377      (let ((res  (make-array n :element-type 'unsigned-char :static t)))
378        (when include
379              (let ((tem (get include 's-data))raw)
380                (or tem (error "Included structure undefined ~a" include))
381                (setq raw (s-data-raw tem))
382              (dotimes (i (min n (length raw)))
383                       (setf (aref res i) (aref raw i)))))
384        (dolist (v slot-descriptions)
385                (setq i (nth 4 v))
386                (let ((type (third v)))
387                  (cond ((<= (the fixnum (alignment type)) *alignment-t*)
388                         (setf (aref res i) (aet-type type))))))
389        (cond ((< n (length *all-t-s-type*))
390               (dotimes (i n)
391                      (cond ((not (eql (the fixnum (aref res i)) 0))
392                             (return-from make-t-type res))))
393               *all-t-s-type*)
394              (t res))))
395    
396    (defvar *standard-slot-positions*
397      (let ((ar (make-array 50 :element-type 'unsigned-short
398                            :static t)))
399        (dotimes (i 50)
400                 (declare (fixnum i))
401                 (setf (aref ar i)(*  (size-of t) i)))
402        ar))
403    
404    (eval-when (compile )
405    (proclaim '(function round-up (fixnum fixnum ) fixnum))
406    )
407    
408    (defun round-up (a b)
409      (declare (fixnum a b))
410      (setq a (ceiling a b))
411      (the fixnum (* a b)))
412    
413    
414    (defun get-slot-pos (leng include slot-descriptions &aux type small-types
415                              has-holes)
416      (declare (special *standard-slot-positions*)) include
417      (dolist (v slot-descriptions)
418              (when (and v (car v))
419                    (setf type
420                          (best-array-element-type (caddr v))
421                          (caddr v) type)
422                    (let ((val (second v)))
423                      (unless (typep val type)
424                              (if (and (symbolp val)
425                                       (constantp val))
426                                  (setf val (symbol-value val)))
427                              (and (constantp val)
428                                   (setf (cadr v) (coerce val type)))))
429                    (cond ((memq type '(signed-char unsigned-char
430                                                    short unsigned-short
431                                             long-float
432                                             bit))
433                           (setq small-types t)))))
434      (cond ((and (null small-types)
435                  (< leng (length *standard-slot-positions*))
436                  (list  *standard-slot-positions* (* leng  (size-of t)) nil)))
437            (t (let ((ar (make-array leng :element-type 'unsigned-short
438                                     :static t))
439                     (pos 0)(i 0)(align 0)type (next-pos 0))
440                 (declare (fixnum pos i align next-pos))
441                 ;; A default array.
442                      
443                 (dolist
444                   (v slot-descriptions)
445                   (setq type (caddr v))
446                   (setq align (alignment type))
447                   (unless (<= align *alignment-t*)
448                           (setq type t)
449                           (setf (caddr v) t)
450                           (setq align *alignment-t*)
451                           (setq v (nconc v '(t))))
452                   (setq next-pos (round-up pos align))    
453                   (or (eql pos next-pos) (setq has-holes t))
454                   (setq pos next-pos)
455                   (setf (aref ar i) pos)
456                   (incf pos (size-of type))
457                   (incf i))
458                 (list ar (round-up pos (size-of t)) has-holes)
459                 ))))
460    
461    
462    
463    
464                  
465                          
466                          
467                          
468                          
469                          
470                          
471                        
472                
473            
474            
475    
476    
477                                          
478                                    
479                                  
480                  
481            
482    
483    (defun define-structure (name conc-name no-conc type named slot-descriptions copier
484                                  static include print-function constructors
485                                  offset predicate &optional documentation no-funs
486                                  &aux def leng)
487      (and (consp type) (eq (car type) 'vector)(setq type 'vector))
488      (setq leng(length slot-descriptions))
489      (dolist (x slot-descriptions)
490               (and x (car x)
491                    (apply #'make-access-function
492                                         name conc-name no-conc type named include no-funs
493                                         x )))
494      (when (and copier (not no-funs))
495            (setf (symbol-function copier)
496                  (ecase type
497                    ((nil) #'si::copy-structure)
498                    (list #'copy-list)
499                    (vector #'copy-seq))))
500                    
501    
502      (cond ((and (null type)
503                  (eq name 's-data))
504             ;bootstrapping code!
505             (setq def (make-s-data-structure
506                         (make-array (* leng (size-of t))
507                                     :element-type 'string-char :static t)
508                         (make-t-type leng nil slot-descriptions)
509                         *standard-slot-positions*
510                         slot-descriptions
511                         t
512                         ))
513             )
514            (t
515              (let (slot-position
516                     (size 0) has-holes
517                     (include-str (and include
518                                       (get include 's-data))))
519                (when include-str
520                      (cond ((and (s-data-frozen include-str)
521                                  (or (not (s-data-included include-str))
522                                      (not (let ((te (get name 's-data)))
523                                             (and te
524                                                  (eq (s-data-includes
525                                                        te)
526                                                      include-str))))))
527                             (warn " ~a was frozen but now included"
528                                   include)))
529                      (pushnew name (s-data-included include-str)))
530                (when (null type)
531                     (setf slot-position
532                           (get-slot-pos leng include slot-descriptions))
533                     (setf size (cadr slot-position)
534                           has-holes (caddr slot-position)
535                           slot-position (car slot-position)
536                           ))
537              (setf def (make-s-data
538                           :name name
539                           :length leng
540                           :raw
541                           (and (null type)
542                                (make-t-type leng include slot-descriptions))
543                           :slot-position slot-position
544                           :size size
545                           :has-holes has-holes
546                           :staticp static
547                           :includes include-str
548                           :print-function print-function
549                           :slot-descriptions slot-descriptions
550                           :constructors constructors
551                           :offset offset
552                           :type type
553                           :named named
554                           :documentation documentation
555                           :conc-name conc-name)))))
556      (let ((tem (get name 's-data)))
557        (cond ((eq name 's-data)
558               (if tem (warn "not replacing s-data property"))
559               (or tem (setf (get name 's-data) def)))
560              (tem
561               (check-s-data tem def name))
562              (t  (setf (get name 's-data) def)))
563        (when documentation
564              (setf (get name 'structure-documentation)
565                    documentation))
566        (when (and  (null type)  predicate)
567              (record-fn predicate 'defun '(t) t)
568              (or no-funs
569                  (setf (symbol-function predicate)
570                        #'(lambda (x)
571                            (si::structure-subtype-p x name))))
572              (setf (get predicate 'compiler::co1)
573                    'compiler::co1structure-predicate)
574              (setf (get predicate 'struct-predicate) name)
575              )
576      ) nil)
577    
578                      
579    (defmacro defstruct (name &rest slots)
580      (let ((slot-descriptions slots)
581            options
582            conc-name
583            constructors default-constructor no-constructor
584            copier
585            predicate predicate-specified
586            include
587            print-function type named initial-offset
588            offset name-offset
589            documentation
590            static
591            (no-conc nil))
592    
593        (when (consp name)
594              ;; The defstruct options are supplied.
595              (setq options (cdr name))
596              (setq name (car name)))
597    
598        ;; The default conc-name.
599        (setq conc-name (si:string-concatenate (string name) "-"))
600    
601        ;; The default constructor.
602        (setq default-constructor
603              (intern (si:string-concatenate "MAKE-" (string name))))
604    
605        ;; The default copier and predicate.
606        (setq copier
607              (intern (si:string-concatenate "COPY-" (string name)))
608              predicate
609              (intern (si:string-concatenate (string name) "-P")))
610    
611        ;; Parse the defstruct options.
612        (do ((os options (cdr os)) (o) (v))
613            ((endp os))
614            (cond ((and (consp (car os)) (not (endp (cdar os))))
615                   (setq o (caar os) v (cadar os))
616                   (case o
617                     (:conc-name
618                       (if (null v)
619                           (progn
620                             (setq conc-name "")
621                             (setq no-conc t))
622                         (setq conc-name v)))
623                     (:constructor
624                       (if (null v)
625                           (setq no-constructor t)
626                         (if (endp (cddar os))
627                             (setq constructors (cons v constructors))
628                           (setq constructors (cons (cdar os) constructors)))))
629                     (:copier (setq copier v))
630                     (:static (setq static v))
631                     (:predicate
632                       (setq predicate v)
633                       (setq predicate-specified t))
634                     (:include
635                       (setq include (cdar os))
636                       (unless (get v 's-data)
637                               (error "~S is an illegal included structure." v)))
638                     (:print-function
639                      (and (consp v) (eq (car v) 'function)
640                           (setq v (second v)))
641                      (setq print-function v))
642                     (:type (setq type v))
643                     (:initial-offset (setq initial-offset v))
644                     (t (error "~S is an illegal defstruct option." o))))
645                  (t
646                    (if (consp (car os))
647                        (setq o (caar os))
648                      (setq o (car os)))
649                    (case o
650                      (:constructor
651                        (setq constructors
652                              (cons default-constructor constructors)))
653                      ((:copier :predicate :print-function))
654                      (:conc-name
655                       (progn
656                         (setq conc-name "")
657                         (setq no-conc t)))
658                      (:named (setq named t))
659                      (t (error "~S is an illegal defstruct option." o))))))
660    
661        (setq conc-name (intern (string conc-name)))
662    
663        (and include (not print-function)
664             (setq print-function (s-data-print-function (get (car include)  's-data))))
665    
666        ;; Skip the documentation string.
667        (when (and (not (endp slot-descriptions))
668                   (stringp (car slot-descriptions)))
669              (setq documentation (car slot-descriptions))
670              (setq slot-descriptions (cdr slot-descriptions)))
671        
672        ;; Check the include option.
673        (when include
674              (unless (equal type
675                             (s-data-type (get  (car include) 's-data)))
676                      (error "~S is an illegal structure include."
677                             (car include))))
678    
679        ;; Set OFFSET.
680        (cond ((null include)
681               (setq offset 0))
682              (t
683                (setq offset (s-data-offset (get (car include) 's-data)))))
684    
685        ;; Increment OFFSET.
686        (when (and type initial-offset)
687              (setq offset (+ offset initial-offset)))
688        (when (and type named)
689              (setq name-offset offset)
690              (setq offset (1+ offset)))
691    
692        ;; Parse slot-descriptions, incrementing OFFSET for each one.
693        (do ((ds slot-descriptions (cdr ds))
694             (sds nil))
695            ((endp ds)
696             (setq slot-descriptions (nreverse sds)))
697            (setq sds (cons (parse-slot-description (car ds) offset) sds))
698            (setq offset (1+ offset)))
699    
700        ;; If TYPE is non-NIL and structure is named,
701        ;;  add the slot for the structure-name to the slot-descriptions.
702        (when (and type named)
703              (setq slot-descriptions
704                    (cons (list nil name) slot-descriptions)))
705    
706        ;; Pad the slot-descriptions with the initial-offset number of NILs.
707        (when (and type initial-offset)
708              (setq slot-descriptions
709                    (append (make-list initial-offset) slot-descriptions)))
710    
711        ;; Append the slot-descriptions of the included structure.
712        ;; The slot-descriptions in the include option are also counted.
713        (cond ((null include))
714              ((endp (cdr include))
715               (setq slot-descriptions
716                     (append (s-data-slot-descriptions
717                               (get (car include) 's-data))
718                             slot-descriptions)))
719              (t
720                (setq slot-descriptions
721                      (append (overwrite-slot-descriptions
722                                (mapcar #'(lambda (sd)
723                                            (parse-slot-description sd 0))
724                                        (cdr include))
725                                (s-data-slot-descriptions
726                                  (get (car include) 's-data)
727                                  ))
728                              slot-descriptions))))
729    
730        (cond (no-constructor
731                ;; If a constructor option is NIL,
732                ;;  no constructor should have been specified.
733                (when constructors
734                      (error "Contradictory constructor options.")))
735              ((null constructors)
736               ;; If no constructor is specified,
737               ;;  the default-constructor is made.
738               (setq constructors (list default-constructor))))
739    
740        ;; We need a default constructor for the sharp-s-reader
741        (or (member t (mapcar 'symbolp  constructors))
742            (push (intern (string-concatenate "__si::" default-constructor))
743                          constructors))
744    
745        ;; Check the named option and set the predicate.
746        (when (and type (not named))
747              (when predicate-specified
748                    (error "~S is an illegal structure predicate."
749                           predicate))
750              (setq predicate nil))
751    
752        (when include (setq include (car include)))
753    
754        ;; Check the print-function.
755        (when (and print-function type)
756              (error "A print function is supplied to a typed structure."))
757        
758        `(progn
759           (define-structure ',name  ',conc-name ',no-conc ',type
760             ',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors
761             ',offset ',predicate ',documentation
762             )
763    
764           ,@(mapcar #'(lambda (constructor)
765                         (make-constructor name constructor type named
766                                           slot-descriptions))
767                     constructors)
768           ,@(if (and type predicate)
769                 (list (make-predicate name predicate type named
770                                       name-offset)))
771           ',name
772           )))
773    
774    ;; First several fields of this must coincide with the C structure
775    ;; s_data (see object.h).
776    
777    
778    (defstruct s-data name
779                     (length 0 :type fixnum)
780                     raw
781                     included
782                     includes
783                     staticp
784                     print-function
785                     slot-descriptions
786                     slot-position
787                     (size 0 :type fixnum)
788                     has-holes
789                     frozen
790                     documentation
791                     constructors
792                     offset
793                     named
794                     type
795                     conc-name
796                     )
797    
798    
799    (defun check-s-data (tem def name)
800      (cond ((s-data-included tem)
801             (setf (s-data-included def)(s-data-included tem))))
802      (cond ((s-data-frozen tem)
803             (setf (s-data-frozen def) t)))
804      (unless (equalp def tem)
805              (warn "structure ~a is changing" name)
806              (setf (get name 's-data) def)))
807    (defun freeze-defstruct (name)
808      (let ((tem (and (symbolp name) (get name 's-data))))
809        (if tem (setf (s-data-frozen tem) t))))
810    
811    
812    ;;; The #S reader.
813    
814    (defun sharp-s-reader (stream subchar arg)
815      (declare (ignore subchar))
816      (when (and arg (null *read-suppress*))
817            (error "An extra argument was supplied for the #S readmacro."))
818      (let* ((l (prog1 (read stream t nil t)
819                  (if *read-suppress*
820                      (return-from sharp-s-reader nil))))
821             (sd
822               (or (get (car l) 's-data)
823                  
824                   (error "~S is not a structure." (car l)))))
825        
826        ;; Intern keywords in the keyword package.
827        (do ((ll (cdr l) (cddr ll)))
828            ((endp ll)
829             ;; Find an appropriate construtor.
830             (do ((cs (s-data-constructors sd) (cdr cs)))
831                 ((endp cs)
832                  (error "The structure ~S has no structure constructor."
833                         (car l)))
834               (when (symbolp (car cs))
835                     (return (apply (car cs) (cdr l))))))
836          (rplaca ll (intern (string (car ll)) 'keyword)))))
837    
838    
839    ;; Set the dispatch macro.
840    (set-dispatch-macro-character #\# #\s 'sharp-s-reader)
841    (set-dispatch-macro-character #\# #\S 'sharp-s-reader)
842    
843    ;; Examples from Common Lisp Reference Manual.
844    
845    #|
846    (defstruct ship
847      x-position
848      y-position
849      x-velocity
850      y-velocity
851      mass)
852    
853    (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
854                                                            sex)
855    (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
856                                                            sex)
857    (defstruct person1 name (age 20 :type fixnum)
858                                                            sex)
859    
860    (defstruct joe a (a1 0 :type (mod  30)) (a2 0 :type (mod  30))
861      (a3 0 :type (mod  30)) (a4 0 :type (mod 30)) )
862    
863    ;(defstruct person name age sex)
864    
865    (defstruct (astronaut (:include person (age 45 :type fixnum))
866                          (:conc-name astro-))
867      helmet-size
868      (favorite-beverage 'tang))
869    
870    (defstruct (foo (:constructor create-foo (a
871                                              &optional b (c 'sea)
872                                              &rest d
873                                              &aux e (f 'eff))))
874      a (b 'bee) c d e f)
875    
876    (defstruct (binop (:type list) :named (:initial-offset 2))
877      (operator '?)
878      operand-1
879      operand-2)
880    
881    (defstruct (annotated-binop (:type list)
882                                (:initial-offset 3)
883                                (:include binop))
884      commutative
885      associative
886      identity)
887    
888    |#

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26