44 |
(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) |
(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) |
45 |
#'(lambda (&rest l) l nil))) |
#'(lambda (&rest l) l nil))) |
46 |
|
|
47 |
(defun make-access-function (name conc-name type named include no-fun |
(defun make-access-function (name conc-name no-conc type named include no-fun |
48 |
;; from apply |
;; from apply |
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 |
|
|
53 |
(let ((access-function |
(let ((access-function |
54 |
(intern (si:string-concatenate (string conc-name) |
(if no-conc |
55 |
(string slot-name)))) |
slot-name |
56 |
|
(intern (si:string-concatenate (string conc-name) |
57 |
|
(string slot-name))))) |
58 |
accsrs dont-overwrite) |
accsrs dont-overwrite) |
59 |
(ecase type |
(ecase type |
60 |
((nil) |
((nil) |
480 |
|
|
481 |
|
|
482 |
|
|
483 |
(defun define-structure (name conc-name type named slot-descriptions copier |
(defun define-structure (name conc-name no-conc type named slot-descriptions copier |
484 |
static include print-function constructors |
static include print-function constructors |
485 |
offset predicate &optional documentation no-funs |
offset predicate &optional documentation no-funs |
486 |
&aux def leng) |
&aux def leng) |
489 |
(dolist (x slot-descriptions) |
(dolist (x slot-descriptions) |
490 |
(and x (car x) |
(and x (car x) |
491 |
(apply #'make-access-function |
(apply #'make-access-function |
492 |
name conc-name type named include no-funs |
name conc-name no-conc type named include no-funs |
493 |
x ))) |
x ))) |
494 |
(when (and copier (not no-funs)) |
(when (and copier (not no-funs)) |
495 |
(setf (symbol-function copier) |
(setf (symbol-function copier) |
587 |
print-function type named initial-offset |
print-function type named initial-offset |
588 |
offset name-offset |
offset name-offset |
589 |
documentation |
documentation |
590 |
static) |
static |
591 |
|
(no-conc nil)) |
592 |
|
|
593 |
(when (consp name) |
(when (consp name) |
594 |
;; The defstruct options are supplied. |
;; The defstruct options are supplied. |
615 |
(setq o (caar os) v (cadar os)) |
(setq o (caar os) v (cadar os)) |
616 |
(case o |
(case o |
617 |
(:conc-name |
(:conc-name |
618 |
(if (null v) |
(if (null v) |
619 |
(setq conc-name "") |
(progn |
620 |
|
(setq conc-name "") |
621 |
|
(setq no-conc t)) |
622 |
(setq conc-name v))) |
(setq conc-name v))) |
623 |
(:constructor |
(:constructor |
624 |
(if (null v) |
(if (null v) |
650 |
(:constructor |
(:constructor |
651 |
(setq constructors |
(setq constructors |
652 |
(cons default-constructor constructors))) |
(cons default-constructor constructors))) |
653 |
((:conc-name :copier :predicate :print-function)) |
((:copier :predicate :print-function)) |
654 |
|
(:conc-name |
655 |
|
(progn |
656 |
|
(setq conc-name "") |
657 |
|
(setq no-conc t))) |
658 |
(:named (setq named t)) |
(:named (setq named t)) |
659 |
(t (error "~S is an illegal defstruct option." o)))))) |
(t (error "~S is an illegal defstruct option." o)))))) |
660 |
|
|
756 |
(error "A print function is supplied to a typed structure.")) |
(error "A print function is supplied to a typed structure.")) |
757 |
|
|
758 |
`(progn |
`(progn |
759 |
(define-structure ',name ',conc-name ',type |
(define-structure ',name ',conc-name ',no-conc ',type |
760 |
',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors |
',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors |
761 |
',offset ',predicate ',documentation |
',offset ',predicate ',documentation |
762 |
) |
) |