Menu
▾
▴
clisp-cvs digest, Vol 1 #567 - 8 msgs
|
From: <cli...@li...> - 2004-06-16 11:14:04
|
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 clos-stablehash1.lisp,NONE,1.1 clos-stablehash2.lisp,NONE,1.1 (Bruno Haible) 2. clisp/src/po Makefile.devel,1.24,1.25 (Bruno Haible) 3. clisp/src init.lisp,1.146,1.147 clos.lisp,1.85,1.86 clos-class5.lisp,1.21,1.22 makemake.in,1.454,1.455 ChangeLog,1.3184,1.3185 (Bruno Haible) 4. clisp/src clos-macros.lisp,NONE,1.1 (Bruno Haible) 5. clisp/src/po Makefile.devel,1.25,1.26 (Bruno Haible) 6. clisp/src clos-class2.lisp,1.34,1.35 init.lisp,1.147,1.148 makemake.in,1.455,1.456 (Bruno Haible) 7. clisp/src clos-macros.lisp,1.1,1.2 (Bruno Haible) 8. clisp/src clos-genfun5.lisp,1.3,1.4 clos-methcomb1.lisp,1.1,1.2 clos-methcomb2.lisp,1.4,1.5 format.lisp,1.27,1.28 ChangeLog,1.3185,1.3186 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-stablehash1.lisp,NONE,1.1 clos-stablehash2.lisp,NONE,1.1 Date: Wed, 16 Jun 2004 10:58:21 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13999/src Added Files: clos-stablehash1.lisp clos-stablehash2.lisp Log Message: Objects with stable hash code. --- NEW FILE: clos-stablehash2.lisp --- ;;;; Common Lisp Object System for CLISP ;;;; Objects with stable hash code ;;;; Part 2: Final class definition, make/initialize-instance methods. ;;;; Bruno Haible 2004-05-15 (in-package "CLOS") ;;; =========================================================================== ;; Define the class <standard-stablehash>. (macrolet ((form () *<standard-stablehash>-defclass*)) (form)) ;;; Lift the initialization protocol. (defmethod initialize-instance ((object standard-stablehash) &rest args &key) (apply #'initialize-instance-<standard-stablehash> object args)) ;;; =========================================================================== --- NEW FILE: clos-stablehash1.lisp --- ;;;; Common Lisp Object System for CLISP ;;;; Objects with stable hash code ;;;; Part 1: Class definition. ;;;; Bruno Haible 2004-05-15 (in-package "CLOS") ;;; =========================================================================== ;;; The class <standard-stablehash> allows CLOS instances to have a ;;; GC-invariant EQ hash code. ;;; Used for (make-hash-table :test 'stablehash-eq). (defvar *<standard-stablehash>-defclass* '(defclass standard-stablehash () ((hashcode :initform (sys::random-posfixnum))) ; GC invariant hash code (:fixed-slot-locations))) ;; Fixed slot locations. (defconstant *<standard-stablehash>-hashcode-location* 1) ;; No need for accessors. The hashcode is used by hashtabl.d. ;; Initialization of a <standard-stablehash> instance. (defun initialize-instance-<standard-stablehash> (object &rest args &key &allow-other-keys) (if *classes-finished* (apply #'%initialize-instance object args) ; == (call-next-method) ; Bootstrapping: Simulate the effect of #'%initialize-instance. (setf (sys::%record-ref object *<standard-stablehash>-hashcode-location*) (sys::random-posfixnum))) object) ;;; =========================================================================== --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src/po Makefile.devel,1.24,1.25 Date: Wed, 16 Jun 2004 10:59:34 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src/po In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14220/src/po Modified Files: Makefile.devel Log Message: Make the standard-stablehash class available early in bootstrap. Index: Makefile.devel =================================================================== RCS file: /cvsroot/clisp/clisp/src/po/Makefile.devel,v retrieving revision 1.24 retrieving revision 1.25 diff -u -d -r1.24 -r1.25 --- Makefile.devel 14 Jun 2004 10:59:01 -0000 1.24 +++ Makefile.devel 16 Jun 2004 10:59:32 -0000 1.25 @@ -47,9 +47,10 @@ # Keep this in the same order as the LPARTS variable in makemake.in ! LISPSOURCES = init defseq backquote defmacro macros1 macros2 defs1 \ timezone lambdalist places floatprint defpackage type subtypep \ - clos-package clos-class0 clos-slotdef1 defstruct format \ - international savemem functions trace cmacros compiler \ - defs2 loop clos \ + clos-package clos-class0 clos-slotdef1 clos-stablehash1 \ + defstruct format international savemem functions trace cmacros \ + compiler defs2 loop clos \ + clos-stablehash2 \ clos-class1 clos-class2 clos-class3 clos-class5 \ clos-slotdef2 clos-slotdef3 clos-slots1 clos-slots2 \ clos-method1 clos-method2 clos-method3 \ --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src init.lisp,1.146,1.147 clos.lisp,1.85,1.86 clos-class5.lisp,1.21,1.22 makemake.in,1.454,1.455 ChangeLog,1.3184,1.3185 Date: Wed, 16 Jun 2004 10:59:35 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14220/src Modified Files: init.lisp clos.lisp clos-class5.lisp makemake.in ChangeLog Log Message: Make the standard-stablehash class available early in bootstrap. Index: init.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/init.lisp,v retrieving revision 1.146 retrieving revision 1.147 diff -u -d -r1.146 -r1.147 --- init.lisp 15 Jun 2004 11:59:49 -0000 1.146 +++ init.lisp 16 Jun 2004 10:59:32 -0000 1.147 @@ -1764,6 +1764,7 @@ (LOAD "clos-package") ; Early CLOS (LOAD "clos-class0") (LOAD "clos-slotdef1") +(LOAD "clos-stablehash1") (LOAD "defstruct") ; DEFSTRUCT-macro Index: clos-class5.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class5.lisp,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- clos-class5.lisp 11 Jun 2004 10:47:07 -0000 1.21 +++ clos-class5.lisp 16 Jun 2004 10:59:32 -0000 1.22 @@ -772,14 +772,6 @@ (:method ((class standard-class)) (finalize-class class t)) (:method ((name symbol)) (finalize-inheritance (find-class name)))) -;;; Misc classes - -;; Definition of <standard-stablehash>. -;; Used for (make-hash-table :test 'stablehash-eq). -(defclass standard-stablehash (standard-object) - ((hashcode :initform (sys::random-posfixnum))) ; GC invariant hash code - (:fixed-slot-locations)) - ;;; Utility functions ;; Returns the slot names of an instance of a slotted-class Index: makemake.in =================================================================== RCS file: /cvsroot/clisp/clisp/src/makemake.in,v retrieving revision 1.454 retrieving revision 1.455 diff -u -d -r1.454 -r1.455 --- makemake.in 14 Jun 2004 10:59:02 -0000 1.454 +++ makemake.in 16 Jun 2004 10:59:32 -0000 1.455 @@ -1426,9 +1426,10 @@ LPARTS=' init defseq backquote defmacro macros1 macros2 defs1' LPARTS=$LPARTS' timezone lambdalist places floatprint defpackage type subtypep' -LPARTS=$LPARTS' clos-package clos-class0 clos-slotdef1 defstruct format' -LPARTS=$LPARTS' international savemem functions trace cmacros compiler' -LPARTS=$LPARTS' defs2 loop clos' +LPARTS=$LPARTS' clos-package clos-class0 clos-slotdef1 clos-stablehash1' +LPARTS=$LPARTS' defstruct format international savemem functions trace cmacros' +LPARTS=$LPARTS' compiler defs2 loop clos' +LPARTS=$LPARTS' clos-stablehash2' LPARTS=$LPARTS' clos-class1 clos-class2 clos-class3 clos-class5' LPARTS=$LPARTS' clos-slotdef2 clos-slotdef3 clos-slots1 clos-slots2' LPARTS=$LPARTS' clos-method1 clos-method2 clos-method3' Index: clos.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos.lisp,v retrieving revision 1.85 retrieving revision 1.86 diff -u -d -r1.85 -r1.86 --- clos.lisp 14 Jun 2004 10:46:43 -0000 1.85 +++ clos.lisp 16 Jun 2004 10:59:32 -0000 1.86 @@ -33,6 +33,7 @@ (load "clos-slots2") (load "clos-class5") (load "clos-slotdef2") +(load "clos-stablehash2") ; Now instance creation works. Instances can be passed to generic functions. (setq *classes-finished* t) (load "clos-slotdef3") Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3184 retrieving revision 1.3185 diff -u -d -r1.3184 -r1.3185 --- ChangeLog 15 Jun 2004 11:59:49 -0000 1.3184 +++ ChangeLog 16 Jun 2004 10:59:32 -0000 1.3185 @@ -1,3 +1,14 @@ +2004-05-15 Bruno Haible <br...@cl...> + + * init.lisp: Load clos-stablehash1. + * clos.lisp: Load clos-stablehash2. + * clos-stablehash1.lisp: New file. + * clos-stablehash2.lisp: New file. + * clos-class5.lisp (standard-stablehash): Moved to clos-stablehash1. + * makemake.in (LPARTS): Add clos-stablehash1, clos-stablehash2. + * po/Makefile.devel (LISPSOURCES): Add clos-stablehash1, + clos-stablehash2. + 2004-06-13 Bruno Haible <br...@cl...> Fixed DEFSETF lambda-list handling. --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-macros.lisp,NONE,1.1 Date: Wed, 16 Jun 2004 11:04:49 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18674/src Added Files: clos-macros.lisp Log Message: Internal Macros for CLOS. --- NEW FILE: clos-macros.lisp --- ;;;; Common Lisp Object System for CLISP ;;;; Internal Macros ;;;; Bruno Haible 2004 (in-package "CLOS") ;;; =========================================================================== ;;; Support for weak sets that are stored as either ;;; - NIL or a weak-list (for saving memory when there are few subclasses), or ;;; - a weak-hash-table (for speed when there are many subclasses). ;;; (def-weak-set-accessors ACCESSOR ELEMENT-TYPE ;;; ADDER REMOVER LISTER) ;;; defines three functions ;;; (defun ADDER (holder element) ...) ; adds element to the set ;;; (defun REMOVER (holder element) ...) ; removes element from the set ;;; (defun LISTER (holder) ...) ; returns the set as a freshly consed list (defmacro def-weak-set-accessors (accessor element-type adder remover lister) `(PROGN (DEFUN ,adder (HOLDER ELEMENT) (ADD-TO-WEAK-SET HOLDER (,accessor HOLDER) ELEMENT #'(SETF ,accessor) ',element-type)) (DEFUN ,remover (HOLDER ELEMENT) (REMOVE-FROM-WEAK-SET HOLDER (,accessor HOLDER) ELEMENT)) (DEFUN ,lister (HOLDER) (LIST-WEAK-SET (,accessor HOLDER))))) ;; Auxiliary functions for def-weak-set-accessors. (defun add-to-weak-set (holder set element setter element-type) (cond ((null set) (let ((new-set (ext:make-weak-list (list element)))) (funcall setter new-set holder))) ((ext:weak-list-p set) (let ((list (ext:weak-list-list set))) (unless (member element list :test #'eq) (push element list) (if (<= (length list) 10) (setf (ext:weak-list-list set) list) (let ((new-set (let ((ht (make-hash-table :key-type element-type :value-type '(eql t) :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t :weak :key))) (dolist (x list) (setf (gethash x ht) t)) ht))) (funcall setter new-set holder)))))) (t (setf (gethash element set) t)))) (defun remove-from-weak-set (holder set element) (cond ((null set)) ((ext:weak-list-p set) (let ((list (ext:weak-list-list set))) (when (member element list :test #'eq) (setf (ext:weak-list-list set) (remove element list :test #'eq))))) (t (remhash element set)))) (defun list-weak-set (set) (cond ((null set) '()) ((ext:weak-list-p set) (ext:weak-list-list set)) (t (let ((l '())) (maphash #'(lambda (x y) (push x l)) set) l)))) --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src/po Makefile.devel,1.25,1.26 Date: Wed, 16 Jun 2004 11:05:10 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src/po In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18871/src/po Modified Files: Makefile.devel Log Message: Use the def-weak-set-accessors macro. Index: Makefile.devel =================================================================== RCS file: /cvsroot/clisp/clisp/src/po/Makefile.devel,v retrieving revision 1.25 retrieving revision 1.26 diff -u -d -r1.25 -r1.26 --- Makefile.devel 16 Jun 2004 10:59:32 -0000 1.25 +++ Makefile.devel 16 Jun 2004 11:05:07 -0000 1.26 @@ -47,9 +47,10 @@ # Keep this in the same order as the LPARTS variable in makemake.in ! LISPSOURCES = init defseq backquote defmacro macros1 macros2 defs1 \ timezone lambdalist places floatprint defpackage type subtypep \ - clos-package clos-class0 clos-slotdef1 clos-stablehash1 \ - defstruct format international savemem functions trace cmacros \ - compiler defs2 loop clos \ + clos-package clos-macros clos-class0 clos-slotdef1 \ + clos-stablehash1 defstruct format \ + international savemem functions trace cmacros compiler \ + defs2 loop clos \ clos-stablehash2 \ clos-class1 clos-class2 clos-class3 clos-class5 \ clos-slotdef2 clos-slotdef3 clos-slots1 clos-slots2 \ --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class2.lisp,1.34,1.35 init.lisp,1.147,1.148 makemake.in,1.455,1.456 Date: Wed, 16 Jun 2004 11:05:09 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18871/src Modified Files: clos-class2.lisp init.lisp makemake.in Log Message: Use the def-weak-set-accessors macro. Index: clos-class2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class2.lisp,v retrieving revision 1.34 retrieving revision 1.35 diff -u -d -r1.34 -r1.35 --- clos-class2.lisp 15 Jun 2004 10:23:20 -0000 1.34 +++ clos-class2.lisp 16 Jun 2004 11:05:07 -0000 1.35 @@ -1144,47 +1144,18 @@ ;;; - NIL or a weak-list (for saving memory when there are few subclasses), or ;;; - a weak-hash-table (for speed when there are many subclasses). +#| ;; Adds a class to the list of direct subclasses. -(defun add-direct-subclass (class subclass) - (let ((direct-subclasses (class-direct-subclasses class))) - (cond ((null direct-subclasses) - (setf (class-direct-subclasses class) - (ext:make-weak-list (list subclass)))) - ((ext:weak-list-p direct-subclasses) - (let ((list (ext:weak-list-list direct-subclasses))) - (unless (member subclass list :test #'eq) - (push subclass list) - (if (<= (length list) 10) - (setf (ext:weak-list-list direct-subclasses) list) - (setf (class-direct-subclasses class) - (let ((ht (make-hash-table :key-type 'class :value-type '(eql t) - :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t - :weak :key))) - (dolist (x list) (setf (gethash x ht) t)) - ht)))))) - (t (setf (gethash subclass direct-subclasses) t))))) - +(defun add-direct-subclass (class subclass) ...) ;; Removes a class from the list of direct subclasses. -(defun remove-direct-subclass (class subclass) - (let ((direct-subclasses (class-direct-subclasses class))) - (cond ((null direct-subclasses)) - ((ext:weak-list-p direct-subclasses) - (let ((list (ext:weak-list-list direct-subclasses))) - (when (member subclass list :test #'eq) - (setf (ext:weak-list-list direct-subclasses) - (remove subclass list :test #'eq))))) - (t (remhash subclass direct-subclasses))))) - +(defun remove-direct-subclass (class subclass) ...) ;; Returns the currently existing direct subclasses, as a freshly consed list. -(defun list-direct-subclasses (class) - (let ((direct-subclasses (class-direct-subclasses class))) - (cond ((null direct-subclasses) '()) - ((ext:weak-list-p direct-subclasses) - (ext:weak-list-list direct-subclasses)) - (t (let ((l '())) - (maphash #'(lambda (x y) (declare (ignore y)) (push x l)) - direct-subclasses) - l))))) +(defun list-direct-subclasses (class) ...) +|# +(def-weak-set-accessors class-direct-subclasses class + add-direct-subclass + remove-direct-subclass + list-direct-subclasses) ;; Returns the currently existing subclasses, in top-down order, including the ;; class itself as first element. Index: init.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/init.lisp,v retrieving revision 1.147 retrieving revision 1.148 diff -u -d -r1.147 -r1.148 --- init.lisp 16 Jun 2004 10:59:32 -0000 1.147 +++ init.lisp 16 Jun 2004 11:05:07 -0000 1.148 @@ -1762,6 +1762,7 @@ (LOAD "type") ; TYPEP (LOAD "clos-package") ; Early CLOS +(LOAD "clos-macros") (LOAD "clos-class0") (LOAD "clos-slotdef1") (LOAD "clos-stablehash1") Index: makemake.in =================================================================== RCS file: /cvsroot/clisp/clisp/src/makemake.in,v retrieving revision 1.455 retrieving revision 1.456 diff -u -d -r1.455 -r1.456 --- makemake.in 16 Jun 2004 10:59:32 -0000 1.455 +++ makemake.in 16 Jun 2004 11:05:07 -0000 1.456 @@ -1426,9 +1426,10 @@ LPARTS=' init defseq backquote defmacro macros1 macros2 defs1' LPARTS=$LPARTS' timezone lambdalist places floatprint defpackage type subtypep' -LPARTS=$LPARTS' clos-package clos-class0 clos-slotdef1 clos-stablehash1' -LPARTS=$LPARTS' defstruct format international savemem functions trace cmacros' -LPARTS=$LPARTS' compiler defs2 loop clos' +LPARTS=$LPARTS' clos-package clos-macros clos-class0 clos-slotdef1' +LPARTS=$LPARTS' clos-stablehash1 defstruct format' +LPARTS=$LPARTS' international savemem functions trace cmacros compiler' +LPARTS=$LPARTS' defs2 loop clos' LPARTS=$LPARTS' clos-stablehash2' LPARTS=$LPARTS' clos-class1 clos-class2 clos-class3 clos-class5' LPARTS=$LPARTS' clos-slotdef2 clos-slotdef3 clos-slots1 clos-slots2' --__--__-- Message: 7 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-macros.lisp,1.1,1.2 Date: Wed, 16 Jun 2004 11:05:56 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19582/src Modified Files: clos-macros.lisp Log Message: Oops, avoid warnings. Index: clos-macros.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-macros.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- clos-macros.lisp 16 Jun 2004 11:04:47 -0000 1.1 +++ clos-macros.lisp 16 Jun 2004 11:05:54 -0000 1.2 @@ -49,6 +49,7 @@ (t (setf (gethash element set) t)))) (defun remove-from-weak-set (holder set element) + (declare (ignore holder)) (cond ((null set)) ((ext:weak-list-p set) (let ((list (ext:weak-list-list set))) @@ -61,5 +62,5 @@ ((ext:weak-list-p set) (ext:weak-list-list set)) (t (let ((l '())) - (maphash #'(lambda (x y) (push x l)) set) + (maphash #'(lambda (x y) (declare (ignore y)) (push x l)) set) l)))) --__--__-- Message: 8 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-genfun5.lisp,1.3,1.4 clos-methcomb1.lisp,1.1,1.2 clos-methcomb2.lisp,1.4,1.5 format.lisp,1.27,1.28 ChangeLog,1.3185,1.3186 Date: Wed, 16 Jun 2004 11:12:30 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22885/src Modified Files: clos-genfun5.lisp clos-methcomb1.lisp clos-methcomb2.lisp format.lisp ChangeLog Log Message: Rework the method combination stuff. Separate parsing from macroexpansion code generation. Many fixes. Index: clos-genfun5.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-genfun5.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- clos-genfun5.lisp 3 Jun 2004 21:16:47 -0000 1.3 +++ clos-genfun5.lisp 16 Jun 2004 11:12:27 -0000 1.4 @@ -47,6 +47,25 @@ :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 (gf-signature gf))) + (methods (remove-if-not group-filter (gf-methods gf))) + (dispatching-arg (single-dispatching-arg reqanz methods))) + (if dispatching-arg + (error-of-type 'method-call-type-error + :datum (nth dispatching-arg args) + :expected-type (dispatching-arg-type dispatching-arg methods) + :generic-function gf :argument-list args + (TEXT "~S: When calling ~S with arguments ~S, no method of group ~S (from ~S) is applicable.") + 'missing-required-method gf args group-name combination) + (error-of-type 'method-call-error + :generic-function gf :argument-list args + (TEXT "~S: When calling ~S with arguments ~S, no method of group ~S (from ~S) is applicable.") + 'missing-required-method gf args group-name combination))))) + +;; Special case of missing-required-method for STANDARD method combination +;; and the PRIMARY method group. (defgeneric no-primary-method (gf &rest args) (:method ((gf t) &rest args) (let* ((reqanz (sig-req-num (gf-signature gf))) Index: format.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/format.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- format.lisp 24 May 2004 00:19:02 -0000 1.27 +++ format.lisp 16 Jun 2004 11:12:27 -0000 1.28 @@ -2541,3 +2541,14 @@ `(FORMATTER-HAIRY ,(coerce control-string 'simple-string)))) ;;; --------------------------------------------------------------------------- + +;; (FORMAT-QUOTE string) +;; returns a format-string that yields exactly the given string. +(defun format-quote (string) + (let ((qstring (make-array 10 :element-type 'character + :adjustable t :fill-pointer 0))) + (map nil #'(lambda (c) + (when (eql c #\~) (vector-push-extend #\~ qstring)) + (vector-push-extend c qstring)) + string) + qstring)) Index: clos-methcomb1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-methcomb1.lisp,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- clos-methcomb1.lisp 2 Apr 2004 10:10:51 -0000 1.1 +++ clos-methcomb1.lisp 16 Jun 2004 11:12:27 -0000 1.2 @@ -7,13 +7,16 @@ (in-package "CLOS") +;;; Global management of method-combinations and their names: + ;; Mapping from name, a symbol, to method-combination instance. (defun find-method-combination (name &key (if-does-not-exist :error)) (or (get name 'find-method-combination) (and if-does-not-exist (error "undefined method combination ~s" name)))) -(defun (setf find-method-combination) (def name) - (setf (get name 'find-method-combination) def)) +(defun (setf find-method-combination) (new-value name) + (setf (get name 'find-method-combination) new-value)) + ;;; The method-combination class definition. ;; A method-combination is used 1) without options when defined and attached @@ -27,29 +30,37 @@ The variations are handled by binding the expander function to the instance and pairing the method-combination definition object with the option list in the generic function instance." + name ; a symbol naming the method combination - (operator nil) ; a symbol operator for short forms - (order :most-specific-first) ; the order for short form primary methods - (qualifiers nil) ; the allowed list of qualifiers (identity-with-one-argument nil) ; true if the short should be so generated - (documentation nil) ; an optional documentation string - (declarations nil) ; list to be prepended to the effective method body - (expander nil) ; A function of 4 arguments - ; (function method-combination options arguments) - ; which computes a combined method function. + (documentation nil) ; an optional documentation string + (declarations nil) ; list to be prepended to the effective method + ; body + (expander nil) ; A function of 4 arguments + ; (function method-combination options arguments) + ; which computes a combined method function. (check-method-qualifiers nil) ; A function of 3 arguments ; (function method-combination method) ; that checks whether the method's qualifiers ; are compatible with the method-combination. (call-next-method-allowed nil) ; A function of 3 arguments - ; (function method-combination method) - ; telling whether call-next-method is allowed - ; in the particular method. - (arguments-lambda-list nil) ; The :arguments option of the defined method - ; combination for inclusion in the effective - ; method function. + ; (function method-combination method) + ; telling whether call-next-method is allowed + ; in the particular method. + (arguments-lambda-list nil) ; The :arguments option of the defined method + ; combination for inclusion in the effective + ; method function. + + ;; The following slots apply only to standard and short form + ;; method-combination. + (qualifiers nil) ; the allowed list of qualifiers + + ;; The following slots apply only to short form method-combination. + (operator nil) ; a symbol + (order :most-specific-first) ; the order for primary methods + ;; The following slots depend on the particular generic function. - (options nil)) ; arguments for the method combination + (options nil)) ; arguments for the method combination (defun print-method-combination (object stream) (print-unreadable-object (object stream :identity t :type t) Index: clos-methcomb2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-methcomb2.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- clos-methcomb2.lisp 15 Jun 2004 10:41:14 -0000 1.4 +++ clos-methcomb2.lisp 16 Jun 2004 11:12:27 -0000 1.5 @@ -14,8 +14,13 @@ (every #'typep required-arguments (std-method-parameter-specializers method))) -;; CLtL2 28.1.7.1., ANSI CL 7.6.6.1. Sorting the applicable methods by -;; precedence order +;; CLtL2 28.1.7.1., ANSI CL 7.6.6.1.2. +;; Sorting the applicable methods by precedence order +;; > methods: A list of methods from the same generic function that are +;; already known to be applicable for the given required-arguments. +;; > required-arguments: The list of required arguments. +;; > argument-order: A list of indices in the range 0..req-num-1 that +;; determines the argument order. (defun sort-applicable-methods (methods required-arguments argument-order) (sort (copy-list methods) #'(lambda (method1 method2) ; method1 < method2 ? @@ -49,29 +54,34 @@ (defvar *method-combination* nil "The generic function's method combination (in compute-effective-method)") -;;; error functions +;; Error about a method whose qualifiers don't fit with a method-combination. +;; This is specified to be a function, not a condition type, because it is +;; meant to be called from a DEFINE-METHOD-COMBINATION's body. (defun invalid-method-error (method format-string &rest args) - (error-of-type 'sys::source-program-error - (TEXT "for function ~s applied to ~s:~%while computing the effective method through ~s:~%invalid method: ~s~%~?") - *method-combination-generic-function* - *method-combination-arguments* + (error + (TEXT "For function ~S applied to argument list ~S:~%While computing the effective method through ~S:~%Invalid method: ~S~%~?") + *method-combination-generic-function* *method-combination-arguments* *method-combination* - method format-string args)) + method + format-string args)) +;; Other error during method combination, not tied to a particular method. +;; This is specified to be a function, not a condition type, because it is +;; meant to be called from a DEFINE-METHOD-COMBINATION's body. +;; The fact that MISSING-REQUIRED-METHOD and NO-PRIMARY-METHOD don't call this +;; function is not a problem, because the user is not supposed to redefine or +;; customize this function. (defun method-combination-error (format-string &rest args) - (error-of-type 'sys::source-program-error - (TEXT "for function ~s applied to ~s:~%while computing the effective method through ~s:~%invalid method combination: ~s~%~?") - *method-combination-generic-function* - *method-combination-arguments* + (error + (TEXT "For function ~S applied to argument list ~S:~%While computing the effective method through ~S:~%Impossible to combine the methods:~%~?") + *method-combination-generic-function* *method-combination-arguments* *method-combination* - *method-combination* format-string args)) + format-string args)) -;;; Method computation implementation: -;;; - compute-effective-method-function handles the function interface -;;; and the next-method support for both short and long forms. -;;; - short forms: compute-short-form-effective-method-form -;;; and short-form-method-combination-expander -;;; - long forms: long-form-method-combination-expander +(defun invalid-method-sort-order-error (order-form order-value) + (method-combination-error + (TEXT "The value of ~S is ~S, should be :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST.") + order-form order-value)) (defun compute-effective-method-function (generic-function combination methods effective-method-form) @@ -120,7 +130,7 @@ (apply #'format nil errorstring arguments)))) (declare (ignore opt opt-i opt-p rest)) (when (> (setq num-req (length positional)) (length req-vars)) - (method-combination-error "invalid combination arguments: ~s." + (method-combination-error (TEXT "invalid combination arguments: ~s.") combination-arguments)) (setf req-vars (append positional (nthcdr num-req req-vars))) ;; Construct analogous interface parameter and application @@ -388,14 +398,14 @@ (push method around-methods) (push method primary-methods)))) (unless primary-methods - (method-combination-error "no applicable primary methods.")) + (method-combination-error (TEXT "no applicable primary methods."))) ;; check that all qualifiers are singular and correct (dolist (method primary-methods) (let ((qualifiers (std-method-qualifiers method))) (unless (and (null (rest qualifiers)) (eq (first qualifiers) qualifier)) (invalid-method-error - method "qualifiers ~s not permitted for combination ~s." + method (TEXT "qualifiers ~s not permitted for combination ~s.") qualifiers qualifier)))) (values (ecase order @@ -507,147 +517,196 @@ (null (null qualifiers)) (symbol (or (eq pattern '*) - (method-combination-error "invalid method group pattern: ~s." + (method-combination-error (TEXT "invalid method group pattern: ~s.") pattern))) - (t (method-combination-error "invalid method group pattern: ~s." + (t (method-combination-error (TEXT "invalid method group pattern: ~s.") pattern)))) -(defun compute-method-partition-lambdas (method-groups) - "Given the method group form from the combination definition, -computes 1. a function to be applied to a list of methods to produce a -partitioned plist. The group variables are used as the keys. -Where order specifications are present consolidate them bind them.?? -2. a function to be applied to a single method to produce a qualifiers check. -Performs static tests for conflicting patterns components and -generates dynamic tests for unmatched methods and required groups." - (let ((order-bindings nil) (*-group-variable nil)) - (labels ((group-error (group message) - (error "invalid group: ~s: ~a." group message)) - (normalize-group (group &aux (g group)) - (let ((variable (pop group)) (patterns nil) (description nil) - (required nil) (order nil)) - (loop (unless group (return)) - (let ((qp (pop group))) - (cond ((or (eq qp '*) (consp qp) (null qp)) - (unless (listp patterns) - (group-error qp "duplicate pattern option")) - (push qp patterns)) - ((eq qp :order) - (if order - (group-error qp "duplicate order option") - (setf order (pop group)))) - ((eq qp :required) - (if required - (group-error qp "duplicate required option") - (setf required (pop group)))) - ((eq qp :description) - (if description - (group-error qp "duplicate description option") - (setf description (pop group)))) - ((symbolp qp) - (if patterns - (group-error qp "duplicate predicate option") - (setf patterns qp))) - (t (group-error qp "illegal group pattern"))))) - (typecase patterns - (cons (setf patterns (reverse patterns))) - (null (group-error g "at least one pattern is required.")) - (symbol t)) - (list variable patterns order required - (or description (format nil "~s qualifiers ~s" - variable patterns))))) - (compute-required-form (group) - (let ((variable (first group)) - (patterns (second group)) - (required-form (fourth group))) - (when required-form - `(unless (getf partitioned-method-plist ',variable) - (method-combination-error - "no methods match group: ~s ~s." - ',variable ',patterns))))) +(defun parse-method-groups (name method-groups) + (labels ((group-error (group message &rest message-args) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: invalid method group specifier ~S: ~A") + 'define-method-combination name group + (apply #'format nil message message-args))) + ;; Performs the syntax check of a method-group-specifier and + ;; returns a simple-vector + ;; #(name patterns/predicate orderform required-p description) + ;; The second element can be a non-empty list of patterns, or a + ;; non-null symbol naming a predicate. + (normalize-group (group) + (unless (and (consp group) (consp (cdr group))) + (group-error group (TEXT "Not a list of at least length 2"))) + (let ((variable (car group)) + (groupr (cdr group)) + (patterns '()) + (predicate nil) + (orderforms '()) + (requireds '()) + (description nil)) + (unless (symbolp variable) + (group-error group (TEXT "Not a variable name: ~S") variable)) + ; Parse the {qualifier-pattern+ | predicate} part: + (do () + ((atom groupr)) + (let ((qp (car groupr))) + (cond ((or (eq qp '*) + (and (listp qp) + (memq (cdr (last qp)) '(nil *)))) + ; A qualifier pattern. + (when predicate + (group-error group (TEXT "In method group ~S: Cannot specify both qualifier patterns and a predicate.") variable)) + (push qp patterns)) + ((memq qp '(:DESCRIPTION :ORDER :REQUIRED)) + ; End of the {qualifier-pattern+ | predicate} part. + (return)) + ((symbolp qp) + ; A predicate. + (when predicate + (group-error group (TEXT "In method group ~S: Cannot specify more than one predicate.") variable)) + (when patterns + (group-error group (TEXT "In method group ~S: Cannot specify both qualifier patterns and a predicate.") variable)) + (setq predicate qp)) + (t + (group-error group (TEXT "In method group ~S: Neither a qualifier pattern nor a predicate: ~S") variable qp)))) + (setq groupr (cdr groupr))) + (do () + ((atom groupr)) + (when (atom (cdr groupr)) + (group-error group (TEXT "In method group ~S: options must come in pairs") variable)) + (let ((optionkey (first groupr)) + (argument (second groupr))) + (case optionkey + (:ORDER + (when orderforms + (group-error group (TEXT "In method group ~S: option ~S may only be given once") variable ':order)) + (setq orderforms (list argument))) + (:REQUIRED + (when requireds + (group-error group (TEXT "In method group ~S: option ~S may only be given once") variable ':required)) + (setq requireds (list (not (null argument))))) + (:DESCRIPTION + (when description + (group-error group (TEXT "In method group ~S: option ~S may only be given once") variable ':description)) + (unless (stringp argument) + (group-error group (TEXT "In method group ~S: ~S is not a string") variable argument)) + (setq description argument)) + (t + (group-error group (TEXT "In method group ~S: Invalid option ~S") variable optionkey)))) + (setq groupr (cddr groupr))) + (unless (or patterns predicate) + (group-error group (TEXT "In method group ~S: Missing pattern or predicate.") variable)) + (vector variable + (or predicate (nreverse patterns)) + (if orderforms (first orderforms) '':MOST-SPECIFIC-FIRST) + (if requireds (first requireds) 'NIL) + (or description + (concatenate 'string + (sys::format-quote (format nil "~A" variable)) + "~@{ ~S~}")))))) + (mapcar #'normalize-group method-groups))) + +(defun compute-method-partition-lambdas (method-groups body) + "Given the normalized method group specifiers, computes +1. a function to be applied to a list of methods to produce the effective +method function's body. The group variables are bound in the body. +2. a function to be applied to a single method to produce a qualifiers check." + (let ((order-bindings nil)) + (labels (;; Returns a form that tests whether a list of qualifiers, assumed + ;; to be present in the variable QUALIFIERS, matches the given pattern. (compute-match-predicate-1 (pattern) - (typecase pattern - (symbol (case pattern - (* `(qualifiers-match-p qualifiers '*)) - ((nil) '(null qualifiers)) - (t `(,pattern qualifiers)))) - (cons `(qualifiers-match-p qualifiers ',pattern)) - (t (error "illegal group pattern: ~s." pattern)))) - (compute-match-predicate (group) - (let ((variable (first group)) - (patterns (second group))) - (cond ((equal patterns '(*)) - (if *-group-variable - (error "duplicate * group: ~s." group) - (setf *-group-variable variable)) - nil) - ((symbolp patterns) - `(,patterns qualifiers)) - (t - (if (null patterns) - '(null qualifiers) - `(or ,@(mapcar #'compute-match-predicate-1 patterns))))))) - (compute-sort-form (group) + ; Already checked above. + (assert (or (eq pattern '*) + (and (listp pattern) + (memq (cdr (last pattern)) '(nil *))))) + (cond ((null pattern) `(NULL QUALIFIERS)) + ((eq pattern '*) `T) + (t `(QUALIFIERS-MATCH-P QUALIFIERS ',pattern)))) + ;; Returns a form that tests whether a list of qualifiers, assumed + ;; to be present in the variable QUALIFIERS, satisfies the test + ;; for the given normalized method group description. + (compute-match-predicate (ngroup) + (let ((patterns (svref ngroup 1))) + ; Already checked above. + (assert (and (or (listp patterns) (symbolp patterns)) + (not (null patterns)))) + (if (listp patterns) + `(OR ,@(mapcar #'compute-match-predicate-1 patterns)) + `(,patterns QUALIFIERS)))) + ;; Returns the variable binding for the given normalized method + ;; group description. + (compute-variable-binding (ngroup) + (let ((variable (svref ngroup 0))) + `(,variable NIL))) + ;; Returns a form that performs the :required check for the given + ;; normalized method group description. + (compute-required-form (ngroup) + (let ((variable (svref ngroup 0)) + (required-p (svref ngroup 3))) + (when required-p + `(UNLESS ,variable + (APPLY #'MISSING-REQUIRED-METHOD + *METHOD-COMBINATION-GENERIC-FUNCTION* + *METHOD-COMBINATION* + ',variable + #'(LAMBDA (METH) + (LET ((QUALIFIERS (METHOD-QUALIFIERS METH))) + (DECLARE (IGNORABLE QUALIFIERS)) + ,(compute-match-predicate ngroup))) + *METHOD-COMBINATION-ARGUMENTS*))))) + ;; Returns a form that reorders the list of methods in the method + ;; group that originates from the given normalized method group + ;; description. + (compute-reorder-form (ngroup) ;; If an order spec is present, make a binding for the ;; shared value and use that to decide whether to reverse. - ;; If no spec if present, then always reverse. - (let ((variable (first group)) - (order (third group)) - (order-variable nil)) - (cond (order - (unless (setf order-variable - (first (find order order-bindings - :key #'second - :test #'equalp))) - (setf order-variable (gensym "ORDER-")) - (push (list order-variable order) order-bindings)) - `(ecase ,order-variable - ((nil :most-specific-first) - (setf (getf partitioned-method-plist ',variable) - (reverse (getf partitioned-method-plist - ',variable)))) - (:most-specific-last ))) - (t - `(setf (getf partitioned-method-plist ',variable) - (reverse (getf partitioned-method-plist - ',variable)))))))) - (setq method-groups (mapcar #'normalize-group method-groups)) - (let ((match-forms '()) (check-forms '())) - (dolist (group method-groups) - (let ((variable (first group)) - (predicate (compute-match-predicate group))) - (when predicate - (push `(when ,predicate - (push methd (getf partitioned-method-plist ',variable))) - match-forms) - (push predicate check-forms)))) - (setq match-forms (nreverse match-forms)) + ;; If the order is :most-positive-first, we have to reverse, + ;; to undo the reversal done by the previous PUSH operations. + (let ((variable (svref ngroup 0)) + (orderform (svref ngroup 2))) + (if (or (equal orderform '':MOST-SPECIFIC-FIRST) + (equal orderform ':MOST-SPECIFIC-FIRST)) + `(SETQ ,variable (NREVERSE ,variable)) + (let ((order-variable + (first (find orderform order-bindings :key #'second)))) + (unless order-variable + (setq order-variable (gensym "ORDER-")) + (push `(,order-variable ,orderform) order-bindings)) + `(COND ((EQ ,order-variable ':MOST-SPECIFIC-FIRST) + (SETQ ,variable (NREVERSE ,variable))) + ((EQ ,order-variable ':MOST-SPECIFIC-LAST)) + (T (INVALID-METHOD-SORT-ORDER-ERROR ',orderform ,order-variable)))))))) + (let ((match-clauses '()) + (check-forms '())) + (dolist (ngroup method-groups) + (let ((variable (svref ngroup 0)) + (qualifier-test-form (compute-match-predicate ngroup))) + (push `(,qualifier-test-form (PUSH METHD ,variable)) + match-clauses) + (push qualifier-test-form check-forms))) + (setq match-clauses (nreverse match-clauses)) (setq check-forms (nreverse check-forms)) (let ((order-forms - (delete nil (mapcar #'compute-sort-form method-groups)))) + (delete nil (mapcar #'compute-reorder-form method-groups)))) (values - `(lambda (methods) - (let ((partitioned-method-plist nil) ,@order-bindings) - (dolist (methd methods) - (let ((qualifiers (method-qualifiers methd))) - (declare (ignorable qualifiers)) - (or ,@match-forms - ,(if *-group-variable - `(push methd (getf partitioned-method-plist - ',*-group-variable)) - '(invalid-method-error - "method matched no group: ~s." methd))))) + `(LAMBDA (METHODS) + (LET (,@(mapcar #'compute-variable-binding method-groups) + ,@order-bindings) + (DOLIST (METHD METHODS) + (LET ((QUALIFIERS (METHOD-QUALIFIERS METHD))) + (DECLARE (IGNORABLE QUALIFIERS)) + (COND ,@match-clauses + (T (INVALID-METHOD-QUALIFIERS-ERROR *METHOD-COMBINATION-GENERIC-FUNCTION* METHD))))) ,@order-forms ,@(delete nil (mapcar #'compute-required-form method-groups)) - partitioned-method-plist)) - `(lambda (gf methd) - ,(if *-group-variable - 'nil - `(let ((qualifiers (method-qualifiers methd))) - (declare (ignorable qualifiers)) - (or ,@check-forms (invalid-method-qualifiers-error gf methd))))))))))) + (PROGN ,@body))) + `(LAMBDA (GF METHD) + (LET ((QUALIFIERS (METHOD-QUALIFIERS METHD))) + (DECLARE (IGNORABLE QUALIFIERS)) + (OR ,@check-forms + (INVALID-METHOD-QUALIFIERS-ERROR GF METHD)))))))))) -(defmacro define-method-combination (name &rest options) +(defmacro define-method-combination (&whole whole-form + name &rest options) "The macro define-method-combination defines a new method combination. Short-form options are :documentation, :identity-with-one-argument, and :operator. @@ -656,116 +715,174 @@ followed by respective :description, :order, :required options, and optional :generic-function, and :arguments options preceeding the definition body." + (unless (symbolp name) + (error-of-type 'sys::source-program-error + (TEXT "~S: method combination name ~S should be a symbol") + 'define-method-combination name)) (sys::check-redefinition - name 'define-method-combination - (and (find-method-combination name :if-does-not-exist nil) - "method combination")) - (cond ((or (null options) ; short form - (typep (first options) '(and symbol (not null)))) - (destructuring-bind ; reconstruct to ensure constants - (&key documentation identity-with-one-argument (operator name)) - options - `(%define-method-combination - ',name - ,@(when documentation - `(:documentation ',documentation)) - ,@(when identity-with-one-argument - `(:identity-with-one-argument ',identity-with-one-argument)) - :operator ',operator - :qualifiers ',(list name ':around) - :expander #'short-form-method-combination-expander - :check-method-qualifiers #'short-form-method-combination-check-method-qualifiers - :call-next-method-allowed #'short-form-method-combination-call-next-method-allowed))) - ((listp (first options)) ; long form - (destructuring-bind (lambda-list qualifier-groups . body) options - (let ((arguments-lambda-list nil) - (gf-variable nil) - (declarations nil) + name 'define-method-combination + (and (find-method-combination name :if-does-not-exist nil) + "method combination")) + (cond ;; "The short form syntax ... is recognized when the second subform is + ;; a non-nil symbol or is not present." + ((or (null options) + (and (consp options) + (typep (first options) '(and symbol (not null))))) + ;; Short form. + (when (oddp (length options)) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: options must come in pairs") + 'define-method-combination name)) + (let ((documentation nil) + (identities '()) + (operators '())) + (do ((optionsr options (cddr optionsr))) + ((atom optionsr)) + (when (atom (cdr optionsr)) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: options must come in pairs") + 'define-method-combination name)) + (let ((optionkey (first optionsr)) + (argument (second optionsr))) + (case optionkey + (:DOCUMENTATION + (when documentation + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: option ~S may only be given once") + 'define-method-combination name ':documentation)) + (unless (stringp argument) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: ~S is not a string") + 'define-method-combination name argument)) + (setq documentation argument)) + (:IDENTITY-WITH-ONE-ARGUMENT + (when identities + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: option ~S may only be given once") + 'define-method-combination name ':identity-with-one-argument)) + (setq identities (list (not (null argument))))) + (:OPERATOR + (when operators + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: option ~S may only be given once") + 'define-method-combination name ':operator)) + (unless (symbolp argument) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S, option ~S: ~S is not a symbol") + 'define-method-combination name ':operator argument)) + (setq operators (list argument))) + (t + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: ~S is not a valid short-form option") + 'define-method-combination name optionkey))))) + `(DO-DEFINE-METHOD-COMBINATION + ',name + ,@(when documentation + `(:DOCUMENTATION ',documentation)) + ,@(when identities + `(:IDENTITY-WITH-ONE-ARGUMENT ',(first identities))) + :OPERATOR ',(if operators (first operators) name) + :QUALIFIERS ',(list name ':around) + :EXPANDER #'SHORT-FORM-METHOD-COMBINATION-EXPANDER + :CHECK-METHOD-QUALIFIERS #'SHORT-FORM-METHOD-COMBINATION-CHECK-METHOD-QUALIFIERS + :CALL-NEXT-METHOD-ALLOWED #'SHORT-FORM-METHOD-COMBINATION-CALL-NEXT-METHOD-ALLOWED))) + ;; "The long form syntax ... is recognized when the second subform is a + ;; list." + ((and (consp options) (listp (first options))) + ;; Long form. + (unless (and (>= (length options) 2) (listp (second options))) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: invalid syntax for long form: ~S") + 'define-method-combination name whole-form)) + (let ((lambda-list (first options)) + (method-group-specifiers (second options)) + (body (cddr options))) + ; Check the lambda-list. + (analyze-lambdalist lambda-list + #'(lambda (errorstring &rest arguments) + (error-of-type 'sys::source-program-error + (TEXT "~S ~S: invalid lambda-list: ~A") + 'define-method-combination name + (apply #'format nil errorstring arguments)))) + ; Check the method-group-specifiers, then the rest. + (let ((method-groups + (parse-method-groups name method-group-specifiers)) + (arguments-lambda-list nil) + (user-gf-variable nil) + (gf-variable (gensym "GF-")) (combination-variable (gensym "COMBINATION-")) (options-variable (gensym "OPTIONS-")) (args-variable (gensym "ARGUMENTS-")) (methods-variable (gensym "METHODS-")) - (method-variable (gensym "METHOD-")) - (ignore-gf nil) - (documentation nil)) - (loop - (typecase (first body) - (string (when documentation (return)) - (setf documentation (pop body))) - (cons (destructuring-bind (keyword . rest) (first body) - (case keyword - (:arguments - (when arguments-lambda-list - (error "duplicate :arguments option.")) - (setf arguments-lambda-list rest)) - (:generic-function - (when gf-variable - (error "duplicate :generic-function option.")) - (setf gf-variable (first rest))) - (declare - (push (first body) declarations)) - (t (return)))) - (pop body)) - (t (return)))) - (unless gf-variable (setf gf-variable (gensym "GF-") ignore-gf t)) - (when arguments-lambda-list - ;; add reflecive bindings for the planned effective function - ;; parameters - (setf body - `((let ,(mapcan - (lambda (parameter) - (unless (memq parameter lambda-list-keywords) - (when (consp parameter) - (setf parameter - (if (consp (... [truncated message content] |