102 |
(cons (if type type name) offset))))))) |
(cons (if type type name) offset))))))) |
103 |
nil)) |
nil)) |
104 |
|
|
105 |
|
(defmacro key-name (key prior-keyword) |
106 |
|
`(cond |
107 |
|
((not (consp ,key)) |
108 |
|
,key) |
109 |
|
(t |
110 |
|
(unless (endp (cdddr ,key)) |
111 |
|
(error "Bad key ~S~%" ,key)) |
112 |
|
(cond |
113 |
|
((not (consp (car ,key))) |
114 |
|
(car ,key)) |
115 |
|
((and (eq ,prior-keyword '&key) (not (consp (caar ,key)))) |
116 |
|
(unless (endp (cddar ,key)) |
117 |
|
(error "Bad key ~S~%" ,key)) |
118 |
|
(cadar ,key)) |
119 |
|
(t |
120 |
|
(error "Bad key ~S~%" ,key)))))) |
121 |
|
|
122 |
|
(defmacro maybe-add-keydef (key keydefs prior-keyword) |
123 |
|
`(let ((def (cadar |
124 |
|
(member (key-name ,key ,prior-keyword) ,keydefs |
125 |
|
:key #'(lambda (k) (when (consp k) (car k))))))) |
126 |
|
(if def |
127 |
|
(cond ((not (consp ,key)) |
128 |
|
(list ,key def)) |
129 |
|
(t |
130 |
|
(if (cdr ,key) ,key (list (car ,key) def)))) |
131 |
|
,key))) |
132 |
|
|
133 |
|
(defun parse-boa-lambda-list (lambda-list keydefs) |
134 |
|
(let ((keywords '(none &optional &rest &key &allow-other-keys &aux)) |
135 |
|
vs res tk restvar seen-keys) |
136 |
|
(do ((ll lambda-list (cdr ll))) ((endp ll)) |
137 |
|
(let ((key (car ll))) |
138 |
|
(cond ((setq tk (member key keywords)) |
139 |
|
(setq keywords tk) |
140 |
|
(push key res) |
141 |
|
(push key seen-keys)) |
142 |
|
((member key lambda-list-keywords) |
143 |
|
(error "Keyword ~S appeared in a bad place in BOA lambda list" key)) |
144 |
|
(t |
145 |
|
(let ((prior-keyword (car keywords))) |
146 |
|
(case prior-keyword |
147 |
|
((none &rest) |
148 |
|
(unless (symbolp key) |
149 |
|
(error "non-symbol appeared in bad place in BOA lambda list" key)) |
150 |
|
(push key res) |
151 |
|
(push key vs) |
152 |
|
(when (eq prior-keyword '&rest) |
153 |
|
(when restvar |
154 |
|
(error "Multiple variables after &rest in BOA lambda list")) |
155 |
|
(setq restvar t))) |
156 |
|
((&optional &key) |
157 |
|
(push (maybe-add-keydef key keydefs prior-keyword) res) |
158 |
|
(push (key-name key prior-keyword) vs)) |
159 |
|
(&allow-other-keys |
160 |
|
(error "Variable ~S appeared after &allow-other-keys in BOA list" key)) |
161 |
|
(&aux |
162 |
|
(push key res) |
163 |
|
(push (key-name key prior-keyword) vs)))))))) |
164 |
|
(when (and (member '&rest seen-keys) (not restvar)) |
165 |
|
(error "Missing &rest variable in BOA list")) |
166 |
|
(unless (member '&aux seen-keys) |
167 |
|
(push '&aux res)) |
168 |
|
(do ((ll keydefs (cdr ll))) ((endp ll)) |
169 |
|
(let* ((keydef (car ll)) |
170 |
|
(keydef-name (if (atom keydef) keydef (car keydef)))) |
171 |
|
(unless (member keydef-name vs) |
172 |
|
(push keydef res)))) |
173 |
|
(nreverse res))) |
174 |
|
|
175 |
(defun make-constructor (name constructor type named |
(defun make-constructor (name constructor type named |
176 |
slot-descriptions) |
slot-descriptions) |
198 |
(t (list (list (car x) (cadr x)))))) |
(t (list (list (car x) (cadr x)))))) |
199 |
slot-descriptions))) |
slot-descriptions))) |
200 |
(cond ((consp constructor) |
(cond ((consp constructor) |
201 |
;; The case for a BOA constructor. |
(setq keys (parse-boa-lambda-list (cadr constructor) keys)) |
|
;; Dirty code!! |
|
|
;; We must add an initial value for an optional parameter, |
|
|
;; if the default value is not specified |
|
|
;; in the given parameter list and yet the initial value |
|
|
;; is supplied in the slot description. |
|
|
(do ((a (cadr constructor) (cdr a)) (l nil) (vs nil)) |
|
|
((endp a) |
|
|
;; Add those options that do not appear in the parameter list |
|
|
;; as auxiliary paramters. |
|
|
;; The parameters are accumulated in the variable VS. |
|
|
(setq keys |
|
|
(nreconc (cons '&aux l) |
|
|
(mapcan #'(lambda (k) |
|
|
(if (member (if (atom k) k (car k)) |
|
|
vs) |
|
|
nil |
|
|
(list k))) |
|
|
keys)))) |
|
|
;; Skip until &OPTIONAL appears. |
|
|
(when (member (car a) lambda-list-keywords) |
|
|
(or (eq (car a) '&optional) (push '&optional a))) |
|
|
(cond ((eq (car a) '&optional) |
|
|
(setq l (cons '&optional l)) |
|
|
(do ((aa (cdr a) (cdr aa)) (ov) (y)) |
|
|
((endp aa) |
|
|
;; Add those options that do not appear in the |
|
|
;; parameter list. |
|
|
(setq keys |
|
|
(nreconc (cons '&aux l) |
|
|
(mapcan #'(lambda (k) |
|
|
(if (member (if (atom k) |
|
|
k |
|
|
(car k)) |
|
|
vs) |
|
|
nil |
|
|
(list k))) |
|
|
keys))) |
|
|
(return nil)) |
|
|
(when (member (car aa) lambda-list-keywords) |
|
|
(when (eq (car aa) '&rest) |
|
|
;; &REST is found. |
|
|
(setq l (cons '&rest l)) |
|
|
(setq aa (cdr aa)) |
|
|
(unless (and (not (endp aa)) |
|
|
(symbolp (car aa))) |
|
|
(illegal-boa)) |
|
|
(setq vs (cons (car aa) vs)) |
|
|
(setq l (cons (car aa) l)) |
|
|
(setq aa (cdr aa)) |
|
|
(when (endp aa) |
|
|
(setq keys |
|
|
(nreconc |
|
|
(cons '&aux l) |
|
|
(mapcan |
|
|
#'(lambda (k) |
|
|
(if (member (if (atom k) |
|
|
k |
|
|
(car k)) |
|
|
vs) |
|
|
nil |
|
|
(list k))) |
|
|
keys))) |
|
|
(return nil))) |
|
|
;; &AUX should follow. |
|
|
(unless (eq (car aa) '&aux) |
|
|
(illegal-boa)) |
|
|
(setq l (cons '&aux l)) |
|
|
(do ((aaa (cdr aa) (cdr aaa))) |
|
|
((endp aaa)) |
|
|
(setq l (cons (car aaa) l)) |
|
|
(cond ((and (atom (car aaa)) |
|
|
(symbolp (car aaa))) |
|
|
(setq vs (cons (car aaa) vs))) |
|
|
((and (symbolp (caar aaa)) |
|
|
(or (endp (cdar aaa)) |
|
|
(endp (cddar aaa)))) |
|
|
(setq vs (cons (caar aaa) vs))) |
|
|
(t (illegal-boa)))) |
|
|
;; End of the parameter list. |
|
|
(setq keys |
|
|
(nreconc l |
|
|
(mapcan |
|
|
#'(lambda (k) |
|
|
(if (member (if (atom k) |
|
|
k |
|
|
(car k)) |
|
|
vs) |
|
|
nil |
|
|
(list k))) |
|
|
keys))) |
|
|
(return nil)) |
|
|
;; Checks if the optional paramter without a default |
|
|
;; value has a default value in the slot-description. |
|
|
(if (and (cond ((atom (car aa)) (setq ov (car aa)) t) |
|
|
((endp (cdar aa)) (setq ov (caar aa)) t) |
|
|
(t nil)) |
|
|
(setq y (member ov |
|
|
keys |
|
|
:key |
|
|
#'(lambda (x) |
|
|
(if (consp x) |
|
|
;; With default value. |
|
|
(car x)))))) |
|
|
;; If no default value is supplied for |
|
|
;; the optional parameter and yet appears |
|
|
;; in KEYS with a default value, |
|
|
;; then cons the pair to L, |
|
|
(setq l (cons (car y) l)) |
|
|
;; otherwise cons just the parameter to L. |
|
|
(setq l (cons (car aa) l))) |
|
|
;; Checks the form of the optional parameter. |
|
|
(cond ((atom (car aa)) |
|
|
(unless (symbolp (car aa)) |
|
|
(illegal-boa)) |
|
|
(setq vs (cons (car aa) vs))) |
|
|
((not (symbolp (caar aa))) |
|
|
(illegal-boa)) |
|
|
((or (endp (cdar aa)) (endp (cddar aa))) |
|
|
(setq vs (cons (caar aa) vs))) |
|
|
((not (symbolp (caddar aa))) |
|
|
(illegal-boa)) |
|
|
((not (endp (cdddar aa))) |
|
|
(illegal-boa)) |
|
|
(t |
|
|
(setq vs (cons (caar aa) vs)) |
|
|
(setq vs (cons (caddar aa) vs))))) |
|
|
;; RETURN from the outside DO. |
|
|
(return nil)) |
|
|
(t |
|
|
(unless (symbolp (car a)) |
|
|
(illegal-boa)) |
|
|
(setq l (cons (car a) l)) |
|
|
(setq vs (cons (car a) vs))))) |
|
202 |
(setq constructor (car constructor))) |
(setq constructor (car constructor))) |
203 |
(t |
(t |
204 |
;; If not a BOA constructor, just cons &KEY. |
;; If not a BOA constructor, just cons &KEY. |
215 |
(list ,@slot-names))) |
(list ,@slot-names))) |
216 |
((error "~S is an illegal structure type" type))))) |
((error "~S is an illegal structure type" type))))) |
217 |
|
|
|
(defun illegal-boa () |
|
|
(error "An illegal BOA constructor.")) |
|
|
|
|
218 |
(defun make-predicate (name predicate type named name-offset) |
(defun make-predicate (name predicate type named name-offset) |
219 |
(cond ((null type)) |
(cond ((null type)) |
220 |
; done in define-structure |
; done in define-structure |