/[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.2 by camm, Sun Sep 14 02:43:05 2003 UTC revision 1.3 by camm, Thu Oct 2 17:55:58 2003 UTC
# Line 102  Line 102 
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)
# Line 129  Line 198 
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.
# Line 279  Line 215 
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

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

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