49 |
slot-name default-init slot-type read-only |
slot-name default-init slot-type read-only |
50 |
offset &optional predicate ) |
offset &optional predicate ) |
51 |
(declare (ignore named default-init predicate )) |
(declare (ignore named default-init predicate )) |
|
|
|
52 |
(let ((access-function |
(let ((access-function |
53 |
(if no-conc |
(if no-conc |
54 |
slot-name |
slot-name |
171 |
(push keydef res)))) |
(push keydef res)))) |
172 |
(nreverse res))) |
(nreverse res))) |
173 |
|
|
174 |
|
(defun maybe-cons-keyname (x &optional y) |
175 |
|
(unless (consp x) |
176 |
|
(specific-error :invalid-form "x ~S is not a list~%" x)) |
177 |
|
(let ((sn (sixth x))) |
178 |
|
(if sn |
179 |
|
(if y |
180 |
|
(list (list (car x) sn) y) |
181 |
|
(list (list (car x) sn))) |
182 |
|
(if y (list (car x) y) (car x))))) |
183 |
|
|
184 |
(defun make-constructor (name constructor type named |
(defun make-constructor (name constructor type named |
185 |
slot-descriptions) |
slot-descriptions) |
186 |
(declare (ignore named)) |
(declare (ignore named)) |
196 |
;; it is the structure name. |
;; it is the structure name. |
197 |
;; This is for typed structures with names. |
;; This is for typed structures with names. |
198 |
(list 'quote (cadr x))) |
(list 'quote (cadr x))) |
199 |
(t (car x)))) |
(t (let ((sn (sixth x))) (if sn sn (car x)))))) |
200 |
slot-descriptions)) |
slot-descriptions)) |
201 |
(keys |
(keys |
202 |
;; Make the keyword parameters. |
;; Make the keyword parameters. |
203 |
(mapcan #'(lambda (x) |
(mapcan #'(lambda (x) |
204 |
(cond ((null x) nil) |
(cond ((null x) nil) |
205 |
((null (car x)) nil) |
((null (car x)) nil) |
206 |
((null (cadr x)) (list (car x))) |
((null (cadr x)) (list (maybe-cons-keyname x))) |
207 |
(t (list (list (car x) (cadr x)))))) |
(t (list (maybe-cons-keyname x (cadr x)))))) |
208 |
slot-descriptions))) |
slot-descriptions))) |
209 |
(cond ((consp constructor) |
(cond ((consp constructor) |
210 |
(setq keys (parse-boa-lambda-list (cadr constructor) keys)) |
(setq keys (parse-boa-lambda-list (cadr constructor) keys)) |
212 |
(t |
(t |
213 |
;; If not a BOA constructor, just cons &KEY. |
;; If not a BOA constructor, just cons &KEY. |
214 |
(setq keys (cons '&key keys)))) |
(setq keys (cons '&key keys)))) |
215 |
(cond ((null type) |
(cond ((null type) |
216 |
`(defun ,constructor ,keys |
`(defun ,constructor ,keys |
217 |
(si:make-structure ',name ,@slot-names))) |
(si:make-structure ',name ,@slot-names))) |
218 |
((or (eq type 'vector) |
((eq type 'vector) |
219 |
(and (consp type) (eq (car type) 'vector))) |
`(defun ,constructor ,keys |
220 |
`(defun ,constructor ,keys |
(vector ,@slot-names))) |
221 |
(vector ,@slot-names))) |
((and (consp type) (eq (car type) 'vector)) |
222 |
((eq type 'list) |
(if (endp (cdr type)) |
223 |
`(defun ,constructor ,keys |
`(defun ,constructor ,keys |
224 |
(list ,@slot-names))) |
(vector ,@slot-names))) |
225 |
((error "~S is an illegal structure type" type))))) |
`(defun ,constructor ,keys |
226 |
|
(make-array ,(length slot-names) |
227 |
|
:element-type ',(cadr type) |
228 |
|
:initial-contents (list ,@slot-names)))) |
229 |
|
((eq type 'list) |
230 |
|
`(defun ,constructor ,keys |
231 |
|
(list ,@slot-names))) |
232 |
|
((error "~S is an illegal structure type" type))))) |
233 |
|
|
234 |
(defun make-predicate (name predicate type named name-offset) |
(defun make-predicate (name predicate type named name-offset) |
235 |
(cond ((null type)) |
(cond ((null type)) |
236 |
; done in define-structure |
; done in define-structure |
407 |
(list ar (round-up pos (size-of t)) has-holes) |
(list ar (round-up pos (size-of t)) has-holes) |
408 |
)))) |
)))) |
409 |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
410 |
(defun define-structure (name conc-name no-conc type named slot-descriptions copier |
(defun define-structure (name conc-name no-conc type named slot-descriptions copier |
411 |
static include print-function constructors |
static include print-function constructors |
412 |
offset predicate &optional documentation no-funs |
offset predicate &optional documentation no-funs |
414 |
(and (consp type) (eq (car type) 'vector)(setq type 'vector)) |
(and (consp type) (eq (car type) 'vector)(setq type 'vector)) |
415 |
(setq leng(length slot-descriptions)) |
(setq leng(length slot-descriptions)) |
416 |
(dolist (x slot-descriptions) |
(dolist (x slot-descriptions) |
417 |
(and x (car x) |
(and x (car x) |
418 |
(apply #'make-access-function |
(apply #'make-access-function |
419 |
name conc-name no-conc type named include no-funs |
name conc-name no-conc type named include no-funs |
420 |
x ))) |
x ))) |
421 |
(when (and copier (not no-funs)) |
(when (and copier (not no-funs)) |
422 |
(setf (symbol-function copier) |
(setf (symbol-function copier) |
423 |
(ecase type |
(ecase type |
486 |
(or tem (setf (get name 's-data) def))) |
(or tem (setf (get name 's-data) def))) |
487 |
(tem |
(tem |
488 |
(check-s-data tem def name)) |
(check-s-data tem def name)) |
489 |
(t (setf (get name 's-data) def))) |
(t (setf (get name 's-data) def))) |
490 |
(when documentation |
(when documentation |
491 |
(setf (get name 'structure-documentation) |
(setf (get name 'structure-documentation) |
492 |
documentation)) |
documentation)) |
681 |
;; Check the print-function. |
;; Check the print-function. |
682 |
(when (and print-function type) |
(when (and print-function type) |
683 |
(error "A print function is supplied to a typed structure.")) |
(error "A print function is supplied to a typed structure.")) |
|
|
|
|
`(progn |
|
|
(define-structure ',name ',conc-name ',no-conc ',type |
|
|
',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors |
|
|
',offset ',predicate ',documentation |
|
|
) |
|
684 |
|
|
685 |
,@(mapcar #'(lambda (constructor) |
(let* (new-slot-descriptions |
686 |
(make-constructor name constructor type named |
(new-slot-descriptions ;(copy-list slot-descriptions))) |
687 |
slot-descriptions)) |
(dolist (sd slot-descriptions (nreverse new-slot-descriptions)) |
688 |
constructors) |
(if (and (consp sd) (eql (length sd) 5)) |
689 |
,@(if (and type predicate) |
(let* ((csd (car sd)) |
690 |
(list (make-predicate name predicate type named |
(sym (when (or (constantp csd) (keywordp csd) (si::specialp csd)) |
691 |
name-offset))) |
(make-symbol (symbol-name csd)))) |
692 |
',name |
(nsd (if (or (constantp csd) (si::specialp csd)) |
693 |
))) |
(cons (intern (symbol-name csd) 'keyword) (cdr sd)) |
694 |
|
sd))) |
695 |
|
(push (append nsd (list sym)) new-slot-descriptions) |
696 |
|
(when sym |
697 |
|
(setf (car sd) sym))) |
698 |
|
(push sd new-slot-descriptions))))) |
699 |
|
`(progn |
700 |
|
(define-structure ',name ',conc-name ',no-conc ',type |
701 |
|
',named ',slot-descriptions ',copier ',static ',include |
702 |
|
',print-function ',constructors |
703 |
|
',offset ',predicate ',documentation |
704 |
|
) |
705 |
|
|
706 |
|
,@(mapcar #'(lambda (constructor) |
707 |
|
(make-constructor name constructor type named new-slot-descriptions)) |
708 |
|
constructors) |
709 |
|
,@(if (and type predicate) |
710 |
|
(list (make-predicate name predicate type named |
711 |
|
name-offset))) |
712 |
|
',name |
713 |
|
)))) |
714 |
|
|
715 |
;; First several fields of this must coincide with the C structure |
;; First several fields of this must coincide with the C structure |
716 |
;; s_data (see object.h). |
;; s_data (see object.h). |