From: <cli...@li...> - 2004-08-30 13:36:05
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src ChangeLog,1.3469,1.3470 clos-genfun2.lisp,1.34,1.35 (Bruno Haible) 2. clisp/src ChangeLog,1.3470,1.3471 clos-genfun2.lisp,1.35,1.36 clos-genfun3.lisp,1.30,1.31 clos-genfun4.lisp,1.14,1.15 clos-method2.lisp,1.18,1.19 describe.lisp,1.50,1.51 (Bruno Haible) 3. clisp/src clos-class0.lisp,1.2,1.3 ChangeLog,1.3472,1.3473 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3469,1.3470 clos-genfun2.lisp,1.34,1.35 Date: Mon, 30 Aug 2004 11:01:53 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4125 Modified Files: ChangeLog clos-genfun2.lisp Log Message: Use set-funcallable-instance-function. Index: clos-genfun2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun2.lisp,v retrieving revision 1.34 retrieving revision 1.35 diff -u -d -r1.34 -r1.35 --- clos-genfun2.lisp 26 Aug 2004 10:45:13 -0000 1.34 +++ clos-genfun2.lisp 30 Aug 2004 11:01:50 -0000 1.35 @@ -391,37 +391,38 @@ (finalize-fast-gf gf) gf)) -(let ((prototype-table - (make-hash-table :key-type '(cons fixnum boolean) :value-type '(simple-array (unsigned-byte 8) (*)) +(let ((prototype-factory-table + (make-hash-table :key-type '(cons fixnum boolean) :value-type '(cons function (simple-array (unsigned-byte 8) (*))) :test 'ext:stablehash-equal :warn-if-needs-rehash-after-gc t))) (defun finalize-fast-gf (gf) (let* ((signature (std-gf-signature gf)) - (reqanz (sig-req-num signature)) + (reqnum (sig-req-num signature)) (restp (gf-sig-restp signature)) - (hash-key (cons reqanz restp)) - (prototype - (or (gethash hash-key prototype-table) - (setf (gethash hash-key prototype-table) - (let* ((reqvars (gensym-list reqanz)) - (proto-gf - (eval `(LET ((GF 'MAGIC)) - (DECLARE (COMPILE)) - (%GENERIC-FUNCTION-LAMBDA - (,@reqvars ,@(if restp '(&REST ARGS) '())) - (DECLARE (INLINE FUNCALL) (IGNORABLE ,@reqvars ,@(if restp '(ARGS) '()))) - (FUNCALL 'INITIAL-FUNCALL-GF GF)))))) - ;; we must keep (sys::%record-ref proto-gf 1) . - ;; (sys::%record-ref proto-gf 2) = #(NIL INITIAL-FUNCALL-GF MAGIC) - (sys::%record-ref proto-gf 1)))))) - (setf (sys::%record-ref gf 1) prototype) - (setf (sys::%record-ref gf 2) (vector 'NIL 'INITIAL-FUNCALL-GF gf)))) + (hash-key (cons reqnum restp)) + (prototype-factory + (car + (or (gethash hash-key prototype-factory-table) + (setf (gethash hash-key prototype-factory-table) + (let* ((reqvars (gensym-list reqnum)) + (prototype-factory + (eval `#'(LAMBDA (GF) + (DECLARE (COMPILE)) + (%GENERIC-FUNCTION-LAMBDA + (,@reqvars ,@(if restp '(&REST ARGS) '())) + (DECLARE (INLINE FUNCALL) (IGNORABLE ,@reqvars ,@(if restp '(ARGS) '()))) + (FUNCALL 'INITIAL-FUNCALL-GF GF)))))) + (assert (<= (sys::%record-length (funcall prototype-factory 'dummy)) 3)) + (cons prototype-factory + (sys::closure-codevec (funcall prototype-factory 'dummy))))))))) + (set-funcallable-instance-function gf (funcall prototype-factory gf)))) (defun gf-never-called-p (gf) (let* ((signature (std-gf-signature gf)) - (reqanz (sig-req-num signature)) + (reqnum (sig-req-num signature)) (restp (gf-sig-restp signature)) - (hash-key (cons reqanz restp)) - (prototype (gethash hash-key prototype-table))) - (eq (sys::%record-ref gf 1) prototype))) + (hash-key (cons reqnum restp)) + (prototype-factory+codevec (gethash hash-key prototype-factory-table))) + (assert prototype-factory+codevec) + (eq (sys::closure-codevec gf) (cdr prototype-factory+codevec)))) (defvar *dynamically-modifiable-generic-function-names* ;; A list of names of functions, which ANSI CL explicitly denotes as ;; "Standard Generic Function"s, meaning that the user may add methods. Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3469 retrieving revision 1.3470 diff -u -d -r1.3469 -r1.3470 --- ChangeLog 27 Aug 2004 20:21:18 -0000 1.3469 +++ ChangeLog 30 Aug 2004 11:01:48 -0000 1.3470 @@ -1,3 +1,9 @@ +2004-06-20 Bruno Haible <br...@cl...> + + * clos-genfun2.lisp (finalize-fast-gf, gf-never-called-p): Use a + prototype-factory-table instead of just a prototype-table. Use + set-funcallable-instance-function. + 2004-08-27 Sam Steingold <sd...@gn...> * makemake.in (full-check): pass "-E utf-8" to clisp; --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src ChangeLog,1.3470,1.3471 clos-genfun2.lisp,1.35,1.36 clos-genfun3.lisp,1.30,1.31 clos-genfun4.lisp,1.14,1.15 clos-method2.lisp,1.18,1.19 describe.lisp,1.50,1.51 Date: Mon, 30 Aug 2004 11:04:12 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4614 Modified Files: ChangeLog clos-genfun2.lisp clos-genfun3.lisp clos-genfun4.lisp clos-method2.lisp describe.lisp Log Message: Handle the case that the generic-function's lambda-list is not yet initialized. Index: clos-genfun2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun2.lisp,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- clos-genfun2.lisp 30 Aug 2004 11:01:50 -0000 1.35 +++ clos-genfun2.lisp 30 Aug 2004 11:04:10 -0000 1.36 @@ -393,36 +393,46 @@ (let ((prototype-factory-table (make-hash-table :key-type '(cons fixnum boolean) :value-type '(cons function (simple-array (unsigned-byte 8) (*))) - :test 'ext:stablehash-equal :warn-if-needs-rehash-after-gc t))) + :test 'ext:stablehash-equal :warn-if-needs-rehash-after-gc t)) + (uninitialized-prototype-factory + (eval `#'(LAMBDA (GF) + (DECLARE (COMPILE)) + (%GENERIC-FUNCTION-LAMBDA (&REST ARGS) + (DECLARE (INLINE FUNCALL) (IGNORE ARGS)) + (FUNCALL 'NO-METHOD-CALLER 'NO-APPLICABLE-METHOD GF)))))) (defun finalize-fast-gf (gf) - (let* ((signature (std-gf-signature gf)) - (reqnum (sig-req-num signature)) - (restp (gf-sig-restp signature)) - (hash-key (cons reqnum restp)) - (prototype-factory - (car - (or (gethash hash-key prototype-factory-table) - (setf (gethash hash-key prototype-factory-table) - (let* ((reqvars (gensym-list reqnum)) - (prototype-factory - (eval `#'(LAMBDA (GF) - (DECLARE (COMPILE)) - (%GENERIC-FUNCTION-LAMBDA - (,@reqvars ,@(if restp '(&REST ARGS) '())) - (DECLARE (INLINE FUNCALL) (IGNORABLE ,@reqvars ,@(if restp '(ARGS) '()))) - (FUNCALL 'INITIAL-FUNCALL-GF GF)))))) - (assert (<= (sys::%record-length (funcall prototype-factory 'dummy)) 3)) - (cons prototype-factory - (sys::closure-codevec (funcall prototype-factory 'dummy))))))))) + (let ((prototype-factory + (if (eq (std-gf-signature gf) (sys::%unbound)) + ;; gf has uninitialized lambda-list, hence no methods. + uninitialized-prototype-factory + (let* ((signature (std-gf-signature gf)) + (reqnum (sig-req-num signature)) + (restp (gf-sig-restp signature)) + (hash-key (cons reqnum restp))) + (car + (or (gethash hash-key prototype-factory-table) + (setf (gethash hash-key prototype-factory-table) + (let* ((reqvars (gensym-list reqnum)) + (prototype-factory + (eval `#'(LAMBDA (GF) + (DECLARE (COMPILE)) + (%GENERIC-FUNCTION-LAMBDA + (,@reqvars ,@(if restp '(&REST ARGS) '())) + (DECLARE (INLINE FUNCALL) (IGNORABLE ,@reqvars ,@(if restp '(ARGS) '()))) + (FUNCALL 'INITIAL-FUNCALL-GF GF)))))) + (assert (<= (sys::%record-length (funcall prototype-factory 'dummy)) 3)) + (cons prototype-factory + (sys::closure-codevec (funcall prototype-factory 'dummy))))))))))) (set-funcallable-instance-function gf (funcall prototype-factory gf)))) (defun gf-never-called-p (gf) - (let* ((signature (std-gf-signature gf)) - (reqnum (sig-req-num signature)) - (restp (gf-sig-restp signature)) - (hash-key (cons reqnum restp)) - (prototype-factory+codevec (gethash hash-key prototype-factory-table))) - (assert prototype-factory+codevec) - (eq (sys::closure-codevec gf) (cdr prototype-factory+codevec)))) + (or (eq (std-gf-signature gf) (sys::%unbound)) + (let* ((signature (std-gf-signature gf)) + (reqnum (sig-req-num signature)) + (restp (gf-sig-restp signature)) + (hash-key (cons reqnum restp)) + (prototype-factory+codevec (gethash hash-key prototype-factory-table))) + (assert prototype-factory+codevec) + (eq (sys::closure-codevec gf) (cdr prototype-factory+codevec))))) (defvar *dynamically-modifiable-generic-function-names* ;; A list of names of functions, which ANSI CL explicitly denotes as ;; "Standard Generic Function"s, meaning that the user may add methods. @@ -495,6 +505,14 @@ ;; One does not need to write (APPLY ... Arguments), ;; it is done by %GENERIC-FUNCTION-LAMBDA automatically. (defun compute-dispatch (gf) + (when (eq (std-gf-signature gf) (sys::%unbound)) + ;; gf has uninitialized lambda-list, hence no methods. + (return-from compute-dispatch + (values + '() + `((&REST ,(gensym)) + (DECLARE (INLINE FUNCALL)) + (FUNCALL 'NO-METHOD-CALLER 'NO-APPLICABLE-METHOD ',gf))))) (let* ((signature (std-gf-signature gf)) (req-anz (sig-req-num signature)) (req-vars (gensym-list req-anz)) @@ -741,7 +759,7 @@ (BLOCK ,block-name ,form ,@(if maybe-no-applicable - `((funcall 'no-method-caller 'no-applicable-method + `((FUNCALL 'NO-METHOD-CALLER 'NO-APPLICABLE-METHOD ',gf)))))))))) (defun no-method-caller (no-method-name gf) @@ -805,6 +823,10 @@ ;;; for the same EQL and class restrictions as the given arguments, ;;; therefore compute dispatch is already taken care of. (defun compute-applicable-methods-effective-method (gf &rest args) + (when (eq (std-gf-signature gf) (sys::%unbound)) + ;; gf has uninitialized lambda-list, hence no methods. + (return-from compute-applicable-methods-effective-method + (no-method-caller 'no-applicable-method gf))) (let ((req-num (sig-req-num (std-gf-signature gf)))) (if (>= (length args) req-num) (let ((req-args (subseq args 0 req-num))) @@ -841,24 +863,27 @@ (compute-applicable-methods-<standard-generic-function> gf args)) (defun compute-applicable-methods-<standard-generic-function> (gf args) - (let ((req-num (sig-req-num (std-gf-signature gf)))) - (if (>= (length args) req-num) - ;; 0. Check the method specializers: - (let ((methods (std-gf-methods gf))) - (dolist (method methods) - (check-method-only-standard-specializers gf method - 'compute-applicable-methods)) - ;; 1. Select the applicable methods: - (let ((req-args (subseq args 0 req-num))) - (setq methods - (remove-if-not #'(lambda (method) - (method-applicable-p method req-args)) - (the list methods))) - ;; 2. Sort the applicable methods by precedence order: - (sort-applicable-methods methods (mapcar #'class-of req-args) (std-gf-argorder gf)))) - (error (TEXT "~S: ~S has ~S required argument~:P, but only ~S arguments were passed to ~S: ~S") - 'compute-applicable-methods gf req-num (length args) - 'compute-applicable-methods args)))) + (if (eq (std-gf-signature gf) (sys::%unbound)) + ;; gf has uninitialized lambda-list, hence no methods. + '() + (let ((req-num (sig-req-num (std-gf-signature gf)))) + (if (>= (length args) req-num) + ;; 0. Check the method specializers: + (let ((methods (std-gf-methods gf))) + (dolist (method methods) + (check-method-only-standard-specializers gf method + 'compute-applicable-methods)) + ;; 1. Select the applicable methods: + (let ((req-args (subseq args 0 req-num))) + (setq methods + (remove-if-not #'(lambda (method) + (method-applicable-p method req-args)) + (the list methods))) + ;; 2. Sort the applicable methods by precedence order: + (sort-applicable-methods methods (mapcar #'class-of req-args) (std-gf-argorder gf)))) + (error (TEXT "~S: ~S has ~S required argument~:P, but only ~S arguments were passed to ~S: ~S") + 'compute-applicable-methods gf req-num (length args) + 'compute-applicable-methods args))))) ;; compute-applicable-methods-using-classes is just plain redundant, and must ;; be a historical relic of the time before CLOS had EQL specializers (or a @@ -872,45 +897,48 @@ (unless (and (proper-list-p req-arg-classes) (every #'class-p req-arg-classes)) (error (TEXT "~S: argument should be a proper list of classes, not ~S") 'compute-applicable-methods-using-classes req-arg-classes)) - (let ((req-num (sig-req-num (std-gf-signature gf)))) - (if (= (length req-arg-classes) req-num) - ;; 0. Check the method specializers: - (let ((methods (std-gf-methods gf))) - (dolist (method methods) - (check-method-only-standard-specializers gf method - 'compute-applicable-methods-using-classes)) - ;; 1. Select the applicable methods. Note that the arguments are - ;; assumed to be _direct_ instances of the given classes, i.e. - ;; classes = (mapcar #'class-of required-arguments). - (setq methods - (remove-if-not #'(lambda (method) - (let ((specializers (std-method-specializers method)) - (applicable t) (unknown nil)) - (mapc #'(lambda (arg-class specializer) - (if (class-p specializer) - ;; For class specializers, - ;; (typep arg specializer) is equivalent to - ;; (subtypep (class-of arg) specializer). - (unless (subclassp arg-class specializer) - (setq applicable nil)) - ;; For EQL specializers, - ;; (typep arg specializer) is certainly false - ;; if (class-of arg) and (class-of (eql-specializer-object specializer)) - ;; differ. Otherwise unknown. - (if (eq arg-class (class-of (eql-specializer-object specializer))) - (setq unknown t) - (setq applicable nil)))) - req-arg-classes specializers) - (when (and applicable unknown) - (return-from compute-applicable-methods-using-classes-<standard-generic-function> - (values nil nil))) - applicable)) - (the list methods))) - ;; 2. Sort the applicable methods by precedence order: - (values (sort-applicable-methods methods req-arg-classes (std-gf-argorder gf)) t)) - (error (TEXT "~S: ~S has ~S required argument~:P, but ~S classes were passed to ~S: ~S") - 'compute-applicable-methods-using-classes gf req-num (length req-arg-classes) - 'compute-applicable-methods-using-classes req-arg-classes)))) + (if (eq (std-gf-signature gf) (sys::%unbound)) + ;; gf has uninitialized lambda-list, hence no methods. + '() + (let ((req-num (sig-req-num (std-gf-signature gf)))) + (if (= (length req-arg-classes) req-num) + ;; 0. Check the method specializers: + (let ((methods (std-gf-methods gf))) + (dolist (method methods) + (check-method-only-standard-specializers gf method + 'compute-applicable-methods-using-classes)) + ;; 1. Select the applicable methods. Note that the arguments are + ;; assumed to be _direct_ instances of the given classes, i.e. + ;; classes = (mapcar #'class-of required-arguments). + (setq methods + (remove-if-not #'(lambda (method) + (let ((specializers (std-method-specializers method)) + (applicable t) (unknown nil)) + (mapc #'(lambda (arg-class specializer) + (if (class-p specializer) + ;; For class specializers, + ;; (typep arg specializer) is equivalent to + ;; (subtypep (class-of arg) specializer). + (unless (subclassp arg-class specializer) + (setq applicable nil)) + ;; For EQL specializers, + ;; (typep arg specializer) is certainly false + ;; if (class-of arg) and (class-of (eql-specializer-object specializer)) + ;; differ. Otherwise unknown. + (if (eq arg-class (class-of (eql-specializer-object specializer))) + (setq unknown t) + (setq applicable nil)))) + req-arg-classes specializers) + (when (and applicable unknown) + (return-from compute-applicable-methods-using-classes-<standard-generic-function> + (values nil nil))) + applicable)) + (the list methods))) + ;; 2. Sort the applicable methods by precedence order: + (values (sort-applicable-methods methods req-arg-classes (std-gf-argorder gf)) t)) + (error (TEXT "~S: ~S has ~S required argument~:P, but ~S classes were passed to ~S: ~S") + 'compute-applicable-methods-using-classes gf req-num (length req-arg-classes) + 'compute-applicable-methods-using-classes req-arg-classes))))) ;; There's no real reason for checking the method specializers in ;; compute-applicable-methods, rather than in Index: describe.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/describe.lisp,v retrieving revision 1.50 retrieving revision 1.51 diff -u -d -r1.50 -r1.51 --- describe.lisp 5 Aug 2004 11:15:27 -0000 1.50 +++ describe.lisp 30 Aug 2004 11:04:10 -0000 1.51 @@ -403,9 +403,10 @@ (format stream (TEXT ".")))) (:method ((obj generic-function) (stream stream)) (format stream (TEXT "a generic function.")) - (terpri stream) - (format stream (TEXT "Argument list: ~A") - (compiler::sig-to-list (clos::std-gf-signature obj))) + (unless (eq (clos::std-gf-signature obj) (sys::%unbound)) + (terpri stream) + (format stream (TEXT "Argument list: ~A") + (compiler::sig-to-list (clos::std-gf-signature obj)))) (let ((mc (clos::method-combination-name (clos::std-gf-method-combination obj)))) (unless (eq mc 'STANDARD) (terpri stream) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3470 retrieving revision 1.3471 diff -u -d -r1.3470 -r1.3471 --- ChangeLog 30 Aug 2004 11:01:48 -0000 1.3470 +++ ChangeLog 30 Aug 2004 11:04:09 -0000 1.3471 @@ -1,3 +1,21 @@ +2004-06-24 Bruno Haible <br...@cl...> + + * clos-genfun2.lisp (finalize-fast-gf, gf-never-called-p, + compute-dispatch, compute-applicable-methods-effective-method, + compute-applicable-methods-<standard-generic-function>, + compute-applicable-methods-using-classes-<standard-generic-function>): + Handle the case that the generic-function's lambda-list is not yet + initialized. + * clos-genfun3.lisp (gf-lambdalist-from-first-method): New function. + (std-add-method, std-find-method): Handle the case that the + generic-function's lambda-list is not yet initialized. + (do-defmethod): Use gf-lambdalist-from-first-method. + * clos-genfun4.lisp (no-applicable-method, missing-required-method, + no-primary-method): Handle the case that the generic-function's + lambda-list is not yet initialized. + * clos-method2.lisp (analyze-method-description): Likewise. + * describe.lisp (describe-object@generic-function): Likewise. + 2004-06-20 Bruno Haible <br...@cl...> * clos-genfun2.lisp (finalize-fast-gf, gf-never-called-p): Use a Index: clos-genfun4.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun4.lisp,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- clos-genfun4.lisp 27 Aug 2004 11:22:20 -0000 1.14 +++ clos-genfun4.lisp 30 Aug 2004 11:04:10 -0000 1.15 @@ -50,28 +50,34 @@ (defgeneric no-applicable-method (gf &rest args) (:method ((gf t) &rest args) - (let* ((reqanz (sig-req-num (std-gf-signature gf))) - (methods (std-gf-methods gf)) - (dispatching-arg (single-dispatching-arg reqanz methods))) + (let* ((methods (std-gf-methods gf)) + (dispatching-arg + (if (eq (std-gf-signature gf) (sys::%unbound)) + nil + (let ((reqnum (sig-req-num (std-gf-signature gf)))) + (single-dispatching-arg reqnum methods))))) (sys::retry-function-call - (if dispatching-arg - (make-condition 'method-call-type-error - :datum (nth dispatching-arg args) - :expected-type (dispatching-arg-type dispatching-arg methods) - :generic-function gf :argument-list args - :format-control (TEXT "~S: When calling ~S with arguments ~S, no method is applicable.") - :format-arguments (list 'no-applicable-method gf args)) - (make-condition 'method-call-error - :generic-function gf :argument-list args - :format-control (TEXT "~S: When calling ~S with arguments ~S, no method is applicable.") - :format-arguments (list 'no-applicable-method gf args))) - gf args)))) + (if dispatching-arg + (make-condition 'method-call-type-error + :datum (nth dispatching-arg args) + :expected-type (dispatching-arg-type dispatching-arg methods) + :generic-function gf :argument-list args + :format-control (TEXT "~S: When calling ~S with arguments ~S, no method is applicable.") + :format-arguments (list 'no-applicable-method gf args)) + (make-condition 'method-call-error + :generic-function gf :argument-list args + :format-control (TEXT "~S: When calling ~S with arguments ~S, no method is applicable.") + :format-arguments (list 'no-applicable-method gf args))) + gf args)))) (defgeneric missing-required-method (gf combination group-name group-filter &rest args) (:method ((gf t) (combination method-combination) (group-name symbol) (group-filter function) &rest args) - (let* ((reqanz (sig-req-num (std-gf-signature gf))) - (methods (remove-if-not group-filter (std-gf-methods gf))) - (dispatching-arg (single-dispatching-arg reqanz methods))) + (let* ((methods (remove-if-not group-filter (std-gf-methods gf))) + (dispatching-arg + (if (eq (std-gf-signature gf) (sys::%unbound)) + nil + (let ((reqnum (sig-req-num (std-gf-signature gf)))) + (single-dispatching-arg reqnum methods))))) (if dispatching-arg (error-of-type 'method-call-type-error :datum (nth dispatching-arg args) @@ -88,23 +94,26 @@ ;; and the PRIMARY method group. (defgeneric no-primary-method (gf &rest args) (:method ((gf t) &rest args) - (let* ((reqanz (sig-req-num (std-gf-signature gf))) - (methods (remove-if-not #'null (std-gf-methods gf) + (let* ((methods (remove-if-not #'null (std-gf-methods gf) :key #'std-method-qualifiers)) - (dispatching-arg (single-dispatching-arg reqanz methods))) + (dispatching-arg + (if (eq (std-gf-signature gf) (sys::%unbound)) + nil + (let ((reqnum (sig-req-num (std-gf-signature gf)))) + (single-dispatching-arg reqnum methods))))) (sys::retry-function-call - (if dispatching-arg - (make-condition 'method-call-type-error - :datum (nth dispatching-arg args) - :expected-type (dispatching-arg-type dispatching-arg methods) - :generic-function gf :argument-list args - :format-control (TEXT "~S: When calling ~S with arguments ~S, no primary method is applicable.") - :format-arguments (list 'no-primary-method gf args)) - (make-condition 'method-call-error - :generic-function gf :argument-list args - :format-control (TEXT "~S: When calling ~S with arguments ~S, no primary method is applicable.") - :format-arguments (list 'no-primary-method gf args))) - gf args)))) + (if dispatching-arg + (make-condition 'method-call-type-error + :datum (nth dispatching-arg args) + :expected-type (dispatching-arg-type dispatching-arg methods) + :generic-function gf :argument-list args + :format-control (TEXT "~S: When calling ~S with arguments ~S, no primary method is applicable.") + :format-arguments (list 'no-primary-method gf args)) + (make-condition 'method-call-error + :generic-function gf :argument-list args + :format-control (TEXT "~S: When calling ~S with arguments ~S, no primary method is applicable.") + :format-arguments (list 'no-primary-method gf args))) + gf args)))) (defun %no-next-method (method &rest args) (apply #'no-next-method (std-method-generic-function method) method args)) Index: clos-genfun3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun3.lisp,v retrieving revision 1.30 retrieving revision 1.31 diff -u -d -r1.30 -r1.31 --- clos-genfun3.lisp 27 Aug 2004 11:27:01 -0000 1.30 +++ clos-genfun3.lisp 30 Aug 2004 11:04:10 -0000 1.31 @@ -92,9 +92,36 @@ (method-combination-name (std-gf-method-combination gf)) gf (std-method-qualifiers method) method)) +;; MOP p. 62 says that the lambda-list of a generic function may become +;; determined only at the moment when the first method is added. +(defun gf-lambdalist-from-first-method (m-lambdalist m-signature) + (let* ((req-num (sig-req-num m-signature)) + (opt-num (sig-opt-num m-signature)) + (rest-p (sig-rest-p m-signature))) + (values + ;; The inferred lambda-list: + (append (subseq m-lambdalist 0 req-num) + (if (> opt-num 0) + (cons '&OPTIONAL + (mapcar #'(lambda (item) (if (consp item) (first item) item)) + (subseq m-lambdalist (+ req-num 1) (+ req-num 1 opt-num)))) + '()) + (if rest-p + (list '&REST + (let ((i (position '&REST m-lambdalist))) + (if i (nth (+ i 1) m-lambdalist) (gensym)))) + '())) + ;; Its corresponding signature: + (make-signature :req-num req-num :opt-num opt-num :rest-p rest-p)))) + ;; Add a method to a generic function. (defun std-add-method (gf method) - (check-signature-congruence gf method) + (if (eq (std-gf-signature gf) (sys::%unbound)) + ;; The first added method determines the generic-function's signature. + (shared-initialize-<standard-generic-function> gf nil + :lambda-list (gf-lambdalist-from-first-method (std-method-lambda-list method) + (std-method-signature method))) + (check-signature-congruence gf method)) (when (std-method-generic-function method) (error-of-type 'error "~S: ~S already belongs to ~S, cannot also add it to ~S" @@ -160,31 +187,35 @@ ;; Find a method in a generic function. (defun std-find-method (gf qualifiers specializers &optional (errorp t)) - (let ((n (sig-req-num (std-gf-signature gf)))) - (unless (listp specializers) - (error-of-type 'error - (TEXT "~S: the specializers argument is not a list: ~S") - 'find-method specializers)) - (unless (eql (length specializers) n) - (error-of-type 'error - (TEXT "~S: the specializers argument has length ~D, but ~S has ~D required parameter~:P") - 'find-method (length specializers) gf n)) - ; Convert (EQL object) -> #<EQL-SPECIALIZER object>: - (setq specializers - (mapcar #'(lambda (specializer) - (if (and (consp specializer) (eq (car specializer) 'EQL) - (consp (cdr specializer)) (null (cddr specializer))) - (intern-eql-specializer (second specializer)) - specializer)) - specializers))) - ;; Simulate - ;; (find hypothetical-method (std-gf-methods gf) :test #'methods-agree-p) - ;; cf. methods-agree-p - (dolist (method (std-gf-methods gf)) - (when (and (equal (std-method-qualifiers method) qualifiers) - (specializers-agree-p (std-method-specializers method) - specializers)) - (return-from std-find-method method))) + (unless (listp specializers) + (error-of-type 'error + (TEXT "~S: the specializers argument is not a list: ~S") + 'find-method specializers)) + (if (eq (std-gf-signature gf) (sys::%unbound)) + ;; Signature not known yet, hence no methods installed. + (assert (null (std-gf-methods gf))) + (progn + (let ((n (sig-req-num (std-gf-signature gf)))) + (unless (eql (length specializers) n) + (error-of-type 'error + (TEXT "~S: the specializers argument has length ~D, but ~S has ~D required parameter~:P") + 'find-method (length specializers) gf n)) + ; Convert (EQL object) -> #<EQL-SPECIALIZER object>: + (setq specializers + (mapcar #'(lambda (specializer) + (if (and (consp specializer) (eq (car specializer) 'EQL) + (consp (cdr specializer)) (null (cddr specializer))) + (intern-eql-specializer (second specializer)) + specializer)) + specializers))) + ;; Simulate + ;; (find hypothetical-method (std-gf-methods gf) :test #'methods-agree-p) + ;; cf. methods-agree-p + (dolist (method (std-gf-methods gf)) + (when (and (equal (std-method-qualifiers method) qualifiers) + (specializers-agree-p (std-method-specializers method) + specializers)) + (return-from std-find-method method))))) (if errorp (error-of-type 'error (TEXT "~S has no method with qualifiers ~:S and specializers ~:S") @@ -298,23 +329,10 @@ (getf method-or-initargs 'signature)) (values (std-method-lambda-list method-or-initargs) (std-method-signature method-or-initargs))) - (let* ((req-num (sig-req-num m-signature)) - (opt-num (sig-opt-num m-signature)) - (rest-p (sig-rest-p m-signature)) - (gf-lambdalist (append (subseq m-lambdalist 0 req-num) - (if (> opt-num 0) - (cons '&OPTIONAL - (mapcar #'(lambda (item) (if (consp item) (first item) item)) - (subseq m-lambdalist (+ req-num 1) (+ req-num 1 opt-num)))) - '()) - (if rest-p - (list '&REST - (let ((i (position '&REST m-lambdalist))) - (if i (nth (+ i 1) m-lambdalist) (gensym)))) - '())))) - ; gf-lambdalist's signature is - ; (make-signature :req-num req-num :opt-num opt-num :rest-p rest-p). - (make-fast-gf <standard-generic-function> funname gf-lambdalist (subseq m-lambdalist 0 req-num) <standard-method> '() nil)))))) + (let ((req-num (sig-req-num m-signature)) + (gf-lambdalist + (gf-lambdalist-from-first-method m-lambdalist m-signature))) + (make-fast-gf <standard-generic-function> funname gf-lambdalist (subseq m-lambdalist 0 req-num) <standard-method> '() nil)))))) (method (if (listp method-or-initargs) (apply #'make-method-instance (std-gf-default-method-class gf) Index: clos-method2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-method2.lisp,v retrieving revision 1.18 retrieving revision 1.19 diff -u -d -r1.18 -r1.19 --- clos-method2.lisp 22 Aug 2004 10:48:23 -0000 1.18 +++ clos-method2.lisp 30 Aug 2004 11:04:10 -0000 1.19 @@ -114,6 +114,7 @@ ;; do not warn about redefinition when no method was defined (and (fboundp 'find-method) (fboundp funname) (typep-class (fdefinition funname) <generic-function>) + (not (eq (std-gf-signature (fdefinition funname)) (sys::%unbound))) (eql (sig-req-num (std-gf-signature (fdefinition funname))) (length spec-list)) (find-method (fdefinition funname) qualifiers spec-list nil) "method")) --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class0.lisp,1.2,1.3 ChangeLog,1.3472,1.3473 Date: Mon, 30 Aug 2004 13:34:50 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30248/src Modified Files: clos-class0.lisp ChangeLog Log Message: Make instance_of_stablehash_p work during bootstrapping. Index: clos-class0.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class0.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- clos-class0.lisp 23 May 2004 23:10:55 -0000 1.2 +++ clos-class0.lisp 30 Aug 2004 13:34:46 -0000 1.3 @@ -5,6 +5,32 @@ (in-package "CLOS") +;; A vector that looks like a class. Needed to make instance_of_stablehash_p +;; work already during bootstrapping. +(defvar *dummy-class* + (vector nil ; inst_class_version + nil ; $hashcode + nil ; $direct-generic-functions + nil ; $direct-methods + nil ; $classname + nil ; $direct-superclasses + nil ; $all-superclasses + nil ; $precedence-list + nil ; $direct-subclasses + nil ; $direct-slots + nil ; $slots + nil ; $slot-location-table + nil ; $direct-default-initargs + nil ; $default-initargs + nil ; $documentation + nil ; $initialized + t ; $subclass-of-stablehash-p + nil ; $generic-accessors + nil ; $direct-accessors + nil ; $valid-initargs + nil ; $instance-size +) ) + ;; A new class-version is created each time a class is redefined. ;; Used to keep the instances in sync through lazy updates. ;; Note: Why are the shared-slots an element of the class-version, not of the @@ -34,7 +60,9 @@ ; that are removed or become shared in the next version ) |# -(defun make-class-version (&key newest-class class shared-slots serial next +(defun make-class-version (&key (newest-class *dummy-class*) + (class *dummy-class*) + shared-slots serial next slotlists-valid-p kept-slot-locations added-slots discarded-slots discarded-slot-locations) (vector newest-class class shared-slots serial next Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3472 retrieving revision 1.3473 diff -u -d -r1.3472 -r1.3473 --- ChangeLog 30 Aug 2004 13:34:06 -0000 1.3472 +++ ChangeLog 30 Aug 2004 13:34:47 -0000 1.3473 @@ -1,3 +1,9 @@ +2004-08-26 Bruno Haible <br...@cl...> + + Make instance_of_stablehash_p work during bootstrapping. + * clos-class0.lisp (*dummy-class*): New variable. + (make-class-version): Use it as default. + 2004-08-24 Bruno Haible <br...@cl...> Update ISO-8859-7 converter to version 2003. --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |