/[gcl]/gcl/pcl/pcl_boot.lisp
ViewVC logotype

Diff of /gcl/pcl/pcl_boot.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by camm, Tue Oct 7 21:06:33 2003 UTC revision 1.4 by camm, Fri Oct 10 03:35:53 2003 UTC
# Line 157  work during bootstrapping. Line 157  work during bootstrapping.
157        ))        ))
158    
159    
160    
161    ;;;  FIXME need GCL support for these kernel:* functions
162    
163    ;;;
164    ;;;
165  ;;;  ;;;
166  ;;;  ;;;
167    ;;; ANSI 3.4.2, Generic Function Lambda Lists
168  ;;;  ;;;
169    
170    ;(defun parse-generic-function-lambda-list (lambda-list)
171      ;; This is like kernel:parse-lambda-list, but returns an additional
172      ;; value AUXP which is true if LAMBDA-LIST contains any &aux keyword.
173    ;  (multiple-value-bind (required optional restp rest keyp keys
174    ;                                allow-other-keys-p aux morep
175    ;                                more-context more-count)
176    ;      (kernel:parse-lambda-list lambda-list)
177    ;    (values required optional restp rest keyp keys allow-other-keys-p
178    ;           (or aux (member '&aux lambda-list :test #'eq)) aux
179    ;           morep more-context more-count)))
180    
181    ;(defun check-generic-function-lambda-list (function-specifier lambda-list)
182    ;  (multiple-value-bind (required optional restp rest keyp keys
183    ;                                allow-other-keys-p auxp aux morep
184    ;                                more-context more-count)
185    ;      (parse-generic-function-lambda-list lambda-list)
186    ;    (declare (ignore restp rest keyp aux allow-other-keys-p more-context
187    ;                    more-count))
188    ;    (labels ((lambda-list-error (format-control &rest format-arguments)
189    ;              (simple-program-error "Generic function ~A:~%~?"
190    ;                                    function-specifier
191    ;                                    format-control format-arguments))
192    ;            (check-required-parameter (parameter)
193    ;              (unless (symbolp parameter)
194    ;                (lambda-list-error
195    ;                 "Invalid generic function parameter name ~A"
196    ;                 parameter)))
197    ;            (check-key-or-optional-parameter (parameter)
198    ;              (unless (or (symbolp parameter)
199    ;                          (and (consp parameter)
200    ;                               (symbolp (car parameter))))
201    ;                (lambda-list-error
202    ;                 "Invalid generic function parameter name: ~A"
203    ;                 parameter))
204    ;              (when (and (consp parameter)
205    ;                         (not (null (cdr parameter))))
206    ;                (lambda-list-error
207    ;                 "Optional and key parameters of generic functions~%~
208    ;                   may not have default values or supplied-p ~
209    ;                   parameters: ~A" parameter))))
210    ;      (when morep
211    ;       (lambda-list-error
212    ;        "&MORE not allowed in generic function lambda lists"))
213    ;      (when auxp
214    ;       (lambda-list-error
215    ;        "&AUX not allowed in generic function lambda lists"))
216    ;      (mapc #'check-required-parameter required)
217    ;      (mapc #'check-key-or-optional-parameter optional)
218    ;      (mapc #'check-key-or-optional-parameter keys))))
219    
220  (defmacro defgeneric (function-specifier lambda-list &body options)  (defmacro defgeneric (function-specifier lambda-list &body options)
221    ;  (check-generic-function-lambda-list function-specifier lambda-list)
222    (expand-defgeneric function-specifier lambda-list options))    (expand-defgeneric function-specifier lambda-list options))
223    
224  (defun expand-defgeneric (function-specifier lambda-list options)  (defun expand-defgeneric (function-specifier lambda-list options)
# Line 454  work during bootstrapping. Line 512  work during bootstrapping.
512                  (mapcar #'(lambda (r s) (declare (ignore s)) r)                  (mapcar #'(lambda (r s) (declare (ignore s)) r)
513                          parameters                          parameters
514                          specializers))                          specializers))
515                   (specialized-parameters
516                    (loop for s in specialized-lambda-list
517                          for p in required-parameters
518                          when (listp s) collect p))
519                 (slots (mapcar #'list required-parameters))                 (slots (mapcar #'list required-parameters))
520                 (calls (list nil))                 (calls (list nil))
                (parameters-to-reference  
                 (make-parameter-references specialized-lambda-list  
                                            required-parameters  
                                            declarations  
                                            method-name  
                                            specializers))  
521                 (class-declarations                 (class-declarations
522                  `(declare                  `(declare
523                    ,@(remove nil                    ,@(remove nil
# Line 479  work during bootstrapping. Line 535  work during bootstrapping.
535                    ;; are inserted to communicate the class of the method's                    ;; are inserted to communicate the class of the method's
536                    ;; arguments to the code walk.                    ;; arguments to the code walk.
537                    `(lambda ,lambda-list                    `(lambda ,lambda-list
538                         (declare (ignorable ,@specialized-parameters))
539                       ,class-declarations                       ,class-declarations
540                       ,@declarations                       ,@declarations
                      (progn ,@parameters-to-reference)  
541                       (block ,(if (listp generic-function-name)                       (block ,(if (listp generic-function-name)
542                                   (cadr generic-function-name)                                   (cadr generic-function-name)
543                                   generic-function-name)                                   generic-function-name)
# Line 496  work during bootstrapping. Line 552  work during bootstrapping.
552                                          (symbol-package constant-value))))                                          (symbol-package constant-value))))
553                            (list :constant-value constant-value)                            (list :constant-value constant-value)
554                            ()))                            ()))
555                 (applyp (dolist (p lambda-list nil)                 (walked-lambda (walk-method-lambda method-lambda
556                           (cond ((memq p '(&optional &rest &key))                                                    required-parameters env
557                                  (return t))                                                    slots calls)))
                                ((eq p '&aux)  
                                 (return nil))))))  
             (multiple-value-bind (walked-lambda call-next-method-p closurep  
                                                 next-method-p-p)  
                 (walk-method-lambda method-lambda required-parameters env  
                                     slots calls)  
558                (multiple-value-bind (ignore walked-declarations walked-lambda-body)                (multiple-value-bind (ignore walked-declarations walked-lambda-body)
559                    (extract-declarations (cddr walked-lambda))                    (extract-declarations (cddr walked-lambda))
560                  (declare (ignore ignore))                  (declare (ignore ignore))
                 (when (or next-method-p-p call-next-method-p)  
                   (setq plist (list* :needs-next-methods-p 't plist)))  
561                  (when (some #'cdr slots)                  (when (some #'cdr slots)
562                    (multiple-value-bind (slot-name-lists call-list)                    (multiple-value-bind (slot-name-lists call-list)
563                        (slot-name-lists-from-slots slots calls)                        (slot-name-lists-from-slots slots calls)
# Line 534  work during bootstrapping. Line 582  work during bootstrapping.
582                  (values `(lambda (.method-args. .next-methods.)                  (values `(lambda (.method-args. .next-methods.)
583                             (simple-lexical-method-functions                             (simple-lexical-method-functions
584                                 (,lambda-list .method-args. .next-methods.                                 (,lambda-list .method-args. .next-methods.
585                                  :call-next-method-p ,call-next-method-p                                  :method-name-declaration ,name-decl)
                                 :next-method-p-p ,next-method-p-p  
                                 :closurep ,closurep  
                                 :applyp ,applyp)  
586                               ,@walked-declarations                               ,@walked-declarations
587                               ,@walked-lambda-body))                               ,@walked-lambda-body))
588                          `(,@(when plist                          `(,@(when plist
# Line 567  work during bootstrapping. Line 612  work during bootstrapping.
612        (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)        (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
613          ,@body))))          ,@body))))
614    
615    (defun call-no-next-method (method-name-declaration &rest args)
616      (destructuring-bind (name qualifiers specializers)
617          (car method-name-declaration)
618        (let ((method (find-method (gdefinition name) qualifiers specializers)))
619          (apply #'no-next-method (method-generic-function method) method args))))
620    
621  (defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body)  (defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body)
622    `(macrolet ((call-next-method-bind (&body body)    `(macrolet ((call-next-method-bind (&body body)
623                  `(let ((.next-method. (car ,',next-methods))                  `(let ((.next-method. (car ,',next-methods))
624                         (,',next-methods (cdr ,',next-methods)))                         (,',next-methods (cdr ,',next-methods)))
625                     .next-method. ,',next-methods                     .next-method. ,',next-methods
626                     ,@body))                     ,@body))
627                (call-next-method-body (cnm-args)                (call-next-method-body (method-name-declaration cnm-args)
628                  `(if .next-method.                  `(if .next-method.
629                       (funcall (the function                       (funcall (the function
630                                     (if (std-instance-p .next-method.)                                     (if (std-instance-p .next-method.)
# Line 581  work during bootstrapping. Line 632  work during bootstrapping.
632                                         .next-method.)) ; for early methods                                         .next-method.)) ; for early methods
633                                (or ,cnm-args ,',method-args)                                (or ,cnm-args ,',method-args)
634                                ,',next-methods)                                ,',next-methods)
635                       (error "No next method.")))                       (apply #'call-no-next-method ',method-name-declaration
636                                (or ,cnm-args ,',method-args))))
637                (next-method-p-body ()                (next-method-p-body ()
638                  `(not (null .next-method.))))                  `(not (null .next-method.))))
639       ,@body))       ,@body))
# Line 804  work during bootstrapping. Line 856  work during bootstrapping.
856                                             &body body)                                             &body body)
857    `(macrolet ((call-next-method-bind (&body body)    `(macrolet ((call-next-method-bind (&body body)
858                  `(let () ,@body))                  `(let () ,@body))
859                (call-next-method-body (cnm-args)                (call-next-method-body (method-name-declaration cnm-args)
860                  `(if ,',next-method-call                  `(if ,',next-method-call
861                       ,(if (and (null ',rest-arg)                       ,(if (and (null ',rest-arg)
862                                 (consp cnm-args)                                 (consp cnm-args)
# Line 823  work during bootstrapping. Line 875  work during bootstrapping.
875                                               ,cnm-args)                                               ,cnm-args)
876                                              ,call)                                              ,call)
877                                   ,call)))                                   ,call)))
878                       (error "No next method.")))                       ,(if (and (null ',rest-arg)
879                                   (consp cnm-args)
880                                   (eq (car cnm-args) 'list))
881                              `(call-no-next-method ',method-name-declaration
882                                                    ,@(cdr cnm-args))
883                              `(call-no-next-method ',method-name-declaration
884                                                    ,@',args
885                                                    ,@',(when rest-arg
886                                                          `(,rest-arg))))))
887                (next-method-p-body ()                (next-method-p-body ()
888                  `(not (null ,',next-method-call))))                  `(not (null ,',next-method-call))))
889       ,@body))       ,@body))
890    
891  (defmacro bind-lexical-method-functions  (defmacro bind-lexical-method-functions
892      ((&key call-next-method-p next-method-p-p closurep applyp)      ((&key method-name-declaration) ;call-next-method-p next-method-p-p closurep applyp)
893       &body body)       &body body)
894    (cond ((and (null call-next-method-p) (null next-method-p-p)      `(call-next-method-bind
895                (null closurep)        (flet ((call-next-method (&rest cnm-args)
896                (null applyp))                                 (call-next-method-body ,method-name-declaration cnm-args))
897           `(let () ,@body))               (next-method-p ()
898           ((and (null closurep)                              (next-method-p-body)))
899                 (null applyp))              ,@body)))
          ;; OK to use MACROLET, and all args are mandatory  
          ;; (else APPLYP would be true).  
          `(call-next-method-bind  
             (macrolet ((call-next-method (&rest cnm-args)  
                          `(call-next-method-body ,(when cnm-args `(list ,@cnm-args))))  
                        (next-method-p ()  
                          `(next-method-p-body)))  
                ,@body)))  
         (t  
          `(call-next-method-bind  
             (flet (,@(and call-next-method-p  
                        '((call-next-method (&rest cnm-args)  
                           #+Genera  
                           (declare (dbg:invisible-frame :clos-internal))  
                           #+copy-&rest-arg (setq args (copy-list args))  
                           (call-next-method-body cnm-args))))  
                      ,@(and next-method-p-p  
                          '((next-method-p ()  
                             (next-method-p-body)))))  
               ,@body)))))  
900    
901  (defmacro bind-args ((lambda-list args) &body body)  (defmacro bind-args ((lambda-list args) &body body)
902    #|| ; Lucid and Allegro don't compile the function inline    #|| ; Lucid and Allegro don't compile the function inline
# Line 1008  work during bootstrapping. Line 1048  work during bootstrapping.
1048             (standard-generic-function-p (gdefinition name))             (standard-generic-function-p (gdefinition name))
1049             (funcallable-instance-p (gdefinition name)))))             (funcallable-instance-p (gdefinition name)))))
1050    
 (defun make-parameter-references (specialized-lambda-list  
                                   required-parameters  
                                   declarations  
                                   method-name  
                                   specializers)  
   (flet ((ignoredp (symbol)  
            (dolist (decl (cdar declarations))  
              (when (and (eq (car decl) 'ignore)  
                         (memq symbol (cdr decl)))  
                (return t)))))        
     (gathering ((references (collecting)))  
       (iterate ((s (list-elements specialized-lambda-list))  
                 (p (list-elements required-parameters)))  
         (progn p)  
         (cond ((not (listp s)))  
               ((ignoredp (car s))  
                (warn "In defmethod ~S, there is a~%~  
                       redundant ignore declaration for the parameter ~S."  
                      method-name  
                      specializers  
                      (car s)))  
               (t  
                (gather (car s) references)))))))  
1051    
1052    
1053  (defvar *method-function-plist* (make-hash-table :test #'eq))  (defvar *method-function-plist* (make-hash-table :test #'eq))
# Line 1453  work during bootstrapping. Line 1470  work during bootstrapping.
1470            (lose "the method has ~S optional arguments than the generic function."            (lose "the method has ~S optional arguments than the generic function."
1471                  (compare nopt gf-nopt)))                  (compare nopt gf-nopt)))
1472          (unless (eq (or keysp restp) gf-key/rest-p)          (unless (eq (or keysp restp) gf-key/rest-p)
1473            (error "the method and generic function differ in whether they accept~%~            (lose "the method and generic function differ in whether they accept~%~
1474                    rest or keyword arguments."))                    rest or keyword arguments."))
1475          (when (consp gf-keywords)          (when (consp gf-keywords)
1476            (unless (or (and restp (not keysp))            (unless (or (and restp (not keysp))

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

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