1
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
3
;; This file is part of GNU Common Lisp, herein referred to as GCL
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)
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.
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.
22
;;;; The structure routines.
32
(proclaim '(optimize (safety 2) (space 3)))
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))
44
(or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
45
#'(lambda (&rest l) l nil)))
47
(defun make-access-function (name conc-name no-conc type named include no-fun
49
slot-name default-init slot-type read-only
50
offset &optional predicate )
51
(declare (ignore named default-init predicate ))
52
(let ((access-function
55
(intern (si:string-concatenate (string conc-name)
56
(string slot-name)))))
57
accsrs dont-overwrite)
60
(setf accsrs *accessors*))
62
(setf accsrs *list-accessors*))
64
(setf accsrs *vector-accessors*)))
65
(or (> (length accsrs) offset)
66
(adjust-array accsrs (+ offset 10)))
69
(record-fn access-function 'defun '(t) slot-type)
71
(and (fboundp access-function)
72
(eq (aref accsrs offset) (symbol-function access-function)))
73
(setf (symbol-function access-function)
74
(or (aref accsrs offset)
75
(setf (aref accsrs offset)
76
(cond ((eq accsrs *accessors*)
79
(error "~a is not a structure" x))
80
(structure-ref1 x offset)))
81
((eq accsrs *list-accessors*)
83
(si:list-nth offset x)))
84
((eq accsrs *vector-accessors*)
86
(aref x offset)))))))))
88
(remprop access-function 'structure-access)
89
(setf (get access-function 'struct-read-only) t))
90
(t (remprop access-function 'setf-update-fn)
91
(remprop access-function 'setf-lambda)
92
(remprop access-function 'setf-documentation)
93
(let ((tem (get access-function 'structure-access)))
94
(cond ((and (consp tem) include
95
(subtypep include (car tem))
96
(eql (cdr tem) offset))
97
;; don't change overwrite accessor of subtype.
98
(setq dont-overwrite t)
100
(t (setf (get access-function 'structure-access)
101
(cons (if type type name) offset)))))))
104
(defmacro key-name (key prior-keyword)
109
(unless (endp (cdddr ,key))
110
(error "Bad key ~S~%" ,key))
112
((not (consp (car ,key)))
114
((and (eq ,prior-keyword '&key) (not (consp (caar ,key))))
115
(unless (endp (cddar ,key))
116
(error "Bad key ~S~%" ,key))
119
(error "Bad key ~S~%" ,key))))))
121
(defmacro maybe-add-keydef (key keydefs prior-keyword)
123
(member (key-name ,key ,prior-keyword) ,keydefs
124
:key #'(lambda (k) (when (consp k) (car k)))))))
126
(cond ((not (consp ,key))
129
(if (cdr ,key) ,key (list (car ,key) def))))
132
(defun parse-boa-lambda-list (lambda-list keydefs)
133
(let ((keywords '(none &optional &rest &key &allow-other-keys &aux))
134
vs res tk restvar seen-keys)
135
(do ((ll lambda-list (cdr ll))) ((endp ll))
136
(let ((key (car ll)))
137
(cond ((setq tk (member key keywords))
140
(push key seen-keys))
141
((member key lambda-list-keywords)
142
(error "Keyword ~S appeared in a bad place in BOA lambda list" key))
144
(let ((prior-keyword (car keywords)))
147
(unless (symbolp key)
148
(error "non-symbol appeared in bad place in BOA lambda list" key))
151
(when (eq prior-keyword '&rest)
153
(error "Multiple variables after &rest in BOA lambda list"))
156
(push (maybe-add-keydef key keydefs prior-keyword) res)
157
(push (key-name key prior-keyword) vs))
159
(error "Variable ~S appeared after &allow-other-keys in BOA list" key))
162
(push (key-name key prior-keyword) vs))))))))
163
(when (and (member '&rest seen-keys) (not restvar))
164
(error "Missing &rest variable in BOA list"))
165
(unless (member '&aux seen-keys)
167
(do ((ll keydefs (cdr ll))) ((endp ll))
168
(let* ((keydef (car ll))
169
(keydef-name (if (atom keydef) keydef (car keydef))))
170
(unless (member keydef-name vs)
174
(defun maybe-cons-keyname (x &optional y)
176
(specific-error :invalid-form "x ~S is not a list~%" x))
177
(let ((sn (sixth x)))
180
(list (list (car x) sn) y)
181
(list (list (car x) sn)))
182
(if y (list (car x) y) (car x)))))
184
(defun make-constructor (name constructor type named
186
(declare (ignore named))
188
;; Collect the slot-names.
189
(mapcar #'(lambda (x)
191
;; If the slot-description is NIL,
192
;; it is in the padding of initial-offset.
195
;; If the slot name is NIL,
196
;; it is the structure name.
197
;; This is for typed structures with names.
198
(list 'quote (cadr x)))
199
(t (let ((sn (sixth x))) (if sn sn (car x))))))
202
;; Make the keyword parameters.
203
(mapcan #'(lambda (x)
206
((null (cadr x)) (list (maybe-cons-keyname x)))
207
(t (list (maybe-cons-keyname x (cadr x))))))
209
(cond ((consp constructor)
210
(setq keys (parse-boa-lambda-list (cadr constructor) keys))
211
(setq constructor (car constructor)))
213
;; If not a BOA constructor, just cons &KEY.
214
(setq keys (cons '&key keys))))
216
`(defun ,constructor ,keys
217
(si:make-structure ',name ,@slot-names)))
219
`(defun ,constructor ,keys
220
(vector ,@slot-names)))
221
((and (consp type) (eq (car type) 'vector))
222
(if (endp (cdr type))
223
`(defun ,constructor ,keys
224
(vector ,@slot-names)))
225
`(defun ,constructor ,keys
226
(make-array ,(length slot-names)
227
:element-type ',(cadr type)
228
:initial-contents (list ,@slot-names))))
230
`(defun ,constructor ,keys
231
(list ,@slot-names)))
232
((error "~S is an illegal structure type" type)))))
234
(defun make-predicate (name predicate type named name-offset)
236
; done in define-structure
237
((or (eq type 'vector)
238
(and (consp type) (eq (car type) 'vector)))
239
;; The name is at the NAME-OFFSET in the vector.
240
(unless named (error "The structure should be named."))
241
`(defun ,predicate (x)
243
(> (the fixnum (length x)) ,name-offset)
244
(eq (aref (the (vector t) x) ,name-offset) ',name))))
246
;; The name is at the NAME-OFFSET in the list.
247
(unless named (error "The structure should be named."))
248
(if (= name-offset 0)
249
`(defun ,predicate (x)
251
(eq (car x) ',name)))
252
`(defun ,predicate (x)
253
(do ((i ,name-offset (1- i))
255
((= i 0) (and (consp z) (eq (car z) ',name)))
257
(unless (consp z) (return nil))))))
258
((error "~S is an illegal structure type."))))
261
;;; PARSE-SLOT-DESCRIPTION parses the given slot-description
262
;;; and returns a list of the form:
263
;;; (slot-name default-init slot-type read-only offset)
265
(defun parse-slot-description (slot-description offset)
266
(let (slot-name default-init slot-type read-only)
267
(cond ((atom slot-description)
268
(setq slot-name slot-description))
269
((endp (cdr slot-description))
270
(setq slot-name (car slot-description)))
272
(setq slot-name (car slot-description))
273
(setq default-init (cadr slot-description))
274
(do ((os (cddr slot-description) (cddr os)) (o) (v))
277
(when (endp (cdr os))
278
(error "~S is an illegal structure slot option."
282
(:type (setq slot-type v))
283
(:read-only (setq read-only v))
285
(error "~S is an illegal structure slot option."
287
(list slot-name default-init slot-type read-only offset)))
290
;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
291
;;; with the new descriptions which are specified in the
292
;;; :include defstruct option.
294
(defun overwrite-slot-descriptions (news olds)
297
(let ((sds (member (caar olds) news :key #'car)))
299
(when (and (null (cadddr (car sds)))
301
;; If read-only is true in the old
302
;; and false in the new, signal an error.
303
(error "~S is an illegal include slot-description."
306
(setf (caddr (car sds))
307
(best-array-element-type (caddr (car sds))))
308
(when (not (equal (normalize-type (or (caddr (car sds)) t))
309
(normalize-type (or (caddr (car olds)) t))))
310
(error "Type mismmatch for included slot ~a" (car sds)))
311
(cons (list (caar sds)
315
;; The offset if from the old.
316
(car (cddddr (car olds))))
317
(overwrite-slot-descriptions news (cdr olds))))
320
(overwrite-slot-descriptions news (cdr olds))))))))
322
(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))
323
(defvar *alignment-t* (alignment t))
325
(defun make-t-type (n include slot-descriptions &aux i)
326
(let ((res (make-array n :element-type 'unsigned-char :static t)))
328
(let ((tem (get include 's-data))raw)
329
(or tem (error "Included structure undefined ~a" include))
330
(setq raw (s-data-raw tem))
331
(dotimes (i (min n (length raw)))
332
(setf (aref res i) (aref raw i)))))
333
(dolist (v slot-descriptions)
335
(let ((type (third v)))
336
(cond ((<= (the fixnum (alignment type)) *alignment-t*)
337
(setf (aref res i) (aet-type type))))))
338
(cond ((< n (length *all-t-s-type*))
340
(cond ((not (eql (the fixnum (aref res i)) 0))
341
(return-from make-t-type res))))
345
(defvar *standard-slot-positions*
346
(let ((ar (make-array 50 :element-type 'unsigned-short
350
(setf (aref ar i)(* (size-of t) i)))
353
(eval-when (compile )
354
(proclaim '(function round-up (fixnum fixnum ) fixnum))
357
(defun round-up (a b)
358
(declare (fixnum a b))
359
(setq a (ceiling a b))
360
(the fixnum (* a b)))
363
(defun get-slot-pos (leng include slot-descriptions &aux type small-types
365
(declare (special *standard-slot-positions*)) include
366
(dolist (v slot-descriptions)
367
(when (and v (car v))
369
(best-array-element-type (caddr v))
371
(let ((val (second v)))
372
(unless (typep val type)
373
(if (and (symbolp val)
375
(setf val (symbol-value val)))
377
(setf (cadr v) (coerce val type)))))
378
(cond ((memq type '(signed-char unsigned-char
382
(setq small-types t)))))
383
(cond ((and (null small-types)
384
(< leng (length *standard-slot-positions*))
385
(list *standard-slot-positions* (* leng (size-of t)) nil)))
386
(t (let ((ar (make-array leng :element-type 'unsigned-short
388
(pos 0)(i 0)(align 0)type (next-pos 0))
389
(declare (fixnum pos i align next-pos))
393
(v slot-descriptions)
394
(setq type (caddr v))
395
(setq align (alignment type))
396
(unless (<= align *alignment-t*)
399
(setq align *alignment-t*)
400
(setq v (nconc v '(t))))
401
(setq next-pos (round-up pos align))
402
(or (eql pos next-pos) (setq has-holes t))
404
(setf (aref ar i) pos)
405
(incf pos (size-of type))
407
(list ar (round-up pos (size-of t)) has-holes)
410
(defun define-structure (name conc-name no-conc type named slot-descriptions copier
411
static include print-function constructors
412
offset predicate &optional documentation no-funs
414
(and (consp type) (eq (car type) 'vector)(setq type 'vector))
415
(setq leng(length slot-descriptions))
416
(dolist (x slot-descriptions)
418
(apply #'make-access-function
419
name conc-name no-conc type named include no-funs
421
(when (and copier (not no-funs))
422
(setf (symbol-function copier)
424
((nil) #'si::copy-structure)
426
(vector #'copy-seq))))
429
(cond ((and (null type)
432
(setq def (make-s-data-structure
433
(make-array (* leng (size-of t))
434
:element-type 'string-char :static t)
435
(make-t-type leng nil slot-descriptions)
436
*standard-slot-positions*
444
(include-str (and include
445
(get include 's-data))))
447
(cond ((and (s-data-frozen include-str)
448
(or (not (s-data-included include-str))
449
(not (let ((te (get name 's-data)))
454
(warn " ~a was frozen but now included"
456
(pushnew name (s-data-included include-str)))
459
(get-slot-pos leng include slot-descriptions))
460
(setf size (cadr slot-position)
461
has-holes (caddr slot-position)
462
slot-position (car slot-position)
464
(setf def (make-s-data
469
(make-t-type leng include slot-descriptions))
470
:slot-position slot-position
474
:includes include-str
475
:print-function print-function
476
:slot-descriptions slot-descriptions
477
:constructors constructors
481
:documentation documentation
482
:conc-name conc-name)))))
483
(let ((tem (get name 's-data)))
484
(cond ((eq name 's-data)
485
(if tem (warn "not replacing s-data property"))
486
(or tem (setf (get name 's-data) def)))
488
(check-s-data tem def name))
489
(t (setf (get name 's-data) def)))
491
(setf (get name 'structure-documentation)
493
(when (and (null type) predicate)
494
(record-fn predicate 'defun '(t) t)
496
(setf (symbol-function predicate)
498
(si::structure-subtype-p x name))))
499
(setf (get predicate 'compiler::co1)
500
'compiler::co1structure-predicate)
501
(setf (get predicate 'struct-predicate) name)
506
(defmacro defstruct (name &rest slots)
507
(let ((slot-descriptions slots)
510
constructors default-constructor no-constructor
512
predicate predicate-specified
514
print-function type named initial-offset
521
;; The defstruct options are supplied.
522
(setq options (cdr name))
523
(setq name (car name)))
525
;; The default conc-name.
526
(setq conc-name (si:string-concatenate (string name) "-"))
528
;; The default constructor.
529
(setq default-constructor
530
(intern (si:string-concatenate "MAKE-" (string name))))
532
;; The default copier and predicate.
534
(intern (si:string-concatenate "COPY-" (string name)))
536
(intern (si:string-concatenate (string name) "-P")))
538
;; Parse the defstruct options.
539
(do ((os options (cdr os)) (o) (v))
541
(cond ((and (consp (car os)) (not (endp (cdar os))))
542
(setq o (caar os) v (cadar os))
552
(setq no-constructor t)
553
(if (endp (cddar os))
554
(setq constructors (cons v constructors))
555
(setq constructors (cons (cdar os) constructors)))))
556
(:copier (setq copier v))
557
(:static (setq static v))
560
(setq predicate-specified t))
562
(setq include (cdar os))
563
(unless (get v 's-data)
564
(error "~S is an illegal included structure." v)))
566
(and (consp v) (eq (car v) 'function)
568
(setq print-function v))
569
(:type (setq type v))
570
(:initial-offset (setq initial-offset v))
571
(t (error "~S is an illegal defstruct option." o))))
579
(cons default-constructor constructors)))
580
((:copier :predicate :print-function))
585
(:named (setq named t))
586
(t (error "~S is an illegal defstruct option." o))))))
588
(setq conc-name (intern (string conc-name)))
590
(and include (not print-function)
591
(setq print-function (s-data-print-function (get (car include) 's-data))))
593
;; Skip the documentation string.
594
(when (and (not (endp slot-descriptions))
595
(stringp (car slot-descriptions)))
596
(setq documentation (car slot-descriptions))
597
(setq slot-descriptions (cdr slot-descriptions)))
599
;; Check the include option.
602
(s-data-type (get (car include) 's-data)))
603
(error "~S is an illegal structure include."
607
(cond ((null include)
610
(setq offset (s-data-offset (get (car include) 's-data)))))
613
(when (and type initial-offset)
614
(setq offset (+ offset initial-offset)))
615
(when (and type named)
616
(setq name-offset offset)
617
(setq offset (1+ offset)))
619
;; Parse slot-descriptions, incrementing OFFSET for each one.
620
(do ((ds slot-descriptions (cdr ds))
623
(setq slot-descriptions (nreverse sds)))
624
(setq sds (cons (parse-slot-description (car ds) offset) sds))
625
(setq offset (1+ offset)))
627
;; If TYPE is non-NIL and structure is named,
628
;; add the slot for the structure-name to the slot-descriptions.
629
(when (and type named)
630
(setq slot-descriptions
631
(cons (list nil name) slot-descriptions)))
633
;; Pad the slot-descriptions with the initial-offset number of NILs.
634
(when (and type initial-offset)
635
(setq slot-descriptions
636
(append (make-list initial-offset) slot-descriptions)))
638
;; Append the slot-descriptions of the included structure.
639
;; The slot-descriptions in the include option are also counted.
640
(cond ((null include))
641
((endp (cdr include))
642
(setq slot-descriptions
643
(append (s-data-slot-descriptions
644
(get (car include) 's-data))
647
(setq slot-descriptions
648
(append (overwrite-slot-descriptions
649
(mapcar #'(lambda (sd)
650
(parse-slot-description sd 0))
652
(s-data-slot-descriptions
653
(get (car include) 's-data)
655
slot-descriptions))))
657
(cond (no-constructor
658
;; If a constructor option is NIL,
659
;; no constructor should have been specified.
661
(error "Contradictory constructor options.")))
663
;; If no constructor is specified,
664
;; the default-constructor is made.
665
(setq constructors (list default-constructor))))
667
;; We need a default constructor for the sharp-s-reader
668
(or (member t (mapcar 'symbolp constructors))
669
(push (intern (string-concatenate "__si::" default-constructor))
672
;; Check the named option and set the predicate.
673
(when (and type (not named))
674
(when predicate-specified
675
(error "~S is an illegal structure predicate."
677
(setq predicate nil))
679
(when include (setq include (car include)))
681
;; Check the print-function.
682
(when (and print-function type)
683
(error "A print function is supplied to a typed structure."))
685
(let* (new-slot-descriptions
686
(new-slot-descriptions ;(copy-list slot-descriptions)))
687
(dolist (sd slot-descriptions (nreverse new-slot-descriptions))
688
(if (and (consp sd) (eql (length sd) 5))
689
(let* ((csd (car sd))
690
(sym (when (or (constantp csd) (keywordp csd) (si::specialp csd))
691
(make-symbol (symbol-name csd))))
692
(nsd (if (or (constantp csd) (si::specialp csd))
693
(cons (intern (symbol-name csd) 'keyword) (cdr sd))
695
(push (append nsd (list sym)) new-slot-descriptions)
697
(setf (car sd) sym)))
698
(push sd new-slot-descriptions)))))
700
(define-structure ',name ',conc-name ',no-conc ',type
701
',named ',slot-descriptions ',copier ',static ',include
702
',print-function ',constructors
703
',offset ',predicate ',documentation
706
,@(mapcar #'(lambda (constructor)
707
(make-constructor name constructor type named new-slot-descriptions))
709
,@(if (and type predicate)
710
(list (make-predicate name predicate type named
715
;; First several fields of this must coincide with the C structure
716
;; s_data (see object.h).
719
(defstruct s-data name
720
(length 0 :type fixnum)
728
(size 0 :type fixnum)
740
(defun check-s-data (tem def name)
741
(cond ((s-data-included tem)
742
(setf (s-data-included def)(s-data-included tem))))
743
(cond ((s-data-frozen tem)
744
(setf (s-data-frozen def) t)))
745
(unless (equalp def tem)
746
(warn "structure ~a is changing" name)
747
(setf (get name 's-data) def)))
748
(defun freeze-defstruct (name)
749
(let ((tem (and (symbolp name) (get name 's-data))))
750
(if tem (setf (s-data-frozen tem) t))))
755
(defun sharp-s-reader (stream subchar arg)
756
(declare (ignore subchar))
757
(when (and arg (null *read-suppress*))
758
(error "An extra argument was supplied for the #S readmacro."))
759
(let* ((l (prog1 (read stream t nil t)
761
(return-from sharp-s-reader nil))))
763
(or (get (car l) 's-data)
765
(error "~S is not a structure." (car l)))))
767
;; Intern keywords in the keyword package.
768
(do ((ll (cdr l) (cddr ll)))
770
;; Find an appropriate construtor.
771
(do ((cs (s-data-constructors sd) (cdr cs)))
773
(error "The structure ~S has no structure constructor."
775
(when (symbolp (car cs))
776
(return (apply (car cs) (cdr l))))))
777
(rplaca ll (intern (string (car ll)) 'keyword)))))
780
;; Set the dispatch macro.
781
(set-dispatch-macro-character #\# #\s 'sharp-s-reader)
782
(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
784
;; Examples from Common Lisp Reference Manual.
794
(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
796
(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
798
(defstruct person1 name (age 20 :type fixnum)
801
(defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30))
802
(a3 0 :type (mod 30)) (a4 0 :type (mod 30)) )
804
;(defstruct person name age sex)
806
(defstruct (astronaut (:include person (age 45 :type fixnum))
809
(favorite-beverage 'tang))
811
(defstruct (foo (:constructor create-foo (a
817
(defstruct (binop (:type list) :named (:initial-offset 2))
822
(defstruct (annotated-binop (:type list)
added
removed
lsp/gcl_defstruct.lsp
