From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 6 13:43:34 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA18653; Mon, 6 Mar 89 13:43:34 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 6 Mar 89 13:45:34 PST Received: by ti.com id AA02960; Mon, 6 Mar 89 11:50:02 CST Received: from Kelvin by tilde id AA04365; Mon, 6 Mar 89 11:36:08 CST Message-Id: <2814197751-13712027@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Mon, 6 Mar 89 11:35:51 CST From: David N Gray To: Patrick Dussud Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU, masinter.pa@Xerox.COM Subject: Re: CLOS questions In-Reply-To: Msg of Tue, 21 Feb 89 10:43:04 PST from Patrick Dussud > I'm a little confused by the way that SLOT-BOUNDP [p. 2-75], > SLOT-EXISTS-P [p. 2-76], and SLOT-MAKUNBOUND [p. 2-77] are specified as > generic functions with a primary method on class STANDARD-OBJECT which > just invokes a SLOT-...-USING-CLASS generic function. Do these really > need to be generic at both levels? According to the specification, > SLOT-BOUNDP, for example, should be implemented as ... > Note that the latter parallels the way that SLOT-VALUE is specified. > > I think we said that was a bug. They all should be functions like slot-value. Fine, but then shouldn't there be a cleanup proposal to correct this? I don't think I've seen one. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 6 14:30:27 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA18927; Mon, 6 Mar 89 13:54:49 PST Received: from lucid.com by SAIL.Stanford.EDU with TCP; 6 Mar 89 13:56:43 PST Received: from challenger ([192.9.200.17]) by heavens-gate.lucid.com id AA02312g; Mon, 6 Mar 89 13:48:46 PST Received: by challenger id AA25817g; Mon, 6 Mar 89 13:44:12 PST Date: Mon, 6 Mar 89 13:44:12 PST From: Patrick Dussud Message-Id: <8903062144.AA25817@challenger> To: Gray@DSG.csc.ti.com Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU, masinter.pa@Xerox.COM In-Reply-To: David N Gray's message of Mon, 6 Mar 89 11:35:51 CST <2814197751-13712027@Kelvin> Subject: CLOS questions Sender: GRAY@Kelvin.csc.ti.com Date: Mon, 6 Mar 89 11:35:51 CST From: David N Gray > I'm a little confused by the way that SLOT-BOUNDP [p. 2-75], > SLOT-EXISTS-P [p. 2-76], and SLOT-MAKUNBOUND [p. 2-77] are specified as > generic functions with a primary method on class STANDARD-OBJECT which > just invokes a SLOT-...-USING-CLASS generic function. Do these really > need to be generic at both levels? According to the specification, > SLOT-BOUNDP, for example, should be implemented as ... > Note that the latter parallels the way that SLOT-VALUE is specified. > > I think we said that was a bug. They all should be functions like slot-value. Fine, but then shouldn't there be a cleanup proposal to correct this? I don't think I've seen one. I don't think that we need a cleanup item for this. I think an editorial change suffices. Patrick. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 6 19:30:33 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA25335; Mon, 6 Mar 89 18:38:26 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 6 Mar 89 18:39:50 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 551871; Mon 6-Mar-89 21:37:29 EST Date: Mon, 6 Mar 89 21:37 EST From: David A. Moon Subject: remote environments To: David N Gray Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU In-Reply-To: <2813272681-7847725@Kelvin> Message-Id: <19890307023706.3.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Thu, 23 Feb 89 18:38:01 CST From: David N Gray I think it might help to focus the discussion about remote environments and meta object programming if we had a clearer picture of what the goals are. The basic question is what kinds of things can be defined and then used during compilation of the same file that defines them, and what restrictions might apply. I think you're right. Let me offer my opinions on the set of issues you have articulated. DEFCLASS * Can the class be used as a superclass of a later DEFCLASS? [clearly yes] * Can it be used as a specializer in a DEFMETHOD? [clearly yes] Agreed. * Can a MAKE-INSTANCE be done by a macro expander, DEFCONSTANT, or "#."? I have two answers to this, both based on current practice but contradictory. One is that I have some users who really need to be able to instantiate such classes in macro expanders. They have an embedded language which has an object-oriented representation for programs; therefore macro expansions include instances of classes defined earlier in the same file. The second is that Flavors does not support instantiation of compile-time classes in the Symbolics implementation, consequently the users I mentioned are currently operating with a kludge. I think it would be much nicer if we could make compile-time classes instantiable. However, I agree that it would not ruin the language to omit that feature if we can't figure out how to do it. - If so, do initforms have access to macros and constants defined earlier in the file? Initforms certainly have access to those things since they are included in the initforms' environment. I think 88-002R implies this. * Can the class be used as the :METACLASS option of a later DEFCLASS? - Can that second class be instantiated? * Can it be used as the :GENERIC-FUNCTION-CLASS option of a DEFGENERIC, GENERIC-FUNCTION, GENERIC-FLET, or GENERIC-LABELS? * Can it be used as the :METHOD-CLASS option of a DEFGENERIC etc.? - Can DEFMETHODs then be done for that generic function? The answers to these three should be the same and should depend just on whether a remote (aka compile-time) class can be instantiated. If yes, then the subsidiary questions are clearly also yes. DEFGENERIC * Referenced by later DEFMETHOD? [clearly yes] * Is the function defined such that it can be called at compile time? Clearly not, since a DEFUN is not. Here I think we should defer to the definition of how COMPILE-FILE deals with DEFUN and not try to propose something "better" that is just for CLOS. In fact I do have something better in mind, in which COMPILE-FILE would be less different from normal Lisp evaluation. But I don't think it would be appropriate to propose something so radical for Common Lisp at its current life stage. DEFMETHOD * Can it be invoked at compile-time? * In particular, will methods added to standard generic functions be invoked by the system at compile time? No, and no, for the same reason. When you compile-file a DEFMETHOD, a method metaobject is created but it is not added to the generic-function metaobject in the local environment. Instead it is added to a different generic-function metaobject created in the remote environment. That's my model of what has to happen. Note that this should be completely consistent with the way that compile-file of a DEFCLASS, with a direct superclass whose name is defined in the local environment and not in the remote environment, does not add the new class metaobject to the direct subclasses of the local superclass, but rather to a different object. (I realize we haven't agreed on what this paragraph says, or even seen a coherent proposal, yet. I'm just telling you my model.) DEFINE-METHOD-COMBINATION * Used in a later DEFGENERIC? - Callable at compile-time? I believe this should be yes to both, although if I'm not mistaken Flavors does not allow it. I think that's a bad design choice in Flavors. Are there other interactions that need to be considered? I can make a few other points. Assuming remote classes can be instantiated, remote methods specialized to a remote class of course cannot be executed. However, nothing stops us from making a local method specialized to a remote class. There happens not to be a defmethod syntax for doing that [although in fact one could imagine such an extension], but it should be easy to do with the interface at the next level down. That's a benefit from the clear separation between names and objects for which CLOS is striving. In the past there has been some controversy about whether the remote environment can inherit from the local environment. I think this is crystal clear: since some user-defined classes have STANDARD-OBJECT as a direct superclass, and STANDARD-OBJECT is not defined in the same file, the remote environment is clearly inheriting from the local environment. Different implementations might want to address the details of this differently, but I think it's clear that there has to be provision for it in the metaobject model. It makes things more complicated, but that's unavoidable. I think that the standard could take a simple, minimal, approach that would still satisfy the most common usages. Suppose we said: DEFCLASS If it appears at top-level, then the class name is defined for use as a type specifier or method specializer. It can also be used as a superclass of a later DEFCLASS since they don't have to be defined before being referenced anyway. The class object can be obtained by calling FIND-CLASS with an environment argument, but it can only be used in ways that do not require the class to be finalized. For example, one could ask for its CLASS-DIRECT-SUPERCLASSES, but not its CLASS-PRECEDENCE-LIST. Other uses, which could involve the need to instantiate the class, could not be portably done in the same file without wrapping an (EVAL-WHEN (EVAL COMPILE LOAD) ...) around the DEFCLASS. Implementations would be free to support compile-time instantiation as an extension. One way to look at this would be to say that it is implementation-dependent whether FINALIZE-INHERITANCE works or signals an error when given a class defined in the compile-time environment. [And no compile-time generic-function or method objects at all] This is an interesting idea, but I think it's too restrictive. Here's a plausible and many-times proposed application for metaobjects which would not be possible if we adopted this idea. Suppose you made an optimizing compiler that is allowed to assume that no class redefinitions, no method redefinitions, and no newly-defined subclasses will be created at run time. The compiler is to take advantage of this constraint on the program to generate more efficient code by doing type propagation and constant-folding out many method lookups and slot lookups. One should expect many CLOS programs compiled this way to have the same efficiency as C++ without suffering the same restrictions during development. Now, the natural way to organize the datastructures in this compiler is as metaobjects. CLOS (chapter 3 at least) already defines how to access the information the compiler needs. The constraint against run-time redefinition means the compiler can assume certain functions of metaobjects return the same result at compile time as they must at run time. For this to work all the metaobjects must exist and finalization must possible. It doesn't appear that instantiation is required, assuming the program being compiled doesn't define any metaclasses. I hope to keep thinking in this direction. From Owners-CommonLoops.PA@Xerox.COM Tue Mar 7 14:10:09 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA10230; Tue, 7 Mar 89 14:10:09 PST Received: from Semillon.ms by ArpaGateway.ms ; 07 MAR 89 14:03:41 PST Redistributed: CommonLoops.PA Received: from Cabernet.ms by ArpaGateway.ms ; 07 MAR 89 13:59:22 PST Date: 7 Mar 89 13:54 PST From: Kiuchi.pa@Xerox.COM Subject: patches.text/pcl.tar.Z in arisia To: CommonLoops.pa@Xerox.COM Cc: Kiuchi.pa@Xerox.COM Message-Id: <890307-140341-8027@Xerox> I've put the file: patches.text in /pcl directory in arisia.xerox.com. This file contains some patches to 12/7/88 no cute name PCL. These changes are also made into PCL files(boot.lisp and vector.lisp) in arisia. There is a file: pcl.tar.Z in /pcl directory in arisia. This is a compressed tar file contains all PCL files other than mailing-list archive. Thanks. Yasuhiko (Kiuchi.pa@Xerox.com) ---------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Tue Mar 7 15:44:31 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA12401; Tue, 7 Mar 89 15:44:31 PST Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 7 Mar 89 15:46:17 PST Received: from Semillon.ms by ArpaGateway.ms ; 07 MAR 89 15:39:49 PST Date: 7 Mar 89 15:39 PST From: Danny Bobrow Subject: Re: remote environments In-Reply-To: David A. Moon 's message of Mon, 6 Mar 89 21:37 EST To: David A. Moon Cc: David N Gray , Common-Lisp-Object-System@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU Message-Id: <890307-153949-8334@Xerox> I agree with Gray and you. There is further internal evidence in your message that we will have to allow instances of classes defined in the file being compiled to be instantiated. You answer for: DEFINE-METHOD-COMBINATION * Used in a later DEFGENERIC? - Callable at compile-time? Moon: I believe this should be yes to both, although if I'm not mistaken Flavors does not allow it. I think that's a bad design choice in Flavors. I agree. And the metaobject protocol specifies that this definition can define a new method-combination class. An instance of this class is used in the DEFGENERIC to effect the method combination. This implies an ability to instantiate a newly defined class at compile time to implement this capability. Another reason to answer the instntiation question YES. From Owners-CommonLoops.pa@Xerox.COM Wed Mar 8 13:03:34 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA29862; Wed, 8 Mar 89 12:30:08 PST Received: from Riesling.ms by ArpaGateway.ms ; 08 MAR 89 11:02:47 PST Return-Path: Redistributed: CommonLoops.pa Received: from shrike.Austin.Lockheed.COM ([192.31.24.65]) by Xerox.COM ; 08 MAR 89 10:59:26 PST Received: by shrike.Austin.Lockheed.COM (4.0/1.41); Wed, 8 Mar 89 12:56:10 CST Received: by opal.STC.LOCKHEED.COM (3.2/1.27); Wed, 8 Mar 89 12:47:57 CST Received: by frege.STC.LOCKHEED.COM (3.2/1.1); Wed, 8 Mar 89 12:47:55 CST Date: Wed, 8 Mar 89 12:47:55 CST From: Jacky Combs Message-Id: <8903081847.AA09179@frege.STC.LOCKHEED.COM> To: CommonLoops.pa@Xerox.COM Subject: Corrected VAX Fix Here is the file I meant to send concerning the PCL VAX Common Lisp fix. Sorry about the mixup in last week's message. ;;; Modified EXPAND-DCODE-CACHE function for VAX Common Lisp. Should replace ;;; the function by the same name in the dcode.lisp file prior to compiling PCL ;;; on the VAX. (defun expand-dcode-cache (generic-function old-cache old-size line-size nkeys next-scan-limit dcode-constructor) (let* ((new-size (* old-size 2)) (new-number-of-lines (floor new-size line-size)) (new-mask (make-wrapper-cache-mask new-number-of-lines)) (new-cache (get-generic-function-cache new-size)) (new-dcode nil) (wrappers ()) (value nil)) (flet ((collect-wrappers (loc) (block collect-wrappers ; need to explicitly create a ; collect-wrappers block for ; VAX Common Lisp in order to do a ; return-from collect-wrappers in the ; following if statement (when (%svref old-cache loc) (setq wrappers ()) (dotimes (i nkeys) (let ((wrapper (%svref old-cache (+ i loc)))) (if (zerop (wrapper-cache-no wrapper)) ;; This wrapper is obsolete, we don't have an instance ;; so there is no related trap. Just drop this line ;; on the floor. (return-from collect-wrappers nil) ; here is the return that ; was causing a problem in ; VAX CL (push wrapper wrappers)))) (setq wrappers (nreverse wrappers) value (and (< nkeys line-size) (%svref old-cache (+ loc nkeys)))) t)))) (flush-generic-function-caches-internal new-cache) (do ((old-location line-size (+ old-location line-size))) ((= old-location old-size)) (when (collect-wrappers old-location) (apply #'dcode-cache-miss generic-function #'(lambda (&rest ignore) (declare (ignore ignore)) value) new-cache new-size new-mask line-size nkeys next-scan-limit nil ;Means don't allow another ;expand while filling the ;new cache. This can only ;happen in one pathological ;case, but prevent it anyways. dcode-constructor wrappers))) (setq new-dcode (funcall dcode-constructor generic-function new-cache)) (setf (generic-function-cache generic-function) new-cache) (install-discriminating-function generic-function new-dcode) (free-generic-function-cache old-cache) new-cache))) ;;; The following is to correct the problem printing generic function ;;; stuff when you are using VAX Common Lisp and should be loaded after the ;;; "regular" PCL files are loaded. (setq *print-pretty* t) (setq *print-level* 2) (setq *print-length* 5) (setq *debug-print-level* 2) (setq *debug-print-length* 5) (define-list-print-function system::%compiled-closure% (alist stream) (if (generic-function-p alist) (write (generic-function-name alist) :stream stream) (write alist :stream stream))) ;; For VAX Common Lisp we have to define a different DESCRIBE-INSTANCE function ;; in order to printout the description of a generic function without ;; getting into an infinite loop. (defun describe-instance (object &optional (stream t)) (let* ((class (class-of object)) (slotds (slots-to-inspect class object)) (max-slot-name-length 0) (instance-slotds ()) (class-slotds ()) (other-slotds ())) (flet ((adjust-slot-name-length (name) (setq max-slot-name-length (max max-slot-name-length (length (the string (symbol-name name)))))) (describe-slot (name value &optional (allocation () alloc-p)) (if alloc-p (format stream "~% ~A ~S ~VT ~S" name allocation (+ max-slot-name-length 7) value) (format stream "~% ~A~VT ~S" name max-slot-name-length value)))) ;; Figure out a good width for the slot-name column. (dolist (slotd slotds) ;; VAX Comon Lisp fix - don't print out DISCRIMINATOR-CODE slot, ;; it is a circular list (if (equalp (slotd-name slotd) 'discriminator-code) () (progn (adjust-slot-name-length (slotd-name slotd)) (case (slotd-allocation slotd) (:instance (push slotd instance-slotds)) (:class (push slotd class-slotds)) (otherwise (push slotd other-slotds)))))) (setq max-slot-name-length (min (+ max-slot-name-length 3) 30)) (format stream "~%~S is an instance of class ~S:" object class) (when instance-slotds (format stream "~% The following slots have :INSTANCE allocation:") (dolist (slotd (nreverse instance-slotds)) (describe-slot (slotd-name slotd) (slot-value-or-default object (slotd-name slotd))))) (when class-slotds (format stream "~% The following slots have :CLASS allocation:") (dolist (slotd (nreverse class-slotds)) (describe-slot (slotd-name slotd) (slot-value-or-default object (slotd-name slotd))))) (when other-slotds (format stream "~% The following slots have allocation as shown:") (dolist (slotd (nreverse other-slotds)) (describe-slot (slotd-name slotd) (slot-value-or-default object (slotd-name slotd)) (slotd-allocation slotd)))) (values)))) From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Wed Mar 8 17:20:48 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA06428; Wed, 8 Mar 89 17:20:48 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 8 Mar 89 17:22:48 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 553444; Wed 8-Mar-89 20:20:16 EST Date: Wed, 8 Mar 89 20:20 EST From: David A. Moon Subject: macroexpansions of the user interface macros To: Gregor.pa@Xerox.COM Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU Message-Id: <19890309012005.2.MOON@EUPHRATES.SCRC.Symbolics.COM> Line-Fold: No I think I made some substantial progress in figuring out the macroexpansions of the user interface macros, although I don't have anything to show yet. I am currently up against a roadblock and I wonder if you can shed any light on it. The briefest description of the problem is that your metaobject document seems confused about where the name-to-object translations happen. For defclass, is it inside of ensure-class or outside of it? The most problematic name-to-object translation is the one from the surface syntax of slot definitions to the direct-slot-definition objects. Don't debug the document right now, just tell me whether your philosophy is to put it inside or outside of ensure-class. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Thu Mar 9 09:18:31 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA00468; Thu, 9 Mar 89 09:18:31 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 9 Mar 89 08:02:07 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 553668; Thu 9-Mar-89 10:59:28 EST Date: Thu, 9 Mar 89 10:59 EST From: David A. Moon Subject: macroexpansions of the user interface macros To: Gregor.pa@Xerox.COM Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: <19890309012005.2.MOON@EUPHRATES.SCRC.Symbolics.COM> Message-Id: <19890309155907.1.MOON@EUPHRATES.SCRC.Symbolics.COM> Line-Fold: No Date: Wed, 8 Mar 89 20:20 EST From: David A. Moon I am currently up against a roadblock and I wonder if you can shed any light on it. The briefest description of the problem is that your metaobject document seems confused about where the name-to-object translations happen. For defclass, is it inside of ensure-class or outside of it? The most problematic name-to-object translation is the one from the surface syntax of slot definitions to the direct-slot-definition objects. Never mind. I figured out that your philosophy is that the programmer interface macros only do parsing, not name-to-object translation. All the name-to-object translation is inside of ensure-class. That's okay with me, I'll proceed that way. From CL-Compiler-mailer@SAIL.STANFORD.EDU Thu Mar 9 11:05:48 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA02963; Thu, 9 Mar 89 11:05:48 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 9 Mar 89 11:02:43 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 553814; Thu 9-Mar-89 13:59:24 EST Date: Thu, 9 Mar 89 13:59 EST From: David A. Moon Subject: Issue MACRO-ENVIRONMENT-EXTENT To: Kim A. Barrett , sandra%defun@CS.UTAH.EDU Cc: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: <12472024104.5.IIM@ECLA.USC.EDU> Message-Id: <19890309185905.3.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Sun 19 Feb 89 15:54:36-PST From: Kim A. Barrett The extent of macro environment objects is related to EVAL-WHEN because macro expanders may wish to return forms which contain environments as quoted constants. I am convinced that this should be ruled out, and that CLOS made a mistake here. (Incidentally the part of CLOS that says this is in chapter 3, the accepted part of CLOS does not say anything about the expansion of the macros is.) .... Requiring environments to have indefinite extent has problems for CLOS because at compile-time it wants to create remote metaobjects and link them into the right places, but then flush those links when the compilation is over. This depends on whether you think the environment actually contains the table that relates names to objects, or just contains a boolean flag that tells functions such as FIND-CLASS which of two tables to look in. Under the latter model, nothing about the environment prevents the COMPILE-FILE table from being reset at any time. This is one reason why I think the second model is right. As far as MACRO-ENVIRONMENT-EXTENT itself goes, I am convinced it should be dynamic extent. I'm also convinced that the decision on this issue does not affect CLOS. From Owners-CommonLoops.pa@Xerox.COM Thu Mar 9 12:26:00 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA02039; Thu, 9 Mar 89 10:25:16 PST Received: from Cabernet.ms by ArpaGateway.ms ; 09 MAR 89 08:09:10 PST Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 09 MAR 89 08:07:03 PST To: CommonLoops.pa@Xerox.COM Subject: OOPSLA '89 Date: Thu, 09 Mar 89 11:07:54 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890309-080910-12305@Xerox> ------- Forwarded Message id ; Thu, 9 Mar 89 05:27:35 -0500 Date: Thu, 9 Mar 89 05:27:35 -0500 From: Steve Vinter Message-Id: <8903091027.AA27699@pineapple.bbn.com> To: kanderson@pineapple.bbn.com Subject: FYI -- where the hell did they announce it, anyway???? From: Rick Floyd Date: Wed, 8 Mar 89 18:05:06 EST To: wwalker Cc: vinter Subject: [crowl@cs.rochester.edu: Re: OOPSLA '89?] Date: Wed, 8 Mar 89 17:54:06 EST From: crowl@cs.rochester.edu To: rfloyd@bbn.com Subject: Re: OOPSLA '89? I have a paper call for participation for OOPSLA'89. The highlights for papers are: topics are applications, design, databases, user interfaces, tools and environments, software engineering, education, languages, implementation, and theory short papers (<= 15 double spaced typewriter pages or 3000 words) may have content specific to a single language or system long papers (<= 25 double spaced typewriter pages or 4500 words) make a contribution to object-oriented programming in general a separate cover sheet includes title, authors' names, affiliations, addresses (postal and electronic), telephone numbers, 100 word abstract, number of words in the paper, a list of keywords, the topic chosen, and choice of short or long paper submission notes send five copies of the paper including cover sheet papers that are late, too long, or with inadequate cover sheets will not be reviewed papers must be received by 17 March 1989 acceptance notification by 15 May 1989 final camera-ready copies by 30 June 1989 send submissions to Kent Beck OOPSLA'89 Program Chair Apple Computer, Inc. 20525 Mariani, MS 42C Cupertino, CA 95014 (408) 974-6027 Note that the deadline is pretty tight already. Lawrence ------- End of Forwarded Message From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Thu Mar 9 12:59:36 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA04712; Thu, 9 Mar 89 12:59:36 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 9 Mar 89 13:01:40 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 554005; Thu 9-Mar-89 15:58:57 EST Date: Thu, 9 Mar 89 15:58 EST From: David A. Moon Subject: Re: Issue: LOAD-OBJECTS (Version 2) To: David N Gray Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU In-Reply-To: <2809731258-5200907@Kelvin> Message-Id: <19890309205844.0.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Fri, 13 Jan 89 18:54:18 CST From: David N Gray This looks good. The only thing I have doubts about is: > The function MAKE-LOAD-FORM-USING-SLOTS can be useful in user-written > MAKE-LOAD-FORM methods. Its first argument is the object. Its > optional second argument is a list of the names of the slots to > preserve; it defaults to all of the local slots. > MAKE-LOAD-FORM-USING-SLOTS returns forms that construct an equivalent > object using MAKE-INSTANCE and SETF of SLOT-VALUE for slots with > values, or SLOT-MAKUNBOUND for slots without values, or using other > functions of equivalent effect. Rather than having the second argument default to a list of all instance slots, it might be better to consider two separate cases: 1. If a second argument is supplied, then MAKE-INSTANCE will be used to create the object, (using INITIALIZE-INSTANCE to default the slot values), and then the designated slots will be forced to have the proper value. 2. Without a second argument, ALLOCATE-INSTANCE will be used to create the object (without invoking INITIALIZE-INSTANCE or SHARED-INITIALIZE), and then all the slots will be filled in. If you are going to specify all of the slot values, then there shouldn't be a need to compute default values, and it may be undesirable to invoke INITIALIZE-INSTANCE -- for example, it might complain about missing required arguments or perform undesired side-effects. I don't think it's a good idea to have such a large deviation in behavior based on whether an optional argument is present or not. What if the argument is present but its value is a list of all the slots? I personally cannot figure out whether calling INITIALIZE-INSTANCE when it's not wanted, or failing to call it when it is wanted, would cause more unexpected behavior. I have to resolve that by keeping it simple so the programmer can figure it out on his own. So I think it should always create the object with MAKE-INSTANCE. > The default MAKE-LOAD-FORM method for STANDARD-OBJECT signals an > error. Wouldn't it be permissible to just not have a default method, so that a "no applicable method" error is signalled? Agreed. From Owners-CommonLoops.pa@Xerox.COM Thu Mar 9 13:27:53 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA05568; Thu, 9 Mar 89 13:27:53 PST Received: from Cabernet.ms by ArpaGateway.ms ; 09 MAR 89 13:23:39 PST Return-Path: Redistributed: CommonLoops.pa Received: from gamma.lanl.gov ([128.165.4.4]) by Xerox.COM ; 09 MAR 89 13:22:09 PST Received: by gamma.lanl.gov (5.54/1.14) id AA11245; Thu, 9 Mar 89 14:21:57 MST Received: by beta.lanl.gov (5.57/Ultrix2.4-C) id AA07625; Thu, 9 Mar 89 14:21:02 MST Date: Thu, 9 Mar 89 14:21:02 MST From: jfd%beta@LANL.GOV (John Davis) Message-Id: <8903092121.AA07625@beta.lanl.gov> To: CommonLoops.pa@Xerox.COM Subject: Failed to port PCL to VMS, DEC Common Lisp Cc: jfd%beta@LANL.GOV Bug report. VMS 4.7, VAX Common Lisp 2.2 could not compile EXPAND-DCODE-CACHE. Error reported was "Return to unseen block name: COLLECT-WRAPPERS" Also got 5 "between function" errors in HIGH.LISP. jfd@lanl.gov From CL-Cleanup-mailer@SAIL.STANFORD.EDU Thu Mar 9 13:35:41 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA05710; Thu, 9 Mar 89 13:35:41 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 9 Mar 89 13:25:46 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 554041; Thu 9-Mar-89 16:22:52 EST Date: Thu, 9 Mar 89 16:22 EST From: David A. Moon Subject: Issue: LOAD-OBJECTS (Version 2) To: John Rose Cc: CL-Cleanup@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU In-Reply-To: <8901140458.AA18401@lukasiewicz.sun.com> Message-Id: <19890309212238.1.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Fri, 13 Jan 89 20:58:49 PST From: jrose@Sun.COM (John Rose) ... The creation form for an object is always evaluated before the initialization form for that object. When either the creation form or the initialization form references other objects of user-defined types that have not been referenced earlier in the COMPILE-FILE, the compiler collects all of the creation forms together and collects all of the initialization forms together. All of the creation forms are evaluated before any of the initialization forms. The order of evaluation of the creation forms is unspecified except when the ordering is forced by data dependencies. The order of evaluation of the initialization forms is unspecified. ... Why does the proposal restrict the evaluation initialization forms to such a late time? Data dependencies would allow an object X's initialization form to be executed any time after X's creation form had finished. Actually, it would be better (and no more difficult, it seems to me) to be strict in the other direction: Objects should be initialized as early as possible, and hence at a deterministic time. This would allow nodes in non-circular structures to be built out of fully initialized subparts, which is clearly something an application could need. Good point. I've modified the proposal accordingly, although I did not use your exact wording. Of course the time is not fully determinstic, but it's more deterministic than in version 2 of the proposal. From CL-Cleanup-mailer@SAIL.STANFORD.EDU Thu Mar 9 13:51:11 1989 Received: from [36.86.0.194] by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA05900; Thu, 9 Mar 89 13:51:11 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 9 Mar 89 13:29:07 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 554052; Thu 9-Mar-89 16:26:35 EST Date: Thu, 9 Mar 89 16:26 EST From: David A. Moon Subject: Issue: LOAD-OBJECTS (Version 3) To: CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU Message-Id: <19890309212623.2.MOON@EUPHRATES.SCRC.Symbolics.COM> At Kauai I was asked to keep working on this and come up with a modified version based on comments received. Here it is. I hope this is ready for voting so we can clear it out of the way. Issue: LOAD-OBJECTS References: none Related issues: LOAD-TIME-EVAL, CONSTANT-COMPILABLE-TYPES, CONSTANT-CIRCULAR-COMPILATION Category: ADDITION Forum: Cleanup Edit history: Version 1, 2-Jan-89, by Moon (for discussion) Version 2, 13-Jan-89, by Moon (draft updated from discussion) Version 3, 9-Mar-89, by Moon (changes suggested by discussion) Problem description: Common Lisp doesn't provide any way to use an object of a user-defined type (defined with DEFCLASS or DEFSTRUCT) as a constant in a program compiled with COMPILE-FILE. The problem is that LOAD has to be able to "reconstruct" an equivalent object when the compiled-code file is loaded, but the programmer has no way to tell LOAD how to do that. Proposal (LOAD-OBJECTS:MAKE-LOAD-FORM): Define a new generic function named MAKE-LOAD-FORM, which takes one argument and returns two values. The argument is an object that is referenced as a constant or as a self-evaluating form in a file being compiled by COMPILE-FILE. The objective is to enable LOAD to construct an equivalent object. The first value, called the "creation form," is a form that, when evaluated at load time, should return an object that is equivalent to the argument. The exact meaning of "equivalent" depends on the type of object and is up to the programmer who defines a method for MAKE-LOAD-FORM. This is the same type of equivalence discussed in issue CONSTANT-COMPILABLE-TYPES. The second value, called the "initialization form," is a form that, when evaluated at load time, should perform further initialization of the object. The value returned by the initialization form is ignored. If the MAKE-LOAD-FORM method returns only one value, the initialization form is NIL, which has no effect. If the object used as the argument to MAKE-LOAD-FORM appears as a constant in the initialization form, at load time it will be replaced by the equivalent object constructed by the creation form; this is how the further initialization gains access to the object. Both the creation form and the initialization form can contain references to objects of user-defined types (defined precisely below). However, there must not be any circular dependencies in creation forms. An example of a circular dependency is when the creation form for the object X contains a reference to the object Y, and the creation form for the object Y contains a reference to the object X. A simpler example would be when the creation form for the object X contains a reference to X itself. Initialization forms are not subject to any restriction against circular dependencies, which is the entire reason that initialization forms exist. See the example of circular data structures below. The creation form for an object is always evaluated before the initialization form for that object. When either the creation form or the initialization form references other objects of user-defined types that have not been referenced earlier in the COMPILE-FILE, the compiler collects all of the creation and initialization forms. Each initialization form is evaluated as soon as possible after its creation form, as determined by data flow. If the initialization form for an object does not reference any other objects of user-defined types that have not been referenced earlier in the COMPILE-FILE, the initialization form is evaluated immediately after the creation form. If a creation or initialization form F references other objects of user-defined types that have not been referenced earlier in the COMPILE-FILE, the creation forms for those other objects are evaluated before F, and the initialization forms for those other objects are also evaluated before F whenever they do not depend on the object created or initialized by F. Where the above rules do not uniquely determine an order of evaluation, which of the possible orders of evaluation is chosen is unspecified. While these creation and initialization forms are being evaluated, the objects are possibly in an uninitialized state, analogous to the state of an object between the time it has been created by ALLOCATE-INSTANCE and it has been processed fully by INITIALIZE-INSTANCE. Programmers writing methods for MAKE-LOAD-FORM must take care in manipulating objects not to depend on slots that have not yet been initialized. It is unspecified whether LOAD calls EVAL on the forms or does some other operation that has an equivalent effect. For example, the forms might be translated into different but equivalent forms and then evaluated, they might be compiled and the resulting functions called by LOAD, or they might be interpreted by a special-purpose interpreter different from EVAL. All that is required is that the effect be equivalent to evaluating the forms. COMPILE-FILE calls MAKE-LOAD-FORM on any object that is referenced as a constant or as a self-evaluating form, if the object's metaclass is STANDARD-CLASS, STRUCTURE-CLASS, any user-defined metaclass (not a subclass of BUILT-IN-CLASS), or any of a possibly-empty implementation-defined list of other metaclasses. COMPILE-FILE will only call MAKE-LOAD-FORM once for any given object (compared with EQ) within a single file. It is valid for user programs to call MAKE-LOAD-FORM in other circumstances, providing the argument's metaclass is not BUILT-IN-CLASS or a subclass of BUILT-IN-CLASS. Define a new function named MAKE-LOAD-FORM-USING-SLOTS, which takes one required argument and one optional argument and returns two values. This can be useful in user-written MAKE-LOAD-FORM methods. The first argument is the object. The optional second argument is a list of the names of the slots to preserve; it defaults to all of the local slots. MAKE-LOAD-FORM-USING-SLOTS returns forms that construct an equivalent object using MAKE-INSTANCE and SETF of SLOT-VALUE for slots with values, or SLOT-MAKUNBOUND for slots without values, or using other functions of equivalent effect. MAKE-LOAD-FORM-USING-SLOTS returns two values, thus it can deal with circular structures. MAKE-LOAD-FORM-USING-SLOTS works for any object of metaclass STANDARD-CLASS or STRUCTURE-CLASS. Whether the result is useful in an application depends on whether the object's type and slot contents fully capture the application's idea of the object's state. MAKE-LOAD-FORM of an object of metaclass STANDARD-CLASS or STRUCTURE-CLASS for which no user-defined method is applicable signals an error. It is valid to implement this either by defining default methods on STANDARD-OBJECT and STRUCTURE-OBJECT that signal an error or by having no applicable method for those classes. Examples: ;; Example 1 (defclass my-class () ((a :initarg :a :reader my-a) (b :initarg :b :reader my-b) (c :accessor my-c))) (defmethod shared-initialize ((self my-class) ignore &rest ignore) (unless (slot-boundp self 'c) (setf (my-c self) (some-computation (my-a self) (my-b self))))) (defmethod make-load-form ((self my-class)) `(make-instance ',(class-name (class-of self)) :a ',(my-a self) :b ',(my-b self))) In this example, an equivalent instance of my-class is reconstructed by using the values of two of its slots. The value of the third slot is derived from those two values. Another way to write the last form in the above example would have been (defmethod make-load-form ((self my-class)) (make-load-form-using-slots self '(a b))) ;; Example 2 (defclass my-frob () ((name :initarg :name :reader my-name))) (defmethod make-load-form ((self my-frob)) `(find-my-frob ',(my-name self) :if-does-not-exist :create)) In this example, instances of my-frob are "interned" in some way. An equivalent instance is reconstructed by using the value of the name slot as a key for searching existing objects. In this case the programmer has chosen to create a new object if no existing object is found; alternatively she could have chosen to signal an error in that case. ;; Example 3 (defclass tree-with-parent () ((parent :accessor tree-parent) (children :initarg :children))) (defmethod make-load-form ((x tree-with-parent)) (values ;; creation form `(make-instance ',(class-of x) :children ',(slot-value x 'children)) ;; initialization form `(setf (tree-parent ',x) ',(slot-value x 'parent)))) In this example, the data structure to be dumped is circular, because each parent has a list of its children and each child has a reference back to its parent. Suppose make-load-form is called on one object in such a structure. The creation form creates an equivalent object and fills in the children slot, which forces creation of equivalent objects for all of its children, grandchildren, etc. At this point none of the parent slots have been filled in. The initialization form fills in the parent slot, which forces creation of an equivalent object for the parent if it was not already created. Thus the entire tree is recreated at load time. At compile time, MAKE-LOAD-FORM is called once for each object in the true. All of the creation forms are evaluated, in unspecified order, and then all of the initialization forms are evaluated, also in unspecified order. ;; Example 4 (defstruct my-struct a b c) (defmethod make-load-form ((s my-struct)) (make-load-form-using-slots s)) In this example, the data structure to be dumped has no special properties and an equivalent structure can be reconstructed simply by reconstructing the slots' contents. Rationale: Only the programmer who designed a class can know the correct way to reconstruct objects of that class at load time, therefore the reconstruction should be controlled by a generic function. Using EVAL as the interface for telling LOAD what to do provides full generality. MAKE-LOAD-FORM returns two values so that circular structures can be handled. If CONSTANT-CIRCULAR-COMPILATION is rejected, MAKE-LOAD-FORM will only return one value, although implementations that make an extension to support circular constants will probably also make the extension to accept two values from MAKE-LOAD-FORM. The default for class objects and structures is to signal an error, rather than picking some particular object reconstruction technique, because no reconstruction technique is appropriate for all objects. It only takes two lines of code, as in example 4, to instruct the compiler to use the technique that most often has been suggested as the default. MAKE-LOAD-FORM has a natural resemblance to PRINT-OBJECT, as a hook for the programmer to control the system's actions. The order of evaluation rules for creation and initialization forms eliminate the possibility of partially initialized objects in the absence of circular structures, and reduce it to the minimum possible in the presence of circular structures. This allows nodes in non-circular structures to be built out of fully initialized subparts. Current practice: Symbolics Flavors has something like this, but under a different name. The name Symbolics uses is not suitable for standardization. JonL reports that Lucid is getting more and more requests for this. Cost to Implementors: This seems like only a few one-line changes in the compiled-code file writer and reader. MAKE-LOAD-FORM-USING-SLOTS is a couple dozen lines of code, assuming the presence of the CLOS metaobject protocol or an implementation-dependent equivalent. Cost to Users: None. Cost of non-adoption: Serious impairment of the ability to use extended-type objects. Each implementation will probably make up its own version of this as an extension. Performance impact: None. Benefits: See Cost of non-adoption. Esthetics: No significant positive or negative impact. Discussion: It would be possible to define an additional level of protocol that allows multiple classes to contribute to the reconstruction of an object, combining initialization arguments contributed by each class. Since a user can easily define that in terms of MAKE-LOAD-FORM without modifying the Lisp system, it is not being proposed now. Any type that has a read syntax is likely to appear as a quoted constant or inside a quoted constant. Pathnames are one example, user programs often define others. Also many implementations provide a way to create a compiled-code file full of data (rather than compiled Lisp programs), and such data probably include extended-type objects. Moon supports this. David Gray and John Rose made major contributions to the discussion that produced this improved version 2 proposal. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Thu Mar 9 16:17:40 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA08201; Thu, 9 Mar 89 16:17:40 PST Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 9 Mar 89 16:19:35 PST Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA06189; Thu, 9 Mar 89 17:17:27 -0700 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA10108; Thu, 9 Mar 89 17:17:24 -0700 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8903100017.AA10108@defun.utah.edu> Date: Thu, 9 Mar 89 17:17:22 MST Subject: issue CLOS-MACRO-COMPILATION To: Gregor.pa@Xerox.COM Cc: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: Gregor.pa@Xerox.COM, Thu, 23 Feb 89 20:23 PST Have you made any progress yet on settling on your new model of how the CLOS defining macros work? I have opened a new cl-compiler issue, CLOS-MACRO-COMPILATION, for this, but I don't yet have a proposal. (Or even a problem statement written down, for that matter.) I am planning to distribute the rest of our issues to X3J13 early next week and would like to have at least a draft ready by then. If you don't think that's possible, I will have to say in our report that we need an extension to get this issue resolved. -Sandra ------- From CL-Compiler-mailer@SAIL.STANFORD.EDU Thu Mar 9 17:12:50 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA09048; Thu, 9 Mar 89 17:12:50 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 9 Mar 89 17:08:20 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 554334; Thu 9-Mar-89 20:05:08 EST Date: Thu, 9 Mar 89 20:04 EST From: David A. Moon Subject: issue CLOS-MACRO-COMPILATION To: Sandra J Loosemore Cc: Gregor.pa@Xerox.COM, cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: <8903100017.AA10108@defun.utah.edu> Message-Id: <19890310010446.2.MOON@EUPHRATES.SCRC.Symbolics.COM> Line-Fold: No Date: Thu, 9 Mar 89 17:17:22 MST From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Have you made any progress yet on settling on your new model of how the CLOS defining macros work? I didn't get a chance to talk with Gregor when he was here a couple days ago, but I have made some progress on this myself. However, it's not ready to show to anyone yet. I have opened a new cl-compiler issue, CLOS-MACRO-COMPILATION, for this, but I don't yet have a proposal. (Or even a problem statement written down, for that matter.) I am planning to distribute the rest of our issues to X3J13 early next week and would like to have at least a draft ready by then. If you don't think that's possible, I will have to say in our report that we need an extension to get this issue resolved. What I'm doing won't be ready to show to X3J13 that soon. However, assuming that eval-when is settled now, I don't think what I'm doing will have any effect on X3J13 as it should be all at the metaobject level. I guess I won't know that for sure until I'm done. From Owners-CommonLoops.pa@Xerox.COM Thu Mar 9 21:05:12 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA01924; Thu, 9 Mar 89 20:27:37 PST Received: from Cabernet.ms by ArpaGateway.ms ; 09 MAR 89 20:28:23 PST Return-Path: Redistributed: CommonLoops.pa Received: from rand.org ([10.3.0.7]) by Xerox.COM ; 09 MAR 89 20:27:00 PST Received: from blackcomb.rand.org by rand.org; Thu, 9 Mar 89 20:04:57 PST Received: from localhost by blackcomb.arpa; Thu, 9 Mar 89 20:04:02 PST Message-Id: <8903100404.AA06998@blackcomb.arpa> To: CommonLoops.pa@Xerox.COM Cc: Darrell_Shane Subject: PCL bug? Date: Thu, 09 Mar 89 20:04:00 PST From: Darrell Suppose the following: (defclass a () ()) (defclass b (a)()) (defclass c (a b) ()) When c's defclass is evaluated I get: Error: While computing the class-precedence-list for the class C: There is a circular constraint through the classes: B A B. This arises because: B must precede A -- A is in the local supers of B. A must precede B -- C has local supers (A B). When I try to evaluate a new defclass for c such as: (defclass c (b) ()) the same error occurs. I believe this is because c is not being removed from class a's direct-subclasses list. That is, by evaluating the following: (defclass c () ()) (describe (find-class 'a)) The class # is an instance of class #. Name: A Class-Precedence-List: (A OBJECT T) Local-Supers: (OBJECT) Direct-Subclasses: (B C) # it is noticed that c is still a member of a's direct-subclasses. Is this a bug or am I missing something? Thanks, Darrell Shane P.S. I am using the "12/7/88 Can't think of a cute name" PCL in Franz Allegro on a Sun3/60. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Fri Mar 10 12:56:32 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA02058; Fri, 10 Mar 89 12:56:32 PST Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 10 Mar 89 12:58:24 PST Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA03202; Fri, 10 Mar 89 13:56:09 -0700 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA10809; Fri, 10 Mar 89 13:56:06 -0700 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8903102056.AA10809@defun.utah.edu> Date: Fri, 10 Mar 89 13:56:05 MST Subject: issue CLOS-MACRO-COMPILATION, version 1 To: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: David A. Moon , Thu, 9 Mar 89 20:04 EST Here is a first cut at getting something written down on this issue. This is mostly extracted from David Gray's list of questions and Moon's responses. To me it seems like the question where there is the most disagreement is whether or not classes are required to be instantiable at compile-time, so I have made two proposals. MINIMAL leaves this unspecified, and NOT-SO-MINIMAL requires them to be instantiable. Forum: Compiler Issue: CLOS-MACRO-COMPILATION References: CLOS chapters 1 & 2 (88-002R) CLOS chapter 3 (89-003) Issue COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS Issue DEFINING-MACROS-NON-TOP-LEVEL Category: CLARIFICATION Edit History: V1, 10 Mar 1989, Sandra Loosemore Status: **DRAFT** Problem Description: Do the CLOS defining macros (DEFCLASS, DEFMETHOD, DEFGENERIC, and DEFINE-METHOD-COMBINATION) have compile-time side-effects similar to those for DEFSTRUCT or DEFMACRO? A part of the problem is that we do not currently have a full understanding of all the issues involved. In particular, work on defining the CLOS meta-object protocol is still in progress. The goal is to say enough about the behavior of these macros in the standard so that users can use them portably in compiled code, but to leave as much of the behavior as possible unspecified to avoid placing undue restrictions on the meta-object protocol. There are two proposals, MINIMAL and NOT-SO-MINIMAL. Proposal CLOS-MACRO-COMPILATION:MINIMAL: State that top-level calls to the CLOS defining macros have the following compile-time side-effects. Any other compile-time behavior is explicitly left unspecified. DEFCLASS: * The class name becomes a type specifier which may appear in subsequent type declarations. * The class name can be used to name a superclass in a subsequent DEFCLASS. * The class name can be used as a specializer in a subsequent DEFMETHOD. DEFGENERIC: * The generic function can be referenced in a subsequent DEFMETHOD. * The generic function is not callable at compile-time. DEFMETHOD: * The method is not callable at compile-time. If there is a generic function with the same name at compile-time, compiling a DEFMETHOD will not add the method to that generic function. [This also seems to imply that tests for existence of the generic function, lambda-list congruence, etc. must not happen until load time.] DEFINE-METHOD-COMBINATION: * The method combination can be used in a subsequent DEFGENERIC. If it is referenced, the body of a long form of method combination must be evaluable at compile-time. Rationale: The compile-time behavior of DEFCLASS is similar to DEFSTRUCT or DEFTYPE. DEFGENERIC and DEFMETHOD are similar to DEFUN. DEFINE-METHOD-COMBINATION is similar to DEFMACRO or DEFSETF. Proposal CLOS-MACRO-COMPILATION:NOT-SO-MINIMAL: This is the same as proposal MINIMAL, except under DEFCLASS add: * The class may be instantiated at compile-time. Provided the appropriate methods are also defined at compile-time, this implies: - The class can be used as the :METACLASS option of a later DEFCLASS. - It can be used as the :GENERIC-FUNCTION-CLASS or :METHOD-CLASS option of a DEFGENERIC, GENERIC-FUNCTION, GENERIC-FLET, or GENERIC-LABELS. Rationale: Being able to instantiate a class at compile-time is somewhat more convenient for users. Current Practice: The items listed under DEFCLASS in proposal MINIMAL are fairly standard programming style. Flavors does not support compile-time instantiation of classes. It does not make method combinations available at compile-time either, but Moon considers that to be a bad design choice. Cost to implementors: Unknown. Cost to users: Unknown, but probably fairly small. Note that for proposal NOT-SO-MINIMAL, users still have to ensure that any methods on the class which may be invoked at compile-time are fully defined. This includes the INITIALIZE-INSTANCE and SHARED-INITIALIZE methods that are invoked by MAKE-INSTANCE. Wrapping an (EVAL-WHEN (EVAL COMPILE LOAD) ...) around the appropriate definitions will make sure they are fully defined at compile-time. Alternatively, the definitions could be placed in a separate file, which is loaded before compiling the file that depends on those definitions. Benefits: Programmers can rely on programs that use the CLOS defining macros being able to compile correctly in all implementations, without having to wrap explicit EVAL-WHENs around every macro call. Discussion: Loosemore says: Although I admit I don't understand all of the issues involved with the meta-object protocol, I support proposal MINIMAL. I don't think leaving the issue of whether or not classes can be instantiated at compile-time unspecified places an undue burden on users, and it does leave more freedom for the meta-object protocol to decide what the right behavior really is. ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Fri Mar 10 16:07:31 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA06518; Fri, 10 Mar 89 16:07:31 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 10 Mar 89 16:09:25 PST Received: by ti.com id AA05516; Fri, 10 Mar 89 17:20:30 CST Received: from Kelvin by tilde id AA26271; Fri, 10 Mar 89 17:10:23 CST Message-Id: <2814563376-4811635@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Fri, 10 Mar 89 17:09:36 CST From: David N Gray To: Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: class FUNCTION etc. Can someone shed some light on why the pre-defined classes listed on page 1-17 of document 88-002R are not included in Figure 2-1 on page 2-13 of the Feb 21 standard draft from the editorial committee? In particular, since proposal FUNCTION-TYPE has already been passed so that FUNCTION could be a class, how come it isn't one already? From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Fri Mar 10 16:13:14 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA06578; Fri, 10 Mar 89 16:13:14 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 10 Mar 89 16:13:48 PST Received: by ti.com id AA05503; Fri, 10 Mar 89 17:20:12 CST Received: from Kelvin by tilde id AA25887; Fri, 10 Mar 89 17:03:00 CST Message-Id: <2814562938-4785295@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Fri, 10 Mar 89 17:02:18 CST From: David N Gray To: Danny Bobrow Cc: "David A. Moon" , Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: Re: remote environments In-Reply-To: Msg of 7 Mar 89 15:39 PST from Danny Bobrow > I agree. And the metaobject protocol specifies that this > definition can define a new method-combination class. > An instance of this class is used in the DEFGENERIC to effect the > method combination. This implies an ability to instantiate > a newly defined class at compile time to implement this capability. > Another reason to answer the instntiation question YES. I don't see where DEFINE-METHOD-COMBINATION has any option for specifying the class of the method combination; doesn't it always produce an instance of the pre-defined class METHOD-COMBINATION ? From Owners-CommonLoops.pa@Xerox.COM Fri Mar 10 19:26:13 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA09644; Fri, 10 Mar 89 19:26:13 PST Received: from Cabernet.ms by ArpaGateway.ms ; 10 MAR 89 09:43:22 PST Return-Path: Redistributed: CommonLoops.pa Received: from decwrl.dec.com ([128.45.9.1]) by Xerox.COM ; 10 MAR 89 09:40:23 PST Received: by decwrl.dec.com (5.54.5/4.7.34) id AA29796; Fri, 10 Mar 89 09:39:55 PST Date: Fri, 10 Mar 89 09:39:55 PST Message-Id: <8903101739.AA29796@decwrl.dec.com> Received: by decwrl.dec.com (5.54.5/4.7.34) for CommonLoops.pa@xerox.com; id AA29796; Fri, 10 Mar 89 09:39:55 PST From: piazza%aitg.DEC@decwrl.dec.com (Jeffrey Piazza) To: jfd%beta@lanl.gov Subject: RE: Failed to port PCL to VMS, DEC Common Lisp Since the release of VAX LISP V2.2, the X3J13 standards committee approved a language change which specifies that FLET and LABELS functions have an implicit BLOCK, in the same way that DEFUN functions do. Future releases of VAX LISP will implement this language change. In the meantime, you can compile DCODE.LISP in VAX LISP V2.2 simply by adding your own explicit BLOCK form in the FLET definition of COLLECT-WRAPPERS in EXPAND-DCODE-CACHE. Jacky Combs sent this out as a patch to the CommonLoops mailing list on 2-Mar-1989. I will be happy to send you another copy of that patch if you don't have the original message. /JEP P.S. Just for the record, there's no such thing as "DEC Common Lisp". Our product is known as VAX LISP. From Owners-commonloops.pa@Xerox.COM Fri Mar 10 19:40:59 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA09694; Fri, 10 Mar 89 19:40:59 PST Received: from Cabernet.ms by ArpaGateway.ms ; 10 MAR 89 15:11:32 PST Return-Path: Redistributed: commonloops.pa Received: from VAX.BBN.COM ([128.89.0.91]) by Xerox.COM ; 10 MAR 89 15:08:46 PST To: commonloops.pa@Xerox.COM Subject: Re: PCL bug (temp fix) Date: Fri, 10 Mar 89 14:56:56 -0500 From: Mike Thome Message-Id: <890310-151132-16136@Xerox> Turns out the bug I just reported is due to some confusion in the method generic-function-pretty-arglist. Below is a temporary patch to fix the problem - notes are in comments in the code. -mike ;;; fix bug in generic-function-pretty-arglist - used to have severe problems with ;;; keywords and more than one method. function-keywords used to only return the ;;; keywords of a function in the keyword package, but ;;; generic-function-pretty-arglist needed them in the same form as the actual ;;; arguments - this led to the pretty-arglist having &key arguments listed in both the ;;; regular package and in the keyword package. MT 89-03-10 ;;; Note that we cannot just change function-keywords to return what we ;;; want as it's first argument, 'cuz it is used elsewhere correctly. ;;; (defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) (let ((methods (generic-function-methods generic-function)) (arglist ())) (when methods (multiple-value-bind (required optional rest key allow-other-keys) (method-pretty-arglist (car methods)) (dolist (m (cdr methods)) (multiple-value-bind (method-key-keywords method-allow-other-keys method-key) (function-keywords m) ;; we've modified function-keywords to return what we want as ;; the third value, no other change here. (declare (ignore method-key-keywords)) (setq key (union key method-key)) (setq allow-other-keys (or allow-other-keys method-allow-other-keys)))) (when allow-other-keys (setq arglist '(&allow-other-keys))) (when key (setq arglist (nconc (list '&key) key arglist))) (when rest (setq arglist (nconc (list '&rest rest) arglist))) (when optional (setq arglist (nconc (list '&optional) optional arglist))) (nconc required arglist))))) (defmethod function-keywords ((method standard-method)) (flet ((get-keyword-from-arg (arg) (if (listp arg) (if (listp (car arg)) (caar arg) (make-keyword (car arg))) (make-keyword arg)))) (let ((keys ()) (syms ()) ; also collect the args themselves (allow-other-keys nil) (state nil)) (dolist (arg (method-arglist method)) (if (memq arg lambda-list-keywords) (case arg (&key (setq state 'key)) (&allow-other-keys (setq allow-other-keys 't))) (when (eq state 'key) (push (get-keyword-from-arg arg) keys) (push (if (listp arg) ; collect the args, too. (if (listp (car arg)) (caar arg) (car arg)) arg) syms)))) ;; return the collected keyword *ARGS* as third value. (values (reverse keys) allow-other-keys (reverse syms))))) From Owners-commonloops.pa@Xerox.COM Fri Mar 10 20:15:05 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA09742; Fri, 10 Mar 89 19:43:41 PST Received: from Semillon.ms by ArpaGateway.ms ; 10 MAR 89 15:12:43 PST Return-Path: Redistributed: commonloops.pa Received: from VAX.BBN.COM ([128.89.0.91]) by Xerox.COM ; 10 MAR 89 15:08:40 PST To: commonloops.pa@Xerox.COM Subject: PCL bug? Date: Fri, 10 Mar 89 13:22:51 -0500 From: Mike Thome Message-Id: <890310-151243-16142@Xerox> Can anyone else confirm this bug? I'm using a fairly modified version of no-name pcl on symbolics (7.2): (defmethod frotz (x &key y) x) (pcl:arglist 'frotz) -> (x &key y) (defmethod frotz ((x integer) &key y) y) (pcl:arglist 'frotz) -> (x &key :y y) thanks, -mike thome (mthome@bbn.com) From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 01:24:03 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA15111; Sat, 11 Mar 89 01:24:03 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 11 Mar 89 01:25:50 PST Received: by ti.com id AA05982; Fri, 10 Mar 89 18:21:46 CST Received: from Kelvin by tilde id AA27610; Fri, 10 Mar 89 18:07:29 CST Message-Id: <2814566813-5018117@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Fri, 10 Mar 89 18:06:53 CST From: David N Gray To: sandra%defun@cs.utah.edu (Sandra J Loosemore) Cc: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Subject: Re: issue CLOS-MACRO-COMPILATION, version 1 In-Reply-To: Msg of Fri, 10 Mar 89 13:56:05 MST from sandra%defun@cs.utah.edu (Sandra J Loosemore) > Proposal CLOS-MACRO-COMPILATION:MINIMAL: ... > DEFMETHOD: > > * The method is not callable at compile-time. If there is a generic > function with the same name at compile-time, compiling a DEFMETHOD > will not add the method to that generic function. > > [This also seems to imply that tests for existence of the generic > function, lambda-list congruence, etc. must not happen until > load time.] No, an implementation should be permitted to check for lambda-list congruence between methods defined in the same file; this doesn't require any reference to the resident generic function definition. If the file doesn't include a DEFGENERIC, then the first DEFMETHOD defines the compile-time generic function attributes, and subsequent methods can be checked against that. > DEFINE-METHOD-COMBINATION: > > * The method combination can be used in a subsequent DEFGENERIC. If it > is referenced, the body of a long form of method combination must be > evaluable at compile-time. But if methods are not installed at compile time and generic functions are not callable at compile time, then I don't think there is any situation in which the method combination body could be executed at compile-time. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 01:28:03 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA15121; Sat, 11 Mar 89 01:28:03 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 11 Mar 89 01:29:36 PST Received: by ti.com id AA05380; Fri, 10 Mar 89 17:04:35 CST Received: from Kelvin by tilde id AA25717; Fri, 10 Mar 89 16:51:06 CST Message-Id: <2814562184-4740019@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Fri, 10 Mar 89 16:49:44 CST From: David N Gray To: "David A. Moon" Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: Re: remote environments In-Reply-To: Msg of Mon, 6 Mar 89 21:37 EST from David A. Moon > I think it would be much nicer if we could make compile-time classes > instantiable. However, I agree that it would not ruin the language to > omit that feature if we can't figure out how to do it. I agree that it would be nice, and intend to support it in our implementation (it's already implemented but has a few problems to be worked out). It's just a question of whether it can be specified in a way that everyone can live with. > - If so, do initforms have access to macros and constants defined > earlier in the file? > > Initforms certainly have access to those things since they are included > in the initforms' environment. I think 88-002R implies this. I intend to implement it that way since it is a reasonable thing to expect. However, I'm not aware of any language in 88-002R that requires this ("implies" isn't good enough). In fact, proposal COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS explicitly says that macro definitions are _not_ necessarily available to the evaluator during compile-time evaluations. > I think that the standard could take a simple, minimal, approach that > would still satisfy the most common usages. Suppose we said: > > DEFCLASS ... > One way to look at this would be to > say that it is implementation-dependent whether FINALIZE-INHERITANCE > works or signals an error when given a class defined in the > compile-time environment. > > [And no compile-time generic-function or method objects at all] > > This is an interesting idea, but I think it's too restrictive. Here's a > plausible and many-times proposed application for metaobjects which > would not be possible if we adopted this idea. Suppose you made an > optimizing compiler that is allowed to assume that no class > redefinitions, no method redefinitions, and no newly-defined subclasses > will be created at run time. The compiler is to take advantage of this ... I certainly don't want to prevent any implementation from doing that. The real issue is what is the minimal functionality that all implementations must support. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 01:48:29 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA15177; Sat, 11 Mar 89 01:48:29 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 11 Mar 89 01:48:49 PST Received: by ti.com id AA04514; Fri, 10 Mar 89 11:03:22 CST Received: from Kelvin by tilde id AA17547; Fri, 10 Mar 89 10:49:22 CST Message-Id: <2814540528-3314903@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Fri, 10 Mar 89 10:48:48 CST From: David N Gray To: "David A. Moon" Cc: "Kim A. Barrett" , sandra%defun@CS.UTAH.EDU, cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Subject: Re: Issue MACRO-ENVIRONMENT-EXTENT In-Reply-To: Msg of Thu, 9 Mar 89 13:59 EST from David A. Moon > The extent of macro environment objects is related to EVAL-WHEN because macro > expanders may wish to return forms which contain environments as quoted > constants. > > I am convinced that this should be ruled out, and that CLOS made a mistake > here. (Incidentally the part of CLOS that says this is in chapter 3, the > accepted part of CLOS does not say anything about the expansion of the > macros is.) Except for ENSURE-GENERIC-FUNCTION, which is defined in chapter 2 with an :ENVIRONMENT argument, and referenced on page 2-28 as part of the semantics of DEFGENERIC. Maybe this function should have been in chapter 3 instead? Should it be removed from the standard? > Requiring environments to have indefinite extent has > problems for CLOS because at compile-time it wants to create remote metaobjects > and link them into the right places, but then flush those links when the > compilation is over. > > This depends on whether you think the environment actually contains the > table that relates names to objects, or just contains a boolean flag > that tells functions such as FIND-CLASS which of two tables to look in. > Under the latter model, nothing about the environment prevents the > COMPILE-FILE table from being reset at any time. This is one reason > why I think the second model is right. But if you reset the table, then a FIND-CLASS on that environment will no longer be meaningful, which has the same effect as being outside the valid extent of the environment. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 08:15:39 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA18563; Sat, 11 Mar 89 08:15:39 PST Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 11 Mar 89 08:17:53 PST Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA03974; Sat, 11 Mar 89 09:15:41 -0700 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA00548; Sat, 11 Mar 89 09:15:39 -0700 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8903111615.AA00548@defun.utah.edu> Date: Sat, 11 Mar 89 09:15:37 MST Subject: Re: issue CLOS-MACRO-COMPILATION, version 1 To: David N Gray Cc: sandra%defun@cs.utah.edu (Sandra J Loosemore), cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: David N Gray , Fri, 10 Mar 89 18:06:53 CST > Date: Fri, 10 Mar 89 18:06:53 CST > From: David N Gray > > > [This also seems to imply that tests for existence of the generic > > function, lambda-list congruence, etc. must not happen until > > load time.] > > No, an implementation should be permitted to check for lambda-list > congruence between methods defined in the same file; this doesn't > require any reference to the resident generic function definition. If > the file doesn't include a DEFGENERIC, then the first DEFMETHOD defines > the compile-time generic function attributes, and subsequent methods can > be checked against that. The description of DEFMETHOD in CLOS chapter 2 talks about calling FBOUNDP and signalling an error if the function is not a generic function, or if it is a generic function but the lambda list of the method is not congruent. Clearly this shouldn't happen at compile-time. I agree that the behavior you suggest makes more sense. > > > DEFINE-METHOD-COMBINATION: > > > > * The method combination can be used in a subsequent DEFGENERIC. If it > > is referenced, the body of a long form of method combination must be > > evaluable at compile-time. > > But if methods are not installed at compile time and generic functions > are not callable at compile time, then I don't think there is any > situation in which the method combination body could be executed at > compile-time. This is something I couldn't quite figure out from reading chapters 1 & 2. At what time does the method combination become "integrated" into the DEFGENERIC? Does the process of expanding the DEFGENERIC macro capture the method combination definition, in the same way that expanding a SETF macro captures the setf method? Or does this happen when you actually execute the DEFGENERIC macro? -Sandra ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 12:18:25 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA20072; Sat, 11 Mar 89 12:18:25 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 11 Mar 89 12:19:38 PST Received: by ti.com id AA10411; Sat, 11 Mar 89 14:18:09 CST Received: from Kelvin by tilde id AA14567; Sat, 11 Mar 89 14:14:39 CST Message-Id: <2814639239-9369595@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Sat, 11 Mar 89 14:13:59 CST From: David N Gray To: sandra%defun@cs.utah.edu (Sandra J Loosemore) Cc: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Subject: Re: issue CLOS-MACRO-COMPILATION, version 1 In-Reply-To: Msg of Sat, 11 Mar 89 09:15:37 MST from sandra%defun@cs.utah.edu (Sandra J Loosemore) > The description of DEFMETHOD in CLOS chapter 2 talks about calling > FBOUNDP and signalling an error if the function is not a generic > function, or if it is a generic function but the lambda list of the > method is not congruent. Clearly this shouldn't happen at > compile-time. Right, unless it is viewed as doing the FBOUNDP in the compile-time environment without inheritance from the resident environment. > > But if methods are not installed at compile time and generic functions > > are not callable at compile time, then I don't think there is any > > situation in which the method combination body could be executed at > > compile-time. > > This is something I couldn't quite figure out from reading chapters 1 > & 2. At what time does the method combination become "integrated" > into the DEFGENERIC? Does the process of expanding the DEFGENERIC > macro capture the method combination definition, in the same way that > expanding a SETF macro captures the setf method? Or does this happen > when you actually execute the DEFGENERIC macro? This is only in chapter 3, and not very clear there even. My understanding of it is that the method combination body would be invoked from COMPUTE-EFFECTIVE-METHOD, which, depending on the implementation, could be invoked as soon as a call to ADD-METHOD, or as late as a call to the generic function which actually needs that particular combination. Since it operates on a list of applicable methods, it couldn't be invoked from DEFGENERIC. The generic function object would just have a pointer to the method combination object for future use. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 14:37:51 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA20715; Sat, 11 Mar 89 14:37:51 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 11 Mar 89 14:39:22 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 555170; Sat 11-Mar-89 17:36:09 EST Date: Sat, 11 Mar 89 17:36 EST From: David A. Moon Subject: Re: remote environments To: David N Gray Cc: Danny Bobrow , Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: <2814562938-4785295@Kelvin> Message-Id: <19890311223604.9.MOON@EUPHRATES.SCRC.Symbolics.COM> Line-Fold: No Date: Fri, 10 Mar 89 17:02:18 CST From: David N Gray I don't see where DEFINE-METHOD-COMBINATION has any option for specifying the class of the method combination; doesn't it always produce an instance of the pre-defined class METHOD-COMBINATION ? 88-002R p. 1-34 says it can make a subclass of METHOD-COMBINATION. 88-002R doesn't specify the implementation of DEFINE-METHOD-COMBINATION, but it might create a new class for each method combination type. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 15:04:22 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA20920; Sat, 11 Mar 89 15:04:22 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 11 Mar 89 15:05:55 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 555182; Sat 11-Mar-89 18:03:02 EST Date: Sat, 11 Mar 89 18:02 EST From: David A. Moon Subject: Re: remote environments To: David N Gray Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: <2814562184-4740019@Kelvin> Message-Id: <19890311230257.4.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Fri, 10 Mar 89 16:49:44 CST From: David N Gray > - If so, do initforms have access to macros and constants defined > earlier in the file? > > Initforms certainly have access to those things since they are included > in the initforms' environment. I think 88-002R implies this. I intend to implement it that way since it is a reasonable thing to expect. However, I'm not aware of any language in 88-002R that requires this ("implies" isn't good enough). In fact, proposal COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS explicitly says that macro definitions are _not_ necessarily available to the evaluator during compile-time evaluations. That is what COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS says, but I think that may show that that proposal was incorrect and needs to be amended. From CL-Compiler-mailer@SAIL.STANFORD.EDU Sat Mar 11 15:04:34 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA20925; Sat, 11 Mar 89 15:04:34 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 11 Mar 89 15:02:28 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 555181; Sat 11-Mar-89 17:58:31 EST Date: Sat, 11 Mar 89 17:58 EST From: David A. Moon Subject: Re: issue CLOS-MACRO-COMPILATION, version 1 To: David N Gray Cc: Sandra J Loosemore , cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: <2814566813-5018117@Kelvin> Message-Id: <19890311225826.2.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Fri, 10 Mar 89 18:06:53 CST From: David N Gray > Proposal CLOS-MACRO-COMPILATION:MINIMAL: ... > DEFMETHOD: > > * The method is not callable at compile-time. If there is a generic > function with the same name at compile-time, compiling a DEFMETHOD > will not add the method to that generic function. > > [This also seems to imply that tests for existence of the generic > function, lambda-list congruence, etc. must not happen until > load time.] No, an implementation should be permitted to check for lambda-list congruence between methods defined in the same file; this doesn't require any reference to the resident generic function definition. If the file doesn't include a DEFGENERIC, then the first DEFMETHOD defines the compile-time generic function attributes, and subsequent methods can be checked against that. Agreed. I would phrase it differently: all the DEFGENERICs and DEFMETHODS for a given generic function name in a given compilation unit can be checked against each other for lambda-list congruence. > DEFINE-METHOD-COMBINATION: > > * The method combination can be used in a subsequent DEFGENERIC. If it > is referenced, the body of a long form of method combination must be > evaluable at compile-time. But if methods are not installed at compile time and generic functions are not callable at compile time, then I don't think there is any situation in which the method combination body could be executed at compile-time. Some implementations compose and compile effective methods at compile time, which of course requires evaluating the body of the define-method-combination at compile time. I haven't read Sandra's proposal yet. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 15:46:39 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA21288; Sat, 11 Mar 89 15:46:39 PST Received: from YUKON.SCRC.Symbolics.COM (SCRC-YUKON.ARPA) by SAIL.Stanford.EDU with TCP; 11 Mar 89 15:47:44 PST Received: from EUPHRATES.SCRC.Symbolics.COM by YUKON.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 437088; Sat 11-Mar-89 18:02:32 EST Date: Sat, 11 Mar 89 18:01 EST From: David A. Moon Subject: Re: remote environments To: David N Gray Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: <2814562184-4740019@Kelvin> Message-Id: <19890311230120.3.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Fri, 10 Mar 89 16:49:44 CST From: David N Gray > One way to look at this would be to > say that it is implementation-dependent whether FINALIZE-INHERITANCE > works or signals an error when given a class defined in the > compile-time environment. > > [And no compile-time generic-function or method objects at all] > > This is an interesting idea, but I think it's too restrictive. Here's a > plausible and many-times proposed application for metaobjects which > would not be possible if we adopted this idea. Suppose you made an > optimizing compiler that is allowed to assume that no class > redefinitions, no method redefinitions, and no newly-defined subclasses > will be created at run time. The compiler is to take advantage of this ... I certainly don't want to prevent any implementation from doing that. Note that I didn't say an implementation was doing that. Such a compiler might be a portable program, that's how some people have proposed writing it. The real issue is what is the minimal functionality that all implementations must support. Agreed. Obviously if the minimal functionality does not make it possible to write such a program portably, then it won't be portable, but it might still exist in some implementations. Still I think I came up with a plausible example of how the existence of metaobjects at compile time could be useful to some portable programs. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 16:56:23 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA21748; Sat, 11 Mar 89 16:56:23 PST Received: from lucid.com by SAIL.Stanford.EDU with TCP; 11 Mar 89 16:58:32 PST Received: from challenger ([192.9.200.17]) by heavens-gate.lucid.com id AA01066g; Sat, 11 Mar 89 16:51:27 PST Received: by challenger id AA05936g; Sat, 11 Mar 89 16:46:51 PST Date: Sat, 11 Mar 89 16:46:51 PST From: Richard P. Gabriel Message-Id: <8903120046.AA05936@challenger> To: CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: Issue: LOAD-OBJECTS (Version 3) I was a little surprised to see that this proposal talks about load forms instead of load functions (which goes to show how much I've been paying attention). After some thought and consultation with Moon, I realized that part of it was that compiled functions could not be compiled constants. If we were to allow such constants, I would propose we consider the alternative of load functions. The model would be that when objects are being either prepared for dumping or are being dumped, at certain points the generic function MAKE-LOAD-FUNCTION would be invoked on objects that needed to be re-created later. It would return either one or two functions. The first is a function of 0 arguments that does the initial creation, and the second is (if present) a function of 1 argument, which is the initializer. If present it is applied to the created instance. This simplifies the naming problem in the current proposal, which, while clever, is a little unpalatable. In particular, it introduces yet another way to think about variables. I think people will find the macro approach (the current approach) baroque, partly because the approach is best understood by thinking of an input phase to a compiler or some such program, rather than by thinking about an output phase when everything has already been supposedly created. For example, when I read the current proposal, I imagined it in the FASDUMP phase. One drawback of my proposal is that the function approach is a little more verbose in some cases. I also think it is subject to more circularity errors by novices than the macro approach. On the other hand, the functional approach makes one think about the issues a little harder when writing the code, which is possibly a good thing. Here are the examples in the macro proposal: ;; Example 1 (defclass my-class () ((a :initarg :a :reader my-a) (b :initarg :b :reader my-b) (c :accessor my-c))) (defmethod shared-initialize ((self my-class) ignore &rest ignore) (unless (slot-boundp self 'c) (setf (my-c self) (some-computation (my-a self) (my-b self))))) (defmethod make-load-function ((self my-class)) (let ((name (class-name (class-of self))) (a (my-a self)) (b (my-b self))) #'(lambda () (make-instance name :a a :b b)))) Here the computations of NAME, A, and B must be outside the function #'(lambda ...) so that they get evaluated in the right environment to avoid a circular (self-referential) structure. For this to work, the faslout of #'(lambda ...) must also notice any constants or such things that need similar treatment, which will get NAME, A, and B, if needed. ;; Example 2 (defclass my-frob () ((name :initarg :name :reader my-name))) (defmethod make-load-function ((self my-frob)) (let ((name (my-name self))) #'(lambda () (find-my-frob name :if-does-not-exist :create)))) Maybe NAME is not something to worry about, but SELF cannot appear in the #'(lambda ...). ;; Example 3 (expanded to do a hairy thing that cannot be easily done ;; in the macro approach). (defclass tree-with-parent () ((parent :accessor tree-parent) (curious-facts :accessor tree-foma) (children :initarg :children))) (defmethod make-load-function ((x tree-with-parent)) (let ((class (class-of x)) (children (slot-value x 'children)) (random-info-at-dump-time (compute-random-info x)) (more-random-info-at-creation-time ()) (parent (slot-value x 'parent))) (flet ((initialize (x) (setf (tree-foma x) (combine-info random-info-at-dump-time random-info-at-creation-time)) (setf (tree-parent x) parent))) (values ;; creation #`(lambda () (setq more-random-info-at-creation-time (compute-more-random-info)) (make-instance class :children children)) ;; initialization #'initialize)))) One can imagine the shared lexical environment of the creator and initializer being a high-bandwidth channel for information, such as the important information passed in the above example. Finally, I wouldn't use the name MAKE-LOAD-FUNCTION-USING-SLOTS, because the structure of the name ...-USING-SLOTS is like ...-USING-CLASS, which is named that way to inform the programmer that he can discriminate on the metaclass. Maybe, MAKE-LOAD-FUNCTION-PRESERVING-SLOTS? -rpg- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sat Mar 11 17:43:04 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA22101; Sat, 11 Mar 89 17:43:04 PST Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 11 Mar 89 17:45:12 PST Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA13023; Sat, 11 Mar 89 18:43:00 -0700 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA00878; Sat, 11 Mar 89 18:42:57 -0700 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8903120142.AA00878@defun.utah.edu> Date: Sat, 11 Mar 89 18:42:56 MST Subject: Re: Issue: LOAD-OBJECTS (Version 3) To: Richard P. Gabriel Cc: CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: Richard P. Gabriel , Sat, 11 Mar 89 16:46:51 PST I haven't been paying too much attention to this issue either -- I've been trusting Moon to do the right thing on the assumption that he knew more about it than I did. I think his latest proposal does look reasonable. However, if there is disagreement about it, I might as well suggest yet another alternative: Have two generic functions, not one. The first would get called by compile-file and it would return a list of components (or whatever) that are required to reconstruct the object. The compiler would dump this list of objects in its usual way. The loader would apply the second generic function to this list to reconstruct the object. It avoids the nasty syntax you object to, doesn't require functions to be dumpable, doesn't require any special support for circular constants, and ought to be real easy to add to the compiler/loader. (You could essentially convert the constant into a LOAD-TIME-VALUE expression.) -Sandra ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sun Mar 12 10:30:22 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA02867; Sun, 12 Mar 89 10:30:22 PST Received: from lucid.com by SAIL.Stanford.EDU with TCP; 12 Mar 89 10:32:40 PST Received: from challenger ([192.9.200.17]) by heavens-gate.lucid.com id AA01322g; Sun, 12 Mar 89 10:25:36 PST Received: by challenger id AA06637g; Sun, 12 Mar 89 10:20:59 PST Date: Sun, 12 Mar 89 10:20:59 PST From: Richard P. Gabriel Message-Id: <8903121820.AA06637@challenger> To: sandra%defun@cs.utah.edu Cc: CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: Sandra J Loosemore's message of Sat, 11 Mar 89 18:42:56 MST <8903120142.AA00878@defun.utah.edu> Subject: Issue: LOAD-OBJECTS (Version 3) Sandra's idea of two generic functions, one producing components and the other doing construction/further initialization has some merits aside from the question of dumping functions. I think we should consider it. -rpg- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sun Mar 12 20:12:00 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA06467; Sun, 12 Mar 89 20:12:00 PST Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 12 Mar 89 20:13:58 PST Received: from Semillon.ms by ArpaGateway.ms ; 12 MAR 89 20:00:24 PST Date: Sun, 12 Mar 89 20:00 PST From: Gregor.pa@Xerox.COM Subject: Re: remote environments To: David A. Moon , Sandra J Loosemore , David N Gray , Patrick Dussud Cc: Kim A. Barrett , cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <19890307023706.3.MOON@EUPHRATES.SCRC.Symbolics.COM>, <19890309185905.3.MOON@EUPHRATES.SCRC.Symbolics.COM>, <8903100017.AA10108@defun.utah.edu>, <2814540528-3314903@Kelvin>, <19890310174955.3.MOON@EUPHRATES.SCRC.Symbolics.COM>, <8903101804.AA10718@defun.utah.edu>, <8903101807.AA03577@challenger>, <19890310194038.9.MOON@EUPHRATES.SCRC.Symbolics.COM>, <8903101949.AA10788@defun.utah.edu>, <8903102056.AA10809@defun.utah.edu>, <8903102240.AA03941@challenger>, <2814562184-4740019@Kelvin>, <8903111615.AA00548@defun.utah.edu>, <2814639239-9369595@Kelvin>, <19890311223604.9.MOON@EUPHRATES.SCRC.Symbolics.COM>, <19890311225826.2.MOON@EUPHRATES.SCRC.Symbolics.COM>, <19890311230120.3.MOON@EUPHRATES.SCRC.Symbolics.COM>, <19890311230257.4.MOON@EUPHRATES.SCRC.Symbolics.COM>, <19890311232009.6.MOON@EUPHRATES.SCRC.Symbolics.COM>, <19890311232035.7.MOON@EUPHRATES.SCRC.Symbolics.COM>, <8903120019.AA00810@defun.utah.edu> Message-Id: <19890313040005.0.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no In this message I question, once again, the existence of remote metaobjects. I may be behind the times here, but since no one answered the long message I sent about why we could do without remote metaobjects I am still stuck at that point. Date: Thu, 23 Feb 89 18:38:01 CST From: David N Gray * Can a MAKE-INSTANCE be done by a macro expander, DEFCONSTANT, or "#."? Date: Mon, 6 Mar 89 21:37 EST From: David A. Moon I think it would be much nicer if we could make compile-time classes instantiable. However, I agree that it would not ruin the language to omit that feature if we can't figure out how to do it. Date: Fri, 10 Mar 89 16:49:44 CST From: David N Gray > One way to look at this would be to > say that it is implementation-dependent whether FINALIZE-INHERITANCE > works or signals an error when given a class defined in the > compile-time environment. I don't understand these comments. It seems to me that the only real questions are "is there a remote class object?" and "if so, how are remote functions represented?". If there is a remote class object then we must solve what I previously previously called the `splicing' problem. That remote class object must have pointers to other class objects which represent its superclasses. If that is the case, then to some extent that remote class will be instantiable. Any class that has direct supers can be finalized provided that none of the supers are forward referenced. Since it can be finalized, allocate-instance can be called. So, the only real question is whether the initfunctions can be called. From the user's point of view, that translates into whether make-instance can be called. Date: Mon, 6 Mar 89 21:37 EST From: David A. Moon When you compile-file a DEFMETHOD, a method metaobject is created but it is not added to the generic-function metaobject in the local environment. Instead it is added to a different generic-function metaobject created in the remote environment. That's my model of what has to happen. Note that this should be completely consistent with the way that compile-file of a DEFCLASS, with a direct superclass whose name is defined in the local environment and not in the remote environment, does not add the new class metaobject to the direct subclasses of the local superclass, but rather to a different object. (I realize we haven't agreed on what this paragraph says, or even seen a coherent proposal, yet. I'm just telling you my model.) Yes, this is the `splicing' problem which must be solved to have remote metaobjects. In the past there has been some controversy about whether the remote environment can inherit from the local environment. I think this is crystal clear: since some user-defined classes have STANDARD-OBJECT as a direct superclass, and STANDARD-OBJECT is not defined in the same file, the remote environment is clearly inheriting from the local environment. Different implementations might want to address the details of this differently, but I think it's clear that there has to be provision for it in the metaobject model. It makes things more complicated, but that's unavoidable. More splicing problems. Date: Fri, 10 Mar 89 16:49:44 CST From: David N Gray > This is an interesting idea, but I think it's too restrictive. Here's a > plausible and many-times proposed application for metaobjects which > would not be possible if we adopted this idea. Suppose you made an > optimizing compiler that is allowed to assume that no class > redefinitions, no method redefinitions, and no newly-defined subclasses > will be created at run time. The compiler is to take advantage of this I certainly don't want to prevent any implementation from doing that. The real issue is what is the minimal functionality that all implementations must support. As Moon says in a later message, the issue here is not what the implementation can do, its what portable programs can do. It needs to be the case that one can write a portable, metaobject `compiler'. Many people have wanted to do this. People currently do this with PCL which surely has no remote metaobjects. But, do we need remote metaobjects to do this? I have argued before that we don't. I believe it would be a reasonable restriction on such portable programs that the program they are `compiling' be loaded before it can be compiled. No one has shown me why that isn't the case. But, what I know wonder is whether it would be a reasonable restriction on implementors. Because, with this metaobject stuff, we can specify minimal behavior, but we can't specify minimally. If we specify that there are no remote metaobjects, then implementations are going to have to prevent themselves from ever instantiating remote versions of portable metaobjects. Moreover they will have to be certain that user's can't get their hands on remote metaobjects. This will make life more complicated for implementations, I don't know how much more complicated. On the other hand, solving the splicing problem will also be complicated for implementations, and for the specification as well. ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 13 06:51:18 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA11193; Mon, 13 Mar 89 06:51:18 PST Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 13 Mar 89 06:53:16 PST Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA15174; Mon, 13 Mar 89 07:44:33 -0700 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA02017; Mon, 13 Mar 89 07:44:17 -0700 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8903131444.AA02017@defun.utah.edu> Date: Mon, 13 Mar 89 07:44:15 MST Subject: Re: remote environments To: Gregor.pa@Xerox.COM Cc: David A. Moon , Sandra.J.Loosemore%defun@cs.utah.edu, , David N Gray , Patrick%defun@cs.utah.edu, Dussud , Kim A. Barrett , cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: Gregor.pa@Xerox.COM, Sun, 12 Mar 89 20:00 PST > Date: Sun, 12 Mar 89 20:00 PST > From: Gregor.pa@Xerox.COM > > If there is a remote class object then we must solve what I previously > previously called the `splicing' problem. That remote class object must > have pointers to other class objects which represent its superclasses. > If that is the case, then to some extent that remote class will be > instantiable. Any class that has direct supers can be finalized > provided that none of the supers are forward referenced. Since it can > be finalized, allocate-instance can be called. So, the only real > question is whether the initfunctions can be called. From the user's > point of view, that translates into whether make-instance can be called. At least three of us (Moon, Gray, and myself) appear to agree that DEFMETHOD should not make the method function callable at compile time (by analogy to DEFUN). If you're using the term "initfunctions" to refer to things like the SHARED-INITIALIZE method, then no, they can't be called at compile-time by default. Of course, if you really those methods to be callable at compile time, you can always wrap an explicit (EVAL-WHEN (EVAL COMPILE LOAD) ...) around both the class and method definitions. Alternatively, you'd probably put the definitions in another file and load it before compiling the file that wants to instantiate that class at compile time. Personally, I think we could leave the issue of whether remote classes exist or are instantiable unspecified for now. It would give those of you who are trying to sort out the meta-object protocol more freedom, and I don't think it would place an unreasonable burden on programmers. > But, do we need remote metaobjects to do this? I have argued before > that we don't. I believe it would be a reasonable restriction on > such portable programs that the program they are `compiling' be loaded > before it can be compiled. No one has shown me why that isn't the case. I guess this is pretty much the same thing as I was saying above. The one reservation I have (that others have also expressed) is that the common practice of a file containing a class definition followed by method definitions on that class should compile properly without having to do any magic with pre-loading the file or wrapping EVAL-WHENs around everything. Would that cause problems for the meta-object protocol? -Sandra ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 13 10:37:12 1989 Received: from [36.86.0.194] by arisia with SMTP (5.59++/IDA-1.2.6) id AA13568; Mon, 13 Mar 89 10:37:12 PST Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 13 Mar 89 10:34:52 PST Received: from Semillon.ms by ArpaGateway.ms ; 13 MAR 89 10:25:22 PST Date: Mon, 13 Mar 89 10:22 PST From: Gregor.pa@Xerox.COM Subject: Re: remote environments To: Sandra J Loosemore Cc: David A. Moon , Sandra.J.Loosemore%defun@cs.utah.edu, David N Gray , Patrick%defun@cs.utah.edu, Dussud , Kim A. Barrett , cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <8903131444.AA02017@defun.utah.edu> Message-Id: <19890313182248.2.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Mon, 13 Mar 89 07:44:15 MST From: sandra%defun@cs.utah.edu (Sandra J Loosemore) At least three of us (Moon, Gray, and myself) appear to agree that DEFMETHOD should not make the method function callable at compile time (by analogy to DEFUN). If you're using the term "initfunctions" to refer to things like the SHARED-INITIALIZE method, then no, they can't be called at compile-time by default. Yes, I understood that. I didn't mean to suggest that it was an open question, just that it was a basic question. Answering it as we have has some implications that I don't fully understand yet. More on that in a second. Personally, I think we could leave the issue of whether remote classes exist or are instantiable unspecified for now. It would give those of you who are trying to sort out the meta-object protocol more freedom, and I don't think it would place an unreasonable burden on programmers. This misses the major point from my message (looking back at my message, the point is obscured). The funny thing about specifying `meta-level' behavior is that while we can specify minimal behavior, we can't specify minimally. In short, I think we have to take a stand on whether there are remote metaobjects or not. We must decide so that users who define their own metaobject classes can know under what conditions those classes will be instantiated. If a user defined metaobject class is instantiated in the remote environment some things will be `different'. At the very least it will have these funny remote functions. User code needs to know that it must deal with this. I believe it is possible to take a minimal stance on what we specify. One such workable minimal stance is to say that no portable metaobject class will ever be instantiated in the remote environment. In this scheme, the implementation could instantiate its own metaobjects in the remote environment, and it could instantiate placeholders for user metaobjects as well. This would make it possible to do the kind of file compilation we all know and love when doing normal programming. Only portable `compilers' would have to use the load, then compile approach. ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 13 10:41:02 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA13619; Mon, 13 Mar 89 10:41:02 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 13 Mar 89 10:38:41 PST Received: by ti.com id AA16905; Mon, 13 Mar 89 12:36:37 CST Received: from Kelvin by tilde id AA26674; Mon, 13 Mar 89 12:18:59 CST Message-Id: <2814805078-2868476@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Mon, 13 Mar 89 12:17:58 CST From: David N Gray To: "David A. Moon" Cc: David N Gray , Danny Bobrow , Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: Re: remote environments In-Reply-To: Msg of Sat, 11 Mar 89 17:36 EST from David A. Moon > I don't see where DEFINE-METHOD-COMBINATION has any option for > specifying the class of the method combination; doesn't it always > produce an instance of the pre-defined class METHOD-COMBINATION ? > > 88-002R p. 1-34 says it can make a subclass of METHOD-COMBINATION. > 88-002R doesn't specify the implementation of DEFINE-METHOD-COMBINATION, > but it might create a new class for each method combination type. OK, but that's still a class created by the implementation; it isn't instantiating a class that the user could have defined with a DEFCLASS earlier in the file. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 13 10:51:40 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA13792; Mon, 13 Mar 89 10:51:40 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 13 Mar 89 10:53:53 PST Received: by ti.com id AA17001; Mon, 13 Mar 89 12:49:36 CST Received: from Kelvin by tilde id AA27491; Mon, 13 Mar 89 12:41:40 CST Message-Id: <2814806442-2950447@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Mon, 13 Mar 89 12:40:42 CST From: David N Gray To: Gregor.pa@Xerox.COM Cc: "David A. Moon" , Sandra J Loosemore , Patrick Dussud , "Kim A. Barrett" , cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Subject: Re: remote environments In-Reply-To: Msg of Sun, 12 Mar 89 20:00 PST from Gregor.pa@Xerox.COM > In this message I question, once again, the existence of remote > metaobjects. I may be behind the times here, but since no one answered > the long message I sent about why we could do without remote metaobjects > I am still stuck at that point. ... > I don't understand these comments. It seems to me that the only real > questions are "is there a remote class object?" and "if so, how are > remote functions represented?". I don't see that we need to have separate classes for representing things in the remote environment. The problem with closures is very easily dealt with by performing compile-time remote-environment definitions only for top-level forms. So I would say that yes there are class objects in the remote environment and they look just like any other class objects. Generic functions and methods are another matter though; permitting compile-time instantiation of classes in the remote environment should not be difficult, but it may not be very useful without having the methods for that class available. > > This is an interesting idea, but I think it's too restrictive. Here's a > > plausible and many-times proposed application for metaobjects which > > would not be possible if we adopted this idea. Suppose you made an > > optimizing compiler that is allowed to assume that no class > > redefinitions, no method redefinitions, and no newly-defined subclasses > > will be created at run time. The compiler is to take advantage of this > > I certainly don't want to prevent any implementation from doing that. > The real issue is what is the minimal functionality that all > implementations must support. > > As Moon says in a later message, the issue here is not what the > implementation can do, its what portable programs can do. It needs to > be the case that one can write a portable, metaobject `compiler'. Many > people have wanted to do this. People currently do this with PCL which > surely has no remote metaobjects. It sounds like there are two issues here: (1) what a standard-conforming Common Lisp compiler is required to do, and (2) what a portable program is able to do with the meta-object protocol features provided. I was only addressing (1), but it sounds like you and Moon have (2) in mind. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 13 11:49:39 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA15294; Mon, 13 Mar 89 11:49:39 PST Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 13 Mar 89 11:51:37 PST Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA26986; Mon, 13 Mar 89 12:43:02 -0700 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA02353; Mon, 13 Mar 89 12:42:59 -0700 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8903131942.AA02353@defun.utah.edu> Date: Mon, 13 Mar 89 12:42:58 MST Subject: Re: remote environments To: Gregor.pa@Xerox.COM Cc: Sandra J Loosemore , David A. Moon , David N Gray , Patrick Dussud , Kim A. Barrett , cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: Gregor.pa@Xerox.COM, Mon, 13 Mar 89 10:22 PST > Date: Mon, 13 Mar 89 10:22 PST > From: Gregor.pa@Xerox.COM > > We must decide so that users who define their own metaobject classes can > know under what conditions those classes will be instantiated. Perhaps my ignorance is showing, but I didn't think that chapters 1 & 2 gave users enough information to define their own metaobject classes anyway. If making this statement is only of interest for users of the part of CLOS that is specified in chapter 3, I don't think we absolutely positively need to say anything about this now. Frankly, I question whether the metaobject protocol is stable enough that we should even *try* to do so now. > I believe it is possible to take a minimal stance on what we specify. > One such workable minimal stance is to say that no portable metaobject > class will ever be instantiated in the remote environment. In this > scheme, the implementation could instantiate its own metaobjects in the > remote environment, and it could instantiate placeholders for user > metaobjects as well. This would make it possible to do the kind of file > compilation we all know and love when doing normal programming. Only > portable `compilers' would have to use the load, then compile approach. I guess part of the problem I'm having is understanding what this implies for normal user code. I think we ought to say something in the standard that your average ignoramus like me can understand, about how to arrange programs so they will compile correctly. The current writeup does that, your statement here doesn't. Is there anything in the MINIMAL proposal that is fundamentally incompatible with this stance? I can see that wanting classes to be instantiable at compile-time (as in proposal NOT-SO-MINIMAL) would imply that the DEFCLASS macro causes some kind of metaobject to be created at compile time. However, it would still be possible to do without distinguished "remote" metaobjects by having DEFCLASS make the class fully defined in the compile-time environment. -Sandra ------- From CL-Cleanup-mailer@SAIL.STANFORD.EDU Mon Mar 13 14:11:08 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA18413; Mon, 13 Mar 89 14:11:08 PST Received: from Sun.COM by SAIL.Stanford.EDU with TCP; 13 Mar 89 13:51:55 PST Received: from snail.Sun.COM by Sun.COM (4.1/SMI-4.0) id AA16534; Mon, 13 Mar 89 11:37:16 PST Received: from lukasiewicz.sun.com by snail.Sun.COM (4.1/SMI-4.0) id AA20771; Mon, 13 Mar 89 11:32:38 PST Received: by lukasiewicz.sun.com (4.0/SMI-4.0) id AA00318; Mon, 13 Mar 89 11:35:38 PST Date: Mon, 13 Mar 89 11:35:38 PST From: jrose@Sun.COM (John Rose) Message-Id: <8903131935.AA00318@lukasiewicz.sun.com> To: sandra%defun@cs.utah.edu Cc: rpg@lucid.com, CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: Sandra J Loosemore's message of Sat, 11 Mar 89 18:42:56 MST <8903120142.AA00878@defun.utah.edu> Subject: Issue: LOAD-OBJECTS (Version 3) From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Date: Sat, 11 Mar 89 18:42:56 MST ... Have two generic functions, not one. The first would get called by compile-file and it would return a list of components (or whatever) that are required to reconstruct the object. The compiler would dump this list of objects in its usual way. The loader would apply the second generic function to this list to reconstruct the object. It avoids the nasty syntax you object to, doesn't require functions to be dumpable, doesn't require any special support for circular constants, and ought to be real easy to add to the compiler/loader. (You could essentially convert the constant into a LOAD-TIME-VALUE expression.) Two objections here: One is that this scheme cannot support circular constants. Since LOAD-OBJECTS is not the issue which determines circular constants, it probably should not force or presuppose a decision against circular constants. Supporting circular constants requires two phases of object construction, one which creates at least a valid reference to the object, and a second one which further initializes the object (at least by patching in back-references to finish building circularities). In order for your technique to support circular constants, you still need #'make-load-form to return two things, not one. It would return two argument lists, and there would be two load-time generic functions. The other objection is that an arglist for a fixed generic function is less general and more complex than an EVAL-able form (or a thunk, as rpg suggests). The programmer must coordinate the construction of the argument list with the definition of the method to digest it at load time, which is probably on a different page of the source code. What's the advantage to offset the complexity and lack of flexibility? Perhaps method combination within the load-time generic gives a clean way to modularize the construction of an object of multiple classes? Someone will have to show me an example of this before I believe it. Until then, I think the simplicity of thunks (either EVAL-able or FUNCALL-able) is far preferable. By the way, I also share rpg's preference for functions over forms, because functions are parametrized naturally via captured lexicals, whereas you've got to use backquote to parametrize forms, a more error-prone technique. Here's an example which suggests the relative conciseness of the techniques: ;; Using functions: (defmethod make-load-form ((x myclass)) (let ((p ) (q ) (r )) #'(lambda () ))) ;; Using forms: (defmethod make-load-form ((x myclass)) `(let ((p ',) (q ',) (r ',)) )) ;; Using a generic: (defmethod make-load-form ((x myclass)) `(cookie00012 :p , :q , :r ,)) (defmethod load-time-constructor ((lf (eql 'cookie00012)) &key p q r &allow-other-keys) ) -Sandra ------- -- John From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Wed Mar 15 12:09:31 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA27461; Wed, 15 Mar 89 12:09:31 PST Received: from sumex-aim.stanford.edu by SAIL.Stanford.EDU with TCP; 15 Mar 89 12:03:54 PST Received: by sumex-aim.stanford.edu (4.0/inc-1.0) id AA14537; Wed, 15 Mar 89 12:02:48 PST Date: Wed, 15 Mar 1989 12:02:44 PST From: James Rice To: Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: Understanding Method Combination. Message-Id: As far as I know the MOP doesn't provide a way for a tool to find out about combined methods in a way in which the user/environment tools might be interested. Method call sequence/behaviour is very important to being able to understand what's happening in a program. What I'd like to propose is the following MOP function (I don't care what its name is, the functionality is what counts): Combined-Method-Pseudo-Code (GF &rest specializers) [Function] This function is passed a generic function and a collection of classes that denote the classes of the arguments that are to be passed to the generic function. It returns the lisp code for the combined method's body but with the actual code that invokes the actual methods replaced by the method objects themselves. Thus in the following example: (defclass container () ()) (defclass bottle (container) ()) (defclass sauce () ()) (defclass ketchup (sauce) ()) (defmethod fill ((me container) with) ...) ;;; vanilla primary method. (defmethod fill ((me bottle) (with sauce)) ...) ;;; New primary method. (defmethod fill :after ((me container) t) ...) ;;; Make sure we don't overflow. (defmethod fill :before ((me container) t) ...) ;;; Make sure lid's open. (defmethod fill :after ((me bottle) (with ketchup) ...) ;;; 57 varieties. (defmethod fill :before ((me bottle) (with sauce)) ...) ;;; Make sure we're upright. ... (Combined-Method-Pseudo-Code #'fill (find-class 'bottle) (find-class 'ketchup)) -> (progn # # (multiple-value-prog1 # # #)) I've implemented this sort of functionality once already and it works just fine, but it's horrible stuff. This is the sort of thing that an implementor could do easily and a user currently cannot do in any system independent way. It clearly doesn't matter that the code body for the combined method could contain system dependent forms, since all we want to be able to do is understand what's going on. Does this sound reasonable? Rice. From Owners-CommonLoops.pa@Xerox.COM Thu Mar 16 12:55:55 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA21524; Thu, 16 Mar 89 12:55:55 PST Received: from Salvador.ms by ArpaGateway.ms ; 14 MAR 89 12:19:11 PST Return-Path: Redistributed: CommonLoops.pa Received: from rand.org ([10.3.0.7]) by Xerox.COM ; 14 MAR 89 12:16:13 PST Received: from blackcomb.rand.org by rand.org; Tue, 14 Mar 89 09:56:36 PST Received: from localhost by blackcomb.arpa; Tue, 14 Mar 89 09:55:30 PST Message-Id: <8903141755.AA08560@blackcomb.arpa> To: CommonLoops.pa@Xerox.COM Cc: Darrell_Shane Subject: Getting (eql ) parameters to work Date: Tue, 14 Mar 89 09:55:28 PST From: Darrell Would someone straighten me out on the use of 's of the form (eql )? Consider the following: (deftype symbol-string () '(or symbol string)) (deftype non-nil-symbol-string () '(satisfies one-of-them)) (defun one-of-them (x) (if (and (typep x 'symbol-string) (not (null x))) t nil)) (defmethod meth ((arg (eql 'non-nil-symbol-string))) (format t "~A is a non-nil symbol or string.~%" arg)) (meth 'asymbol) ==> Error: No matching method for the generic-function #, when called with arguments (ASYMBOL). Reading the clos spec., I realize that the above usage of the eql parameter specializer is incorrect, but its usage seems very limited if the parameter, arg, must be eql to the value of the parameter specializer form. Is it legal to have a specializer that is a type, and if so, how? Are eql parameter-specializer-name's implemented in the 12/7/88 version of pcl? If they are, how would I declare a method that would agree on a parameter that is of type non-nil-symbol-string? Thanks, Darrell Shane RAND Corp. P.S. I am using Franz Allegro CL 3.0.1. From Owners-CommonLoops.pa@Xerox.COM Thu Mar 16 13:06:42 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA21663; Thu, 16 Mar 89 13:06:42 PST Received: from Chardonnay.ms by ArpaGateway.ms ; 13 MAR 89 09:50:27 PST Return-Path: Redistributed: CommonLoops.pa Received: from wucs1.wustl.edu ([128.252.123.12]) by Xerox.COM ; 13 MAR 89 09:47:06 PST Return-Path: Received: by wucs1.wustl.edu (5.59/1.34); id AA08389; Mon, 13 Mar 89 11:47:59 CST Date: Mon, 13 Mar 89 11:47:59 CST From: grs@wucs1.wustl.edu (Guillermo Ricardo Simari) Message-Id: <8903131747.AA08389@wucs1.wustl.edu> To: CommonLoops.pa@Xerox.COM Subject: Bayesian Reasoning Tool (BaRT) I don't know if it is appropriate to post this here but ... I am looking for the Bayesian Reasoning Tool (BaRT). Is a Common Lisp package developed at the Naval Research Lab and I have the BaRT Manual (Preliminary Version 1.0) by N. Hota, C.Loggia Ramsey and L.B.Booker. They give a machine to access the code but I cannot connect to it. Does anybody know where I can get the sources? Thank you very much in advance, Guillermo R. Simari Washington University (grs@wucs1.wustl.edu) Department of Computer Science St. Louis, MO, 63130-4899, U.S.A. From Owners-CommonLoops.pa@Xerox.COM Thu Mar 16 13:13:58 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA21956; Thu, 16 Mar 89 13:13:58 PST Received: from Cabernet.ms by ArpaGateway.ms ; 15 MAR 89 16:21:25 PST Return-Path: Redistributed: CommonLoops.pa Received: from rand.org ([10.3.0.7]) by Xerox.COM ; 15 MAR 89 16:16:14 PST Received: from blackcomb.rand.org by rand.org; Wed, 15 Mar 89 14:01:19 PST Received: from localhost by blackcomb.arpa; Wed, 15 Mar 89 14:00:15 PST Message-Id: <8903152200.AA09082@blackcomb.arpa> To: CommonLoops.pa@Xerox.COM Cc: Gregor.pa@Xerox.COM, Darrell_Shane Subject: Is it possible to use deftyped types as parameter-specializers? Date: Wed, 15 Mar 89 14:00:13 PST From: Darrell Consider the following: (deftype symbol-or-string () '(or symbol string)) (deftype non-nil-symbol-or-string () '(satisfies non-nil-symbol-or-string)) (defun non-nil-symbol-or-string (x) (if (and (typep x 'symbol-or-string) (not (null x))) t nil)) Suppose I wanted a method to be applicable only when its argument is of type non-nil-symbol-or-string. If non-nil-symbol-or-string were a class then the method I want would look like: (defmethod meth ((arg non-nil-symbol-or-string)) (format t "~A is a non-nil symbol or a string.~%" arg)) Is this possible in clos? If so, is it implemented in pcl? If not, then why; must not implementations of clos coerce predefined cl types into classes (such as symbol and string)? Why not allow another parameter-specializer-name like: (type form) where the value of form is a known common lisp type? Thanks, Darrell Shane RAND Corp. From Kiuchi.pa@Xerox.COM Thu Mar 16 13:26:21 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA20790; Thu, 16 Mar 89 12:42:59 PST Received: from Semillon.ms by ArpaGateway.ms ; 14 MAR 89 11:37:15 PST Date: 14 Mar 89 11:32 PST From: Kiuchi.pa@Xerox.COM Subject: pcl.tar.Z on arisia.xerox.com To: CommonLoops.pa@Xerox.COM Cc: Kiuchi.pa@Xerox.COM Message-Id: <890314-113715-143@Xerox> I've moved compressed tar file on arisia.xerox.com from /pcl/pcl.tar.Z to /pub/pcl.tar.Z. I also updated the get-pcl.text about this information. Thanks. Yasuhiko (Kiuchi.pa@Xerox.com) ----- From Owners-CommonLoops.pa@Xerox.COM Thu Mar 16 13:49:18 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA22975; Thu, 16 Mar 89 13:49:18 PST Received: from Salvador.ms by ArpaGateway.ms ; 13 MAR 89 16:54:32 PST Return-Path: Redistributed: CommonLoops.pa Received: from voodoo.ucsb.edu ([128.111.8.80]) by Xerox.COM ; 13 MAR 89 16:50:28 PST Received: from pcs0 by voodoo.ucsb.edu with DECNET ; Mon, 13 Mar 89 16:36:10 PST Date: Mon, 13 Mar 89 16:35:47 PST From: silber%pcs0@voodoo.ucsb.edu (Eric Silber) Message-Id: <890313163435.260000e3@pcs0> Subject: Re: Undeliverable Mail To: CommonLoops.pa@Xerox.COM RE: PCL BUILD: Hi, i recently ftp'd pcl to a vax/vms, i had trouble building it, following are some symptoms etc: Re: PCL build on a vaxstation: I am rather new to CL, let alone CLOS, so i hope you will bear with me on this question re: PCL build: Procedure followed was: 0) lisp is installed in sys$common:[vaxlisp], pcl is in sys$common:[vaxlisp.pcl] 1) i simply added the vax path in the null string "" provided in the example (defvar *pcl-directories* ... [without deleting any of the other examples] 2)rename *.lisp *.lsp 3) invoke lisp, (load 'defsys)(pcl::compile-pcl) ....it takes quite a while...and seemed to be going ok (only some recurrent warns about unset time-zone and reports of compilations with warns but, no errors)... i became complacent about watching the build, because all of a sudden, i noticed that expand_dcode_cache failed to compile... CAN PCL RUN WITHOUT THIS FUNCTION? : portion of compilation console output: ... Finished compilation of file SYS$COMMON:[VAXLISP.PCL]DCODE.LSP;1 1 Errors, 1 Warnings Errors were detected in the following functions: #:EXPAND-DCODE-CACHE-I14169 The following are assumed to be functions, but were not declared or defined: ALL-STD-CLASS-READERS-MISS-1 Loading binary of DCODE... Compiling DCODE-PRE1... ... [i left pcl compiling, when i returned i found:] ; Finished garbage collection due to dynamic-0 space overflow. ; Starting garbage collection due to dynamic-1 space overflow. %LISP-F-IEGCVMFAIL, Internal error: new dynamic space too small during garbage c ollection. %TRACE-F-TRACEBACK, symbolic stack dump follows module name routine name line rel PC abs PC GC LISP$GETGCSPACE 4053 0000003E 0040E46F MAIN LISP$MAIN 1371 000000A3 004054A3 [Any suggestions? } (i haven't been able to study the TeX docs yet, because the TeX on this machine is complaining about things that reuire it to be rebuilt with greater allocation of certain resources) defsys.lsp says Once PCL has been compiled it can be loaded with (pcl::load-pcl). and then talks about "worlds" (i didnt see this word in the steele index) do i have a "world" description file in sys$common:[vaxlisp.pcl] as a side effect of the build? is there a test prog i can use after building the system? thanks for pointers you can give -e.k.s. +------------------------------------------------------------------+ | Prostkarte | | | |Luftaufnahme | {8-) | | |Strand, OberAmiGau |______| | | _ __ _ | | _/_\__/__\__/_\_ La Cour de Cassation, | | | | | | Nimes | | """"""""_- _- _- -_ -_ -"""""""" | | | | Eric Silber AT&T: (805)-961-8366 | | Physics Computer Services Internet: silber@sbphy.ucsb.edu | | 5223 Broida Hall Bitnet: silber@sbitp | | U.C.S.B. HEPnet: sbphy::silber | | | | WeltProstverein | | Schweizer Obstverbrand | | Oesterreichischer Ethylenglykolverschnitt | +------------------------------------------------------------------+ From Owners-CommonLoops.pa@Xerox.COM Fri Mar 17 05:08:34 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA06211; Fri, 17 Mar 89 05:08:34 PST Received: from Cabernet.ms by ArpaGateway.ms ; 17 MAR 89 04:18:29 PST Return-Path: Redistributed: CommonLoops.pa Received: from gateway.mitre.org ([128.29.31.10]) by Xerox.COM ; 17 MAR 89 04:14:37 PST Received: by gateway.mitre.org (5.54/SMI-2.2) id AA01572; Fri, 17 Mar 89 07:11:21 EST Received: from jello by starbase (4.0/SMI-4.0) id AA25179; Fri, 17 Mar 89 07:14:21 EST Return-Path: Received: by jello (3.2/SMI-2.2) id AA00718; Fri, 17 Mar 89 07:13:12 EST Date: Fri, 17 Mar 89 07:13:12 EST From: john%jello@gateway.mitre.org (John Davidson) Message-Id: <8903171213.AA00718@jello> To: grs@wucs1.wustl.edu Cc: CommonLoops.pa@Xerox.COM In-Reply-To: Guillermo Ricardo Simari's message of Mon, 13 Mar 89 11:47:59 CST <8903131747.AA08389@wucs1.wustl.edu> Subject: Bayesian Reasoning Tool (BaRT) > Organization: The MITRE Corp., Washington, D.C. > Posted-From: The MITRE Corp., Bedford, MA > X-Alternate-Route: user%node@mbunix.mitre.org > Redistributed: CommonLoops.pa > Date: Mon, 13 Mar 89 11:47:59 CST > From: grs@wucs1.wustl.edu (Guillermo Ricardo Simari) > > > I don't know if it is appropriate to post this here but ... > I am looking for the Bayesian Reasoning Tool (BaRT). Is a Common > Lisp package developed at the Naval Research Lab and I have > the BaRT Manual (Preliminary Version 1.0) by N. Hota, C.Loggia Ramsey > and L.B.Booker. They give a machine to access the code but I cannot > connect to it. Does anybody know where I can get the sources? > Thank you very much in advance, > > > Guillermo R. Simari Washington University > (grs@wucs1.wustl.edu) Department of Computer Science > St. Louis, MO, 63130-4899, U.S.A. Inquiries regarding BaRT are best sent to Dr. Lashon Booker (NRL) at: booker@nrl-aic.arpa - a satisfied BaRT user John Davidson MITRE Washington AI Center davidson@mitre.arpa From Owners-CommonLoops.PA@Xerox.COM Fri Mar 17 15:17:56 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA15231; Fri, 17 Mar 89 14:17:39 PST Received: from Salvador.ms by ArpaGateway.ms ; 17 MAR 89 14:11:48 PST Return-Path: Redistributed: CommonLoops.PA Received: from natasha.cs.cornell.edu ([128.84.254.14]) by Xerox.COM ; 17 MAR 89 14:07:40 PST Received: from underdog.cs.cornell.edu by natasha.cs.cornell.edu via CHAOS with CHAOS-MAIL id 1433; Fri 17-Mar-89 16:29:41 EST Date: Fri, 17 Mar 89 16:30 EST From: Richard Zippel Subject: Method combination To: CommonLoops.PA@Xerox.COM Message-Id: <19890317213028.2.RZ@underdog.cs.cornell.edu> I must be confused or I've missed some thing in the release notes that I should have seen. I'm trying to include some code that runs when an instance of a class is created (using the CLOS style initialization protocol). If I define an class as follows, and create it with (pcl:*make-instance 'foo), GOTCHA is printed, but not FOO-INITIALIZED. What happened? (This is using a Rel 7.2, 12/7/88 Can't think of a cute name PCL.) (defclass foo () ()) (defmethod *initialize-instance :after ((object foo) &rest ignore) (print 'foo-initialized)) (defmethod print-object :after ((object foo) stream) (Print 'gotcha)) From Gregor.pa@Xerox.COM Fri Mar 17 19:25:07 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA23198; Fri, 17 Mar 89 19:25:07 PST Received: from Semillon.ms by ArpaGateway.ms ; 17 MAR 89 19:06:23 PST Date: Fri, 17 Mar 89 19:01 PST From: Gregor.pa@Xerox.COM Subject: Re: Method combination To: Richard Zippel Cc: CommonLoops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <19890317213028.2.RZ@underdog.cs.cornell.edu> Message-Id: <19890318030109.8.GREGOR@SHERMAN.parc.xerox.com> Line-Fold: no This message contains a note of interest to all PCL users. Date: Fri, 17 Mar 89 16:30 EST From: Richard Zippel I must be confused or I've missed some thing in the release notes that I should have seen. I'm trying to include some code that runs when an instance of a class is created (using the CLOS style initialization protocol). If I define an class as follows, and create it with (pcl:*make-instance 'foo), FOO-INITIALIZED is not printed. (defclass foo () ()) (defmethod *initialize-instance :after ((object foo) &rest ignore) (print 'foo-initialized)) This works properly for me. The only thing I can think of is that you might be getting screwed by package problems. Maybe your defmethod on *initialize-instance is defining a method on a generic function of that name in your package. One thing that makes me suspect this is that you package qualify *make-instance but not *initialize-instance. Neither of those symbols is actually exported from the PCL package. A note of general interest. The names of the initialization functions will be switched to conform to the specification in the next release. A simple way to start using the correct names for these generic functions now is shown below. This scheme has the nice property that you don't have to fix all of your code at once, the old name and new name will refer to the same generic function object. (in-package "MY-PACKAGE" :use "PCL") (shadow '("MAKE-INSTANCE" "INITIALIZE-INSTANCE")) (eval-when (compile load eval) (setf (symbol-function 'make-instance) #'pcl::*make-instance (symbol-function 'initialize-instance) #'pcl::*initialize-instance)) ------- From CL-Cleanup-mailer@SAIL.STANFORD.EDU Fri Mar 17 23:10:14 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA26852; Fri, 17 Mar 89 23:10:14 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 17 Mar 89 22:54:01 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 560294; Sat 18-Mar-89 01:50:31 EST Date: Sat, 18 Mar 89 01:50 EST From: David A. Moon Subject: Re: Issue: LOAD-OBJECTS (Version 3) To: Sandra J Loosemore , Richard P. Gabriel Cc: CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: <8903120142.AA00878@defun.utah.edu> Message-Id: <19890318065022.2.MOON@EUPHRATES.SCRC.Symbolics.COM> There are a couple of small changes that seem warranted: MAKE-LOAD-FORM-USING-SLOTS is too easy to confuse with SLOT-VALUE-USING-CLASS. MAKE-LOAD-FORM-FROM-SLOTS is better, except for form/from dyslexia. MAKE-LOAD-FORM-FOR-SLOTS ? Maybe there should be a SIMILAR-AS-CONSTANTS generic function for the benefit of CONSTANT-COLLAPSING. In the absence of that we're just using EQ. On the subject of this proposed alternative: Date: Sat, 11 Mar 89 18:42:56 MST From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Have two generic functions, not one. The first would get called by compile-file and it would return a list of components (or whatever) that are required to reconstruct the object. The compiler would dump this list of objects in its usual way. The loader would apply the second generic function to this list to reconstruct the object. This is exactly the way I did the first implementation of this idea, back in about 1978. It didn't work very well, basically for two reasons. One is that representing information in the form of lists is pretty impoverished and it's very easy to get the list the wrong length or out of order; it's also more difficult than it should be to make upward-compatible changes, because the new format always has to be a superset of the old format. Forms are more general. You can make upward-compatible changes by inventing a new function name and keeping the old function name around forever with the old semantics; this also ensures an undefined-function error if the new format is loaded into the old system. The second reason is more serious. The way you propose cannot be nicely extended to deal with circular structures, because it fails to separate object creation from object initialization. The second generic function does both operations. My application used circular structures extensively and had a fairly horrible kludge for them, involving standin objects that were replaced with the correct objects later in loading; this was fragile and permeated the reconstruction methods, all the worst characteristics for this kind of thing. On the subject of forms versus functions as the interface, I think David Gray has expressed very well the reasons why that is not practical, at least at Common Lisp's present stage of development. I've read all the mail on the subject, but I stand by LOAD-OBJECTS version 3. There may be more thought behind this proposal than is apparent at first glance. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Sun Mar 19 18:11:37 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA13317; Sun, 19 Mar 89 18:11:37 PST Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 19 Mar 89 18:11:19 PST Received: from Cabernet.ms by ArpaGateway.ms ; 19 MAR 89 18:10:23 PST Date: Sun, 19 Mar 89 04:19 PST From: Gregor.pa@Xerox.COM Subject: Re: Understanding Method Combination. To: James Rice Cc: CommonLoops.PA@Xerox.COM, Common-Lisp-Object-System@SAIL.STANFORD.EDU Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: Message-Id: <19890319121941.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Wed, 15 Mar 89 12:02:44 PST From: James Rice As far as I know the MOP doesn't provide a way for a tool to find out about combined methods in a way in which the user/environment tools might be interested. The MOP provides this behavior, and PCL implements a version of it. In fact, much of this is specified in chapters 1 and 2. COMPUTE-APPLICABLE-METHODS (generic-function args) This accepts a generic function and a list of arguments and returns the ordered list of methods applicable to those arguments. COMPUTE-EFFECTIVE-METHOD-BODY (generic-function methods) This takes a generic function and a list of methods and returns the `effective method body' of the effective method. So, this does the actual method combination. Note that the arguments to this will change slightly in a future release. For example: (defclass c1 () ()) (defclass c2 () ()) (defclass c3 (c1 c2) ()) (defmethod foo ((o c1)) ()) (defmethod foo :before ((o c2)) ()) (defmethod foo :before ((o c3)) ()) (defmethod foo :after ((o c1)) ()) (compute-applicable-methods #'foo (list (*make-instance 'c3))) ==> (# # # #) (compute-effective-method-body #'foo *) ==> (PROGN (CALL-METHOD # NIL) (CALL-METHOD # NIL) (MULTIPLE-VALUE-PROG1 (CALL-METHOD # NIL) (CALL-METHOD # NIL))) Which I believe is what you are asking for. NOTE: In typing this message I discovered that there is a slight bug in COMPUTE-APPLICABLE-METHODS. You have to actually call the generic function once before COMPUTE-APPLICABLE-METHODS will work properly. This is now on my to fix list. ------- From Gregor.pa@Xerox.COM Sun Mar 19 18:10:38 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA13308; Sun, 19 Mar 89 18:10:38 PST Received: from Cabernet.ms by ArpaGateway.ms ; 19 MAR 89 18:10:23 PST Date: Sun, 19 Mar 89 04:19 PST From: Gregor.pa@Xerox.COM Subject: Re: Understanding Method Combination. To: James Rice Cc: CommonLoops.PA@Xerox.COM, Common-Lisp-Object-System@SAIL.STANFORD.EDU Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: Message-Id: <19890319121941.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Wed, 15 Mar 89 12:02:44 PST From: James Rice As far as I know the MOP doesn't provide a way for a tool to find out about combined methods in a way in which the user/environment tools might be interested. The MOP provides this behavior, and PCL implements a version of it. In fact, much of this is specified in chapters 1 and 2. COMPUTE-APPLICABLE-METHODS (generic-function args) This accepts a generic function and a list of arguments and returns the ordered list of methods applicable to those arguments. COMPUTE-EFFECTIVE-METHOD-BODY (generic-function methods) This takes a generic function and a list of methods and returns the `effective method body' of the effective method. So, this does the actual method combination. Note that the arguments to this will change slightly in a future release. For example: (defclass c1 () ()) (defclass c2 () ()) (defclass c3 (c1 c2) ()) (defmethod foo ((o c1)) ()) (defmethod foo :before ((o c2)) ()) (defmethod foo :before ((o c3)) ()) (defmethod foo :after ((o c1)) ()) (compute-applicable-methods #'foo (list (*make-instance 'c3))) ==> (# # # #) (compute-effective-method-body #'foo *) ==> (PROGN (CALL-METHOD # NIL) (CALL-METHOD # NIL) (MULTIPLE-VALUE-PROG1 (CALL-METHOD # NIL) (CALL-METHOD # NIL))) Which I believe is what you are asking for. NOTE: In typing this message I discovered that there is a slight bug in COMPUTE-APPLICABLE-METHODS. You have to actually call the generic function once before COMPUTE-APPLICABLE-METHODS will work properly. This is now on my to fix list. ------- From Gregor.pa@Xerox.COM Sun Mar 19 18:27:31 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA13451; Sun, 19 Mar 89 18:27:31 PST Received: from Cabernet.ms by ArpaGateway.ms ; 19 MAR 89 18:27:48 PST Date: Sun, 19 Mar 89 18:25 PST From: Gregor.pa@Xerox.COM Subject: Re: Is it possible to use deftyped types as parameter-specializers? To: Darrell Cc: CommonLoops.pa@Xerox.COM, Darrell_Shane Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <8903152200.AA09082@blackcomb.arpa> Message-Id: <19890320022552.5.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Wed, 15 Mar 89 14:00:13 PST From: Darrell Consider the following: (deftype symbol-or-string () '(or symbol string)) (deftype non-nil-symbol-or-string () '(satisfies non-nil-symbol-or-string)) (defun non-nil-symbol-or-string (x) (if (and (typep x 'symbol-or-string) (not (null x))) t nil)) Suppose I wanted a method to be applicable only when its argument is of type non-nil-symbol-or-string. If non-nil-symbol-or-string were a class then the method I want would look like: (defmethod meth ((arg non-nil-symbol-or-string)) (format t "~A is a non-nil symbol or a string.~%" arg)) Is this possible in clos? This is not possible in CLOS. The only permissible parameter specializers are classes and lists of the form (EQL ). This question comes up fairly regularly, it is something people always wonder about. The spec doesn't explain the reasoning behind this, I believe Sonya Keene's book does. Here is an explanation which should help: The reason is that, in CLOS, a generic function must be able to order the set of applicable methods. That is, once the set of methods that can be applied to the arguments are determined, those methods must be ordered in terms of specificity. The entire determination of method combination and which method to apply is based on being able to perform this ordering. Using specializers like the one you propose break the ability to do this ordering. To see this, suppose I tried to make what you are suggesting work and wrote the following: (deftype symbol-or-string () '(or symbol string)) (deftype string-or-number () '(or string number)) (defmethod trouble ((x symbol-or-string)) 'symbol-or-string) (defmethod trouble ((x string-or-number)) 'string-or-number) If I say (trouble 'foo) things are OK. Also, (trouble 32) is OK. But, if I say (trouble "what now?") I have no sound mechanism for determining which of the two applicable methods is more specific. It is true that there are any number of rules we could come up with for ordering these methods. It is possible that some of these rules are reasonable for a given application. But it doesn't seem possible to discover a rule that will be reasonable for all uses. If you really want to do this, there is the metaobject protocol. It will let you define a generic function of your own that follows the lookup rules you want. ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 20 13:05:49 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA25906; Mon, 20 Mar 89 13:05:49 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 20 Mar 89 13:05:03 PST Received: by ti.com id AA21308; Mon, 20 Mar 89 10:18:35 CST Received: from Kelvin by tilde id AA20446; Mon, 20 Mar 89 10:05:33 CST Message-Id: <2815401819-2255364@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Mon, 20 Mar 89 10:03:39 CST From: David N Gray To: Gregor.pa@Xerox.COM Cc: James Rice , Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: Re: Understanding Method Combination. In-Reply-To: Msg of Sun, 19 Mar 89 04:19 PST from Gregor.pa@Xerox.COM > The MOP provides this behavior, and PCL implements a version of it. In > fact, much of this is specified in chapters 1 and 2. > > COMPUTE-APPLICABLE-METHODS (generic-function args) > > This accepts a generic function and a list of arguments and > returns the ordered list of methods applicable to those arguments. > > COMPUTE-EFFECTIVE-METHOD-BODY (generic-function methods) > > This takes a generic function and a list of methods and returns > the `effective method body' of the effective method. So, this > does the actual method combination. Note that the arguments to > this will change slightly in a future release. This may work in PCL, but there isn't any COMPUTE-EFFECTIVE-METHOD-BODY in chapter 3 of the CLOS specs. There is only COMPUTE-EFFECTIVE-METHOD, which returns the complete method object rather than a form. From CL-Cleanup-mailer@SAIL.STANFORD.EDU Mon Mar 20 13:39:04 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA26453; Mon, 20 Mar 89 13:39:04 PST Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 20 Mar 89 13:24:54 PST Received: from Semillon.ms by ArpaGateway.ms ; 20 MAR 89 13:17:33 PST Date: 20 Mar 89 13:16 PST From: Danny Bobrow Subject: Re: Issue: LOAD-OBJECTS (Version 3) In-Reply-To: David A. Moon 's message of Sat, 18 Mar 89 01:50 EST To: David A. Moon Cc: Sandra J Loosemore , Richard P. Gabriel , CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU Message-Id: <890320-131733-6488@Xerox> MAKE-LOAD-FORM-USING-SLOTS is too easy to confuse with SLOT-VALUE-USING-CLASS. MAKE-LOAD-FORM-FROM-SLOTS is better, except for form/from dyslexia. MAKE-LOAD-FORM-FOR-SLOTS ? How about MAKE-LOAD-FORM-SAVING-SLOTS danny From CL-Cleanup-mailer@SAIL.STANFORD.EDU Mon Mar 20 15:09:55 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA28327; Mon, 20 Mar 89 15:09:55 PST Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 20 Mar 89 14:27:09 PST Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 561368; Mon 20-Mar-89 17:23:27 EST Date: Mon, 20 Mar 89 17:23 EST From: David A. Moon Subject: Re: Issue: LOAD-OBJECTS (Version 3) To: Danny Bobrow Cc: Sandra J Loosemore , Richard P. Gabriel , CL-Cleanup@SAIL.STANFORD.EDU, CL-Compiler@SAIL.STANFORD.EDU, Common-Lisp-Object-System@SAIL.STANFORD.EDU In-Reply-To: <890320-131733-6488@Xerox> Message-Id: <19890320222313.1.MOON@EUPHRATES.SCRC.Symbolics.COM> Line-Fold: No Date: 20 Mar 89 13:16 PST From: Danny Bobrow MAKE-LOAD-FORM-USING-SLOTS is too easy to confuse with SLOT-VALUE-USING-CLASS. MAKE-LOAD-FORM-FROM-SLOTS is better, except for form/from dyslexia. MAKE-LOAD-FORM-FOR-SLOTS ? How about MAKE-LOAD-FORM-SAVING-SLOTS I like that name. From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 20 15:36:05 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA28614; Mon, 20 Mar 89 15:36:05 PST Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 20 Mar 89 15:36:08 PST Received: from Semillon.ms by ArpaGateway.ms ; 20 MAR 89 15:03:20 PST Date: Mon, 20 Mar 89 15:03 PST From: Gregor.pa@Xerox.COM Subject: Re: Understanding Method Combination. To: David N Gray Cc: James Rice , Common-Lisp-Object-System@SAIL.STANFORD.EDU Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <2815401819-2255364@Kelvin> Message-Id: <19890320230314.2.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Mon, 20 Mar 89 10:03:39 CST From: David N Gray This may work in PCL, but there isn't any COMPUTE-EFFECTIVE-METHOD-BODY in chapter 3 of the CLOS specs. There is only COMPUTE-EFFECTIVE-METHOD, which returns the complete method object rather than a form. I mistyped, the generic function is indeed called COMPUTE-EFFECTIVE-METHOD. It is mentioned in chapter 1. As it is documented in chapter 3, it returns an effective method which is a lisp form that could be thought of as the body of a lambda. Inside the forms are invocations of the call-method macro. This macro arranges to pass the arguments to the method to the actual method objects. So, the rest of my message was basically correct wrt the specification. ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Mar 20 18:18:37 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA01848; Mon, 20 Mar 89 18:18:37 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 20 Mar 89 18:18:09 PST Received: by ti.com id AA02140; Mon, 20 Mar 89 20:18:28 CST Received: from Kelvin by tilde id AA04354; Mon, 20 Mar 89 20:07:16 CST Message-Id: <2815437931-4425034@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Mon, 20 Mar 89 20:05:31 CST From: David N Gray To: Gregor.pa@Xerox.COM Cc: James Rice , Common-Lisp-Object-System@SAIL.STANFORD.EDU Subject: Re: Understanding Method Combination. In-Reply-To: Msg of Mon, 20 Mar 89 15:03 PST from Gregor.pa@Xerox.COM > I mistyped, the generic function is indeed called COMPUTE-EFFECTIVE-METHOD. > It is mentioned in chapter 1. As it is documented in chapter 3, it returns > an effective method which is a lisp form that could be thought of as the > body of a lambda. Inside the forms are invocations of the call-method > macro. This macro arranges to pass the arguments to the method to the > actual method objects. So, the rest of my message was basically correct > wrt the specification. OK, that makes sense, but the spec doesn't say that. Page 3-43 says that it is "called to determine the effective method", but does not ever specify what the returned value is. I apparently made an invalid assumption about what was intended. I see now that page 1-28 says that it "returns a Lisp form that defines the effective method", but it doesn't say anything about what it can be expected to look like. From Gregor.pa@Xerox.COM Mon Mar 20 23:11:39 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA07203; Mon, 20 Mar 89 23:11:39 PST Received: from Semillon.ms by ArpaGateway.ms ; 20 MAR 89 15:02:16 PST Date: Mon, 20 Mar 89 14:58 PST From: Gregor.pa@Xerox.COM Subject: Re: allowable specializers To: goldman@vaxa.isi.edu Cc: CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <8903202243.AA14464@vaxa.isi.edu> Message-Id: <19890320225839.1.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Mon, 20 Mar 89 14:43:35 PST From: goldman@vaxa.isi.edu Re: Gregor's note on allowable specializers: The only permissible parameter specializers are classes and lists of the form (EQL ). I presume that "classes" here encompasses types defined by DEFSTRUCT (without the :type option)? The way I read "Integrating Types and Classes" in chapter 1, I would expect (portably) to be able to use the name of a defstruct type as a specializer in the same places where I could use the name of a class introduced with defclass. Is that correct? Yes that is correct. As you say, the reason it is correct is that CLOS amends defstruct to actually define classes (of a special metaclass). So that statement and my original statement are compatible. Is there any way to use defstruct types as specializers in PCL (without defining a new kind of generic function)? Not yet. ------- From Owners-CommonLoops.PA@Xerox.COM Mon Mar 20 23:18:00 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA07446; Mon, 20 Mar 89 23:18:00 PST Received: from Salvador.ms by ArpaGateway.ms ; 20 MAR 89 16:39:30 PST Return-Path: Redistributed: CommonLoops.PA Received: from uxc.cso.uiuc.edu ([130.126.174.50]) by Xerox.COM ; 20 MAR 89 16:36:00 PST Received: from mmm.UUCP by uxc.cso.uiuc.edu with UUCP (5.61+/IDA-1.2.8) id AA05066; Mon, 20 Mar 89 17:32:43 -0600 Received: by mmm.3m.com (4.0/smail2.5/1.0BDR/08-14-88) id AA00714; Mon, 20 Mar 89 17:16:15 CST From: collins@mmm.3m.com (John Collins) Message-Id: <8903202316.AA00714@mmm.3m.com> To: Richard Zippel Cc: CommonLoops.PA@Xerox.COM Subject: Re: Method combination In-Reply-To: Your message of Fri, 17 Mar 89 16:30:00 EST. <19890317213028.2.RZ@underdog.cs.cornell.edu> Date: Mon, 20 Mar 89 17:16:11 CST > I must be confused or I've missed some thing in the release notes that I > should have seen. I'm trying to include some code that runs when an > instance of a class is created (using the CLOS style initialization > protocol). If I define an class as follows, and create it with > (pcl:*make-instance 'foo), GOTCHA is printed, but not FOO-INITIALIZED. > What happened? (This is using a > Rel 7.2, 12/7/88 Can't think of a cute name PCL.) > > (defclass foo () > ()) > > (defmethod *initialize-instance :after ((object foo) &rest ignore) > (print 'foo-initialized)) > > (defmethod print-object :after ((object foo) stream) > (Print 'gotcha)) The last time that happened to me, it was because I had neglected to import pcl::*initialize-instance. I had simply created another generic function called *initialize-instance in the current package. John Collins, 3M Company collins@mmm.3M.com From Owners-CommonLoops.pa@Xerox.COM Mon Mar 20 23:52:06 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA07755; Mon, 20 Mar 89 23:24:59 PST Received: from Salvador.ms by ArpaGateway.ms ; 20 MAR 89 14:46:23 PST Return-Path: Redistributed: CommonLoops.pa Received: from vaxa.isi.edu ([128.9.0.33]) by Xerox.COM ; 20 MAR 89 14:44:42 PST Posted-Date: Mon, 20 Mar 89 14:43:35 PST Message-Id: <8903202243.AA14464@vaxa.isi.edu> Received: from LOCALHOST by vaxa.isi.edu (5.59/5.51) id AA14464; Mon, 20 Mar 89 14:43:40 PST To: CommonLoops.pa@Xerox.COM From: goldman@vaxa.isi.edu Subject: allowable specializers Date: Mon, 20 Mar 89 14:43:35 PST Sender: goldman@vaxa.isi.edu Re: Gregor's note on allowable specializers: The only permissible parameter specializers are classes and lists of the form (EQL ). I presume that "classes" here encompasses types defined by DEFSTRUCT (without the :type option)? The way I read "Integrating Types and Classes" in chapter 1, I would expect (portably) to be able to use the name of a defstruct type as a specializer in the same places where I could use the name of a class introduced with defclass. Is that correct? Is there any way to use defstruct types as specializers in PCL (without defining a new kind of generic function)? Neil From Owners-CommonLoops.pa@Xerox.COM Tue Mar 21 04:19:44 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA09428; Tue, 21 Mar 89 02:05:47 PST Received: from Riesling.ms by ArpaGateway.ms ; 21 MAR 89 02:06:22 PST Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 21 MAR 89 02:04:13 PST To: goldman@vaxa.isi.edu Cc: CommonLoops.pa@Xerox.COM Subject: Re: allowable specializers In-Reply-To: Your message of Mon, 20 Mar 89 14:43:35 -0800. <8903202243.AA14464@vaxa.isi.edu> Date: Tue, 21 Mar 89 04:24:43 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890321-020622-8020@Xerox> Here is the software we use at BBN to make structures part of PCL. It works on LISPM, and KCL. Unfortunately, CL does not specify enough about defstruct to make this completely portable, so each implementation must provide 3 functions. Please forward any improvements or suggestions back to me. Someone else has mailed out something like this, but i can't find his name at the moment. He modified defstruct to automatically define a class, and recompiled built-in-class-of every time. I don't do either of these things, because i don't think they are right. The file contains all the soft you'll need to load this as a patch to an existing PCL. k ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp; Patch-File: Yes -*- #|| ;;; STRUCTURE-CLASS. Integrates structures into the CLOS class hierarchy. Before the first method is defined on a structure, use DEFINE-STRUCTURE-CLASS to create the corresponding class. Classes will automatically be created any included structures. ;;; Example following CLtL p 312. (defstruct person name age sex) (defstruct (person-in-space (:include person)) x y z) (defstruct (astronaut (:include person-in-space) (:conc-name astro-)) helmet-size (beverage 'tang)) (define-structure-class 'astronaut) (pcl:defmethod olderp ((a astronaut) (b person)) (> (astro-age a) (person-age b))) (pcl:defmethod olderp ((b person) (a astronaut)) (> (person-age b) (astro-age a))) (setq a (make-astronaut :name 'mary :age 50 :sex 'female)) (setq b (make-person :name 'ken :age 41 :sex 'male)) (olderp a b) (olderp b a) ||# (in-package "PCL") ;;; Patch PKG.LISP (export '(define-structure-class structure) 'pcl) ;;; Patch LOW.LISP ;;; Each implementation must provide versions of the following functions: (defmacro structurep (thing) `(typep ,thing 'structure)) (defun structure-name (thing) (declare (ignore thing)) (error "An implementation specific version of STRUCTURE-NAME is required.")) (defun defstruct-include (name) (declare (ignore name)) ;; The name of the included structure type or NIL if none. (error "An implementation specific version of DEFSTRUCT-INCLUDE is required.")) (defun describe-structure (thing) (print thing)) ;;; Patch KCL-LOW.LISP #+kcl (setf (symbol-function 'structure-name) (symbol-function 'system::structure-name)) #+kcl (defun defstruct-include (name) (get name 'system::structure-include)) ;;; Patch 3600-LOW.LISP ;;; Each implementation must provide versions of these. #+3600 (defmacro structurep (thing) `(scl:named-structure-p ,thing)) #+3600 (defmacro structure-name (thing) "Given a struct, return its type name." `(scl:named-structure-p ,thing)) #+3600 (defun find-defstruct-description (name &optional (errorp t)) (let ((description (get name 'si:defstruct-description))) (if description description (if errorp (error "A structure with this name has not been defined" name))))) #+3600 (defun defstruct-include (name) (car (si:defstruct-description-include (find-defstruct-description name)))) #+3600 (defun describe-structure (thing) (LET ((NSS (si:NAMED-STRUCTURE-P THING))) (COND ((AND NSS (GET NSS 'si:NAMED-STRUCTURE-INVOKE) (MEMQ ':DESCRIBE (si:NAMED-STRUCTURE-INVOKE THING ':WHICH-OPERATIONS))) (si:NAMED-STRUCTURE-INVOKE THING ':DESCRIBE) (si:DESCRIBE-ARRAY THING T)) ((AND NSS (GET NSS 'si:DEFSTRUCT-DESCRIPTION)) (si:DESCRIBE-DEFSTRUCT THING) (si:DESCRIBE-ARRAY THING T)) (T (si:DESCRIBE-ARRAY THING))))) ;;; Patch LOW.LISP (EVAL-WHEN (compile load) (setq *class-of* '(lambda (x) (or (and (iwmc-class-p x) (wrapper-class (iwmc-class-class-wrapper x))) (and (funcallable-instance-p x) (funcallable-instance-class x)) (and (structurep x) (structure-class-of x)) (built-in-class-of x) (error "Can't determine class of ~S" x)))) (setq *wrapper-of* '(lambda (x) (or (and (iwmc-class-p x) (iwmc-class-class-wrapper x)) (and (funcallable-instance-p x) (funcallable-instance-wrapper x)) (and (structurep x) (class-wrapper (structure-class-of x))) (built-in-wrapper-of x) (error "Can't determine wrapper of ~S" x)))) ) ; End EVAL-WHEN ;;; Patch BRAID1.LISP (defun class-of (x) (#.*class-of* x)) (defun wrapper-of (x) (#.*wrapper-of* x)) ;;; Patch HIGH.LISP (eval-when (compile load eval) ;;; Added structure as a built in class (setq *built-in-classes* '((array (t)) (bit-vector (vector)) (character (t)) (complex (number)) (cons (list)) (float (number)) (integer (rational)) (list (sequence)) (null (symbol list)) (number (t)) (ratio (rational)) (rational (number)) (sequence (t)) (string (vector)) (symbol (t)) (vector (array sequence)) (hash-table (t)) (structure (t)))) (define-built-in-classes) ) ;;; This needs to be eval-when'ed when HIGH.LISP is compiled, so it ;;; needs to be here too to work as a patch. (eval-when (compile eval) (defun make-built-in-class-subs () (mapcar #'(lambda (e) (let ((class (car e)) (class-subs ())) (dolist (s *built-in-classes*) (when (memq class (cadr s)) (pushnew (car s) class-subs))) (cons class class-subs))) (cons '(t) *built-in-classes*))) (defun make-built-in-class-tree () (let ((subs (make-built-in-class-subs))) (labels ((descend (class) (cons class (mapcar #'descend (cdr (assq class subs)))))) (descend 't)))) (defun make-built-in-wrapper-of-body () (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) 'x #'get-built-in-wrapper-symbol)) (defun make-built-in-class-of-body () (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) 'x #'get-built-in-class-symbol)) (defun make-built-in-wrapper-of-body-1 (tree var get-symbol) (let ((*specials* ())) (declare (special *specials*)) (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol))) `(locally (declare (special .,*specials*)) ,inner)))) (defun make-built-in-wrapper-of-body-2 (tree var get-symbol) (declare (special *specials*)) (let ((symbol (funcall get-symbol (car tree)))) (push symbol *specials*) (let ((sub-tests (mapcar #'(lambda (x) (make-built-in-wrapper-of-body-2 x var get-symbol)) (cdr tree)))) `(and (typep ,var ',(car tree)) ,(if sub-tests `(or ,.sub-tests ,symbol) symbol))))) ) ; End Eval-when (defun built-in-wrapper-of (x) #.(make-built-in-wrapper-of-body)) (defun built-in-class-of (x) #.(make-built-in-class-of-body)) (defclass structure-class (standard-class) ((class-precedence-list :initform (list *the-class-t*)))) (defmethod inform-type-system-about-class ((class structure-class) name) ;; Defstruct informs the type system for us. (declare (ignore name))) ;; This assumes that MAKE-FOO will always work. (defmethod class-prototype ((c structure-class)) (or (slot-value c 'prototype) (setf (slot-value c 'prototype) ;; Gross! Is there a better way? (funcall (intern (format nil "MAKE-~A" (class-name c)) (symbol-package (class-name c))))))) (defmethod allocate-instance ((class structure-class) &rest initargs) (declare (ignore initargs)) (error "Attempt to make an instance of the structure-class ~S.~@ It is not possible to make instance of structure classes with~@ allocate-instance." class)) (defmethod check-super-metaclass-compatibility ((class structure-class) (new-super built-in-class)) (or (eq new-super (find-class 'structure)) (error "~S cannot have ~S as a super.~%~ The only meta-class STANDARD-CLASS class that a structure~%~ class can have as a super is the class STRUCTURE." class new-super))) (defmethod check-super-metaclass-compatibility ((class structure-class) (new-super structure-class)) 't) (defun define-structure-class (name) (let ((proto (class-prototype (find-class 'structure-class))) (supers (list (let ((include (defstruct-include name))) (if include (find-structure-class include) (find-class 'structure)))))) (add-named-class proto name supers () ()))) (defun find-structure-class (name) "Find structure-class named NAME, creating it if necessary." (let ((class (find-class name nil))) (if class class (define-structure-class name)))) (defun structure-class-of (structure) (find-structure-class (structure-name structure))) (defmethod describe #-Symbolics ((object structure)) #+Symbolics ((object structure) &optional no-complaints) #+Symbolics (declare (ignore no-complaints)) (describe-structure object)) From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Tue Mar 21 08:42:49 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA13267; Tue, 21 Mar 89 08:42:49 PST Received: from Sun.COM by SAIL.Stanford.EDU with TCP; 21 Mar 89 08:42:47 PST Received: from snail.Sun.COM (snail.Corp.Sun.COM) by Sun.COM (4.1/SMI-4.0) id AA28027; Tue, 21 Mar 89 08:44:46 PST Received: from suntana.sun.com by snail.Sun.COM (4.1/SMI-4.1) id AA28469; Tue, 21 Mar 89 08:40:55 PST Received: from localhost by suntana.sun.com (4.0/SMI-4.0) id AA01870; Tue, 21 Mar 89 08:42:58 PST Message-Id: <8903211642.AA01870@suntana.sun.com> To: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Subject: Compile Time Class Creation (was: remote environments) Date: Tue, 21 Mar 89 08:42:55 PST From: kempf@Sun.COM I've just had time to plough through the X3 mail on CLOS and there was a point lurking in the correspondence on this topic that I think was never clearly articulated. That point has to do with the role of class objects in type checking and inference. If the goal is to enable compiler implementors and extenders to write type checking and inference code in an object-oriented way, then some kind of object representing the class must be created at compile time. The entire class need not be defined. For example, the slot accessor method certainly don't need to be defined. I think the minimum amount of information which needs to be there is the following: -class precedence list-Because the class precedence list is used in subtyping, it must be available to the type checker. -slot location (instance, class)-The compiler might be able to optimize slot access based on this. -slot type-Again, potentially necessary for slot access. -metaclass-Needed for slot access, possibly to optimize instance creation and initialization. -interface information for slot access functions-So they can be optimized. Most compilers currently use list structures for their type checkers, and it certainly would be possible to disallow compile time creation of classes for standard-class objects, to simplify things. But to do so for the metaobject protocol would limit the metaobject protocol in a way that would be crippling, since the point of the metaobject protocol is to allow extensibility in the language processing software. There are a number of possible decisions. It could be left either unintentionally or deliberately ambiguous. It could be specified that standard-class objects either are created, are partially created, or are not created at compile time, while leaving open the question for other metaclasses (since the MOP will probably not be a part of the official ANSI Common Lisp '89 standard anyway). However, it is important to understand the effect of these decisions on future evolution and user extensibility. jak From Owners-CommonLoops.pa@Xerox.COM Tue Mar 21 16:43:23 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA20674; Tue, 21 Mar 89 16:43:23 PST Received: from Riesling.ms by ArpaGateway.ms ; 21 MAR 89 12:02:49 PST Return-Path: Redistributed: CommonLoops.pa Received: from hx.LCS.MIT.EDU ([18.30.0.197]) by Xerox.COM ; 21 MAR 89 12:00:44 PST Received: by hx.LCS.MIT.EDU (5.51/4.7); Tue, 21 Mar 89 14:55:51 EST Date: Tue, 21 Mar 89 14:55:51 EST From: waldemar@hx.LCS.MIT.EDU (Waldemar Horwat) Message-Id: <8903211955.AA25144@hx.LCS.MIT.EDU> Subject: Caching bug? Apparently-To: CommonLoops.pa@Xerox.COM I am running into what looks like a bug in the PCL caches. Specifically, I defined a slot-unbound method to catch references to unbound slots and compute appropriate values. Unfortunately, in some cases calling a slot accessor function appears to fall into an infinite loop within PCL before the slot-unbound method is ever called. On the other hand, calling slot-value on that slot returns the correct value. The problem is 100% reproducible; unfortunately, the bug appears only after a specific sequence of calls to the accessor (everything works fine the first few times the accessor is called), so the smallest example I have which exhibits this problem is a large program. Effectively, I am doing something akin to the following sketch of code: (defclass c1 () ((x :reader x))) (defclass c2 (c1) ((y :reader y))) (defclass cc () ()) (defmethod slot-unbound (class (instance c1) (slot (eql 'x))) (setf (slot-value instance 'x) (make-instance 'cc))) (In my large program there are a few more classes in the hierarchy between c1 and c2.) Calling (slot-value (make-instance 'c2) 'x) always works, while calling (x (make-instance 'c2)) falls into an infinite loop (in my large program, not this example). Interestingly enough, using defclass to define a new subclass of c1 makes the problem temporarily go away. I'd like to isolate the problem, but I am not familiar enough with PCL's internals to know what to do next. What should I look for to determine what is causing the problem? I am using the 12/7/88 PCL on a Macintosh using Coral Common Lisp 1.2.2. Waldemar Horwat waldemar@hx.lcs.mit.edu From Owners-CommonLoops.pa@Xerox.COM Tue Mar 21 20:16:51 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA24064; Tue, 21 Mar 89 20:16:51 PST Received: from Riesling.ms by ArpaGateway.ms ; 21 MAR 89 20:16:38 PST Return-Path: Redistributed: CommonLoops.pa Received: from hx.LCS.MIT.EDU ([18.30.0.197]) by Xerox.COM ; 21 MAR 89 20:14:03 PST Received: by hx.LCS.MIT.EDU (5.51/4.7); Tue, 21 Mar 89 23:05:48 EST Date: Tue, 21 Mar 89 23:05:48 EST From: waldemar@hx.LCS.MIT.EDU (Waldemar Horwat) Message-Id: <8903220405.AA29511@hx.LCS.MIT.EDU> Subject: Caching bug? Apparently-To: CommonLoops.pa@Xerox.COM I have determined that the infinite loop mentioned in my previous message occurs in the all-std-class-readers-dcode and all-std-class-accessors-dcode-internal routines. Apparently all-std-class-accessors-dcode-internal calls dcode-cache-miss, which returns an integer (7 in my case), so it goes to the hit label, which goes to the fast form, which then determines that the slot is unbound, so it goes back to the miss label, calling dcode-cache-miss again, which again returns 7, and the resulting loop never terminates. Waldemar Horwat From Owners-CommonLoops.pa@Xerox.COM Wed Mar 22 20:35:50 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA16030; Wed, 22 Mar 89 20:35:50 PST Received: from Riesling.ms by ArpaGateway.ms ; 22 MAR 89 11:08:31 PST Return-Path: Redistributed: CommonLoops.pa Received: from A.GP.CS.CMU.EDU ([128.2.242.7]) by Xerox.COM ; 22 MAR 89 09:08:39 PST Date: Wed, 22 Mar 89 10:44:20 EST From: Christopher.McConnell@A.GP.CS.CMU.EDU To: goldman@vaxa.isi.edu Cc: CommonLoops.pa@Xerox.COM Subject: Re: allowable specializers Message-Id: <890322-110831-110@Xerox> Here is another way to allow writing methods on defstructs. It should work in any CL. It works by adding defstructs to the built-in class hierarchy. It redefines defstruct, so that this automatically happens. ;;; (in-package 'pcl) ;;; ;;; This whole set of hair is from PCL's high.lisp. Some day, it will be ;;; built into defstruct. It allows you to define defstructs without ;;; much penalty, but the first time you call a generic function, it ;;; rebuilds the type wrappers, so it can take a while. ;;; (defun make-built-in-class-subs () (mapcar #'(lambda (e) (let ((class (car e)) (class-subs ())) (dolist (s *built-in-classes*) (when (memq class (cadr s)) (pushnew (car s) class-subs))) (cons class class-subs))) (cons '(t) *built-in-classes*))) (defun make-built-in-class-tree () (let ((subs (make-built-in-class-subs))) (labels ((descend (class) (cons class (mapcar #'descend (cdr (assq class subs)))))) (descend 't)))) (defun make-built-in-wrapper-of-body () (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) 'x #'get-built-in-wrapper-symbol)) (defun make-built-in-class-of-body () (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) 'x #'get-built-in-class-symbol)) (defun make-built-in-wrapper-of-body-1 (tree var get-symbol) (let ((*specials* ())) (declare (special *specials*)) (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol))) `(locally (declare (special .,*specials*)) ,inner)))) (defun make-built-in-wrapper-of-body-2 (tree var get-symbol) (declare (special *specials*)) (let ((symbol (funcall get-symbol (car tree)))) (push symbol *specials*) (let ((sub-tests (mapcar #'(lambda (x) (make-built-in-wrapper-of-body-2 x var get-symbol)) (cdr tree)))) `(and (typep ,var ',(car tree)) ,(if sub-tests `(or ,.sub-tests ,symbol) symbol))))) ;;; (defun DEFINE-BUILT-IN-CLASS (name supers) "Define a new built in CLOS class. Typically for structures." (let ((proto (class-prototype (find-class 'built-in-class)))) (add-named-class proto name supers () ()) (let ((class-symbol (get-built-in-class-symbol name)) (wrapper-symbol (get-built-in-wrapper-symbol name)) (class (find-class name)) (cell (or (assoc name *built-in-classes*) (first (push (list name) *built-in-classes*))))) (set class-symbol class) (set wrapper-symbol (class-wrapper class)) ;; This is a funky trick to rebuild the wrappers, next time they are ;; referenced. (rplacd cell (list supers)) (setf (symbol-function 'built-in-wrapper-of) #'(lambda (x) (setf (symbol-function 'built-in-wrapper-of) (compile nil `(lambda (x) ,(make-built-in-wrapper-of-body)))) (built-in-wrapper-of x)) (symbol-function 'built-in-class-of) #'(lambda (x) (setf (symbol-function 'built-in-class-of) (compile nil `(lambda (x) ,(make-built-in-class-of-body)))) (built-in-class-of x)))))) ;;; ;;; Redefine the LISP defstruct macro so that structures are ;;; automatically added to the built-in-class lattice. This is a very ;;; simple minded implementation that does not handle changing the ;;; inheritance of defstructs. ;;; (eval-when (compile load eval) (unless (macro-function 'old-defstruct) (setf (macro-function 'old-defstruct) (macro-function 'defstruct)))) (defmacro DEFSTRUCT (name-and-options &rest body) (let* ((include (when (listp name-and-options) (second (assoc :include (cdr name-and-options))))) (supertype (or include #+lucid t)) (name (if (listp name-and-options) (first name-and-options) name-and-options))) `(eval-when (compile load eval) (define-built-in-class ',name '(,supertype)) (old-defstruct ,name-and-options ,@body)))) From CL-Windows-mailer@SAIL.STANFORD.EDU Thu Mar 23 12:25:51 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA27902; Thu, 23 Mar 89 12:25:51 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 23 Mar 89 09:08:32 PST Received: by ti.com id AA12307; Wed, 22 Mar 89 21:38:08 CST Received: from Kelvin by tilde id AA27213; Wed, 22 Mar 89 21:21:09 CST Message-Id: <2815615116-2334006@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Wed, 22 Mar 89 21:18:36 CST From: David N Gray To: CL-Cleanup@SAIL.STANFORD.EDU Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU, CL-Windows@SAIL.STANFORD.EDU, Bartley@MIPS.csc.ti.com, Waldrum@Tilde.csc.ti.com, salem@Think.COM Subject: Issue STREAM-DEFINITION-BY-USER (V1) Following is a more detailed write-up of the idea of a generic function I/O interface that allows users to create their own streams. I have put this in the format of a cleanup proposal because that seems like a good way of presenting the information, but I realize that the timing isn't right for including this in the standard now. Hopefully, though, this can be used as a guideline for implementors to avoid unnecessarily coming up with different names for the same thing, and after some experience has been gained, this feature could be considered for inclusion in a revision of the standard. I wanted to get this in your hands before the X3J13 meeting in case anyone was interested in discussing it, but I don't expect any official action to be taken. Issue: STREAM-DEFINITION-BY-USER References: CLtL pages 329-332, 378-381, and 384-385. Related issues: STREAM-INFO, CLOSED-STREAM-FUNCTIONS, STREAM-ACCESS, STREAM-CAPABILITIES Category: ADDITION Edit history: Version 1, 22-Mar-89 by David N. Gray Status: For discussion and evaluation; not proposed for inclusion in the standard at this time. Problem description: Common Lisp does not provide a standard way for users to define their own streams for use by the standard I/O functions. This impedes the development of window systems for Common Lisp because, while there are standard Common Lisp I/O functions and there are beginning to be standard window systems, there is no portable way to connect them together to make a portable Common Lisp window system. There are also many applications where users might want to define their own filter streams for doing things like printer device control, report formatting, character code translation, or encryption/decryption. Proposal STREAM-DEFINITION-BY-USER:GENERIC-FUNCTIONS Overview: Define a set of generic functions for performing I/O. These functions will have methods that specialize on the stream argument; they would be used by the existing I/O functions. Users could write additional methods for them in order to support their own stream classes. Define a set of classes to be used as the superclass of a stream class in order to provide some default methods. Classes: The following classes are to be used as super classes of user-defined stream classes. They are not intended to be directly instantiated; they just provide places to hang default methods. FUNDAMENTAL-STREAM [Class] This class is a subclass of STREAM and of STANDARD-OBJECT. STREAMP will return true for an instance of any class that includes this. (It may return true for some other things also.) FUNDAMENTAL-INPUT-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. Its inclusion causes INPUT-STREAM-P to return true. FUNDAMENTAL-OUTPUT-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. Its inclusion causes OUTPUT-STREAM-P to return true. Bi-direction streams may be formed by including both FUNDAMENTAL-OUTPUT-STREAM and FUNDAMENTAL-INPUT-STREAM. FUNDAMENTAL-CHARACTER-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. It provides a method for STREAM-ELEMENT-TYPE which returns CHARACTER. FUNDAMENTAL-BINARY-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. Any instantiable class that includes this needs to define a method for STREAM-ELEMENT-TYPE. FUNDAMENTAL-CHARACTER-INPUT-STREAM [Class] Includes FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-CHARACTER-STREAM. It provides default methods for several generic functions used for character input. FUNDAMENTAL-CHARACTER-OUTPUT-STREAM [Class] Includes FUNDAMENTAL-OUTPUT-STREAM and FUNDAMENTAL-CHARACTER-STREAM. It provides default methods for several generic functions used for character output. FUNDAMENTAL-BINARY-INPUT-STREAM [Class] Includes FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-BINARY-STREAM. FUNDAMENTAL-BINARY-OUTPUT-STREAM [Class] Includes FUNDAMENTAL-OUTPUT-STREAM and FUNDAMENTAL-BINARY-STREAM. Character input: A character input stream can be created by defining a class that includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods for the generic functions below. STREAM-READ-CHAR stream [Generic Function] This reads one character from the stream. It returns either a character object, or the symbol :EOF if the stream is at end-of-file. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a method for this function. Note that for all of these generic functions, the stream argument must be a stream object, not T or NIL. STREAM-UNREAD-CHAR stream character [Generic Function] Un-does the last call to STREAM-READ-CHAR, as in UNREAD-CHAR. Returns NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a method for this function. STREAM-READ-CHAR-NO-HANG stream [Generic Function] This is used to implement READ-CHAR-NO-HANG. It returns either a character, or NIL if no input is currently available, or :EOF if end-of-file is reached. The default method provided by FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this is sufficient for file streams, but interactive streams should define their own method. STREAM-PEEK-CHAR stream [Generic Function] Used to implement PEEK-CHAR; this corresponds to peek-type of NIL. It returns either a character or :EOF. The default method calls STREAM-READ-CHAR and STREAM-UNREAD-CHAR. STREAM-LISTEN stream [Generic Function] Used by LISTEN. Returns true or false. The default method uses STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should define their own method since it will usually be trivial and will always be more efficient than the default method. STREAM-READ-LINE stream [Generic Function] Used by READ-LINE. A string is returned as the first value. The second value is true if the string was terminated by end-of-file instead of the end of a line. The default method uses repeated calls to STREAM-READ-CHAR. STREAM-CLEAR-INPUT stream [Generic Function] Implements CLEAR-INPUT for the stream, returning NIL. The default method does nothing. Character output: A character output stream can be created by defining a class that includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods for the generic functions below. STREAM-WRITE-CHAR stream character [Generic Function] Writes character to the stream and returns the character. Every subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method defined for this function. STREAM-LINE-COLUMN stream [Generic Function] This function returns the column number where the next character will be written, or NIL if that is not meaningful for this stream. The first column on a line is numbered 0. This function is used in the implementation of PPRINT and the FORMAT ~T directive. For every character output stream class that is defined, a method must be defined for this function, although it is permissible for it to always return NIL. STREAM-START-LINE-P stream [Generic Function] This is a predicate which returns T if the stream is positioned at the beginning of a line, else NIL. It is permissible to always return NIL. This is used in the implementation of FRESH-LINE. Note that while a value of 0 from STREAM-LINE-COLUMN also indicates the beginning of a line, there are cases where STREAM-START-LINE-P can be meaningfully implemented although STREAM-LINE-COLUMN can't be. For example, for a window using variable-width characters, the column number isn't very meaningful, but the beginning of the line does have a clear meaning. The default method for STREAM-START-LINE-P on class FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if that is defined to return NIL, then a method should be provided for either STREAM-START-LINE-P or STREAM-FRESH-LINE. STREAM-WRITE-STRING stream string &optional start end [Generic Function] This is used by WRITE-STRING. It writes the string to the stream, optionally delimited by start and end, which default to 0 and NIL. The string argument is returned. The default method provided by FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to STREAM-WRITE-CHAR. STREAM-TERPRI stream [Generic Function] Writes an end of line, as for TERPRI. Returns NIL. The default method does (STREAM-WRITE-CHAR stream #\NEWLINE). STREAM-FRESH-LINE stream [Generic Function] Used by FRESH-LINE. The default method uses STREAM-START-LINE-P and STREAM-TERPRI. STREAM-FINISH-OUTPUT stream [Generic Function] Implements FINISH-OUTPUT. The default method does nothing. STREAM-FORCE-OUTPUT stream [Generic Function] Implements FORCE-OUTPUT. The default method does nothing. STREAM-CLEAR-OUTPUT stream [Generic Function] Implements CLEAR-OUTPUT. The default method does nothing. STREAM-ADVANCE-TO-COLUMN stream column [Generic Function] Writes enough blank space so that the next character will be written at the specified column. Returns true if the operation is successful, or NIL if it is not supported for this stream. This is intended for use by by PPRINT and FORMAT ~T. The default method uses STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL. Other functions: CLOSE stream &key abort [Generic Function] The existing function CLOSE is redefined to be a generic function, but otherwise behaves the same. The default method provided by class FUNDAMENTAL-STREAM sets a flag for OPEN-STREAM-P. The value returned by CLOSE will be as specified by the issue CLOSED-STREAM-OPERATIONS. OPEN-STREAM-P stream [Generic Function] This function [from proposal STREAM-ACCESS] is made generic. A default method is provided by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been called on the stream. STREAMP object [Generic Function] INPUT-STREAM-P stream [Generic Function] OUTPUT-STREAM-P stream [Generic Function] These three existing predicates may optionally be implemented as generic functions for implementations that want to permit users to define streams that are not STANDARD-OBJECTs. Normally, the default methods provided by classes FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-OUTPUT-STREAM are sufficient. Note that, for example, (INPUT-STREAM-P x) is not equivalent to (TYPEP x 'FUNDAMENTAL-INPUT-STREAM) because implementations may have additional ways of defining their own streams even if they don't make that visible by making these predicates generic. STREAM-ELEMENT-TYPE stream [Generic Function] This existing function is made generic, but otherwise behaves the same. Class FUNDAMENTAL-CHARACTER-STREAM provides a default method which returns CHARACTER. PATHNAME and TRUENAME are also permitted to be implemented as generic functions. There is no default method since these are not valid for all streams. Binary streams: Binary streams can be created by defining a class that includes either FUNDAMENTAL-BINARY-INPUT-STREAM or FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method for STREAM-ELEMENT-TYPE and for one or both of the following generic functions. STREAM-READ-BYTE stream [Generic Function] Used by READ-BYTE; returns either an integer, or the symbol :EOF if the stream is at end-of-file. STREAM-WRITE-BYTE stream integer [Generic Function] Implements WRITE-BYTE; writes the integer to the stream and returns the integer as the result. Rationale: The existing I/O functions cannot be made generic because, in nearly every case, the stream argument is optional, and therefore cannot be specialized. Therefore, it is necessary to define a lower-level generic function to be used by the existing function. It also isn't appropriate to specialize on the second argument of PRINT-OBJECT because it is a higher-level function -- even when the first argument is a character or a string, it needs to format it in accordance with *PRINT-ESCAPE*. In order to make the meaning as obvious as possible, the names of the generic functions have been formed by prefixing "STREAM-" to the corresponding non-generic function. Having the generic input functions just return :EOF at end-of-file, with the higher-level functions handling the eof-error-p and eof-value arguments, simplifies the generic function interface and makes it more efficient by not needing to pass through those arguments. Note that the functions that use this convention can only return a character or integer as a stream element, so there is no possibility of ambiguity. Functions STREAM-LINE-COLUMN, STREAM-START-LINE-P, and STREAM-ADVANCE-TO-COLUMN may appear to be a reincarnation of the defeated proposal STREAM-INFO, but the motivation here is different. This interface needs to be defined if user-defined streams are to be able to be used by PPRINT and FORMAT ~T, which could be viewed as a separate question from whether the user can call then on system-defined streams. Current practice: No one currently supports exactly this proposal, but this is very similar to the stream interface used in CLUE. On descendants of the MIT Lisp Machine, streams can be implemented by users as either flavors, with methods to accept the various messages corresponding to the I/O operations, or as functions, which take a message keyword as their first argument. Examples: ;;;; Here is an example of how the default methods could be ;;;; implemented (omitting the most trivial ones): (defmethod STREAM-PEEK-CHAR ((stream fundamental-character-input-stream)) (let ((character (stream-read-char stream))) (unless (eq character :eof) (stream-unread-char stream character)) character)) (defmethod STREAM-LISTEN ((stream fundamental-character-input-stream)) (let ((char (stream-read-char-no-hang stream))) (and (not (null char)) (not (eq char :eof)) (progn (stream-unread-char stream char) t)))) (defmethod STREAM-READ-LINE ((stream fundamental-character-input-stream)) (let ((line (make-array 64 :element-type 'string-char :fill-pointer 0 :adjustable t))) (loop (let ((character (stream-read-char stream))) (if (eq character :eof) (return (values line t)) (if (eql character #\newline) (return (values line nil)) (vector-push-extend character line))))))) (defmethod STREAM-START-LINE-P ((stream fundamental-character-output-stream)) (equal (stream-line-column stream) 0)) (defmethod STREAM-WRITE-STRING ((stream fundamental-character-output-stream) string &optional (start 0) (end (length string))) (do ((i start (1+ i))) ((>= i end) string) (stream-write-char stream (char string i)))) (defmethod STREAM-TERPRI ((stream fundamental-character-output-stream)) (stream-write-char stream #\newline) nil) (defmethod STREAM-FRESH-LINE ((stream fundamental-character-output-stream)) (if (stream-start-line-p stream) nil (progn (stream-terpri stream) t))) (defmethod STREAM-ADVANCE-TO-COLUMN ((stream fundamental-character-output-stream) column) (let ((current (stream-line-column stream))) (unless (null current) (dotimes (i (- current column) t) (stream-write-char stream #\space))))) (defmethod INPUT-STREAM-P ((stream fundamental-input-stream)) t) (defmethod INPUT-STREAM-P ((stream fundamental-output-stream)) ;; allow the two classes to be mixed in either order (typep stream 'fundamental-input-stream)) (defmethod OUTPUT-STREAM-P ((stream fundamental-output-stream)) t) (defmethod OUTPUT-STREAM-P ((stream fundamental-input-stream)) (typep stream 'fundamental-output-stream)) ;;;; Following is an example of how the existing I/O functions could ;;;; be implemented using standard Common Lisp and the generic ;;;; functions specified above. The standard functions being defined ;;;; are in upper case. ;; Internal helper functions (proclaim '(inline decode-read-arg decode-print-arg check-for-eof)) (defun decode-read-arg (arg) (cond ((null arg) *standard-input*) ((eq arg t) *terminal-io*) (t arg))) (defun decode-print-arg (arg) (cond ((null arg) *standard-output*) ((eq arg t) *terminal-io*) (t arg))) (defun check-for-eof (value stream eof-errorp eof-value) (if (eq value :eof) (report-eof stream eof-errorp eof-value) value)) (defun report-eof (stream eof-errorp eof-value) (if eof-errorp (error 'end-of-file :stream stream) eof-value)) ;;; Common Lisp input functions (defun READ-CHAR (&optional input-stream (eof-errorp t) eof-value recursive-p) (declare (ignore recursive-p)) ; a mistake in CLtL? (let ((stream (decode-read-arg input-stream))) (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))) (defun PEEK-CHAR (&optional peek-type input-stream (eof-errorp t) eof-value recursive-p) (declare (ignore recursive-p)) (let ((stream (decode-read-arg input-stream))) (if (null peek-type) (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value) (loop (let ((value (stream-peek-char stream))) (if (eq value :eof) (return (report-eof stream eof-errorp eof-value)) (if (if (eq peek-type t) (not (member value '(#\space #\tab #\newline #\page #\return #\linefeed))) (char= peek-type value)) (return value) (stream-read-char stream)))))))) (defun UNREAD-CHAR (character &optional input-stream) (stream-unread-char (decode-read-arg input-stream) character)) (defun LISTEN (&optional input-stream) (stream-listen (decode-read-arg input-stream))) (defun READ-LINE (&optional input-stream (eof-error-p t) eof-value recursive-p) (declare (ignore recursive-p)) (let ((stream (decode-read-arg input-stream))) (multiple-value-bind (string eofp) (stream-read-line stream) (if eofp (if (= (length string) 0) (report-eof stream eof-error-p eof-value) (values string t)) (values string nil))))) (defun CLEAR-INPUT (&optional input-stream) (stream-clear-input (decode-read-arg input-stream))) (defun READ-CHAR-NO-HANG (&optional input-stream (eof-errorp t) eof-value recursive-p) (declare (ignore recursive-p)) (let ((stream (decode-read-arg input-stream))) (check-for-eof (stream-read-char-no-hang stream) stream eof-errorp eof-value))) ;;; Common Lisp output functions (defun WRITE-CHAR (character &optional output-stream) (stream-write-char (decode-print-arg output-stream) character)) (defun FRESH-LINE (&optional output-stream) (stream-fresh-line (decode-print-arg output-stream))) (defun TERPRI (&optional output-stream) (stream-terpri (decode-print-arg output-stream))) (defun WRITE-STRING (string &optional output-stream &key (start 0) end) (stream-write-string (decode-print-arg output-stream) string start end)) (defun WRITE-LINE (string &optional output-stream &key (start 0) end) (let ((stream (decode-print-arg output-stream))) (stream-write-string stream string start end) (stream-terpri stream) string)) (defun FORCE-OUTPUT (&optional stream) (stream-force-output (decode-print-arg stream))) (defun FINISH-OUTPUT (&optional stream) (stream-finish-output (decode-print-arg stream))) (defun CLEAR-OUTPUT (&optional stream) (stream-clear-output (decode-print-arg stream))) ;;; Binary streams (defun READ-BYTE (binary-input-stream &optional (eof-errorp t) eof-value) (check-for-eof (stream-read-byte binary-input-stream) binary-input-stream eof-errorp eof-value)) (defun WRITE-BYTE (integer binary-output-stream) (stream-write-byte binary-output-stream integer)) ;;; String streams (defclass string-input-stream (fundamental-character-input-stream) ((string :initarg :string :type string) (index :initarg :start :type fixnum) (end :initarg :end :type fixnum) )) (defun MAKE-STRING-INPUT-STREAM (string &optional (start 0) end) (make-instance 'string-input-stream :string string :start start :end (or end (length string)))) (defmethod stream-read-char ((stream string-input-stream)) (with-slots (index end string) stream (if (>= index end) :eof (prog1 (char string index) (incf index))))) (defmethod stream-unread-char ((stream string-input-stream) character) (with-slots (index end string) stream (decf index) (assert (eql (char string index) character)) nil)) (defmethod stream-read-line ((stream string-input-stream)) (with-slots (index end string) stream (let* ((endline (position #\newline string :start index :end end)) (line (subseq string index endline))) (if endline (progn (setq index (1+ endline)) (values line nil)) (progn (setq index end) (values line t)))))) (defclass string-output-stream (fundamental-character-output-stream) ((string :initform nil :initarg :string))) (defun MAKE-STRING-OUTPUT-STREAM () (make-instance 'string-output-stream)) (defun GET-OUTPUT-STREAM-STRING (stream) (with-slots (string) stream (if (null string) "" (prog1 string (setq string nil))))) (defmethod stream-write-char ((stream string-output-stream) character) (with-slots (string) stream (when (null string) (setq string (make-array 64. :element-type 'string-char :fill-pointer 0 :adjustable t))) (vector-push-extend character string) character)) (defmethod stream-line-column ((stream string-output-stream)) (with-slots (string) stream (if (null string) 0 (let ((nx (position #\newline string :from-end t))) (if (null nx) (length string) (- (length string) nx 1)) )))) Cost to Implementors: Given that CLOS is supported, adding the above generic functions and methods is easy, since most of the code is included in the examples above. The hard part would be re-writing existing I/O functionality in terms of methods on these new generic functions. That could be simplified if methods can be defined to forward the operations to the old representation of streams. For a new implementation, the cost could be zero since an approach similar to this would likely be used anyway. Cost to Users: None; this is an upward-compatible addition. Users won't even need to know anything about this unless they actually need this feature. Cost of non-adoption: Development of portable I/O extensions will be discouraged. Performance impact: This shouldn't affect performance of new implementations (assuming an efficient CLOS implementation), but it could slow down I/O if it were clumsily grafted on top of an existing implementation. Benefits: A broader domain of programs that can be written portably. Esthetics: This seems to be a simple, straight-forward approach. Discussion: This proposal incorporates suggestions made by several people in response to an earlier outline. So far, no one has expressed opposition to the concept. There are some differences of opinion about whether certain operations should have default methods or required methods: STREAM-LISTEN, STREAM-READ-CHAR-NO-HANG, STREAM-LINE-COLUMN, and STREAM-START-LINE-P. An experimental prototype of this has been successfully implemented on the Explorer. This proposal does not provide sufficient capability to implement forwarding streams such as for MAKE-SYNONYM-STREAM, MAKE-BROADCAST-STREAM, MAKE-CONCATENATED-STREAM, MAKE-TWO-WAY-STREAM, or MAKE-ECHO-STREAM. The generic function approach does not lend itself as well to that as a message passing model where the intermediary does not need to know what all the possible messages are. A possible way of extending it for that would be to define a class (defclass stream-generic-function (standard-generic-function) ()) to be used as the :generic-function-class option for all of the I/O generic functions. This would then permit doing something like (defmethod no-applicable-method ((gfun stream-generic-function) &rest args) (if (streamp (first args)) (apply #'stream-operation-not-handled (first args) gfun (rest args)) (call-next-method))) where stream-operation-not-handled is a generic function whose default method signals an error, but forwarding streams can define methods that will create a method to handle the unexpected operation. (Perhaps NO-APPLICABLE-METHOD should be changed to take two required arguments since all generic functions need at least one required argument, and that would make it unnecessary to define a new generic function class just to be able to write this one method.) Another thing that is not addressed here is a way to cause an instance of a user-defined stream class to be created from a call to the OPEN function. That should be part of a separate issue for generic functions on pathnames. If that capability were available, then PATHNAME and TRUENAME should be required to be generic functions. An earlier draft defined just two classes, FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-OUTPUT-STREAM, that were used for both character and binary streams. It isn't clear whether that simple approach is sufficient or whether the larger set of classes is really needed. From CL-Windows-mailer@SAIL.STANFORD.EDU Thu Mar 23 17:34:52 1989 Received: from Sail.Stanford.EDU by arisia with SMTP (5.59++/IDA-1.2.6) id AA02357; Thu, 23 Mar 89 17:34:52 PST Received: from ti.com by SAIL.Stanford.EDU with TCP; 23 Mar 89 09:08:32 PST Received: by ti.com id AA12307; Wed, 22 Mar 89 21:38:08 CST Received: from Kelvin by tilde id AA27213; Wed, 22 Mar 89 21:21:09 CST Message-Id: <2815615116-2334006@Kelvin> Sender: GRAY@Kelvin.csc.ti.com Date: Wed, 22 Mar 89 21:18:36 CST From: David N Gray To: CL-Cleanup@SAIL.STANFORD.EDU Cc: Common-Lisp-Object-System@SAIL.STANFORD.EDU, CL-Windows@SAIL.STANFORD.EDU, Bartley@MIPS.csc.ti.com, Waldrum@Tilde.csc.ti.com, salem@Think.COM Subject: Issue STREAM-DEFINITION-BY-USER (V1) Following is a more detailed write-up of the idea of a generic function I/O interface that allows users to create their own streams. I have put this in the format of a cleanup proposal because that seems like a good way of presenting the information, but I realize that the timing isn't right for including this in the standard now. Hopefully, though, this can be used as a guideline for implementors to avoid unnecessarily coming up with different names for the same thing, and after some experience has been gained, this feature could be considered for inclusion in a revision of the standard. I wanted to get this in your hands before the X3J13 meeting in case anyone was interested in discussing it, but I don't expect any official action to be taken. Issue: STREAM-DEFINITION-BY-USER References: CLtL pages 329-332, 378-381, and 384-385. Related issues: STREAM-INFO, CLOSED-STREAM-FUNCTIONS, STREAM-ACCESS, STREAM-CAPABILITIES Category: ADDITION Edit history: Version 1, 22-Mar-89 by David N. Gray Status: For discussion and evaluation; not proposed for inclusion in the standard at this time. Problem description: Common Lisp does not provide a standard way for users to define their own streams for use by the standard I/O functions. This impedes the development of window systems for Common Lisp because, while there are standard Common Lisp I/O functions and there are beginning to be standard window systems, there is no portable way to connect them together to make a portable Common Lisp window system. There are also many applications where users might want to define their own filter streams for doing things like printer device control, report formatting, character code translation, or encryption/decryption. Proposal STREAM-DEFINITION-BY-USER:GENERIC-FUNCTIONS Overview: Define a set of generic functions for performing I/O. These functions will have methods that specialize on the stream argument; they would be used by the existing I/O functions. Users could write additional methods for them in order to support their own stream classes. Define a set of classes to be used as the superclass of a stream class in order to provide some default methods. Classes: The following classes are to be used as super classes of user-defined stream classes. They are not intended to be directly instantiated; they just provide places to hang default methods. FUNDAMENTAL-STREAM [Class] This class is a subclass of STREAM and of STANDARD-OBJECT. STREAMP will return true for an instance of any class that includes this. (It may return true for some other things also.) FUNDAMENTAL-INPUT-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. Its inclusion causes INPUT-STREAM-P to return true. FUNDAMENTAL-OUTPUT-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. Its inclusion causes OUTPUT-STREAM-P to return true. Bi-direction streams may be formed by including both FUNDAMENTAL-OUTPUT-STREAM and FUNDAMENTAL-INPUT-STREAM. FUNDAMENTAL-CHARACTER-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. It provides a method for STREAM-ELEMENT-TYPE which returns CHARACTER. FUNDAMENTAL-BINARY-STREAM [Class] A subclass of FUNDAMENTAL-STREAM. Any instantiable class that includes this needs to define a method for STREAM-ELEMENT-TYPE. FUNDAMENTAL-CHARACTER-INPUT-STREAM [Class] Includes FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-CHARACTER-STREAM. It provides default methods for several generic functions used for character input. FUNDAMENTAL-CHARACTER-OUTPUT-STREAM [Class] Includes FUNDAMENTAL-OUTPUT-STREAM and FUNDAMENTAL-CHARACTER-STREAM. It provides default methods for several generic functions used for character output. FUNDAMENTAL-BINARY-INPUT-STREAM [Class] Includes FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-BINARY-STREAM. FUNDAMENTAL-BINARY-OUTPUT-STREAM [Class] Includes FUNDAMENTAL-OUTPUT-STREAM and FUNDAMENTAL-BINARY-STREAM. Character input: A character input stream can be created by defining a class that includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods for the generic functions below. STREAM-READ-CHAR stream [Generic Function] This reads one character from the stream. It returns either a character object, or the symbol :EOF if the stream is at end-of-file. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a method for this function. Note that for all of these generic functions, the stream argument must be a stream object, not T or NIL. STREAM-UNREAD-CHAR stream character [Generic Function] Un-does the last call to STREAM-READ-CHAR, as in UNREAD-CHAR. Returns NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a method for this function. STREAM-READ-CHAR-NO-HANG stream [Generic Function] This is used to implement READ-CHAR-NO-HANG. It returns either a character, or NIL if no input is currently available, or :EOF if end-of-file is reached. The default method provided by FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this is sufficient for file streams, but interactive streams should define their own method. STREAM-PEEK-CHAR stream [Generic Function] Used to implement PEEK-CHAR; this corresponds to peek-type of NIL. It returns either a character or :EOF. The default method calls STREAM-READ-CHAR and STREAM-UNREAD-CHAR. STREAM-LISTEN stream [Generic Function] Used by LISTEN. Returns true or false. The default method uses STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should define their own method since it will usually be trivial and will always be more efficient than the default method. STREAM-READ-LINE stream [Generic Function] Used by READ-LINE. A string is returned as the first value. The second value is true if the string was terminated by end-of-file instead of the end of a line. The default method uses repeated calls to STREAM-READ-CHAR. STREAM-CLEAR-INPUT stream [Generic Function] Implements CLEAR-INPUT for the stream, returning NIL. The default method does nothing. Character output: A character output stream can be created by defining a class that includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods for the generic functions below. STREAM-WRITE-CHAR stream character [Generic Function] Writes character to the stream and returns the character. Every subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method defined for this function. STREAM-LINE-COLUMN stream [Generic Function] This function returns the column number where the next character will be written, or NIL if that is not meaningful for this stream. The first column on a line is numbered 0. This function is used in the implementation of PPRINT and the FORMAT ~T directive. For every character output stream class that is defined, a method must be defined for this function, although it is permissible for it to always return NIL. STREAM-START-LINE-P stream [Generic Function] This is a predicate which returns T if the stream is positioned at the beginning of a line, else NIL. It is permissible to always return NIL. This is used in the implementation of FRESH-LINE. Note that while a value of 0 from STREAM-LINE-COLUMN also indicates the beginning of a line, there are cases where STREAM-START-LINE-P can be meaningfully implemented although STREAM-LINE-COLUMN can't be. For example, for a window using variable-width characters, the column number isn't very meaningful, but the beginning of the line does have a clear meaning. The default method for STREAM-START-LINE-P on class FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if that is defined to return NIL, then a method should be provided for either STREAM-START-LINE-P or STREAM-FRESH-LINE. STREAM-WRITE-STRING stream string &optional start end [Generic Function] This is used by WRITE-STRING. It writes the string to the stream, optionally delimited by start and end, which default to 0 and NIL. The string argument is returned. The default method provided by FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to STREAM-WRITE-CHAR. STREAM-TERPRI stream [Generic Function] Writes an end of line, as for TERPRI. Returns NIL. The default method does (STREAM-WRITE-CHAR stream #\NEWLINE). STREAM-FRESH-LINE stream [Generic Function] Used by FRESH-LINE. The default method uses STREAM-START-LINE-P and STREAM-TERPRI. STREAM-FINISH-OUTPUT stream [Generic Function] Implements FINISH-OUTPUT. The default method does nothing. STREAM-FORCE-OUTPUT stream [Generic Function] Implements FORCE-OUTPUT. The default method does nothing. STREAM-CLEAR-OUTPUT stream [Generic Function] Implements CLEAR-OUTPUT. The default method does nothing. STREAM-ADVANCE-TO-COLUMN stream column [Generic Function] Writes enough blank space so that the next character will be written at the specified column. Returns true if the operation is successful, or NIL if it is not supported for this stream. This is intended for use by by PPRINT and FORMAT ~T. The default method uses STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL. Other functions: CLOSE stream &key abort [Generic Function] The existing function CLOSE is redefined to be a generic function, but otherwise behaves the same. The default method provided by class FUNDAMENTAL-STREAM sets a flag for OPEN-STREAM-P. The value returned by CLOSE will be as specified by the issue CLOSED-STREAM-OPERATIONS. OPEN-STREAM-P stream [Generic Function] This function [from proposal STREAM-ACCESS] is made generic. A default method is provided by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been called on the stream. STREAMP object [Generic Function] INPUT-STREAM-P stream [Generic Function] OUTPUT-STREAM-P stream [Generic Function] These three existing predicates may optionally be implemented as generic functions for implementations that want to permit users to define streams that are not STANDARD-OBJECTs. Normally, the default methods provided by classes FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-OUTPUT-STREAM are sufficient. Note that, for example, (INPUT-STREAM-P x) is not equivalent to (TYPEP x 'FUNDAMENTAL-INPUT-STREAM) because implementations may have additional ways of defining their own streams even if they don't make that visible by making these predicates generic. STREAM-ELEMENT-TYPE stream [Generic Function] This existing function is made generic, but otherwise behaves the same. Class FUNDAMENTAL-CHARACTER-STREAM provides a default method which returns CHARACTER. PATHNAME and TRUENAME are also permitted to be implemented as generic functions. There is no default method since these are not valid for all streams. Binary streams: Binary streams can be created by defining a class that includes either FUNDAMENTAL-BINARY-INPUT-STREAM or FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method for STREAM-ELEMENT-TYPE and for one or both of the following generic functions. STREAM-READ-BYTE stream [Generic Function] Used by READ-BYTE; returns either an integer, or the symbol :EOF if the stream is at end-of-file. STREAM-WRITE-BYTE stream integer [Generic Function] Implements WRITE-BYTE; writes the integer to the stream and returns the integer as the result. Rationale: The existing I/O functions cannot be made generic because, in nearly every case, the stream argument is optional, and therefore cannot be specialized. Therefore, it is necessary to define a lower-level generic function to be used by the existing function. It also isn't appropriate to specialize on the second argument of PRINT-OBJECT because it is a higher-level function -- even when the first argument is a character or a string, it needs to format it in accordance with *PRINT-ESCAPE*. In order to make the meaning as obvious as possible, the names of the generic functions have been formed by prefixing "STREAM-" to the corresponding non-generic function. Having the generic input functions just return :EOF at end-of-file, with the higher-level functions handling the eof-error-p and eof-value arguments, simplifies the generic function interface and makes it more efficient by not needing to pass through those arguments. Note that the functions that use this convention can only return a character or integer as a stream element, so there is no possibility of ambiguity. Functions STREAM-LINE-COLUMN, STREAM-START-LINE-P, and STREAM-ADVANCE-TO-COLUMN may appear to be a reincarnation of the defeated proposal STREAM-INFO, but the motivation here is different. This interface needs to be defined if user-defined streams are to be able to be used by PPRINT and FORMAT ~T, which could be viewed as a separate question from whether the user can call then on system-defined streams. Current practice: No one currently supports exactly this proposal, but this is very similar to the stream interface used in CLUE. On descendants of the MIT Lisp Machine, streams can be implemented by users as either flavors, with methods to accept the various messages corresponding to the I/O operations, or as functions, which take a message keyword as their first argument. Examples: ;;;; Here is an example of how the default methods could be ;;;; implemented (omitting the most trivial ones): (defmethod STREAM-PEEK-CHAR ((stream fundamental-character-input-stream)) (let ((character (stream-read-char stream))) (unless (eq character :eof) (stream-unread-char stream character)) character)) (defmethod STREAM-LISTEN ((stream fundamental-character-input-stream)) (let ((char (stream-read-char-no-hang stream))) (and (not (null char)) (not (eq char :eof)) (progn (stream-unread-char stream char) t)))) (defmethod STREAM-READ-LINE ((stream fundamental-character-input-stream)) (let ((line (make-array 64 :element-type 'string-char :fill-pointer 0 :adjustable t))) (loop (let ((character (stream-read-char stream))) (if (eq character :eof) (return (values line t)) (if (eql character #\newline) (return (values line nil)) (vector-push-extend character line))))))) (defmethod STREAM-START-LINE-P ((stream fundamental-character-output-stream)) (equal (stream-line-column stream) 0)) (defmethod STREAM-WRITE-STRING ((stream fundamental-character-output-stream) string &optional (start 0) (end (length string))) (do ((i start (1+ i))) ((>= i end) string) (stream-write-char stream (char string i)))) (defmethod STREAM-TERPRI ((stream fundamental-character-output-stream)) (stream-write-char stream #\newline) nil) (defmethod STREAM-FRESH-LINE ((stream fundamental-character-output-stream)) (if (stream-start-line-p stream) nil (progn (stream-terpri stream) t))) (defmethod STREAM-ADVANCE-TO-COLUMN ((stream fundamental-character-output-stream) column) (let ((current (stream-line-column stream))) (unless (null current) (dotimes (i (- current column) t) (stream-write-char stream #\space))))) (defmethod INPUT-STREAM-P ((stream fundamental-input-stream)) t) (defmethod INPUT-STREAM-P ((stream fundamental-output-stream)) ;; allow the two classes to be mixed in either order (typep stream 'fundamental-input-stream)) (defmethod OUTPUT-STREAM-P ((stream fundamental-output-stream)) t) (defmethod OUTPUT-STREAM-P ((stream fundamental-input-stream)) (typep stream 'fundamental-output-stream)) ;;;; Following is an example of how the existing I/O functions could ;;;; be implemented using standard Common Lisp and the generic ;;;; functions specified above. The standard functions being defined ;;;; are in upper case. ;; Internal helper functions (proclaim '(inline decode-read-arg decode-print-arg check-for-eof)) (defun decode-read-arg (arg) (cond ((null arg) *standard-input*) ((eq arg t) *terminal-io*) (t arg))) (defun decode-print-arg (arg) (cond ((null arg) *standard-output*) ((eq arg t) *terminal-io*) (t arg))) (defun check-for-eof (value stream eof-errorp eof-value) (if (eq value :eof) (report-eof stream eof-errorp eof-value) value)) (defun report-eof (stream eof-errorp eof-value) (if eof-errorp (error 'end-of-file :stream stream) eof-value)) ;;; Common Lisp input functions (defun READ-CHAR (&optional input-stream (eof-errorp t) eof-value recursive-p) (declare (ignore recursive-p)) ; a mistake in CLtL? (let ((stream (decode-read-arg input-stream))) (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))) (defun PEEK-CHAR (&optional peek-type input-stream (eof-errorp t) eof-value recursive-p) (declare (ignore recursive-p)) (let ((stream (decode-read-arg input-stream))) (if (null peek-type) (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value) (loop (let ((value (stream-peek-char stream))) (if (eq value :eof) (return (report-eof stream eof-errorp eof-value)) (if (if (eq peek-type t) (not (member value '(#\space #\tab #\newline #\page #\return #\linefeed))) (char= peek-type value)) (return value) (stream-read-char stream)))))))) (defun UNREAD-CHAR (character &optional input-stream) (stream-unread-char (decode-read-arg input-stream) character)) (defun LISTEN (&optional input-stream) (stream-listen (decode-read-arg input-stream))) (defun READ-LINE (&optional input-stream (eof-error-p t) eof-value recursive-p) (declare (ignore recursive-p)) (let ((stream (decode-read-arg input-stream))) (multiple-value-bind (string eofp) (stream-read-line stream) (if eofp (if (= (length string) 0) (report-eof stream eof-error-p eof-value) (values string t)) (values string nil))))) (defun CLEAR-INPUT (&optional input-stream) (stream-clear-input (decode-read-arg input-stream))) (defun READ-CHAR-NO-HANG (&optional input-stream (eof-errorp t) eof-value recursive-p) (declare (ignore recursive-p)) (let ((stream (decode-read-arg input-stream))) (check-for-eof (stream-read-char-no-hang stream) stream eof-errorp eof-value))) ;;; Common Lisp output functions (defun WRITE-CHAR (character &optional output-stream) (stream-write-char (decode-print-arg output-stream) character)) (defun FRESH-LINE (&optional output-stream) (stream-fresh-line (decode-print-arg output-stream))) (defun TERPRI (&optional output-stream) (stream-terpri (decode-print-arg output-stream))) (defun WRITE-STRING (string &optional output-stream &key (start 0) end) (stream-write-string (decode-print-arg output-stream) string start end)) (defun WRITE-LINE (string &optional output-stream &key (start 0) end) (let ((stream (decode-print-arg output-stream))) (stream-write-string stream string start end) (stream-terpri stream) string)) (defun FORCE-OUTPUT (&optional stream) (stream-force-output (decode-print-arg stream))) (defun FINISH-OUTPUT (&optional stream) (stream-finish-output (decode-print-arg stream))) (defun CLEAR-OUTPUT (&optional stream) (stream-clear-output (decode-print-arg stream))) ;;; Binary streams (defun READ-BYTE (binary-input-stream &optional (eof-errorp t) eof-value) (check-for-eof (stream-read-byte binary-input-stream) binary-input-stream eof-errorp eof-value)) (defun WRITE-BYTE (integer binary-output-stream) (stream-write-byte binary-output-stream integer)) ;;; String streams (defclass string-input-stream (fundamental-character-input-stream) ((string :initarg :string :type string) (index :initarg :start :type fixnum) (end :initarg :end :type fixnum) )) (defun MAKE-STRING-INPUT-STREAM (string &optional (start 0) end) (make-instance 'string-input-stream :string string :start start :end (or end (length string)))) (defmethod stream-read-char ((stream string-input-stream)) (with-slots (index end string) stream (if (>= index end) :eof (prog1 (char string index) (incf index))))) (defmethod stream-unread-char ((stream string-input-stream) character) (with-slots (index end string) stream (decf index) (assert (eql (char string index) character)) nil)) (defmethod stream-read-line ((stream string-input-stream)) (with-slots (index end string) stream (let* ((endline (position #\newline string :start index :end end)) (line (subseq string index endline))) (if endline (progn (setq index (1+ endline)) (values line nil)) (progn (setq index end) (values line t)))))) (defclass string-output-stream (fundamental-character-output-stream) ((string :initform nil :initarg :string))) (defun MAKE-STRING-OUTPUT-STREAM () (make-instance 'string-output-stream)) (defun GET-OUTPUT-STREAM-STRING (stream) (with-slots (string) stream (if (null string) "" (prog1 string (setq string nil))))) (defmethod stream-write-char ((stream string-output-stream) character) (with-slots (string) stream (when (null string) (setq string (make-array 64. :element-type 'string-char :fill-pointer 0 :adjustable t))) (vector-push-extend character string) character)) (defmethod stream-line-column ((stream string-output-stream)) (with-slots (string) stream (if (null string) 0 (let ((nx (position #\newline string :from-end t))) (if (null nx) (length string) (- (length string) nx 1)) )))) Cost to Implementors: Given that CLOS is supported, adding the above generic functions and methods is easy, since most of the code is included in the examples above. The hard part would be re-writing existing I/O functionality in terms of methods on these new generic functions. That could be simplified if methods can be defined to forward the operations to the old representation of streams. For a new implementation, the cost could be zero since an approach similar to this would likely be used anyway. Cost to Users: None; this is an upward-compatible addition. Users won't even need to know anything about this unless they actually need this feature. Cost of non-adoption: Development of portable I/O extensions will be discouraged. Performance impact: This shouldn't affect performance of new implementations (assuming an efficient CLOS implementation), but it could slow down I/O if it were clumsily grafted on top of an existing implementation. Benefits: A broader domain of programs that can be written portably. Esthetics: This seems to be a simple, straight-forward approach. Discussion: This proposal incorporates suggestions made by several people in response to an earlier outline. So far, no one has expressed opposition to the concept. There are some differences of opinion about whether certain operations should have default methods or required methods: STREAM-LISTEN, STREAM-READ-CHAR-NO-HANG, STREAM-LINE-COLUMN, and STREAM-START-LINE-P. An experimental prototype of this has been successfully implemented on the Explorer. This proposal does not provide sufficient capability to implement forwarding streams such as for MAKE-SYNONYM-STREAM, MAKE-BROADCAST-STREAM, MAKE-CONCATENATED-STREAM, MAKE-TWO-WAY-STREAM, or MAKE-ECHO-STREAM. The generic function approach does not lend itself as well to that as a message passing model where the intermediary does not need to know what all the possible messages are. A possible way of extending it for that would be to define a class (defclass stream-generic-function (standard-generic-function) ()) to be used as the :generic-function-class option for all of the I/O generic functions. This would then permit doing something like (defmethod no-applicable-method ((gfun stream-generic-function) &rest args) (if (streamp (first args)) (apply #'stream-operation-not-handled (first args) gfun (rest args)) (call-next-method))) where stream-operation-not-handled is a generic function whose default method signals an error, but forwarding streams can define methods that will create a method to handle the unexpected operation. (Perhaps NO-APPLICABLE-METHOD should be changed to take two required arguments since all generic functions need at least one required argument, and that would make it unnecessary to define a new generic function class just to be able to write this one method.) Another thing that is not addressed here is a way to cause an instance of a user-defined stream class to be created from a call to the OPEN function. That should be part of a separate issue for generic functions on pathnames. If that capability were available, then PATHNAME and TRUENAME should be required to be generic functions. An earlier draft defined just two classes, FUNDAMENTAL-INPUT-STREAM and FUNDAMENTAL-OUTPUT-STREAM, that were used for both character and binary streams. It isn't clear whether that simple approach is sufficient or whether the larger set of classes is really needed. From Owners-Commonloops.pa@Xerox.COM Fri Mar 24 11:31:07 1989 Received: from Xerox.COM by arisia with SMTP (5.59++/IDA-1.2.6) id AA15842; Fri, 24 Mar 89 11:31:07 PST Received: from Chardonnay.ms by ArpaGateway.ms ; 24 MAR 89 11:31:03 PST Return-Path: Redistributed: Commonloops.pa Received: from porthos.rutgers.edu ([128.6.25.3]) by Xerox.COM ; 24 MAR 89 11:28:42 PST Received: by porthos.rutgers.edu (5.59/SMI4.0/RU1.1/3.04) id AA14721; Fri, 24 Mar 89 14:28:36 EST Date: Fri, 24 Mar 89 14:28:33 EST From: Gadi Reply-To: friedman@aramis.rutgers.edu To: Commonloops.pa@Xerox.COM Subject: Changing slot class Message-Id: Is a rough draft of Chapter 3 available yet? I would like to know if it will be possible to change the class of a slot from STANDARD-SLOT-DESCRIPTION. I Would like to be able to maintain more information about my slots, such as a cardinality, and valueclass, prevous value, etc. I know I can store Instances in my slots that will contain all the information, but I will have to write all my own access functions. Gadi From Owners-Commonloops.pa@Xerox.COM Tue Mar 28 14:49:17 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA14413; Tue, 28 Mar 89 14:49:17 PST Received: from Semillon.ms by ArpaGateway.ms ; 28 MAR 89 12:48:56 PST Return-Path: Redistributed: Commonloops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 28 MAR 89 12:44:32 PST To: friedman@aramis.rutgers.edu Cc: Commonloops.pa@Xerox.COM Subject: Re: Changing slot class In-Reply-To: Your message of Fri, 24 Mar 89 14:28:33 -0500. Date: Tue, 28 Mar 89 15:21:13 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890328-124856-1291@Xerox> Date: Fri, 24 Mar 89 14:28:33 EST From: Gadi Reply-To: friedman@aramis.rutgers.edu To: Commonloops.pa@xerox.com Subject: Changing slot class Message-Id: Is a rough draft of Chapter 3 available yet? No. There are old drafts, but you don't want them. I would like to know if it will be possible to change the class of a slot from STANDARD-SLOT-DESCRIPTION. I Would like to be able to maintain more information about my slots, such as a cardinality, and valueclass, prevous value, etc. I know I can store Instances in my slots that will contain all the information, but I will have to write all my own access functions. Gadi Well, the metaclass has control of the slots, so it is fairly straight forward to add features onto the slot descriptions. Basically, you need a metaclass that uses the new slot descriptions: (defclass new-class (standard-class) ()) (defclass new-slotd (standard-slot-description) (... your new slots ...)) (defmethod make-slotd ((class new-class) &rest keywords-and-options) (apply #'*make-instance 'new-slotd keywords-and-options)) (defmethod legal-slotd-option-p ((class new-class) key) ...) Now classes you define with new-class as their metaclass will have the new kind of slot description. This can basically give your slots "facets" that are shared by each instance of a class. Each instance, will still have only a local slot value in the instance. If you want to let each instance have a set of facets for each slot, you'll have to do a bit more work. k From Owners-CommonLoops.pa@Xerox.COM Tue Mar 28 14:53:46 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA14512; Tue, 28 Mar 89 14:53:46 PST Received: from Cabernet.ms by ArpaGateway.ms ; 28 MAR 89 13:49:23 PST Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 28 MAR 89 13:47:13 PST To: CommonLoops.pa@Xerox.COM Cc: kanderson@DINO.BBN.COM Subject: qualifier are non-nil-atoms bug Date: Tue, 28 Mar 89 16:58:05 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890328-134923-1475@Xerox> Here are to simple patches. The clos spec says qualifiers are non-nil-atoms but PCL used SYMBOLP rather than ATOM. ;;; Patch 3600-low.lisp (si:define-function-spec-handler method (op spec &optional arg1 arg2) (if (eq op 'sys:validate-function-spec) (and (let ((gspec (cadr spec))) (or (symbolp gspec) (and (listp gspec) (eq (car gspec) 'setf) (symbolp (cadr gspec)) (null (cddr gspec))))) (let ((tail (cddr spec))) (loop (cond ((null tail) (return nil)) ((listp (car tail)) (return t)) ((atom (pop tail))) (t (return nil)))))) (let ((meth (and (listp spec) (and (fboundp 'generic-function-p) (generic-function-p #'add-method)) (multiple-value-bind (ignore method) (parse-method-or-spec (cdr spec) nil) method)))) (method-definition-handler-1 op spec meth arg1 arg2)))) ;;; patch BOOT.LISP (defun parse-defmethod (cdr-of-form) (declare (values name qualifiers specialized-lambda-list body)) (let ((name (pop cdr-of-form)) (qualifiers ()) (spec-ll ())) (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) (push (pop cdr-of-form) qualifiers) (return (setq qualifiers (nreverse qualifiers))))) (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) From Owners-CommonLoops.pa@Xerox.COM Wed Mar 29 10:09:13 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA02411; Wed, 29 Mar 89 10:09:13 PST Received: from Salvador.ms by ArpaGateway.ms ; 29 MAR 89 07:52:28 PST Return-Path: <@CUNYVM.CUNY.EDU:K320440@AEARN.BITNET> Redistributed: CommonLoops.pa Received: from CUNYVM.CUNY.EDU ([128.228.1.2]) by Xerox.COM ; 29 MAR 89 07:49:39 PST Received: from AEARN.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.1) with BSMTP id 5886; Wed, 29 Mar 89 10:49:30 EST Received: by AEARN (Mailer X1.25) id 4601; Wed, 29 Mar 89 16:14:07 EDT Date: Wed, 29 Mar 89 16:09:20 EDT From: Wilhelm Burger Subject: slot list To: CommonLoops.pa@Xerox.COM Message-Id: <890329-075228-3325@Xerox> Why is the function pcl::class-slots not exported by PCL and not provided by the CLOS specifications at all? I don't see how someone could write generic class browsers, printers ... without it. W.Burger Johannes Kepler University A-4045 Linz, Austria From Owners-CommonLoops.pa@Xerox.COM Wed Mar 29 14:15:00 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA06662; Wed, 29 Mar 89 14:15:00 PST Received: from Chardonnay.ms by ArpaGateway.ms ; 29 MAR 89 14:10:47 PST Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 29 MAR 89 14:04:57 PST To: CommonLoops.pa@Xerox.COM Cc: kanderson@DINO.BBN.COM Subject: with-slots bug? Date: Wed, 29 Mar 89 16:10:43 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890329-141047-4374@Xerox> Here's an example of where WITH-SLOTS does not seems to follow the scoping rules in the spec. (pcl:defclass point () ((x :initform 0) (y :initform 0))) (pcl:defmethod move ((point point) new-x new-y) (with-slots (x y) point (flet ((f (x) (* x 2))) ; X treated as (slot-value point 'x) here. (setf x (f new-x) y (f new-y))))) From Owners-CommonLoops.pa@Xerox.COM Thu Mar 30 12:48:32 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA25176; Thu, 30 Mar 89 12:48:32 PST Received: from Cabernet.ms by ArpaGateway.ms ; 30 MAR 89 11:31:41 PST Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 30 MAR 89 11:29:12 PST To: CommonLoops.pa@Xerox.COM Cc: kanderson@DINO.BBN.COM Subject: bug in change class of a class Date: Thu, 30 Mar 89 14:37:08 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890330-113141-6460@Xerox> ;;; ;;; Patch std-class.lisp ;;; KRA 89/3/30: Let class-change happen if the metaclass of a class changes. ;;; Previously when you redefined a class to have a new metaclass, the ;;; metaclass didn't change. (defmethod class-for-redefinition ((old-class standard-class) (proto-class standard-class) name local-supers local-slot-slotds extra) (declare (ignore name local-supers local-slot-slotds extra)) (UNLESS (EQ (CLASS-OF OLD-CLASS) (CLASS-OF PROTO-CLASS)) (CHANGE-CLASS OLD-CLASS (CLASS-OF PROTO-CLASS))) old-class) From Owners-commonloops.pa@Xerox.COM Thu Mar 30 12:51:38 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA25193; Thu, 30 Mar 89 12:51:38 PST Received: from Cabernet.ms by ArpaGateway.ms ; 30 MAR 89 11:48:18 PST Return-Path: Redistributed: commonloops.pa Received: from vaxa.isi.edu ([128.9.0.33]) by Xerox.COM ; 30 MAR 89 11:46:34 PST Posted-Date: Thu, 30 Mar 89 11:45:43 PST Message-Id: <8903301945.AA25251@vaxa.isi.edu> Received: from LOCALHOST by vaxa.isi.edu (5.59/5.51) id AA25251; Thu, 30 Mar 89 11:45:48 PST To: commonloops.pa@Xerox.COM From: goldman@vaxa.isi.edu Subject: WITH-SLOTS Cc: kanderso@dino.bbn.com Date: Thu, 30 Mar 89 11:45:43 PST Sender: goldman@vaxa.isi.edu Are there ANY cases in which PCL's WITH-SLOTS macro respects inner lexical bindings of symbols that are used in the list of slots? If you look at EXPAND-WITH-SLOTS-INTERNAL, there is no apparent check of the lexical context before transforming a symbol. (There is not even a parameter of EXPAND-WITH-SLOTS-INTERNAL to represent the lexical context, although concievably that is being kept around in special variables by the code walker). neil From Owners-commonloops.pa@Xerox.COM Thu Mar 30 13:43:44 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA26009; Thu, 30 Mar 89 13:43:44 PST Received: from Salvador.ms by ArpaGateway.ms ; 30 MAR 89 13:05:14 PST Return-Path: Redistributed: commonloops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 30 MAR 89 13:03:15 PST To: goldman@vaxa.isi.edu Cc: commonloops.pa@Xerox.COM Subject: Re: WITH-SLOTS In-Reply-To: Your message of Thu, 30 Mar 89 11:45:43 -0800. <8903301945.AA25251@vaxa.isi.edu> Date: Thu, 30 Mar 89 16:07:42 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890330-130514-6737@Xerox> Posted-Date: Thu, 30 Mar 89 11:45:43 PST Message-Id: <8903301945.AA25251@vaxa.isi.edu> Received: from LOCALHOST by vaxa.isi.edu (5.59/5.51) id AA25251; Thu, 30 Mar 89 11:45:48 PST To: commonloops.pa@xerox.com From: goldman@vaxa.isi.edu Subject: WITH-SLOTS Cc: kanderso@dino.bbn.com Date: Thu, 30 Mar 89 11:45:43 PST Sender: goldman@vaxa.isi.edu Are there ANY cases in which PCL's WITH-SLOTS macro respects inner lexical bindings of symbols that are used in the list of slots? Unfortunately, no. If you look at EXPAND-WITH-SLOTS-INTERNAL, there is no apparent check of the lexical context before transforming a symbol. (There is not even a parameter of EXPAND-WITH-SLOTS-INTERNAL to represent the lexical context, although concievably that is being kept around in special variables by the code walker). I presume checks for lexical bindings should be added. neil From Owners-CommonLoops.pa@Xerox.COM Fri Mar 31 09:47:47 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA12991; Fri, 31 Mar 89 09:47:47 PST Received: from Riesling.ms by ArpaGateway.ms ; 31 MAR 89 09:11:48 PST Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 31 MAR 89 09:09:33 PST To: CommonLoops.pa@Xerox.COM Cc: kanderson@DINO.BBN.COM, aboulanger@DINO.BBN.COM Subject: Avoid method cache locking Date: Fri, 31 Mar 89 12:19:20 -0500 From: kanderso@DINO.BBN.COM Message-Id: <890331-091148-8837@Xerox> I'd like to propose the PCL not lock its method caches. Background: When you call a generic function, it must find the effective method to run. Effective methods are stored in a cache indexed by the class wrappers of the specialized arguments. When the lookup is done, the cache is locked so that only 1 process can access the cache at the same time. This is because PCL rearranges the cache to make sure that the looked up effective-method will be found easily next time. I'd like to argue that locking the cache (and thus reorganizing it) is the wrong thing to do in a LISP with multiple processes. On the Symbolics machine, we have gotten the discrimination code down to a minimum of 37 instructions. It turns out that 25% of this time is spent in the 3 instructions that make up WITHOUT-INTERRUPTS. Thus avoiding locking would speed up PCL by 25%. On a parallel machine, like the BBN Butterfly, locking mega loozer because if multiple processes are running the same method, they would all have to line up and take turns. So, i'd like to propose that the current caching mechanism be replaced with one that builds the complete cache and never changes it unless a method is redefined. This may make the caches bigger, (but each implementation could trade time for space as it saw fit) but it would produce faster descriminators, and perhaps smaller descriminators as well. k From CL-Compiler-mailer@SAIL.STANFORD.EDU Mon Apr 3 14:28:00 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA04007; Mon, 3 Apr 89 14:28:00 PDT Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 3 Apr 89 14:21:20 PDT Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA24104; Mon, 3 Apr 89 15:21:15 -0600 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA18470; Mon, 3 Apr 89 15:21:13 -0600 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8904032121.AA18470@defun.utah.edu> Date: Mon, 3 Apr 89 15:21:11 MDT Subject: issue COMPILE-ENVIRONMENT-CONSISTENCY To: cl-compiler@SAIL.STANFORD.EDU Cc: common-lisp-object-system@SAIL.STANFORD.EDU At the meeting, an amendment was proposed to this issue to replace all of the current item (g) with: The compiler can assume that type definitions made with DEFTYPE or DEFSTRUCT in the compiletime environment will retain the same definition in the runtime environment. This implies that subtype/supertype relationships of type specifiers defined by DEFTYPE or DEFSTRUCT will not change between compiletime and runtime. (Note that it is not an error for an unknown type to appear in a declaration at compiletime, although it is reasonable for the compiler to emit a warning in such a case.) The proposal was tabled with this amendment pending (it was not officially seconded or voted on). Having had time to think about this for a while, to me it seems like this amendment is going to cause trouble. I've been thinking about our canonical example of a type-inferencing preprocessor. Such a preprocessor could conceivably be written so as not make use of information about certain type relationships, provided that it is possible to test whether a type specifier is one of the ones that it can't make assumptions about. That's the real problem: given a type specifier, how do you know whether it was defined with DEFTYPE or DEFSTRUCT, or some other way? Also, one might want to define a metaclass that does license the compiler to make assumptions about the type hierarchy of its instance classes not changing. (In fact, I think this would be a rather common extension.) I wouldn't object to rewording the amendment so that the compiler is permitted to make assumptions about all type specifiers except those that name classes whose metaclass is (a subclass of) STANDARD-CLASS. It's at least possible (although a little convoluted) to test for that. What do the rest of you think about this? -Sandra ------- From CL-Compiler-mailer@SAIL.STANFORD.EDU Mon Apr 3 14:58:43 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA06624; Mon, 3 Apr 89 14:58:43 PDT Received: from STONY-BROOK.SCRC.Symbolics.COM (SCRC-STONY-BROOK.ARPA) by SAIL.Stanford.EDU with TCP; 3 Apr 89 14:53:10 PDT Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 570544; Mon 3-Apr-89 17:52:13 EDT Date: Mon, 3 Apr 89 17:52 EDT From: David A. Moon Subject: issue COMPILE-ENVIRONMENT-CONSISTENCY To: Sandra J Loosemore Cc: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: <8904032121.AA18470@defun.utah.edu> Message-Id: <19890403215202.7.MOON@EUPHRATES.SCRC.Symbolics.COM> What do the rest of you think about this? I think you're pointing in the right direction, however there is a problem. Any specification in terms of the metaclass requires that class objects be created at compile time by COMPILE-FILE, or there is no reasonable way to find out at compile time what the metaclass is. CLOS-MACRO-COMPILATION (which you wrote) seems to be trying to avoid requiring any compile-time objects to be created. So we have a conflict between two proposals. In fact it's possible that the metaclass is the wrong way to say "this class will not be redefined later" and instead that should be said by the way that the program is compiled, not by anything in the program, making it an environment issue rather than a language issue. An interesting question is whether this type-inferencing preprocessor is supposed to be able to accept all conforming programs, or only a subset of conforming programs subject to additional restrictions, for example that class definitions in the program are not changed between preprocess time and run time. Saying that we have two languages, the full language and the type-inferencing preprocessable subset, might eliminate the conflict here (although it will likely make Gabriel sound off). From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Mon Apr 3 15:10:34 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA06707; Mon, 3 Apr 89 15:10:34 PDT Received: from lucid.com by SAIL.Stanford.EDU with TCP; 3 Apr 89 15:10:36 PDT Received: from challenger ([192.9.200.17]) by heavens-gate.lucid.com id AA15372g; Mon, 3 Apr 89 15:04:47 PDT Received: by challenger id AA05980g; Mon, 3 Apr 89 14:59:57 PDT Date: Mon, 3 Apr 89 14:59:57 PDT From: Patrick Dussud Message-Id: <8904032159.AA05980@challenger> To: sandra%defun@cs.utah.edu Cc: cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU In-Reply-To: Sandra J Loosemore's message of Mon, 3 Apr 89 15:21:11 MDT <8904032121.AA18470@defun.utah.edu> Subject: issue COMPILE-ENVIRONMENT-CONSISTENCY From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Date: Mon, 3 Apr 89 15:21:11 MDT At the meeting, an amendment was proposed to this issue to replace all of the current item (g) with: The compiler can assume that type definitions made with DEFTYPE or DEFSTRUCT in the compiletime environment will retain the same definition in the runtime environment. This implies that subtype/supertype relationships of type specifiers defined by DEFTYPE or DEFSTRUCT will not change between compiletime and runtime. (Note that it is not an error for an unknown type to appear in a declaration at compiletime, although it is reasonable for the compiler to emit a warning in such a case.) The proposal was tabled with this amendment pending (it was not officially seconded or voted on). Also, one might want to define a metaclass that does license the compiler to make assumptions about the type hierarchy of its instance classes not changing. (In fact, I think this would be a rather common extension.) I wouldn't object to rewording the amendment so that the compiler is permitted to make assumptions about all type specifiers except those that name classes whose metaclass is (a subclass of) STANDARD-CLASS. It's at least possible (although a little convoluted) to test for that. What do the rest of you think about this? When we drafted the amendment, I was thinking of specifying the behavior of conforming programs. Precisely, I think that it provides an answer to the following question: What kinds of consistency should the programmer preserve, from compile-file to load? with the understanding that these constraints of consistency are dictated by the compiler. What we are proposing, is that in the general case, the user is free to redefine the class between compile-file and load. In this sense, the situation you describe has little bearing. I your case, the kind of consistency that the programmer has to maintain is dictated by the metaclass, not by the compiler. If compile-file can take advantage of this restriction, fine. I don't think that an implementation doing just that would violate the proposal as amended. Your first question about type-inference preprocessor touches more on compile-time meta-object creation, or syntatic-environment access. I understand the problem, I don't know what is the best solution. I personally lean towards extending the syntactic environment access, because we don't want to specify that metaobject should be instantiated at compile time. Patrick. From CL-Compiler-mailer@SAIL.STANFORD.EDU Mon Apr 3 16:09:16 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA07652; Mon, 3 Apr 89 16:09:16 PDT Received: from cs.utah.edu by SAIL.Stanford.EDU with TCP; 3 Apr 89 16:03:05 PDT Received: from defun.utah.edu by cs.utah.edu (5.61/utah-2.1-cs) id AA00322; Mon, 3 Apr 89 17:03:00 -0600 Received: by defun.utah.edu (5.61/utah-2.0-leaf) id AA18576; Mon, 3 Apr 89 17:02:54 -0600 From: sandra%defun@cs.utah.edu (Sandra J Loosemore) Message-Id: <8904032302.AA18576@defun.utah.edu> Date: Mon, 3 Apr 89 17:02:53 MDT Subject: Re: issue COMPILE-ENVIRONMENT-CONSISTENCY To: cl-compiler@SAIL.STANFORD.EDU Cc: common-lisp-object-system@SAIL.STANFORD.EDU > Date: Mon, 3 Apr 89 17:52 EDT > From: David A. Moon > > CLOS-MACRO-COMPILATION (which you wrote) seems to be trying to > avoid requiring any compile-time objects to be created. So we have > a conflict between two proposals. Right. In fact, I had such potential conflicts in the back of my mind when I decided to keep CLOS-MACRO-COMPILATION on hold until we got a better handle on how to resolve this issue. > Date: Mon, 3 Apr 89 14:59:57 PDT > From: Patrick Dussud > > Your first question about type-inference preprocessor touches more on > compile-time meta-object creation, or syntatic-environment access. I > understand the problem, I don't know what is the best solution. I personally > lean towards extending the syntactic environment access, because we don't want > to specify that metaobject should be instantiated at compile time. The idea behind such a preprocessor is that it would preserve the semantics of the code it examines. It shouldn't make any assumptions about types that the compiler itself would not be able to make. I agree that extending SYNTACTIC-ENVIRONMENT-ACCESS would be a reasonable solution to the problem. In particular, I remember hearing suggestions in the past to add TYPE-EXPAND and TYPE-EXPAND-1 functions, that would at least take care of the problems relating to DEFTYPE. (The interesting thing about DEFTYPE as it relates to this problem is not determinining whether a type specifier has been defined with DEFTYPE, but rather what that DEFTYPE expands into.) I don't think that not having a metaclass for a STANDARD-CLASS object defined at compile-time is a serious problem. If there's no metaclass around, that would just indicate that you can't make any assumptions about the type, the same as if it were not defined at all. (In fact, I think it would be consistent if DEFCLASS didn't make the corresponding type specifier defined at compile-time either.) Is it unreasonable to require that DEFSTRUCT make the metaclass be defined at compile-time? -Sandra ------- From Bobrow.pa@Xerox.COM Mon Apr 3 22:56:32 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA14364; Mon, 3 Apr 89 22:56:32 PDT Received: from Semillon.ms by ArpaGateway.ms ; 03 APR 89 13:48:56 PDT Date: 3 Apr 89 13:37 PDT From: Danny Bobrow Subject: Re: Avoid method cache locking In-Reply-To: kanderso@DINO.BBN.COM's message of Fri, 31 Mar 89 12:19:20 -0500 To: kanderso@DINO.BBN.COM Cc: CommonLoops.pa@Xerox.COM, kanderson@DINO.BBN.COM, aboulanger@DINO.BBN.COM Message-Id: <890403-134856-4209@Xerox> So, i'd like to propose that the current caching mechanism be replaced with one that builds the complete cache and never changes it unless a method is redefined. This may make the caches bigger, (but each implementation could trade time for space as it saw fit) but it would produce faster descriminators, and perhaps smaller descriminators as well. This suggestion has two nonfeatures. First, many caches would have to be updated when a new class is defined, since to be complete, a cache must mention each applicable class (not just the class wehre the method is defined). For this reason, for any generic function that has a method on standard-object, the size of the "complete" discriminator cache is the total number of classes ever defined. Here is an alternative scheme that requires locking only on update. Method-lookup can proceed without locking (or checking a lock), trapping out to an cache-update procedure if no appropriate entry is found. After taking the lock, the update code determines any entries it is modifying. It smashes the method address for each of those entries replacing the method address with one for a trap routine. Since smashing a single location is (should be?) atomic, any method lookup process will either get the correct method address, or trap out to wait to update the cache. For a machine whose cache does not contain an address to jump to, the entry can be set to NIL, and the lookup code can check for NIL before using the value found. From Owners-commonloops.pa@Xerox.COM Mon Apr 3 23:34:18 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA15227; Mon, 3 Apr 89 23:34:18 PDT Received: from Riesling.ms by ArpaGateway.ms ; 03 APR 89 15:22:25 PDT Return-Path: <@EN-C06.Prime.COM,@NET.Prime.COM:doug@zaphod.prime.com> Redistributed: commonloops.pa Received: from EN-C06.Prime.COM ([192.5.58.32]) by Xerox.COM ; 03 APR 89 14:47:25 PDT Received: from NET.Prime.COM by EN-C06.Prime.COM; 03 Apr 89 17:27:43 EDT Received: from primerd.prime.com by NET.Prime.COM; 03 Apr 89 16:23:30 EST Received: from zaphod.prime.com by primerd.prime.com (4.0/SMI-4.0) id AA01177; Mon, 3 Apr 89 17:21:29 EDT Received: from localhost by zaphod.prime.com (4.0/SMI-4.0) id AA05761; Mon, 3 Apr 89 17:22:00 EDT Message-Id: <8904032122.AA05761@zaphod.prime.com> To: CommonLoops.pa@Xerox.COM Cc: doug@zaphod.prime.com Subject: Specializing slot-missing Date: Mon, 03 Apr 89 17:21:57 EDT From: Douglas Rand Here's an idea for perusal. Is there any reason not to use slot-missing to build a persistant object store? It seems like a simple way to create such a thing and it would be easy enough to write the methods. How about it? Are there any operations to access the instances that don't go through slot-value? Cheers, Doug From Gregor.pa@Xerox.COM Mon Apr 3 23:37:53 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA15255; Mon, 3 Apr 89 23:37:53 PDT Received: from Semillon.ms by ArpaGateway.ms ; 03 APR 89 15:34:31 PDT Date: Mon, 3 Apr 89 15:29 PDT From: Gregor.pa@Xerox.COM Subject: Re: Infinite loop bug in cache stuff To: rich@linus.MITRE.ORG Cc: CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <8904032107.AA00403@sabre.mitre.org> Message-Id: <19890403222901.2.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no I will reply to your message in a couple of days. Unfortunately I am about to leave my office and can't answer it now. ------- From Owners-commonloops.pa@Xerox.COM Mon Apr 3 23:44:21 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA15078; Mon, 3 Apr 89 23:15:55 PDT Received: from Semillon.ms by ArpaGateway.ms ; 03 APR 89 15:11:09 PDT Return-Path: Redistributed: commonloops.pa Received: from mbunix.mitre.org ([192.12.120.1]) by Xerox.COM ; 03 APR 89 14:09:22 PDT Posted-From: The MITRE Corp., Bedford, MA X-Alternate-Route: user%node@mbunix.mitre.org Return-Path: Received: from sabre.mitre.org by linus.MITRE.ORG (5.59/RCF-3S) id AA23446; Mon, 3 Apr 89 17:07:27 EDT Posted-Date: Mon, 03 Apr 89 17:07:13 EDT Received: from localhost by sabre.mitre.org (3.2/RCF-3C) id AA00403; Mon, 3 Apr 89 17:07:21 EDT Message-Id: <8904032107.AA00403@sabre.mitre.org> To: gregor.pa@Xerox.COM Cc: CommonLoops.pa@Xerox.COM Subject: Infinite loop bug in cache stuff Date: Mon, 03 Apr 89 17:07:13 EDT From: rich@linus.MITRE.ORG ** Reply to rlp@mitre-bedford.arpa or rich@mitre.org ** ------------------------------------------------------------------------- I have just received some mail about this from the commonloops list. The problem is that I reported this bug back in January. No one from Xerox (or anybody else) has ever responded to me about this. Therefore, I have had to continue use AAAI PCL. Besides just being angry, I have a few suggestions: 1. If a bug report is made to the list, someone should a least acknowledge that it has been put on a bug list, and that bug could be given a number. 2. When fixes are posted to the net, people could reference a number. 3. It seems to me, from various postings, that there is a bug list at Xerox. If that list was on arisia, people could see if their bug has been reported, and if there is any fix. This would be particularly useful for people who just started reading the mailing list. That could prevent people from wasting there time (like did) trying to find out what is causing their bug. My bug report in January essentially gave the same info as in the 2 posting from . If there was a bug list, he could have looked at it and found the same info without having to spend how many hours (days?) wading thru the PCL code. Now onto the bug. As I and have reported, it is difficult to repeat this bug on a small example. But it is NOT intermittent. I get it everytime I use my STRIPS-like planner on a specific problem. However, if you just look at the cache code, it is pretty obvious that something is wrong. I realize that PCL is not a product, but if bug reports were a bit more organized, it would contribute to the development of a more efficient and usable PCL. Rich Piazza From Gregor.pa@Xerox.COM Tue Apr 4 03:45:23 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA15899; Tue, 4 Apr 89 00:29:27 PDT Received: from Semillon.ms by ArpaGateway.ms ; 03 APR 89 13:27:10 PDT Date: Mon, 3 Apr 89 13:21 PDT From: Gregor.pa@Xerox.COM Subject: Re: Avoid method cache locking To: kanderso@DINO.BBN.COM Cc: CommonLoops.pa@Xerox.COM, kanderson@DINO.BBN.COM, aboulanger@DINO.BBN.COM Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: The message of 31 Mar 89 09:19 PST from kanderso@DINO.BBN.COM Message-Id: <19890403202124.8.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Fri, 31 Mar 89 12:19:20 -0500 From: kanderso@DINO.BBN.COM I'd like to propose the PCL not lock its method caches. Danny just came up with a beautiful solution to this problem which the margin of this note is too small to contain. Seriously, I am in the middle of doing something else, so I can't write it up, but there is a nice way of avoiding locking that doesn't require rebuilding caches. I will send a message about it later this week. ------- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Tue Apr 4 09:09:09 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA20706; Tue, 4 Apr 89 09:09:09 PDT Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 4 Apr 89 09:09:32 PDT Received: from Semillon.ms by ArpaGateway.ms ; 04 APR 89 08:57:37 PDT Date: Tue, 4 Apr 89 08:54 PDT From: Gregor.pa@Xerox.COM Subject: Re: issue COMPILE-ENVIRONMENT-CONSISTENCY To: David A. Moon Cc: Sandra J Loosemore , cl-compiler@SAIL.STANFORD.EDU, common-lisp-object-system@SAIL.STANFORD.EDU Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <19890403215202.7.MOON@EUPHRATES.SCRC.Symbolics.COM> Message-Id: <19890404155429.5.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no I won't be able to respond to this until Friday as I am about to go out of town. In fact, the only reason I am here now is that 4 different airlines cancelled their morning flights to Boston. ------- From Owners-CommonLoops.pa@Xerox.COM Wed Apr 5 19:31:50 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA24992; Wed, 5 Apr 89 19:31:50 PDT Received: from Chardonnay.ms by ArpaGateway.ms ; 05 APR 89 19:26:33 PDT Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 05 APR 89 19:22:51 PDT To: Wilhelm Burger Cc: CommonLoops.pa@Xerox.COM Subject: Re: slot list In-Reply-To: Your message of Wed, 29 Mar 89 16:09:20 -0400. <890329-075228-3325@Xerox> Date: Wed, 05 Apr 89 22:29:45 -0400 From: kanderso@DINO.BBN.COM Message-Id: <890405-192633-4328@Xerox> Date: Wed, 29 Mar 89 16:09:20 EDT From: Wilhelm Burger Subject: slot list To: CommonLoops.pa@xerox.com Message-Id: <890329-075228-3325@Xerox> Why is the function pcl::class-slots not exported by PCL and not provided by the CLOS specifications at all? I don't see how someone could write generic class browsers, printers ... without it. W.Burger Johannes Kepler University A-4045 Linz, Austria CLASS-SLOT is a reader provided by STANDARD-CLASS, thus it is part of the metaclass protocol (88-002). It is not part of CLOS Chapters 1 & 2 that have been accepted by X3J13. PCL attempts to export everything in chapter 2 though. k From Owners-CommonLoops.pa@Xerox.COM Wed Apr 5 23:32:41 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA29040; Wed, 5 Apr 89 23:32:41 PDT Received: from Salvador.ms by ArpaGateway.ms ; 05 APR 89 23:01:22 PDT Return-Path: Redistributed: CommonLoops.pa Received: from lucid.com ([192.26.25.1]) by Xerox.COM ; 05 APR 89 22:57:26 PDT Received: from bhopal ([192.9.200.13]) by heavens-gate.lucid.com id AA01008g; Wed, 5 Apr 89 22:51:06 PDT Received: by bhopal id AA05891g; Wed, 5 Apr 89 22:57:38 PDT Date: Wed, 5 Apr 89 22:57:38 PDT From: Jon L White Message-Id: <8904060557.AA05891@bhopal> To: Bobrow.pa@Xerox.COM Cc: kanderso@DINO.BBN.COM, CommonLoops.pa@Xerox.COM, aboulanger@DINO.BBN.COM In-Reply-To: Danny Bobrow's message of 3 Apr 89 13:37 PDT <890403-134856-4209@Xerox> Subject: Avoid method cache locking I think your alternative scheme is flawed in a subtle way that goes under the rubric of "the multiple-readers/single-writer problem". The basic problem is that the "read" step cannot be atomic (unless explicitly made so by the offensive interrupt-inhibition construct) -- you typically have to read several words from the cache to verify that the keys match, and then you read the result word (i.e. the "method address"). [Some Lisp implementations redefine the granularity level of atomicity to be essentially the function entry, rather than a single machine instruction, or single (shared) memory fetch -- they would provide locking without the offensive behaviour that Ken is referring to, but they have so many other problems that I don't think they are in the majority.] To make a long story short, the "multiple-readers/single-writer" seems to require that the readers also acquire the lock. Ask Ron Goldman (arg@Lucid.com), who is doing our parallel LISP (QLISP) implementation, for references and more details. Yet, specific problems can avoid the reader lock, by recoding in appropriate ways. A recent issue of SIGPLAN Notices, Vol 24, No. 4, contains papers from a workshop on Object-based Concurrent Programming; the position paper by Herlihy of CMU "Taking Concurrency Seriously" spurred the idea for a non-locking cache in Lucid's implementation of CLOS. Although he merely suggests "wait-free" programming, I translated that into a relatively simple idea, and have volunteered to help Gregor put it into PCL if he so wants. The "simple idea" is that of version numbers -- where each update increments the version. Readers simply check for EQLness between the start of access and the finish thereof. Only two restrictions seem necessary: (1) the version number range be big enough so as not to "cycle" back to the same number (assuming modular arithmetic) during any small number of scheduling quanta; (2) the updating process leaves the cache in a state such that if an interrupted reader has performed some, but not all, of its atomic steps, then the subsequent atomic steps of the reader will not cause memory access violations. It isn't hard to see how a reasonable fixnum range satisfies (1), and how a little care will satisfy (2), especially if the update process is allowed to inhibit other processes from running while it is doing its operations. Of course, on a true parallel machine, the task of "inhibiting other processes/processors from running" is more serious than a simple multiple-reader lock; so we wouldn't do it this way in QLISP. But in fact a very minor variation of this "simple idea" will work for parallel processors -- primarily, I believe, because of the simple nature of a "cache" as a database. Of course, I have no doubt that many other people could work out reasonable variants of this "simple idea" by themselves too. Once you think to do this rather than to do locking, the problem becomes rather easy. -- JonL -- From Common-Lisp-Object-System-mailer@SAIL.STANFORD.EDU Thu Apr 6 17:16:27 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.59++/IDA-1.2.6) id AA13847; Thu, 6 Apr 89 17:16:27 PDT Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 6 Apr 89 17:15:33 PDT Received: from Cabernet.ms by ArpaGateway.ms ; 06 APR 89 16:55:14 PDT Date: 6 Apr 89 16:54 PDT From: masinter.pa@Xerox.COM Subject: [kempf%Sun:COM:Xerox: CLOS Slot Subclassing Rule Violates Contravariance] To: common-lisp-object-system@SAIL.STANFORD.EDU Message-Id: <890406-165514-7021@Xerox> ----- Begin Forwarded Messages ----- Date: 31 Mar 89 13:53 PST From: kempf%Sun:COM:Xerox Subject: CLOS Slot Subclassing Rule Violates Contravariance To: masinter:PA:Xerox Larry: The CLOS rules for subtyping a slot violate contravariance. This means that it is possible to type check a slot access and still end up getting a no matching method message at run time. I personally believe that this should be fixed, however, I am not prepared to invest any time in it, because I suspect there are a number of people on the committee (perhaps you among them?) who don't particularly care whether this is a problem, since Common Lisp is by nature untyped. This argument would maintain that no matching methods at run time are OK, even if the compiler tries to get rid of them. I'm prepared to submit a proposal, but, I don't plan to get into a fruitless argument about whether types are good or bad. The proposal would have the following suggestions to eliminate the problem: 1) Slot typing be removed from CLOS. All slots are therefore untyped. 2) The typing rules be tightened up so that contravariance is respected. The upshot is that slot subtyping either be done right or it not be done at all. Incidently, something similar can happen with methods, but I think the argument for dynamic binding is stronger because the need for optimization is less critical. jak ----- Next Message ----- Date: 3 Apr 89 14:10 PDT From: masinter:PARC:Xerox Subject: Re: CLOS Slot Subclassing Rule Violates Contravariance In-Reply-to: kempf%Sun:COM's message of Friday, March 31, 1989 1:53 pm To: kempf%Sun:COM:Xerox I think the goal was to make it compatible with :TYPE in defstruct. Xerox Common Lisp used :TYPE in defstruct to allow for compact structures. I don't understand how the CLOS rules for subtyping a slot violates contravariance and how this could mean that it is possible to type check a slot access and still end up getting a no matching method message at run time. I thought the goal of slot typing was to allow for specialized storage for some kinds of types. Maybe you're trying to optimize a different goal? In any case, whether you have a formal proposal or an informal one, you should discuss this on the common-lisp-object-system mailing list and see if you can get a couple of other people to agree with you. ----- End Forwarded Messages ----- From Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Fri Apr 7 08:35:04 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA15176; Fri, 7 Apr 89 08:35:04 -0700 Reply-To: Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Received: from STONY-BROOK.SCRC.Symbolics.COM by SAIL.Stanford.EDU with TCP; 7 Apr 89 08:35:33 PDT Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 573337; Fri 7-Apr-89 11:34:59 EDT Date: Fri, 7 Apr 89 11:34 EDT From: David A. Moon Subject: [kempf%Sun:COM:Xerox: CLOS Slot Subclassing Rule Violates Contravariance] To: masinter.pa@arisia.Xerox.COM, Kempf@sun.com Cc: common-lisp-object-system@sail.stanford.edu In-Reply-To: <890406-165514-7021@Xerox> Message-Id: <19890407153450.1.MOON@EUPHRATES.SCRC.Symbolics.COM> Line-Fold: No Since I don't know what you mean by contravariance and since you didn't supply an example exhibiting the problem, I can only ignore this message. From Owners-commonloops.pa@Xerox.COM Fri Apr 7 09:33:57 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA15887; Fri, 7 Apr 89 09:33:57 -0700 Reply-To: Owners-commonloops.pa@arisia.Xerox.COM Received: from Salvador.ms by ArpaGateway.ms ; 07 APR 89 07:50:50 PDT Return-Path: Redistributed: commonloops.pa Received: from VAX.BBN.COM ([128.89.0.91]) by Xerox.COM ; 07 APR 89 07:46:25 PDT Date: Fri, 7 Apr 89 10:30:26 EDT From: Christine Joor To: commonloops.pa@arisia.Xerox.COM Cc: cjoor@BBN.COM, broberts@BBN.COM, ecooper@BBN.COM, gdonlon@BBN.COM Subject: Product Loops -> PCL Message-Id: <890407-075050-8312@Xerox> We are in the process of coverting a project written in Interlisp and Loops into Common Lisp and PCL, and are interested in finding out if anyone already has functions to convert Loops (Product release) to PCL. If this has already been done, what is the availability of the code? Thanks in advance, Christine Joor From Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Sun Apr 9 14:19:46 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA23830; Sun, 9 Apr 89 14:19:46 -0700 Reply-To: Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Received: from Sun.COM by SAIL.Stanford.EDU with TCP; 9 Apr 89 14:19:59 PDT Received: from snail.Sun.COM (snail.Corp.Sun.COM) by Sun.COM (4.1/SMI-4.0) id AA17178; Sun, 9 Apr 89 14:22:27 PDT Received: from suntana.sun.com by snail.Sun.COM (4.1/SMI-4.1) id AA20487; Sun, 9 Apr 89 14:18:22 PDT Received: from localhost by suntana.sun.com (4.0/SMI-4.0) id AA03467; Sun, 9 Apr 89 14:20:21 PDT Message-Id: <8904092120.AA03467@suntana.sun.com> To: David A. Moon Cc: masinter.pa@xerox.com, common-lisp-object-system@sail.stanford.edu Subject: Re: [kempf%Sun:COM:Xerox: CLOS Slot Subclassing Rule Violates Contravariance] In-Reply-To: Your message of Fri, 07 Apr 89 11:34:00 -0400. <19890407153450.1.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Sun, 09 Apr 89 14:20:19 PDT From: kempf@Sun.COM The following is a CLOS example which illustrates contravariance violation. (defclass super () ( (sl :type number :accessor s1) ) ) (defclass sub (super) ( (s1 :type integer :accessor s1) ) ) (defun do-bad () (let ( (subi (make-instance 'super)) (sup NIL)) (declare (type super sup) (type sub subi)) (setf sup subi) (setf (s1 sup) 1.2))) The compiler type checks the function body OK, because the assignment of subtyped identifier to a supertyped one is OK. Subclass objects should be usable wherever their less specialized superclass objects are. The type of the slot accessor new value argument for sub is (and integer number), effectively just integer, since that is the most restrictive type. The type of the new value argument for the super slot accessor is number, so the setf checks OK. However, at run time, there is no method matching, since the slot accessor for sub cannot take a new value float. Like I said, I don't want to get into a religious argument about whether static typing is good or bad. But the very least one would expect from the type system in an object-oriented language is that it would enable you to write code that didn't get a no matching method message at run time. You might also want to use it to get better performance in some way. Incidently, the Eiffel programming language, which is fully statically type checked and supposedly type safe, also has this problem. My original message was sent only to Larry to inform him of the problem as Cleanup Chair. I did not intend to have it redistributed, because X3J has enough on its hands right now, and one could make a legitimate argument that, since typing is "optional" in Common Lisp anyway, the problem was not particularly serious. However, now that the issue has been broached, we might as well discuss it. jak From Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Mon Apr 10 13:25:59 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA09500; Mon, 10 Apr 89 13:25:59 -0700 Reply-To: Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 10 Apr 89 13:26:28 PDT Received: from Cabernet.ms by ArpaGateway.ms ; 10 APR 89 13:10:02 PDT Date: 10 Apr 89 13:09 PDT From: Danny Bobrow Subject: Re: [kempf%Sun:COM:Xerox: CLOS Slot Subclassing Rule Violates Contravariance] In-Reply-To: kempf@Sun.COM's message of Sun, 09 Apr 89 14:20:19 PDT To: kempf@Sun.COM Cc: David A. Moon , masinter.pa@Xerox.COM, common-lisp-object-system@sail.stanford.edu Message-Id: <890410-131002-4883@Xerox> But the very least one would expect from the type system in an object-oriented language is that it would enable you to write code that didn't get a no matching method message at run time. In our original discussion of accessors and types, I remember that the model proposed was that: (defclass foo () ((bar :type baz :accessor foo-bar))) would, if type checking were to be enforced in the accessors, generate a method equivalent to: (defmethod (setf foo-bar) (new-value (inst foo)) (check-type inst 'baz) (setf (slot-value inst bar) new-value)) This would give the expected error message. There is a general confusion in the use of CLOS about whether specialization of arguments should be used for type checking. My take is that these discrimination and type checking should be separated. But it is convenient to have type declarations in the header. However, is easy to make a special defining form, e.g. (define-checked-method ((:check new-value baz) (inst foo)) (setf (slot-value inst bar) new-value)) that expands into the definition above. One might use the checking syntax in optionals and keyword positions as well. From Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Wed Apr 12 08:13:41 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA00583; Wed, 12 Apr 89 08:13:41 -0700 Reply-To: Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Received: from STONY-BROOK.SCRC.Symbolics.COM by SAIL.Stanford.EDU with TCP; 12 Apr 89 08:14:09 PDT Received: from EUPHRATES.SCRC.Symbolics.COM by STONY-BROOK.SCRC.Symbolics.COM via CHAOS with CHAOS-MAIL id 575831; Wed 12-Apr-89 11:13:39 EDT Date: Wed, 12 Apr 89 11:13 EDT From: David A. Moon Subject: Chap 3 question: Class of allocated instances. To: Jon L White Cc: common-lisp-object-system@sail.stanford.edu In-Reply-To: <8904120631.AA19866@bhopal> Message-Id: <19890412151329.2.MOON@EUPHRATES.SCRC.Symbolics.COM> Date: Tue, 11 Apr 89 23:31:52 PDT From: Jon L White I'm wondering why one can't count on the following being true: (eq (find-class 'foo) (class-of (allocate-instance 'foo))) Presumably, if a programmer defined a method on 'allocate-instance' he could have it return any old sort of widget (rather than a "foo"). Is this useful? Flavors has such a feature, which is used quite a bit. Is it still useful if the constraint is added that (subtype (class-of (allocate-instance 'foo)) 'foo) The Flavors feature satisfies this constraint. Without some such constraint, it might be possible for (typep (allocate-instance 'foo) 'foo) to be false. I don't really see any reason for CLOS to prohibit users from creating classes or metaclasses that behave this way, violating that constraint. That might not be good style, and it might be the case that those classes will not work with some programs. But I don't see any reason to forbid it outright. From Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Wed Apr 12 09:49:34 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA01616; Wed, 12 Apr 89 09:49:34 -0700 Reply-To: Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Received: from lucid.com by SAIL.Stanford.EDU with TCP; 12 Apr 89 09:49:31 PDT Received: from challenger ([192.9.200.17]) by heavens-gate.lucid.com id AA03426g; Wed, 12 Apr 89 09:49:43 PDT Received: by challenger id AA06224g; Wed, 12 Apr 89 09:49:33 PDT Date: Wed, 12 Apr 89 09:49:33 PDT From: Patrick Dussud Message-Id: <8904121649.AA06224@challenger> To: jonl@lucid.com Cc: common-lisp-object-system@sail.stanford.edu In-Reply-To: Jon L White's message of Tue, 11 Apr 89 23:31:52 PDT <8904120631.AA19866@bhopal> Subject: Chap 3 question: Class of allocated instances. Date: Tue, 11 Apr 89 23:31:52 PDT From: Jon L White I'm wondering why one can't count on the following being true: (eq (find-class 'foo) (class-of (allocate-instance 'foo))) This is too restrictive, I think. Flavors defines some mechanisms where this wouldn't be true. I know these machanisms are used in customer code. Presumably, if a programmer defined a method on 'allocate-instance' he could have it return any old sort of widget (rather than a "foo"). Is this useful? Is it still useful if the constraint is added that (subtype (class-of (allocate-instance 'foo)) 'foo) This looks more reasonnable. However I don't know if it gives a tremendous performance leverage for implementation to impose this restriction on all metaclasses. I would like to see an argumentation before putting this restriction (consistency of meta concepts, performance optimizations...., flexibility of extension, less built-in assumptions....) Patrick. From Gregor.pa@Xerox.COM Thu Apr 13 13:49:31 1989 Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06990; Thu, 13 Apr 89 13:49:31 -0700 Reply-To: Gregor.pa@Xerox.COM Received: from Semillon.ms by ArpaGateway.ms ; 12 APR 89 10:36:28 PDT Date: Wed, 12 Apr 89 10:28 PDT From: Gregor.pa@Xerox.COM Subject: Re: bug in 12/7 pcl under ibcl and kcl To: Diana Smetters Cc: commonloops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <8901251704.AA06620@coracle.cis.ohio-state.edu> Message-Id: <19890412172846.0.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no This is for users of PCL in KCL, AKCL or IBCL only. Date: Wed, 25 Jan 89 12:04:41 EST From: Diana Smetters If you load pcl as source, there are no problems. If you compile it, you get no errors in compiling pkg.lsp. However, if you load the compiled pcl, it breaks while loading pkg.o saying that *exports* is unbound. Many people have complained about this problem. I finally have a fix for it. In the file defs.lisp, replace the line: (export *exports* *the-pcl-package*) With the lines: #-(or KCL IBCL) (export *exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *exports*) (list *the-pcl-package*)) ------- From Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Fri Apr 14 09:31:44 1989 Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA15923; Fri, 14 Apr 89 09:31:44 -0700 Reply-To: Common-Lisp-Object-System-mailer@SAIL.Stanford.EDU Received: from ti.com ([128.247.159.141]) by SAIL.Stanford.EDU with TCP; 14 Apr 89 09:32:03 PDT Received: by ti.com id AA13419; Fri, 14 Apr 89 11:33:09 CDT Received: from Kelvin by tilde id AA17618; Fri, 14 Apr 89 11:21:13 CDT Message-Id: <2817562858-10264048@Kelvin> Sender: GRAY@kelvin.csc.ti.com Date: Fri, 14 Apr 89 11:20:58 CDT From: David N Gray To: Jon L White Cc: Common-Lisp-Object-System@SAIL.Stanford.edu Subject: Re: DEFSTRUCT and DEFCLASS In-Reply-To: Msg of Fri, 14 Apr 89 00:36:22 PDT from Jon L White > whether > (DEFSTRUCT ... (:METACLASS STRUCTURE-CLASS)) > is legal and, if so, just what it means. > > Did anyone ever give satisfactory answers to your question about this? No one ever responded to that message, but I did discuss it with Patrick -- he felt that this didn't need to be supported until the metaclass protocol was better defined. I did notice since then, though, that the working draft standard, March 21, page 2-5, says that "The :METACLASS option is reserved for future use; an implementation can be extended to make use of the :metaclass option." That seems to answer the question as far as the standard is concerned, but I feel uneasy about having that sneaked in without discussion. Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA16547; Wed, 19 Apr 89 00:04:15 -0700 Reply-To: kiuchi.pa@Xerox.COM Received: from Semillon.ms by ArpaGateway.ms ; 18 APR 89 15:37:37 PDT Date: 18 Apr 89 14:04 PDT From: kiuchi.pa@Xerox.COM Subject: check1.lisp (2/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890418-153737-155@Xerox> ---------- check1.lisp ---------- ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "PCL") ;;; ;;; This file contains: ;;; * a new definition of compute-combination-point ;;; * a new definition of compute-class-precedence-list ;;; ;;; This file is designed to be compiled and loaded in the 12/7/88 ;;; version of PCL. Attempting to load it into later versions of ;;; PCL can cause bad surprises. ;;; ;from miscellaneous places (defun forward-referenced-class-p (x) (typep--class x 'forward-referenced-class)) ;from defs.lisp ;;; ;;; This little macro requires one case for each of the currently defined ;;; kinds of specializers. At macroexpansion time it will signal an error ;;; if an unsupplied case is found. At runtime, it assumes the specializer ;;; argument is a legal specializer. This means there is no error checking ;;; at all at runtime. ;;; (defmacro specializer-case (specializer &body cases) (flet ((find-case (key) (or (cdr (assq key cases)) (error "~S case not found." key)))) (once-only (specializer) `(if (listp ,specializer) (progn . ,(find-case :eql)) (progn . ,(find-case :class)))))) (defmacro specializer-cross-case (specializer-1 specializer-2 &body cases) (let ((otherwise (cdr (assq t cases)))) (flet ((find-case (key) (or (cdr (assq key cases)) (if otherwise '((.specializer-cross-case-otherwise.)) (error "~S case not found." key))))) (once-only (specializer-1 specializer-2) `(flet ,(and otherwise `((.specializer-cross-case-otherwise. () . ,otherwise))) (specializer-case ,specializer-1 (:eql (specializer-case ,specializer-2 (:eql . ,(find-case :eql-eql)) (:class . ,(find-case :eql-class)))) (:class (specializer-case ,specializer-2 (:eql . ,(find-case :class-eql)) (:class . ,(find-case :class-class)))))))))) (defun specializer-eq (a b) (specializer-cross-case a b (:eql-eql (eq (cadr a) (cadr b))) (:class-class (eq a b)) (t nil))) (defun specializer-assoc (specializer alist) (assoc specializer alist :test #'specializer-eq)) (defun sub-specializer-p (x y) (specializer-cross-case y x (:eql-eql (eql (cadr x) (cadr y))) (:eql-class nil) (:class-eql (memq y (class-precedence-list (class-of (cadr x))))) (:class-class (memq y (class-precedence-list x))))) ;;; ;;; ;;; ;;; ;;; This code operates on a special kind of tree called a cptree (combination ;;; point tree). A cptree is just a cpnode. The cpnode contains the actual ;;; data stored at the cpnode, called the entry, and the subnodes. This code ;;; doesn't define a special structure type for cpnodes. It does define an ;;; abstraction for them though. ;;; ;;; The WALK-CPNODE and MAP-NODE functions are useful for operating on entire ;;; trees. ;;; ;;; WALK-CPNODE applies the argument to the entry of each cpnode ;;; in the tree. It proceeds in depth first order. If at any ;;; point, the call to returns non-nil, the walk is ;;; terminated. ;;; ;;; MAP-CPNODE is like walk-cpnode except that it builds up a new tree. ;;; The resultant tree has the same structure as the ;;; argument. The node-entry at each node of the new tree ;;; is the result of calling on the corresponding ;;; node-entry in the old tree. ;;; ;;; If at any point, the second value returned by ;;; is non-nil, the walk is terminated. In this case, the ;;; result tree will have the same structure as the part of ;;; input tree that was walked. ;;; ;;; ;;; Some places in the code depend on CPNODEs being disjoint from lists. ;;; (defmacro make-cpnode (entry subnodes) `(let ((.new-node. (make-array 2))) (setf (cpnode-entry .new-node.) ,entry (cpnode-subnodes .new-node.) ,subnodes) .new-node.)) (defmacro cpnode-entry (node) `(svref ,node 0)) (defmacro cpnode-subnodes (node) `(svref ,node 1)) (defun walk-cpnode (node function) (funcall function (cpnode-entry node)) (dolist (subnode (cpnode-subnodes node)) (walk-cpnode subnode function))) (defun map-cpnode (node function) (make-cpnode (funcall function (cpnode-entry node)) (mapcar #'(lambda (subnode) (map-cpnode subnode function)) (cpnode-subnodes node)))) ;;; ;;; Arrange for all of this to indent nicely in ZWEI. Its amazingly stupid ;;; that this has to be evaluated after the functions are defined, but that ;;; is the way it goes. ;;; #+Genera (progn (zwei:defindentation (walk-cpnode 1 2)) (zwei:defindentation (map-cpnode 1 2))) ;;; ;;; These entry types are used by code in combin.lisp to compute the so-called ;;; combination points of a generic function. The full documentation for ;;; them appears there. They are defined here for the obvious reason. ;;; ;;; ;;; point tree entries are used internally by CROSS-COLUMNS. ;;; (defmacro make-point-entry (classes partial-method-order) `(vector ,classes ,partial-method-order nil ())) (defmacro point-entry-classes (point-entry) `(svref ,point-entry 0)) (defmacro point-entry-pmo (point-entry) `(svref ,point-entry 1)) (defmacro point-entry-flag (point-entry) `(svref ,point-entry 2)) (defmacro point-entry-cross-info (point-entry) `(svref ,point-entry 3)) ;;; ;;; This entry type is used in the result of compute-columns. ;;; (defmacro make-column-entry (class pmo) `(vector ,class ,pmo nil)) (defmacro column-entry-class (column-entry) `(svref ,column-entry 0)) (defmacro column-entry-pmo (column-entry) `(svref ,column-entry 1)) (defmacro column-entry-flag (column-entry) `(svref ,column-entry 2)) ;;; ;;; The result of compute-precedence-dag is a tree with this entry type. ;;; (defmacro make-cpd-entry (class precedence) `(vector ,class ,precedence nil)) (defmacro cpd-entry-class (cpd-entry) `(svref ,cpd-entry 0)) (defmacro cpd-entry-precedence (cpd-entry) `(svref ,cpd-entry 1)) (defmacro cpd-entry-multiple-supers-p (cpd-entry) `(svref ,cpd-entry 2)) ;;; ;;; This entry type is used internally by compute-precedence-dag and friends. ;;; No entry with this type is ever returned by that function. ;;; (defmacro make-cpdi-entry (class precedence) `(vector ,class ,precedence 0 () 'kept)) (defmacro cpdi-entry-class (cpdi-entry) `(svref ,cpdi-entry 0)) (defmacro cpdi-entry-precedence (cpdi-entry) `(svref ,cpdi-entry 1)) (defmacro cpdi-entry-count (cpdi-entry) `(svref ,cpdi-entry 2)) (defmacro cpdi-entry-supers (cpdi-entry) `(svref ,cpdi-entry 3)) (defmacro cpdi-entry-status (cpdi-entry) `(svref ,cpdi-entry 4)) ;from combin.lisp ;;; ;;; ;;; (defun *compute-combination-points (generic-function) (let ((methods (generic-function-methods generic-function))) (if (null (cdr methods)) (list (list (method-type-specifiers (car methods)) methods)) (let* ((precedence ;; *** *** ;; *** stupidly compute this for now. Also have to fix *** ;; *** the lexical function inverse-precedence when this *** ;; *** is fixed *** ;; *** *** (gathering1 (collecting) (iterate ((i (interval :from 0)) (a (list-elements (method-type-specifiers (car methods))))) (progn a) (gather1 i)))) (specializers (mapcar #'method-type-specifiers methods)) (columns (compute-columns specializers methods precedence))) (cross-columns columns methods))))) (defun cross-columns (columns all-methods) (cross-columns-main t (car columns) (cdr columns) all-methods)) (defun cross-columns-main (all-t-left-of-here first rest all-methods) (if (null rest) (cross-columns-null-rest all-t-left-of-here first all-methods) (let ((recurse (cross-columns-main (and all-t-left-of-here (eq first 't)) (car rest) (cdr rest) all-methods))) (if (eq first 't) (cond (all-t-left-of-here (dolist (point recurse) (push *the-class-t* (car point))) recurse) (t (let ((flag (list nil))) (walk-cpnode recurse #'(lambda (point-entry) (unless (eq (point-entry-flag point-entry) flag) (setf (point-entry-flag point-entry) flag) (push *the-class-t* (point-entry-classes point-entry)))))) recurse)) (let ((points (full-on-column-cross first recurse))) (if all-t-left-of-here (progn (dolist (p points) (setf (cadr p) (pmo->total (cadr p)))) points) (rebuild-combination-tree-from-points points))))))) (defun cross-columns-null-rest (all-t-left-of-here first-column all-methods) (if (eq first-column 't) (if all-t-left-of-here `((,*the-class-t*) ,all-methods) (make-cpnode (make-point-entry (list *the-class-t*) all-methods) ())) (if all-t-left-of-here ;; In this case, we can just return a list of combination ;; points, a point tree isn't needed. Note that this also ;; catches the case where there is only one column. (gathering1 (collecting) (walk-cpnode first-column ;Convert from a column tree #'(lambda (column-entry) ;to actual points (unless (column-entry-flag column-entry) (setf (column-entry-flag column-entry) t) (let ((class (column-entry-class column-entry)) (pmo (column-entry-pmo column-entry))) (when pmo (gather1 `((,class) ,(pmo->total pmo))))))))) ;; ;; Need to make a tree because someone to the `left' of this ;; column will need to do a full-on cross with it. ;; (map-cpnode first-column ;Convert from a column tree #'(lambda (column-entry) ;to a combination point tree. (let ((been-here (column-entry-flag column-entry))) (if (and (neq been-here nil) (neq been-here t)) been-here (let* ((class (column-entry-class column-entry)) (pmo (column-entry-pmo column-entry)) (new-entry (make-point-entry (list class) pmo))) (setf (column-entry-flag column-entry) new-entry) new-entry)))))))) (defun full-on-column-cross (column point) (cross-column-with-point column point) (cross-point-with-column point column)) (defun cross-column-with-point (column point) (labels ((walk-column (cnode) (let* ((centry (cpnode-entry cnode)) (cpmo (column-entry-pmo centry))) (unless (eq (column-entry-flag centry) 'been-here) (setf (column-entry-flag centry) 'been-here) (when cpmo (walk-point centry cpmo point t t)) (dolist (subnode (cpnode-subnodes cnode)) (walk-column subnode))))) (walk-point (centry cpmo pnode super-crossed-pmo super-ppmo) (let* ((pentry (cpnode-entry pnode)) (ppmo (point-entry-pmo pentry)) (force nil) (crossed-pmo nil)) (unless (eq (point-entry-flag pentry) centry) ;Been here? (setf (point-entry-flag pentry) centry) (setq crossed-pmo (cross-pmos cpmo ppmo)) (setq force (equal ppmo super-ppmo)) (when (or force (and crossed-pmo (not (equal crossed-pmo super-crossed-pmo)))) (setq super-crossed-pmo crossed-pmo) (push (list centry force crossed-pmo) (point-entry-cross-info pentry))) (dolist (subnode (cpnode-subnodes pnode)) (walk-point centry cpmo subnode super-crossed-pmo ppmo)))))) (walk-column column))) (defun cross-point-with-column (point column) (gathering1 (collecting) (labels ((walk-point (pnode) (let* ((pentry (cpnode-entry pnode)) (pclasses (point-entry-classes pentry))) (unless (eq (point-entry-flag pentry) 'been-here) (setf (point-entry-flag pentry) 'been-here) (walk-column pentry pclasses column t t) (dolist (subnode (cpnode-subnodes pnode)) (walk-point subnode))))) (walk-column (pentry pclasses cnode super-crossed-pmo super-cpmo) (let* ((centry (cpnode-entry cnode)) (cclass (column-entry-class centry)) (cpmo (column-entry-pmo centry))) (unless (eq (column-entry-flag centry) pentry) ;Been here? (setf (column-entry-flag centry) pentry) (destructuring-bind (nil force crossed-pmo) (assq centry (point-entry-cross-info pentry)) (when (and crossed-pmo (or force (not (equal crossed-pmo super-crossed-pmo)) (equal super-cpmo cpmo))) (setq super-crossed-pmo crossed-pmo) (gather1 (list (cons cclass pclasses) crossed-pmo))) (dolist (subnode (cpnode-subnodes cnode)) (walk-column pentry pclasses subnode super-crossed-pmo cpmo))))))) (walk-point point)))) (defun rebuild-combination-tree-from-points (points) (labels ((insert-node (tree node entry methods) (let ((subtrees (cpnode-subnodes tree)) (farther-down-p nil) (between-here-and-sub-p nil)) ;; ;; First try to stick it down below one of our subtrees. ;; Note that it can go below more than one of our subtrees. ;; (dolist (sub subtrees) (when (eq sub node) (return-from insert-node t)) (when (pmo-sub-p methods (point-entry-pmo (cpnode-entry sub))) (setq farther-down-p t) (insert-node sub node entry methods))) ;; ;; Now try to put it between us and a subtree. ;; (dolist (sub subtrees) (when (and (pmo-sub-p (point-entry-pmo (cpnode-entry sub)) methods) (not (equal (point-entry-pmo (cpnode-entry sub)) methods))) (setf (cpnode-subnodes tree) (remove sub (cpnode-subnodes tree))) (push node (cpnode-subnodes tree)) (push sub (cpnode-subnodes node)) (setq between-here-and-sub-p t))) ;; ;; If it couldn't go below any of our subs, and it couldn't ;; go between us and a sub, then it must just be a sub of ;; us. Do that. ;; (unless (or farther-down-p between-here-and-sub-p) (push node (cpnode-subnodes tree)))))) (let* ((t-point (or (dolist (p points) (when (every #'(lambda (x) (eq x *the-class-t*)) (car p)) (setq points (delete p points)) (return p))) (list (make-list (length (caar points)) :initial-element *the-class-t*) ()))) (result (make-cpnode (make-point-entry (car t-point) (cadr t-point)) ()))) (dolist (point points) (let* ((entry (make-point-entry (car point) (cadr point))) (node (make-cpnode entry ()))) (insert-node result node entry (cadr point)))) result))) ;;; ;;; Returns a list of trees with entry type COLUMN-ENTRY. Each tree in the ;;; list is the column combination for one column of the generic function. ;;; The list is in the same order as the precedence. As a special case, if ;;; all the specializers of a column are T, the value for that column will ;;; be the symbol T. ;;; ;;; Each column is a fresh column since the COLUMN-ENTRY-FLAG field of the ;;; entries is intended to be modified by our caller. ;;; (defun compute-columns (specializers methods precedence) (gathering1 (collecting) (dolist (n precedence) (gather1 (compute-one-column n specializers methods))))) (defun compute-one-column (n specializers methods) (let* ((all-t-p t) (specls (mapcar #'(lambda (specializer-list) (let ((specl (nth n specializer-list))) (unless (eq specl *the-class-t*) (setq all-t-p nil)) specl)) specializers))) (if all-t-p 't (compute-one-column-internal specls methods)))) (defun compute-one-column-internal (specializers methods) (let ((been-here-alist ())) ;; CONVERT-1 actually converts a node and recurses. CONVERT ;; deals with sharing in the result DAG by keeping track of ;; whether a node in the precedence has been visited before. (labels ((convert (cpd-node) (let ((cpd-entry (cpnode-entry cpd-node)) (cpd-subnodes (cpnode-subnodes cpd-node))) (if (cpd-entry-multiple-supers-p cpd-entry) ;; ;; Since this node has multiple supers, it is possible ;; to visit it more than once. Deal with the multiple ;; visits stuff. Note, have to maintain the separate ;; alist because we aren't allowed to mutate precedence ;; dags. ;; (let ((been-here (assq cpd-node been-here-alist))) (if been-here (cdr been-here) (let ((new-node (convert-1 cpd-entry cpd-subnodes))) (push (cons cpd-node new-node) been-here-alist) new-node))) ;; ;; No multiple supers means charge ahead! ;; (convert-1 cpd-entry cpd-subnodes)))) (convert-1 (cpd-entry cpd-subnodes) (make-cpnode (make-column-entry (cpd-entry-class cpd-entry) (precedence->pmo (cpd-entry-precedence cpd-entry) specializers methods)) (mapcar #'convert cpd-subnodes)))) (convert (compute-precedence-dag specializers))))) ;;; ;;; Random useful functions for manipulating partial method orders. ;;; ;;; A partial method order is just a set of methods which are ordered by ;;; one column in a combination. A partial method order supplies absolute ;;; ordering information between some methods and no ordering information ;;; between other methods. Its best described by example: ;;; ;;; (M1 M2 M3) Actually, this is a total order. ;;; (M1 (M2 M3) M4) M1 must precede M2, M3 and M4 ;;; M2 must precede M4 ;;; M3 must precede M4 ;;; the order of M2 and M3 is unspecified ;;; ;;; ((M1 M2) (M3 M4)) M1 must precede M3 and M4 ;;; M2 must precede M3 and M4 ;;; ordering of M1 and M2 unspecified ;;; ordering of M3 and M4 unspecified ;;; ;;; In other words, a partial method order is a list whose elements may be ;;; lists. The top-level list provides ordering information. Methods in ;;; the top level list must precede the `flattened' part of the list that ;;; follows them. But, when an element of the top level list is itself a ;;; list, no ordering among those sublist elements is specified. ;;; ;;; The most important operation defined on partial method orders is a kind ;;; of cross product. The result is a partial method order with only those ;;; methods that appeared in both inputs. The order of the result is as ;;; specified by the first input, except that where the first input doesn't ;;; specify ordering between two methods, the ordering is taken from the ;;; second input. If neither input provides ordering then there will be ;;; partial ordering in the result. ;;; (defun precedence->pmo (precedence specializers methods) (gathering1 (collecting) (dolist (p precedence) (let ((last-hit-state nil) (last-hit-p nil) (last-hit-m nil)) (flet ((enqueue (m) (ecase last-hit-state ((nil) (setq last-hit-state 'one last-hit-p p last-hit-m m)) (one (setq last-hit-state 'two last-hit-m (list m last-hit-m))) (two (push m last-hit-m)))) (flush-queue () (ecase last-hit-state ((nil) ()) (one (gather1 last-hit-m)) (two (gather1 (nreverse last-hit-m)))) (setq last-hit-state nil last-hit-p nil))) (do ((s specializers (cdr s)) (m methods (cdr m))) ((null s) (flush-queue)) (when (specializer-eq (car s) p) (enqueue (car m))))))))) (defun pmo->total (pmo) (gathering1 (collecting) (dolist (e pmo) (if (not (listp e)) (gather1 e) (dolist (ee e) (gather1 ee)))))) (defun pmo-nelements (pmo) (let ((n 0)) (dolist (e pmo) (if (not (listp e)) (incf n) (incf n (length e)))) n)) (defun cross-pmos (pmo-1 pmo-2) (let* ((result (list nil)) (tail result) (subsetp-flag t)) (flet ((gather (m) (setq tail (setf (cdr tail) (list m))))) (dolist (e1 pmo-1) (if (not (listp e1)) (if (pmo-memq e1 pmo-2) (gather e1) (unless (eq subsetp-flag '?) (setq subsetp-flag nil))) ;; ;; This element of pmo-1 is a list. That means ;; pmo-1 supplies no ordering information among ;; the elements of this list. Now go use the order ;; of pmo-2 to try and place elements of this ;; list in the result. ;; (progn (setq subsetp-flag '?) (dolist (e2 pmo-2) (if (not (listp e2)) (if (memq e2 e1) (gather e2) ()) ;; ;; Holy Shit Batman, we have come across a list in ;; both pmo-1 and pmo-2. The intersection ;; of the two goes into the result now. ;; (let ((result (intersection e1 e2))) (cond ((null result)) ((cdr result) (gather result)) (t (gather (car result))))))))))) (values (cdr result) (ecase subsetp-flag ((nil) nil) ((t) t) (? (pmo-subsetp pmo-1 (cdr result))))))) (defun pmo-subsetp (pmo-1 pmo-2) (dolist (e1 pmo-1 t) (if (not (listp e1)) (unless (pmo-memq e1 pmo-2) (return-from pmo-subsetp nil)) (dolist (ee1 e1) (unless (pmo-memq ee1 pmo-2) (return-from pmo-subsetp nil)))))) (defun pmo-memq (x pmo) (do* ((tail pmo (cdr tail)) (e (car tail) (car tail))) ((null tail) nil) (if (not (listp e)) (when (eq x e) (return tail)) (when (memq x e) (return tail))))) (defun pmo-sub-p (sub-pmo super-pmo) (dolist (super-e super-pmo t) (if (not (listp super-e)) (unless (setq sub-pmo (pmo-memq super-e sub-pmo)) (return nil)) (let ((farthest sub-pmo)) (dolist (super-ee super-e) (do* ((tail sub-pmo (cdr tail)) (sub-e (car tail) (car tail))) ((null tail) (return-from pmo-sub-p nil)) (if (not (listp sub-e)) (when (eq super-ee sub-e) (return 't)) (when (memq super-ee sub-e) (return 't))) (when (eq farthest tail) (pop farthest)))) (setq sub-pmo farthest))))) ;;; ;;; COMPUTE-PRECEDENCE-DAG ;;; ;;; ;;; The reason this value is split out is that it can be meaningfully cached. ;;; It is reasonable to expect that generic functions will have the same sets ;;; of specializers, so caching this value can save time. This is especially ;;; winning since this is the part of this algorithm that takes the most work. ;;; ;;; The cache must be cleared whenever any class changes its class precedence ;;; list. It does not need to be reset when a class gets a cpl for the very ;;; first time. The cache reseting code could be changed pretty easily to ;;; invalidate less of the cache when something changes. That is left as an ;;; exercise for future users. ;;; (defvar *precedence-dag-cache* (make-hash-table :test #'equal :size 500)) (defvar *enable-precedence-dag-caching* 't) (defun clear-precedence-dag-cache () (clrhash *precedence-dag-cache*)) (defun compute-precedence-dag (classes) (setq classes (remove-duplicates classes)) (if (null *enable-precedence-dag-caching*) (compute-precedence-dag-1 classes) (let ((key (sort (copy-list classes) #'(lambda (c1 c2) (let ((cpl1 (class-precedence-list c1)) (cpl2 (class-precedence-list c2))) (cond ((memq c2 cpl1) t) ((memq c1 cpl2) nil) (t (< (length cpl2) (length cpl1))))))))) (or (gethash key *precedence-dag-cache*) (setf (gethash key *precedence-dag-cache*) (compute-precedence-dag-1 classes)))))) ;;; ;;; The code which actually builds the precedence dag works in three passes. ;;; The first two passes operate on a tree with an entry type specialized to ;;; this code. The third pass uses that specialized tree to produce actual ;;; result tree. ;;; ;;; The specialized entry type used by this code is called CPDI-ENTRY. CPDI ;;; is an abbreviation for Class Precedence Dag Internal. These entries are ;;; created by the macro MAKE-CPDI-ENTRY. These entries have 5 fields: ;;; ;;; CPDI-ENTRY-CLASS ;;; The class object for this entry. ;;; ;;; CPDI-ENTRY-PRECEDENCE ;;; The precedence of CLASSES at this node. ;;; ;;; CPDI-ENTRY-SUPERS ;;; A list of the super nodes of this node. ;;; ;;; CPDI-ENTRY-COUNT ;;; At the end of the first pass, this is the length of ;;; ENTRY-SUPERS. During the second pass, this value is ;;; decremented each time a node is encountered. When this ;;; counter reaches zero, it means all the parents of this ;;; node have been visited. This gets parents first search. ;;; ;;; CPDI-ENTRY-STATUS ;;; The second pass uses this field to mark nodes as being ;;; either KEPT or DELETED. In the third pass this field ;;; is used to know which nodes to place in the result and ;;; to implement structure sharing in the result. The first ;;; a kept subtree is visited, this field is filled with the ;;; result subtree for that subtree so that that result can ;;; be used again if the kept node is encountered again. ;;; ;;; Entries in the returned tree are called CPD-ENTRY. CPD is an abbreviation ;;; for Class Precedence Dag. These have three fields: ;;; ;;; CPD-ENTRY-CLASS ;;; The class object. ;;; ;;; CPD-ENTRY-PRECEDENCE ;;; The precedence at this point in the dag. ;;; ;;; CPD-ENTRY-MULTIPLE-SUPERS-P ;;; A boolean flag indicating whether this subtree has multiple ;;; supers in the dag. Our caller is free to use this as an ;;; optimization when detecting multiple inheritance in the dag. ;;; ;;; ;;; ;;; The first pass is the BUILD pass. This builds a skeleton of the complete ;;; class DAG. This skeleton includes: ;;; * The class named T (the top of the tree). ;;; * Each class in CLASSES. ;;; * Any other class having the following properties: ;;; - has multiple supers ;;; - is a subclass of more than one class in CLASSES ;;; - more than one of the supers is itself a subclass ;;; of some class in CLASSES ;;; ;;; The second pass (REDUCE) goes through and marks some of the nodes deleted. ;;; Nodes are deleted when they have the same precedence as THE ONE of their ;;; parent nodes they inherit from. This pass uses parents first traversal of ;;; the tree. Parents first traversal means that when considering whether to ;;; delete or keep a node, the status of each of its parents is known. Using ;;; the class precedence list of the node, we can determine which of the kept ;;; parents the node will inherit from. ;;; ;;; The third pass (COLLECT) simply builds the returned tree by including one ;;; node for each kept node in the tree produced by pass 1 and 2. ;;; ;;; (defun compute-precedence-dag-1 (classes) (let* ((top-entry (make-cpdi-entry *the-class-t* (remove-if #'(lambda (x) (neq x *the-class-t*)) classes))) (top-of-tree (make-cpnode top-entry ()))) (compute-precedence-dag-pass-1 classes top-of-tree) (compute-precedence-dag-pass-2 top-of-tree) (compute-precedence-dag-pass-3 top-of-tree))) (defun compute-precedence-dag-pass-1 (classes tree) (let ((been-here-alist ())) (labels ((insert (tree new-node new-entry class cpl) (let ((subtrees (cpnode-subnodes tree)) (inserted-somewhere-below-here-p nil)) ;; ;; First see if the new node can be inserted below ;; any of our subtrees. Note that a new node can ;; be below more than one of our subtrees. ;; (dolist (subtree subtrees) (let* ((subentry (cpnode-entry subtree)) (subclass (cpdi-entry-class subentry))) (when (memq subclass cpl) (setq inserted-somewhere-below-here-p t) (insert subtree new-node new-entry class cpl)))) ;; ;; Then see if the new node can be inserted above ;; any of our subtrees. Note that a new node can ;; be above some of our subtrees and below others. ;; (dolist (subtree subtrees) (let* ((subentry (cpnode-entry subtree)) (subclass (cpdi-entry-class subentry))) (when (memq class (class-precedence-list subclass)) (setq inserted-somewhere-below-here-p t) (unlink subtree subentry tree) ;sub not below us (link new-node new-entry tree) ;new below us (link subtree subentry new-node)))) ;sub below new (unless inserted-somewhere-below-here-p (link new-node new-entry tree)))) (build (node class) (unless (or (eq class *the-class-t*) (eq class *the-class-object*)) (dolist (subclass (class-direct-subclasses class)) (build-1 node subclass)))) (build-1 (node subclass) (let ((been-here (assq subclass been-here-alist))) (if been-here ;; ;; If we have already encountered this class, then ;; record this possibly new path to whatever nodes ;; are below it. Note that we are relying on LINK ;; not to record redundant relationships. ;; (dolist (old-node (cdr been-here)) (link old-node (cpnode-entry old-node) node)) ;; ;; ;; (let ((cpl (class-precedence-list subclass))) (if (class-goes-in-p subclass cpl) ;; ;; A new node has to go into the tree for this ;; subclass. Create that node, insert it, and ;; then recurse with it. ;; (let* ((precedence (compute-precedence cpl)) (new-entry (make-cpdi-entry subclass precedence)) (new-node (make-cpnode new-entry ()))) (link new-node new-entry node) (push (list subclass new-node) been-here-alist) (build new-node subclass)) ;; ;; No new node for this class. But we do have ;; to be sure to record this class on the been ;; here alist. ;; (let ((existing (cpnode-subnodes node)) (been-here (list subclass))) (build node subclass) (dolist (new-sub (cpnode-subnodes node)) (unless (memq new-sub existing) (push new-sub (cdr been-here)) (link new-sub (cpnode-entry new-sub) node))) (push been-here been-here-alist))))))) (class-goes-in-p (class cpl) (let ((supers (class-local-supers class))) (or (memq class classes) (and (cdr supers) (let ((state nil)) ;More than one class (dolist (class cpl) ;from classes in cpl? (when (memq class classes) (if (eq state nil) (setq state t) (return 't))))) (let ((state nil)) (block check-supers (dolist (sup supers) (dolist (class (class-precedence-list sup)) (when (memq class classes) (if (null state) (setq state t) (return-from check-supers 't))))))))))) (compute-precedence (cpl) (gathering1 (collecting) (dolist (class cpl) (when (memq class classes) (gather1 class))))) (link (subnode subentry supnode) (unless (memq subnode (cpnode-subnodes supnode)) (push subnode (cpnode-subnodes supnode)) (incf (cpdi-entry-count subentry)) (push supnode (cpdi-entry-supers subentry)))) (unlink (subnode subentry supnode) (when (memq subnode (cpnode-subnodes supnode)) (setf (cpnode-subnodes supnode) (delete subnode (cpnode-subnodes supnode))) (decf (cpdi-entry-count subentry)) (setf (cpdi-entry-supers subentry) (delete supnode (cpdi-entry-supers subentry)))))) (dolist (class classes) (unless (or (eq class *the-class-t*) (assq class been-here-alist)) (let* ((cpl (class-precedence-list class)) (precedence (compute-precedence cpl)) (new-entry (make-cpdi-entry class precedence)) (new-node (make-cpnode new-entry ()))) (insert tree new-node new-entry class cpl) (push (list class new-node) been-here-alist) (build new-node class)))) tree))) (defun compute-precedence-dag-pass-2 (tree) (labels ((reduce (node) (let* ((entry (cpnode-entry node)) (subs (cpnode-subnodes node)) (class ()) (rcpl ()) (supers ()) (precedence ()) (kept-super nil)) (if (> (cpdi-entry-count entry) 1) (decf (cpdi-entry-count entry)) (progn (when (setq supers (cpdi-entry-supers entry)) (setq precedence (cpdi-entry-precedence entry) class (cpdi-entry-class entry) rcpl (reverse (class-precedence-list class)) kept-super (get-kept-super supers rcpl)) (when (and kept-super (equal (cpdi-entry-precedence (cpnode-entry kept-super)) precedence)) (setf (cpdi-entry-status entry) 'deleted))) (dolist (sub subs) (reduce sub)))))) (get-kept-super (supers rcpl) (when supers (let* ((best-super (car supers)) (best-rcpl-tail (memq (cpdi-entry-class (cpnode-entry best-super)) rcpl))) (dolist (s (cdr supers)) (let ((tail (memq (cpdi-entry-class (cpnode-entry s)) best-rcpl-tail))) (when tail (setq best-rcpl-tail tail best-super s)))) (if (eq (cpdi-entry-status (cpnode-entry best-super)) 'kept) (values best-super best-rcpl-tail) (let ((best-sub-super nil) (best-sub-rcpl-tail ())) (dolist (s supers) (multiple-value-bind (sub-super sub-rcpl-tail) (get-kept-super (cpdi-entry-supers (cpnode-entry s)) rcpl) (when (and sub-super (or (null best-sub-super) (tailp sub-rcpl-tail best-sub-rcpl-tail))) (setq best-sub-super sub-super best-sub-rcpl-tail sub-rcpl-tail)))) (values best-sub-super best-sub-rcpl-tail))))))) (reduce tree))) (defun compute-precedence-dag-pass-3 (tree) (labels ((collect (node previous-precedence) (let* ((entry (cpnode-entry node)) (subnodes (cpnode-subnodes node)) (status (cpdi-entry-status entry)) (precedence (cpdi-entry-precedence entry))) (case (cpdi-entry-status entry) (kept (when (sub-precedence-p precedence previous-precedence) (let* ((result-entry (make-cpd-entry (cpdi-entry-class entry) precedence)) (result-node (make-cpnode result-entry (collect-1 subnodes precedence)))) (setf (cpdi-entry-status entry) (list result-node))))) (deleted (collect-1 subnodes previous-precedence)) (t ;; We have been here before, mark the node(s) as ;; having multiple supers and return them. (dolist (node status) (let ((entry (cpnode-entry node))) (setf (cpd-entry-multiple-supers-p entry) 't))) status)))) (collect-1 (subnodes previous-precedence) (gathering1 (joining) (dolist (subnode subnodes) (gather1 (copy-list (collect subnode previous-precedence)))))) (sub-precedence-p (sub sup) (dolist (c sup t) (unless (setq sub (memq c sub)) (return nil))))) (car (collect tree ())))) ;from std-class.lisp ;;; ;;; compute-class-precedence-list ;;; ;;; ;;; Knuth section 2.2.3 has some interesting notes on this. ;;; ;;; What appears here is basically the algorithm presented there. ;;; ;;; The key idea is that we use class-precedence-description (CPD) structures ;;; to store the precedence information as we proceed. The CPD structure for ;;; a class stores two critical pieces of information: ;;; ;;; - a count of the number of "reasons" why the class can't go ;;; into the class precedence list yet. ;;; ;;; - a list of the "reasons" this class prevents others from ;;; going in until after it ;; ;;; A "reason" is essentially a single local precedence constraint. If a ;;; constraint between two classes arises more than once it generates more ;;; than one reason. This makes things simpler, linear, and isn't a problem ;;; as long as we make sure to keep track of each instance of a "reason". ;;; ;;; This code is divided into three phases. ;;; ;;; - the first phase simply generates the CPD's for each of the class ;;; and its superclasses. The remainder of the code will manipulate ;;; these CPDs rather than the class objects themselves. At the end ;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs ;;; of the direct superclasses of the class. ;;; ;;; - the second phase folds all the local constraints into the CPD ;;; structure. The CPD-COUNT of each CPD is built up, and the ;;; CPD-AFTER fields are augmented to include precedence constraints ;;; from the CPD-SUPERS field and from the order of classes in other ;;; CPD-SUPERS fields. ;;; ;;; After this phase, the CPD-AFTER field of a class includes all the ;;; direct superclasses of the class plus any class that immediately ;;; follows the class in the direct superclasses of another. There ;;; can be duplicates in this list. The CPD-COUNT field is equal to ;;; the number of times this class appears in the CPD-AFTER field of ;;; all the other CPDs. ;;; ;;; - In the third phase, classes are put into the precedence list one ;;; at a time, with only those classes with a CPD-COUNT of 0 being ;;; candidates for insertion. When a class is inserted , every CPD ;;; in its CPD-AFTER field has its count decremented. ;;; ;;; In the usual case, there is only one candidate for insertion at ;;; any point. If there is more than one, the specified tiebreaker ;;; rule is used to choose among them. ;;; (defstruct (class-precedence-description (:conc-name nil) (:print-function (lambda (obj str depth) (declare (ignore depth)) (format str "#" (class-name (cpd-class obj)) (cpd-count obj)))) (:constructor make-cpd ())) (cpd-class nil) (cpd-supers ()) (cpd-after ()) (cpd-count 0)) (defun compute-std-cpl (class) (let ((supers (class-local-supers class))) (cond ((null supers) ;First two branches of COND (list class)) ;are implementing the single ((null (cdr supers)) ;inheritance optimization. (cons class (compute-std-cpl (car supers)))) (t (multiple-value-bind (all-cpds nclasses) (compute-std-cpl-phase-1 class supers) (compute-std-cpl-phase-2 all-cpds) (compute-std-cpl-phase-3 class all-cpds nclasses)))))) (defvar *compute-std-cpl-class->entry-table-size* 60) (defun compute-std-cpl-phase-1 (class supers) (let ((nclasses 0) (all-cpds ()) (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test #'eq))) (labels ((get-cpd (c) (or (gethash c table) (setf (gethash c table) (make-cpd)))) (walk (c supers) (if (forward-referenced-class-p c) (cpl-forward-referenced-class-error class c) (let ((cpd (get-cpd c))) (unless (cpd-class cpd) ;If we have already done this ;class before, we can quit. (setf (cpd-class cpd) c) (incf nclasses) (push cpd all-cpds) (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) (dolist (super supers) (walk super (class-local-supers super)))))))) (walk class supers) (values all-cpds nclasses)))) (defun compute-std-cpl-phase-2 (all-cpds) (dolist (cpd all-cpds) (let ((supers (cpd-supers cpd))) (when supers (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) (incf (cpd-count (car supers)) 1) (do* ((t1 supers t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (incf (cpd-count (car t2)) 2) (push (car t2) (cpd-after (car t1)))))))) (defun compute-std-cpl-phase-3 (class all-cpds nclasses) (let ((candidates ()) (next-cpd nil) (rcpl ())) ;; ;; We have to bootstrap the collection of those CPD's that ;; have a zero count. Once we get going, we will maintain ;; this list incrementally. ;; (dolist (cpd all-cpds) (when (zerop (cpd-count cpd)) (push cpd candidates))) (loop (when (null candidates) ;; ;; If there are no candidates, and enough classes have been put ;; into the precedence list, then we are all done. Otherwise ;; it means there is a consistency problem. (if (zerop nclasses) (return (reverse rcpl)) (cpl-inconsistent-error class all-cpds))) ;; ;; Try to find the next class to put in from among the candidates. ;; If there is only one, its easy, otherwise we have to use the ;; famous RPG tiebreaker rule. There is some hair here to avoid ;; having to call DELETE on the list of candidates. I dunno if ;; its worth it but what the hell. ;; (setq next-cpd (if (null (cdr candidates)) (prog1 (car candidates) (setq candidates ())) (block tie-breaker (dolist (c rcpl) (let ((supers (class-local-supers c))) (if (memq (cpd-class (car candidates)) supers) (return-from tie-breaker (pop candidates)) (do ((loc candidates (cdr loc))) ((null (cdr loc))) (let ((cpd (cadr loc))) (when (memq (cpd-class cpd) supers) (setf (cdr loc) (cddr loc)) (return-from tie-breaker cpd)))))))))) (decf nclasses) (push (cpd-class next-cpd) rcpl) (dolist (after (cpd-after next-cpd)) (when (zerop (decf (cpd-count after))) (push after candidates)))))) ;;; ;;; Support code for signalling nice error messages. ;;; (defun cpl-error (class format-string &rest format-args) (error "While computing the class precedence list of the class ~A.~%~A" (if (class-name class) (format nil "named ~S" (class-name class)) class) (apply #'format nil format-string format-args))) (defun cpl-forward-referenced-class-error (class forward-class) (flet ((class-or-name (class) (if (class-name class) (format nil "named ~S" (class-name class)) class))) (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))) (cpl-error class "The class ~A is a forward referenced class.~@ The class ~A is ~A." (class-or-name forward-class) (class-or-name forward-class) (if (null (cdr names)) (format nil "a direct superclass of the class ~A" (class-or-name class)) (format nil "reached from the class ~A by following~@ the direct superclass chain through: ~A~ ~% ending at the class ~A" (class-or-name class) (format nil "~{~% the class ~A,~}" (butlast names)) (car (last names)))))))) (defun find-superclass-chain (bottom top) (labels ((walk (c chain) (if (eq c top) (return-from find-superclass-chain (nreverse chain)) (dolist (super (class-local-supers c)) (walk super (cons super chain)))))) (walk bottom (list bottom)))) (defun cpl-inconsistent-error (class all-cpds) (let ((reasons (find-cycle-reasons all-cpds))) (cpl-error class "It is not possible to compute the class precedence list because~@ there ~A in the local precedence relations.~@ ~A because:~{~% ~A~}." (if (cdr reasons) "are circularities" "is a circularity") (if (cdr reasons) "These arise" "This arises") (format-cycle-reasons (apply #'append reasons))))) (defun format-cycle-reasons (reasons) (flet ((class-or-name (cpd) (let ((class (cpd-class cpd))) (if (class-name class) (format nil "named ~S" (class-name class)) class)))) (mapcar #'(lambda (reason) (ecase (caddr reason) (:super (format nil "the class ~A appears in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)))) (:in-supers (format nil "the class ~A follows the class ~A in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)) (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) (let ((been-here ()) ;List of classes we have visited. (cycle-reasons ())) (labels ((chase (path) (if (memq (car path) (cdr path)) (record-cycle (memq (car path) (nreverse path))) (unless (memq (car path) been-here) (push (car path) been-here) (dolist (after (cpd-after (car path))) (chase (cons after path)))))) (record-cycle (cycle) (let ((reasons ())) (do* ((t1 cycle t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (let ((c1 (car t1)) (c2 (car t2))) (if (memq c2 (cpd-supers c1)) (push (list c1 c2 :super) reasons) (dolist (cpd all-cpds) (when (memq c2 (memq c1 (cpd-supers cpd))) (return (push (list c1 c2 :in-supers cpd) reasons))))))) (push (nreverse reasons) cycle-reasons)))) (dolist (cpd all-cpds) (unless (zerop (cpd-count cpd)) (chase (list cpd)))) cycle-reasons))) ---------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA20679; Wed, 19 Apr 89 03:14:30 -0700 Reply-To: kiuchi.pa@Xerox.COM Received: from Salvador.ms by ArpaGateway.ms ; 18 APR 89 15:44:48 PDT Date: 18 Apr 89 14:04 PDT From: kiuchi.pa@Xerox.COM Subject: checking precedence changes (1/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890418-154448-164@Xerox> We will release a new version of PCL in the very near future. In this new version, there are some changes to the way class precedence list computation and standard method combination work. These changes make these facilities conform to the specification. Most programs will be completely unaffected by these changes. But, for the very few programs that are affected, the differences can be subtle. To make this transition easier for you, I have written a program which detects the effects of these changes. The way this program works is you run it on your code in the current version of PCL. It will tell you how your code will be affected in the next version of PCL so you can fix it before you make the jump. This program is designed to be compiled and loaded in the 12/7/88 version of PCL. Do not load it into later versions of PCL. The rest of this message contains instructions on how to use this program. I will be sending out two more messages which contain the actual code. If there are any questions please feel free to contact me. Yasuhiko Kiuchi (kiuchi.pa@Xerox.com) ---------- check.text ---------- This is the instructions describing how to use PCL check program. The files related with the check program are followings. check.text [This file] Instruction for using the check program. check1.lisp a new definition of compute-combination-points a new definition of compute-class-precedence-list check2.lisp friendly code to check to see if the new definitions in check1.lisp will affect a given system. *** This program is designed to be compiled and loaded in the 12/7/88 *** *** version of PCL. Attempting to load it into later versions of PCL *** *** can cause bad surprises. *** * The behavior of check program The check program will gather all metaobjects in the Lisp image and analyze if there is any difference of the behaviour of the program. If there are any, the check program will warn about the changes. If the check program cannot analyze the changes of behaviour of some metaobjects, check program will explicitly point those out. The process of the check program consists of three phase. Phase 1: Gathering metaobjects Gather the all metaobjects(classes, generic-functions, slot-definitions) Phase 2: Analyzing Analyze the effects of the changes on a given system written in PCL. Phase 3: Description of effects of the changes. Display the changes if any. * How to use the check program (1) load 12/7/88 version of PCL (2) load and run the programs you want to analyze. (3) compile and load check1.lisp and check2.lisp (4) call (pcl::check-precedence) Then, the check program will display the changes if any. If you have a check-pointed lisp-image or sysout containing PCL and your programs, you can start from (3). * A known problem with the check program The gather program contained in the check2.lisp doesn't gather those generic-functions for which all of the methods have only EQL specializers. If your program contains such generic-functions, you need to check by hand. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA23555; Wed, 19 Apr 89 05:06:43 -0700 Reply-To: Owners-CommonLoops.pa@Xerox.COM Received: from Semillon.ms by ArpaGateway.ms ; 18 APR 89 16:16:30 PDT Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 18 APR 89 15:12:58 PDT To: CommonLoops.pa@Xerox.COM Cc: kanderson@DINO.BBN.COM Subject: update-method-inheritance invalidates gf's unnecessarily Date: Tue, 18 Apr 89 17:09:42 -0400 From: kanderso@DINO.BBN.COM Message-Id: <890418-161630-220@Xerox> When a new class is defined, ADD-NAMED-CLASS creates an instance of STANDARD-CLASS for it. This instance has a CLASS-PRECEDENCE-LIST (CPL) of (T) while the class will ultimately have some actual CLP of say (C-N ... C-0 T). Eventually UPDATE-METHOD-INHERITANCE gets called and all CLASS-DIRECT-METHODS on classes named C-N ... C-O have INVALIDATE-GENERIC-FUNCTION run on their METHOD-GENERIC-FUNCTION. So, for example, if you define a class built on STANDARD-CLASS, ~107 generic functions of PCL are trashed. This invalidation is unnecessary because this new class has no methods defined for it yet and thus can't alter any generic function's behavior. I wasn't sure where to fix this. Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA24136; Wed, 19 Apr 89 06:21:07 -0700 Reply-To: kiuchi.pa@Xerox.COM Received: from Semillon.ms by ArpaGateway.ms ; 18 APR 89 15:38:00 PDT Date: 18 Apr 89 14:05 PDT From: kiuchi.pa@Xerox.COM Subject: check2.lisp (3/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890418-153800-155@Xerox> ---------- check2.lisp ---------- ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "PCL") ;;; ;;; This file contains: ;;; * almost friendly code to check to see if these new ;;; definitions will screw a given system ;;; ;;; This file is designed to be compiled and loaded in the 12/7/88 ;;; version of PCL. Attempting to load it into later versions of ;;; PCL can cause bad surprises ;;; ;;; These are special stuff for computing the changes that will be ;;; caused by new implementation of compute-class-precedence-list ;;; and standard-method-combination in the next version of PCL ;;; ;;; check program for new cpl and combination-points implementations ;;; to use ;;; (1) load 12/7/88 version of PCL by (pcl:load-pcl) ;;; (2) load the program you want to analyze ;;; (3) compile and load check1.lisp and check2.lisp ;;; (4) call (pcl::check-precedence) ;;; ;;; ;;; This first part is basically lifted from gather.lisp. ;;; (defun collect-pcl-external-symbols () (gathering ((result (collecting))) (do-external-symbols (s *the-pcl-package*) (gather s result)))) (defvar *pcl-external-symbols* (collect-pcl-external-symbols)) (defvar *the-lisp-package* (find-package 'lisp)) (defvar *generic-functions* ()) (defvar *classes* ()) (defvar *methods* ()) (defvar *metaobjects* ()) (defun gather-metaobjects (&optional (scope :user)) (check-type scope (or (member :user :all :pcl :clos) package) "A PACKAGE or one of the symbols :user :all :pcl :clos") (setq *generic-functions* () *classes* () *methods* ()) (labels ((walk (class) (when (gatherp class scope) (pushnew class *classes*) (pushnew class *metaobjects*)) (dolist (m (class-direct-methods class)) (when (gatherp m scope) (pushnew m *methods*) (pushnew m *metaobjects*)) (let ((gf (method-generic-function m))) (when (and gf (gatherp gf scope)) (pushnew gf *generic-functions*) (pushnew gf *metaobjects*)))) (dolist (sub (class-direct-subclasses class)) (walk sub)))) (walk (find-class 't)) (format t "~&~D Classes, ~D Generic Functions, ~D Methods." (length *classes*) (length *generic-functions*) (length *methods*)))) (defmethod gatherp ((class standard-class) scope) (let* ((name (class-name class)) (package (and name (symbolp name) (symbol-package name)))) (if (or (null package) (neq (find-class name nil) class)) t (gatherp-internal name package scope)))) (defmethod gatherp ((method standard-method) scope) (let ((generic-function (method-generic-function method))) (and generic-function (gatherp generic-function scope)))) (defmethod gatherp ((gf standard-generic-function) scope) (let* ((name (generic-function-name gf)) (specp (cond ((null name) nil) ((symbolp name) 'symbol) ((and (listp name) (eq (car name) 'setf) (null (cddr name))) 'setf) (t nil))) (package (ecase specp (symbol (symbol-package name)) (setf (symbol-package (cadr name))) ((nil) nil)))) (if (or (null specp) (not (gboundp name)) (neq (gdefinition name) gf)) t (gatherp-internal name package scope)))) (defun gatherp-internal (name package scope) (case scope (:user (and (neq package *the-pcl-package*) (neq package *the-lisp-package*))) (:pcl (eq package *the-pcl-package*)) (:clos (or (eq package *the-lisp-package*) (memq name *pcl-external-symbols*))) (:all t) (otherwise (eq package scope)))) ;;; ;;; Here is the check program ;;; (defvar *changed-classes* ()) (defvar *changed-generic-functions* ()) (defvar *eql-gfs* ()) (defvar *specializer-error-gfs* ()) (defvar *non-standard-qualifier-gfs* ()) (defun check-precedence (&optional (scope :all)) (let ((*classes* ()) (*generic-functions* ()) (*methods* ()) (*metaobjects* ()) (*changed-classes* ()) (*changed-generic-functions* ()) (*eql-gfs* ()) (*specializer-error-gfs* ()) (*non-standard-qualifier-gfs* ())) (format t "~%Phase 1: Gathering metaobjects...~%") (gather-metaobjects scope) (format t "~%~%Phase 2: Analyzing...~%") (gather-changed-metaobjects) (cond ((or *eql-gfs* *specializer-error-gfs* *non-standard-qualifier-gfs* *changed-classes* *changed-generic-functions*) ;we do have some change (format t "~%Phase 3: Description of effects of new precedence computation...~%") (when *eql-gfs* (warn-eql-gfs)) (when *specializer-error-gfs* (warn-specializer-error-gfs)) (when *non-standard-qualifier-gfs* (warn-non-standard-qualifier-gfs)) (when *changed-generic-functions* (warn-generic-function-change)) (when *changed-classes* (warn-class-change))) (t ;we don't have any chage (format t "~%No differences found."))))) ;;; ;;; gather changed objects by checking check the *classes*'s cpl ;;; and *generic-functions*'s combination-points ;;; (defun gather-changed-metaobjects () (dolist (class *classes*) (unless (equal (compute-class-precedence-list class) (compute-std-cpl class)) (push class *changed-classes*))) (labels ((point-lessp (p1 p2) (cond ((eq p1 p2) nil) ((eq (car p1) (car p2)) (point-lessp (cdr p1) (cdr p2))) (t (member (car p2) (member (car p1) *classes*))))) (sort-points (points) (sort points #'(lambda (p1 p2) (point-lessp (car p1) (car p2)))))) ;; set *eql-gfs*, *non-standard-qualifier-gfs*, ;; *specializer-error-gfs* and *generic-functions* (precheck-generic-functions) (let ((old-sorted-points ()) (new-sorted-points ())) (dolist (generic-function *generic-functions*) (push (sort-points (compute-combination-points generic-function)) old-sorted-points)) ;; We need to make sure we are computing new combination-points ;; by using new cpl (unwind-protect (progn (dolist (class *classes*) (setf (class-precedence-list class) (compute-std-cpl class))) (dolist (generic-function *generic-functions*) (push (sort-points (*compute-combination-points generic-function)) new-sorted-points))) (dolist (class *classes*) (setf (class-precedence-list class) (compute-class-precedence-list class)))) (iterate ((old-sort (list-elements (nreverse old-sorted-points))) (new-sort (list-elements (nreverse new-sorted-points))) (generic-function (list-elements *generic-functions*))) (unless (same-method-order-p old-sort new-sort) (push (list generic-function old-sort new-sort) *changed-generic-functions*)))))) ;(defun sort-methods-by-qualifiers (methods) ; (stable-sort methods ; #'(lambda (one another) ; (and (equal (method-type-specifiers one) ; (method-type-specifiers another)) ; (string-lessp (prin1-to-string ; (method-qualifiers one)) ; (prin1-to-string ; (method-qualifiers another))))))) ;;; ;;; check over the all points and if the order of methods of all points ;;; are same it returns t ;;; (defun same-method-order-p (old-points new-points) (unless (eql (length old-points) (length new-points)) (return-from same-method-order-p nil)) (iterate ((old-p-m (list-elements old-points)) (new-p-m (list-elements new-points))) (unless (and (equal (car old-p-m) (car new-p-m)) (same-method-order-p-1 (cadr old-p-m) (cadr new-p-m))) (return-from same-method-order-p nil))) t) ;;; ;;; check two lists of methods each other and if the order of methods ;;; are same it returns t ;;; (defun same-method-order-p-1 (order-1 order-2) (dolist (qualifiers '(() (:before) (:after) (:around))) (let ((methods-1 ()) (methods-2 ())) (dolist (m1 order-1) (when (equal (method-qualifiers m1) qualifiers) (push m1 methods-1))) (dolist (m2 order-2) (when (equal (method-qualifiers m2) qualifiers) (push m2 methods-2))) (unless (equal methods-1 methods-2) (return-from same-method-order-p-1 nil)))) t) ;;; ;;; This check program cannot analyze the behavior of generic functions ;;; which contain EQL methods. The following generic functions warned by ;;; this function should be checked by hand. ;;; ;;; If you have any generic functions such as all methods in this generic ;;; function have all EQL specailizers, you also need to check these by hand. ;;; This check program doesn't say anything because the gather program cannot ;;; gather these kinds of methods and generic functions ;;; (defun warn-eql-gfs () (format t "~%This program cannot analyze the behavior of generic functions~%~ which contain EQL methods. The following generic functions~%~ should be checked by hand:~%~%") (dolist (gf *eql-gfs*) (format t " ~S~%" (generic-function-name gf))) (format t "~%Keep in mind that in 12/7/88 and older versions of PCL,~%~ EQL methods did not interact properly with method combination.~%~ In the next version of PCL, this will work properly.~%~ ~%***~%")) ;;; ;;; 12/7/88 version of PCL only supports standard-method-combination. This ;;; check program only handle standart method combination. ;;; (defun warn-non-standard-qualifier-gfs () (format t "~%This program cannot analyze the behavior of generic functions~%~ which using non-standard method combination. The following~%~ generic functions should be checked by hand:~%~%") (dolist (gf *non-standard-qualifier-gfs*) (format t " ~S~%" (generic-function-name gf))) (format t "~%***~%")) ;;; ;;; wanrs the bugs in your method definitions ;;; (defun warn-specializer-error-gfs () (format t "~%The following generic functions have methods with a different~%~ number of parameter specializers. This program cannot analyze~%~ the behavior of such generic functions. A future version of~%~ PCL will signal an error in such cases.~%~%") (dolist (gf *specializer-error-gfs*) (format t " ~S~%" (generic-function-name gf))) (format t "~%***~%")) ;;; ;;; The check program only works on generic functions filitered by this ;;; precheck. ;;; (defun precheck-generic-functions () (let ((eql-gfs ()) (non-standard-qualifier-gfs ()) (specializer-error-gfs ()) (other-gfs ())) (dolist (gf *generic-functions*) (let* ((methods (generic-function-methods gf)) (no-of-spec-params (length (method-type-specifiers (car methods))))) (block next-gf (dolist (method methods) (let ((specl (method-type-specifiers method)) (qualifiers (method-qualifiers method))) (when (neq (length specl) no-of-spec-params) (push gf specializer-error-gfs) (return-from next-gf)) (unless (or (cadr qualifiers) (memq (car qualifiers) '(() :before :after :around))) (push gf non-standard-qualifier-gfs) (return-from next-gf)) (dolist (spec specl) (specializer-case spec (:eql (push gf eql-gfs) (return-from next-gf)) (:class nil))))) (push gf other-gfs)))) (setq *eql-gfs* eql-gfs *non-standard-qualifier-gfs* non-standard-qualifier-gfs *specializer-error-gfs* specializer-error-gfs *generic-functions* other-gfs))) ;;; ;;; warns the changes of generic functions ;;; (defun warn-generic-function-change () (dolist (gf-and-points *changed-generic-functions*) (destructuring-bind (gf old-points new-points) gf-and-points (multiple-value-bind (different missing extra) (compute-point-diffs old-points new-points) ;; check specializers to make sure (warn-point-diffs gf old-points new-points different missing extra))))) (defun warn-point-diffs (gf old-points new-points different missing extra) (dolist (d different) (warn-gf-difference gf (caar d) (compute-gf-difference (cadar d) (cadadr d)))) (dolist (m missing) (let ((old-super-point (get-super-point old-points (car m) #'compute-class-precedence-list)) (new-super-point (get-super-point new-points (car m) #'compute-std-cpl))) (if (same-method-order-p-1 (cadr m) (cadr old-super-point)) (warn-gf-redundant-point gf m :old) (or (same-method-order-p-1 (cadr m) (cadr new-super-point)) (warn-gf-difference gf (car m) (compute-gf-difference (cadr m) (cadr new-super-point))))))) (dolist (e extra) (let ((old-super-point (get-super-point old-points (car e) #'compute-class-precedence-list)) (new-super-point (get-super-point new-points (car e) #'compute-std-cpl))) (if (same-method-order-p-1 (cadr e) (cadr new-super-point)) (warn-gf-redundant-point gf e :new) (or (same-method-order-p-1 (cadr e) (cadr old-super-point)) (warn-gf-difference gf (car e) (compute-gf-difference (cadr old-super-point) (cadr e)))))))) (defun warn-gf-redundant-point (gf p-m old-or-new) (declare (ignore gf p-m old-or-new)) ;; This is the codes for debugging the new implementation ;; of compute-std-cpl, *compute-combination-points and check program ; (ecase old-or-new ; (:old (format t "~%Generic function ~S had a redundant point~%~ ; This is now fixed in the new implementation" ; (generic-function-name gf))) ; (:new (format t "~%Generic function ~S has a redundant point~%~ ; This is not a real error but should be fixed" ; (Generic-function-name gf)))) ; (format t "~%point: ~S" ; (mapcar #'class-name (car p-m))) ; (format t "~%method: ~S~%" ; (mapcar #'(lambda (method) ; (mapcar #'class-name ; (method-type-specifiers method))) ; (cadr p-m))) ) (defun warn-gf-difference (gf point changes) (iterate ((qualifier (list-elements '(before after around primary))) (change (list-elements changes))) (unless (eq change t) (let ((o-result (car change)) (n-result (cadr change))) (cond ((and (null o-result) (null n-result))) ((null o-result) (format t "~%~%~ When generic-function ~S is called with instance~P of:~%~ ~S~%~ The ~A method~P ~S ~A not applicable in old implementation~%~ Now, the method~P ~A applicable in new implementation" (generic-function-name gf) (length point) (mapcar #'class-name point) qualifier (length n-result) n-result (is-or-are n-result) (length n-result) (is-or-are n-result))) ((null n-result) (format t "~%~%~ When generic-function ~S is called with instance~P of:~%~ ~S~%~ The ~A method~P ~S ~A applicable in old implementation~%~ Now, the method~P ~A not applicable in new implementation" (generic-function-name gf) (length point) (mapcar #'class-name point) qualifier (length o-result) o-result (is-or-are o-result) (length o-result) (is-or-are o-result))) (t (format t "~%~%~ When generic-function ~S is called with instance~P of:~%~ ~S~%~ Order of ~A method~P has changed~%~ Old order of method~P is:~%~ ~S~%~ New order of method~P is:~%~ ~S" (generic-function-name gf) (length point) (mapcar #'class-name point) qualifier (length o-result) (length o-result) o-result (length n-result) n-result))))))) (defun is-or-are (sequence) (if (eq (length sequence) 1) "is" "are")) (defun separate-methods (ordered-methods) (let ((before ()) (after ()) (around ()) (primary ())) (dolist (m ordered-methods) (let ((qualifiers (method-qualifiers m)) (spec (mapcar #'class-name (method-type-specifiers m)))) (cond ((memq ':before qualifiers) (push spec before)) ((memq ':after qualifiers) (push spec after)) ((memq ':around qualifiers) (push spec around)) (t (push spec primary))))) (values before (nreverse after) (nreverse around) (nreverse primary)))) (defun compute-gf-difference (o-methods n-methods) (multiple-value-bind (old-before old-after old-around old-primary) (separate-methods o-methods) (multiple-value-bind (new-before new-after new-around new-primary) (separate-methods n-methods) (list (compute-gf-difference-1 old-before new-before) (compute-gf-difference-1 old-after new-after) (compute-gf-difference-1 old-around new-around) (compute-gf-difference-1 old-primary new-primary))))) (defun compute-gf-difference-1 (old new) (if (equal old new) t (list (subseq old (mismatch old new :test #'equal) (mismatch old new :test #'equal :from-end t)) (subseq new (mismatch old new :test #'equal) (mismatch old new :test #'equal :from-end t))))) (defun get-super-point (points point &optional (compute-fn #'compute-std-cpl)) (let ((list-of-cpl (mapcar #'(lambda (spec) (funcall compute-fn spec)) point)) (result-so-far ())) (dolist (p-m points) (block next-point (let ((p (car p-m)) (label ())) (if (equal p point) (return-from next-point) (iterate ((class (list-elements p)) (cpl (list-elements list-of-cpl))) (let ((foundp (memq class cpl))) (if foundp (push (length foundp) label) (return-from next-point))))) (setq label (nreverse label)) (if result-so-far (when (list-greater-p label (cdr result-so-far)) (setq result-so-far (cons p-m label))) (setq result-so-far (cons p-m label)))))) (if result-so-far (car result-so-far)))) (defun list-greater-p (label label-so-far) (let ((number (car label)) (number-so-far (car label-so-far))) (cond ((> number number-so-far) t) ((= number number-so-far) (list-greater-p (cdr label) (cdr label-so-far)))))) ;;; ;;; compute the different points for each changed generic functiuons ;;; (defun compute-point-diffs (old-points new-points) (let ((different ()) (missing old-points) (extra ())) (dolist (new-point new-points) (let ((old-point (find (car new-point) old-points :key #'car :test #'equal))) (if old-point (progn (unless (same-method-order-p-1 (cadr old-point) (cadr new-point)) (push (list old-point new-point) different)) (setq missing (remove old-point missing :test #'equal))) (push new-point extra)))) (values different missing extra))) ;;; ;;; warn changed classes(cpl, default-initargs and slots[initform/initargs/ ;;; allocation/type] (defun warn-class-change () (dolist (class *changed-classes*) (let ((old-cpl (compute-class-precedence-list class)) (new-cpl (compute-std-cpl class))) (multiple-value-bind (old new) (compute-cpl-difference old-cpl new-cpl) (format t "~%~%Class ~S's class-precedence-list has changed~%~ Old order: ~S~%~ New order: ~S" (class-name class) old new)) (let ((old-default (collect-all-default-initargs class old-cpl)) (new-default (collect-all-default-initargs class new-cpl))) (when (iterate ((old (list-elements old-default)) (new (list-elements new-default))) (unless (and (eq (car old) (car new)) (equal (caddr old) (caddr new))) (return t))) (multiple-value-bind (o-result n-result) (compute-initarg-difference old-default new-default) (warn-initarg-difference class o-result n-result)))) (let ((old-slotds (collect-slotds class (class-local-slots class) old-cpl)) (new-slotds (collect-slotds class (class-local-slots class) new-cpl))) (multiple-value-bind (different missing extra) (compute-slotd-diffs old-slotds new-slotds) (warn-slotd-diffs class different missing extra)))))) (defun compute-cpl-difference (old-cpl new-cpl) (gathering ((old (collecting)) (new (collecting))) (iterate ((o (list-elements old-cpl)) (n (list-elements new-cpl))) (unless (equal o n) (gather (class-name o) old) (gather (class-name n) new))))) (defun compute-initarg-difference (old-default new-default) (gathering ((o-result (collecting)) (n-result (collecting))) (iterate ((o-default (list-elements old-default)) (n-default (list-elements new-default))) (unless (and (eq (car o-default) (car n-default)) (equal (caddr o-default) (caddr n-default))) (gather o-default o-result) (gather n-default n-result))))) (defun warn-initarg-difference (class old-default new-default) (format t "~%Default initargs for class ~S also changed~%~ Old: ~S~%~ New: ~S" (class-name class) (mapcar #'(lambda (old) (cons (car old) (cddr old))) old-default) (mapcar #'(lambda (new) (cons (car new) (cddr new))) new-default))) (defun compute-slotd-diffs (old-slotds new-slotds) (let ((different ()) (missing old-slotds) (extra ())) (dolist (new-slotd new-slotds) (let ((old-slotd (find-slotd (slotd-name new-slotd) old-slotds))) (if old-slotd (progn (unless (slotd-equal old-slotd new-slotd) (push (list old-slotd new-slotd) different)) (setq missing (remove old-slotd missing))) (push new-slotd extra)))) (values different missing extra))) (defun slotd-equal (one another) (flet ((initarg-equal (args1 args2) (and (eql (length args1) (length args2)) (not (dolist (arg1 args1) (unless (memq arg1 args2) (return t))))))) (and (equal (slotd-initform one) (slotd-initform another)) (initarg-equal (slotd-initargs one) (slotd-initargs another)) (eq (slotd-allocation one) (slotd-allocation another)) (equal (slotd-type one) (slotd-type another))))) (defun warn-slotd-diffs (class different missing extra) (when (or different missing extra) (format t "~%Slot information for class ~S has changed" (class-name class)) (dolist (d different) (multiple-value-bind (initform initargs allocation type) (compute-slotd-difference (car d) (cadr d)) (warn-slotd-difference (class-name class) (slotd-name (car d)) initform initargs allocation type))) (dolist (m missing) (format t "~%slot named ~S for class ~S has disappeared by cpl change" (slotd-name m) (class-name class))) (dolist (e extra) (format t "~%slot named ~S for class ~S is added by cpl change" (slotd-name e) (class-name class))))) (defun compute-slotd-difference (old-slotd new-slotd) (let ((initform ()) (initargs ()) (allocation ()) (type ())) (unless (equal (slotd-initform old-slotd) (slotd-initform new-slotd)) (setq initform (list (slotd-initform old-slotd) (slotd-initform new-slotd)))) (unless (equal (slotd-initargs old-slotd) (slotd-initargs new-slotd)) (setq initargs (list (slotd-initargs old-slotd) (slotd-initargs new-slotd)))) (unless (equal (slotd-allocation old-slotd) (slotd-allocation new-slotd)) (setq allocation (list (slotd-allocation old-slotd) (slotd-allocation new-slotd)))) (unless (equal (slotd-type old-slotd) (slotd-type new-slotd)) (setq type (list (slotd-type old-slotd) (slotd-type new-slotd)))) (values initform initargs allocation type))) (defun warn-slotd-difference (class-name slot-name initform initargs allocation type) (format t "~%slot named ~S of class ~S has changed by cpl change:" slot-name class-name) (if initform (format t "~%initform has changed from ~S to ~S" (car initform) (cadr initform))) (if initargs (format t "~%initargs has changed from ~S to ~S" (car initargs) (cadr initargs))) (if allocation (format t "~%allocation has changed from ~S to ~S" (car allocation) (cadr allocation))) (if type (format t "~%type has changed from ~S to ~S" (car type) (cadr type)))) ; ;(defun class-name-or-eql-spec (spec) ; (if (listp spec) ; spec ; (class-name spec))) ---------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA26485; Thu, 20 Apr 89 18:11:47 -0700 Reply-To: Owners-CommonLoops.pa@Xerox.COM Received: from Riesling.ms by ArpaGateway.ms ; 20 APR 89 08:42:57 PDT Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 20 APR 89 08:41:22 PDT To: CommonLoops.pa@Xerox.COM Cc: kanderson@DINO.BBN.COM Subject: notice-methods-change and my lexical environment too Date: Thu, 20 Apr 89 11:47:57 -0400 From: kanderso@DINO.BBN.COM Message-Id: <890420-084257-4036@Xerox> (NOTICE-METHODS-CHANGE generic-function) contains the warning: ;; Note that because this closure will be the discriminator code ;; of a generic function it must be careful about how it changes ;; the discriminator code of that same generic function. If it ;; isn't careful, it could change its closure variables out from ;; under itself. So it is careful to be sure that any call to the generic function after NOTICE-METHODS-CHANGE has returned will work even while the discriminator is being changed. However, NOTICE-METHODS-CHANGE calls SET-FUNCALLABLE-INSTANCE-FUNCTION, which at least in #+Genera, will smash the closure variables of the discriminator of the generic function. So if that discriminator happens to be running during the call to NOTICE-METHODS-CHANGE, you suddenly have new free variables. It is possible to avoid this by changing the defintion of funcallable instances slightly, with probably little performance penalty. However, it seems that all uses of NOTICE-METHODS-CHANGE (except INVALIDATE-GENERIC-FUNCTION) really only want to flush the cache. So, i propose that: 1. the use of NOTICE-METHODS-CHANGE should be replaced with FLUSH-GENERIC-FUNCTION-CACHES (which should be atomic). 2. INVALIDATE-GENERIC-FUNCTION should only be used inside DEFGENERIC, or places where you really want to change the generic function. This could either: 2.1 Smash the generic function, or, 2.2 Change the generic function in a way that will not effect any running discriminators. k Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA26765; Thu, 20 Apr 89 18:24:47 -0700 Reply-To: Owners-commonloops.pa@Xerox.COM Received: from Salvador.ms by ArpaGateway.ms ; 20 APR 89 10:37:34 PDT Return-Path: Redistributed: commonloops.pa Received: from june.cs.washington.edu ([128.95.1.4]) by Xerox.COM ; 20 APR 89 09:13:14 PDT Received: from localhost by june.cs.washington.edu (5.59/6.13+) id AA06626; Wed, 19 Apr 89 10:28:31 PDT Return-Path: Message-Id: <8904191728.AA06626@june.cs.washington.edu> To: CommonLoops.pa@Xerox.COM Subject: : PCL on KCL Date: Wed, 19 Apr 89 10:28:30 PDT From: andyg@june.cs.washington.edu I can't seem to get PCL to work on the KCL we have here on VAX/ ULTRIX. We have the June 3, 1987 release of KCL. In the file get-pcl.text (of the most recent PCL release) it says PCL should work with the June version of KCL. In the file notes.text, however, it says PCL works with a later release of KCL: Oct. 15, 1987. Is there more than one release of KCL? I was told that there wasn't. PCL actually compiled, but then would not load when I tried it in a new world. PCL would not even compile with AKCL. Does anyone have a PCL up and running on KCL/AKCL and ULTRIX? I would be most interested in hearing about PCL's on AKCL. Thanks in advance, Andy Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA26849; Thu, 20 Apr 89 18:32:32 -0700 Reply-To: Owners-CommonLoops.pa@Xerox.COM Received: from Semillon.ms by ArpaGateway.ms ; 20 APR 89 11:52:44 PDT Return-Path: Redistributed: CommonLoops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 20 APR 89 09:32:00 PDT Cc: CommonLoops.pa@Xerox.COM, kanderson@DINO.BBN.COM Subject: Re: notice-methods-change and my lexical environment too In-Reply-To: Your message of Thu, 20 Apr 89 11:47:57 -0400. Date: Thu, 20 Apr 89 12:39:59 -0400 From: kanderso@DINO.BBN.COM Message-Id: <890420-115244-5742@Xerox> Well, as usual, i was a bit quick coming up with a proposal. Luckily, someone ususally sets me straight pretty quick. Mike Thome pointed out that adding and removing methods and resizing the cache can change the discriminator, so my proposal isn't so good. So i guess we need a safer way to bash generic functions. We should have something soon for Genera. k Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA03035; Fri, 21 Apr 89 00:19:25 -0700 Message-Id: <8904210719.AA03035@arisia.Xerox.COM> Reply-To: Received: from Forsythe.Stanford.EDU by SAIL.Stanford.EDU with TCP; 21 Apr 89 00:20:05 PDT Received: by Forsythe.Stanford.EDU; Fri, 21 Apr 89 00:19:18 PDT Received: by AEARN (Mailer X1.25) id 2553; Fri, 21 Apr 89 09:19:53 EDT Date: Fri, 21 Apr 89 09:14:41 EDT From: Wilhelm Burger Subject: DELPHI CLOS To: common-lisp-object-system@sail.stanford.edu DELPHI (Italy) claims that they have a full implementation of CLOS? Has anybody made experiences with that software? W.Burger Johannes Kepler University Linz, Austria Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA20679; Wed, 19 Apr 89 03:14:30 -0700 Reply-To: kiuchi.pa@Xerox.COM Received: from Salvador.ms by ArpaGateway.ms ; 18 APR 89 15:44:48 PDT Date: 18 Apr 89 14:04 PDT From: kiuchi.pa@Xerox.COM Subject: checking precedence changes (1/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890418-154448-164@Xerox> We will release a new version of PCL in the very near future. In this new version, there are some changes to the way class precedence list computation and standard method combination work. These changes make these facilities conform to the specification. Most programs will be completely unaffected by these changes. But, for the very few programs that are affected, the differences can be subtle. To make this transition easier for you, I have written a program which detects the effects of these changes. The way this program works is you run it on your code in the current version of PCL. It will tell you how your code will be affected in the next version of PCL so you can fix it before you make the jump. This program is designed to be compiled and loaded in the 12/7/88 version of PCL. Do not load it into later versions of PCL. The rest of this message contains instructions on how to use this program. I will be sending out two more messages which contain the actual code. If there are any questions please feel free to contact me. Yasuhiko Kiuchi (kiuchi.pa@Xerox.com) ---------- check.text ---------- This is the instructions describing how to use PCL check program. The files related with the check program are followings. check.text [This file] Instruction for using the check program. check1.lisp a new definition of compute-combination-points a new definition of compute-class-precedence-list check2.lisp friendly code to check to see if the new definitions in check1.lisp will affect a given system. *** This program is designed to be compiled and loaded in the 12/7/88 *** *** version of PCL. Attempting to load it into later versions of PCL *** *** can cause bad surprises. *** * The behavior of check program The check program will gather all metaobjects in the Lisp image and analyze if there is any difference of the behaviour of the program. If there are any, the check program will warn about the changes. If the check program cannot analyze the changes of behaviour of some metaobjects, check program will explicitly point those out. The process of the check program consists of three phase. Phase 1: Gathering metaobjects Gather the all metaobjects(classes, generic-functions, slot-definitions) Phase 2: Analyzing Analyze the effects of the changes on a given system written in PCL. Phase 3: Description of effects of the changes. Display the changes if any. * How to use the check program (1) load 12/7/88 version of PCL (2) load and run the programs you want to analyze. (3) compile and load check1.lisp and check2.lisp (4) call (pcl::check-precedence) Then, the check program will display the changes if any. If you have a check-pointed lisp-image or sysout containing PCL and your programs, you can start from (3). * A known problem with the check program The gather program contained in the check2.lisp doesn't gather those generic-functions for which all of the methods have only EQL specializers. If your program contains such generic-functions, you need to check by hand. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA02592; Fri, 21 Apr 89 11:00:29 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 21 APR 89 10:55:17 PDT Return-Path: Redistributed: CommonLoops.pa Received: from mcnc.mcnc.org ([128.109.131.1]) by Xerox.COM ; 21 APR 89 10:34:07 PDT Received: from mercury.cs.unc.edu by mcnc.mcnc.org (5.59/MCNC/5-16-88) id AA07945; Fri, 21 Apr 89 13:04:53 EDT Received: from dopey.cs.unc.edu by mercury.cs.unc.edu (5.54/UNC/6-17-88) id AA14286; Fri, 21 Apr 89 12:04:53 Received: by dopey.cs.unc.edu (5.54/UNC/06-13-88) id AA25051; Fri, 21 Apr 89 12:04:46 Date: Fri, 21 Apr 89 12:04:46 From: William Clagett Message-Id: <8904211704.AA25051@dopey.cs.unc.edu> To: CommonLoops.pa@Xerox.COM Subject: new PCL; when? Any estimate on when the new PCL will be available? I was just about to (finally) convert a large amount of code to the 12/7 PCL from a much older version. If the new version is going to be available in the next couple of weeks, perhaps I should just wait for that release... Even a rough estimate would be helpful. thanks, Bruce Clagett (clagett@cs.unc.edu) Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA02592; Fri, 21 Apr 89 11:00:29 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 21 APR 89 10:55:17 PDT Return-Path: Redistributed: CommonLoops.pa Received: from mcnc.mcnc.org ([128.109.131.1]) by Xerox.COM ; 21 APR 89 10:34:07 PDT Received: from mercury.cs.unc.edu by mcnc.mcnc.org (5.59/MCNC/5-16-88) id AA07945; Fri, 21 Apr 89 13:04:53 EDT Received: from dopey.cs.unc.edu by mercury.cs.unc.edu (5.54/UNC/6-17-88) id AA14286; Fri, 21 Apr 89 12:04:53 Received: by dopey.cs.unc.edu (5.54/UNC/06-13-88) id AA25051; Fri, 21 Apr 89 12:04:46 Date: Fri, 21 Apr 89 12:04:46 From: William Clagett Message-Id: <8904211704.AA25051@dopey.cs.unc.edu> To: CommonLoops.pa@Xerox.COM Subject: new PCL; when? Any estimate on when the new PCL will be available? I was just about to (finally) convert a large amount of code to the 12/7 PCL from a much older version. If the new version is going to be available in the next couple of weeks, perhaps I should just wait for that release... Even a rough estimate would be helpful. thanks, Bruce Clagett (clagett@cs.unc.edu) Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA10169; Fri, 21 Apr 89 15:46:36 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 21 APR 89 13:58:21 PDT Date: Fri, 21 Apr 89 13:54 PDT From: Gregor.pa@Xerox.COM Subject: Re: new PCL; when? To: William Clagett Cc: CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <8904211704.AA25051@dopey.cs.unc.edu> Message-Id: <19890421205419.6.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no We are actively working on the new release now. It should be out within a few days since we plan to call it Passover PCL. The following excerpt from the new notes.text file may be useful to you as well, it describes some of the changes that will be in this release. - In the last release there was an implementation of the specified CLOS initialization protocol. This implementation had the correct behavior, but some of the generic functions had temporary names (*make-instance, *initialize-instance and *default-initargs). This was done to give people time to convert their code to the behavior of the new initialization protocol. In this release, all generic functions in the specified initialization protocol have their proper names. The implementation of the old, obsolete initialization protocol has disappeared entirely. The following renamings have happened: 12/7/88 release this release *make-instance make-instance *initialize-instance initialize-instance *default-initargs default-initargs The functions shared-initialize and reinitialize-instance already had the proper names. The new initialization protocol is documented fully in the 88-002R specification. As part of this change, PCL now uses the new initialization protocol to create metaobjects internally. That is it calls make-instance to create these metaobjects. The actual initargs passed are not yet as specified, that will be in a later release. This is the largest change in this release. If you have not already started using the new initialization protocol (with the temporary *xxx names) you are going to have to do so now. In most cases, old methods on the generic functions INITIALIZE, INITIALIZE-FROM-DEFAULTS and INITIALIZE-FROM-INIT-PLIST must be substantially rewritten to convert them to methods on INITIALIZE and SHARED-INITIALIZE. - The following functions and macros have disappeared. This table also show briefly what you use instead. DEFMETHOD-SETF (use DEFMETHOD) RUN-SUPER (use CALL-NEXT-METHOD) OBSOLETE-WITH-SLOTS (use WITH-SLOTS or WITH-ACCESSORS) SYMBOL-CLASS (use FIND-CLASS) CBOUNDP (use FIND-CLASS) CLASS-NAMED (use FIND-CLASS) GET-SETF-GENERIC-FUNCTION (use GDEFINITION) - In certain ports, method lookup will be faster because of a new scheme to deal with interrupts and the cache code. In other ports it will be slightly slower. In all ports, the cache code now interacts properly with interrupts. - DEFMETHOD should interact properly with TRACE, ADVISE etc. in most ports. two new port-specific functions (in defs.lisp) implement this. These are unencapsulated-fdefinition and fdefine-carefully. If this doesn't work properly in your port, fix the definition of these functions and send it back so it can be in the next release. - This release runs in Golden Common Lisp version 3.0. - Previously, the use of slot-value (or with-slots) in the body of a method which had an illegal specializer gave strange errors. Now it gives a more reasonable error message. - An annoying problem which caused KCL and friends to complain about *exports* being unbound has been fixed. - The walker has been modified to understand the ccl:%stack-block special form in Coral Common Lisp. - The use of defadvice in pre 3.0 releases has been fixed in Lucid Low. - multiple-value-setq inside of with-slots now returns the correct value. - A minor bug having to do with macroexpansion environments and the KCL walker has been fixed. - A bug in the parsing of defmethod which caused only symbols (rather than non-nil atoms) to be used as qualifiers. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA02592; Fri, 21 Apr 89 11:00:29 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 21 APR 89 10:55:17 PDT Return-Path: Redistributed: CommonLoops.pa Received: from mcnc.mcnc.org ([128.109.131.1]) by Xerox.COM ; 21 APR 89 10:34:07 PDT Received: from mercury.cs.unc.edu by mcnc.mcnc.org (5.59/MCNC/5-16-88) id AA07945; Fri, 21 Apr 89 13:04:53 EDT Received: from dopey.cs.unc.edu by mercury.cs.unc.edu (5.54/UNC/6-17-88) id AA14286; Fri, 21 Apr 89 12:04:53 Received: by dopey.cs.unc.edu (5.54/UNC/06-13-88) id AA25051; Fri, 21 Apr 89 12:04:46 Date: Fri, 21 Apr 89 12:04:46 From: William Clagett Message-Id: <8904211704.AA25051@dopey.cs.unc.edu> To: CommonLoops.pa@Xerox.COM Subject: new PCL; when? Any estimate on when the new PCL will be available? I was just about to (finally) convert a large amount of code to the 12/7 PCL from a much older version. If the new version is going to be available in the next couple of weeks, perhaps I should just wait for that release... Even a rough estimate would be helpful. thanks, Bruce Clagett (clagett@cs.unc.edu) Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA10169; Fri, 21 Apr 89 15:46:36 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 21 APR 89 13:58:21 PDT Date: Fri, 21 Apr 89 13:54 PDT From: Gregor.pa@Xerox.COM Subject: Re: new PCL; when? To: William Clagett Cc: CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-5.text.newest In-Reply-To: <8904211704.AA25051@dopey.cs.unc.edu> Message-Id: <19890421205419.6.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no We are actively working on the new release now. It should be out within a few days since we plan to call it Passover PCL. The following excerpt from the new notes.text file may be useful to you as well, it describes some of the changes that will be in this release. - In the last release there was an implementation of the specified CLOS initialization protocol. This implementation had the correct behavior, but some of the generic functions had temporary names (*make-instance, *initialize-instance and *default-initargs). This was done to give people time to convert their code to the behavior of the new initialization protocol. In this release, all generic functions in the specified initialization protocol have their proper names. The implementation of the old, obsolete initialization protocol has disappeared entirely. The following renamings have happened: 12/7/88 release this release *make-instance make-instance *initialize-instance initialize-instance *default-initargs default-initargs The functions shared-initialize and reinitialize-instance already had the proper names. The new initialization protocol is documented fully in the 88-002R specification. As part of this change, PCL now uses the new initialization protocol to create metaobjects internally. That is it calls make-instance to create these metaobjects. The actual initargs passed are not yet as specified, that will be in a later release. This is the largest change in this release. If you have not already started using the new initialization protocol (with the temporary *xxx names) you are going to have to do so now. In most cases, old methods on the generic functions INITIALIZE, INITIALIZE-FROM-DEFAULTS and INITIALIZE-FROM-INIT-PLIST must be substantially rewritten to convert them to methods on INITIALIZE and SHARED-INITIALIZE. - The following functions and macros have disappeared. This table also show briefly what you use instead. DEFMETHOD-SETF (use DEFMETHOD) RUN-SUPER (use CALL-NEXT-METHOD) OBSOLETE-WITH-SLOTS (use WITH-SLOTS or WITH-ACCESSORS) SYMBOL-CLASS (use FIND-CLASS) CBOUNDP (use FIND-CLASS) CLASS-NAMED (use FIND-CLASS) GET-SETF-GENERIC-FUNCTION (use GDEFINITION) - In certain ports, method lookup will be faster because of a new scheme to deal with interrupts and the cache code. In other ports it will be slightly slower. In all ports, the cache code now interacts properly with interrupts. - DEFMETHOD should interact properly with TRACE, ADVISE etc. in most ports. two new port-specific functions (in defs.lisp) implement this. These are unencapsulated-fdefinition and fdefine-carefully. If this doesn't work properly in your port, fix the definition of these functions and send it back so it can be in the next release. - This release runs in Golden Common Lisp version 3.0. - Previously, the use of slot-value (or with-slots) in the body of a method which had an illegal specializer gave strange errors. Now it gives a more reasonable error message. - An annoying problem which caused KCL and friends to complain about *exports* being unbound has been fixed. - The walker has been modified to understand the ccl:%stack-block special form in Coral Common Lisp. - The use of defadvice in pre 3.0 releases has been fixed in Lucid Low. - multiple-value-setq inside of with-slots now returns the correct value. - A minor bug having to do with macroexpansion environments and the KCL walker has been fixed. - A bug in the parsing of defmethod which caused only symbols (rather than non-nil atoms) to be used as qualifiers. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA12389; Mon, 24 Apr 89 17:52:59 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 24 APR 89 17:51:01 PDT Date: 24 Apr 89 17:48 PDT From: kiuchi.pa@Xerox.COM Subject: checking precedence changes (1/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890424-175101-1485@Xerox> Due to the network problem, lots of people have not got the check program. I will sent out these three messages again. I will apology to those who get these twice. Yasuhiko (Kiuchi.pa@Xerox.com) ----- Begin Forwarded Messages ----- Date: 18 Apr 89 14:04 PDT From: kiuchi.pa Subject: checking precedence changes (1/3) To: CommonLoops.pa cc: kiuchi.pa We will release a new version of PCL in the very near future. In this new version, there are some changes to the way class precedence list computation and standard method combination work. These changes make these facilities conform to the specification. Most programs will be completely unaffected by these changes. But, for the very few programs that are affected, the differences can be subtle. To make this transition easier for you, I have written a program which detects the effects of these changes. The way this program works is you run it on your code in the current version of PCL. It will tell you how your code will be affected in the next version of PCL so you can fix it before you make the jump. This program is designed to be compiled and loaded in the 12/7/88 version of PCL. Do not load it into later versions of PCL. The rest of this message contains instructions on how to use this program. I will be sending out two more messages which contain the actual code. If there are any questions please feel free to contact me. Yasuhiko Kiuchi (kiuchi.pa@Xerox.com) ---------- check.text ---------- This is the instructions describing how to use PCL check program. The files related with the check program are followings. check.text [This file] Instruction for using the check program. check1.lisp a new definition of compute-combination-points a new definition of compute-class-precedence-list check2.lisp friendly code to check to see if the new definitions in check1.lisp will affect a given system. *** This program is designed to be compiled and loaded in the 12/7/88 *** *** version of PCL. Attempting to load it into later versions of PCL *** *** can cause bad surprises. *** * The behavior of check program The check program will gather all metaobjects in the Lisp image and analyze if there is any difference of the behaviour of the program. If there are any, the check program will warn about the changes. If the check program cannot analyze the changes of behaviour of some metaobjects, check program will explicitly point those out. The process of the check program consists of three phase. Phase 1: Gathering metaobjects Gather the all metaobjects(classes, generic-functions, slot-definitions) Phase 2: Analyzing Analyze the effects of the changes on a given system written in PCL. Phase 3: Description of effects of the changes. Display the changes if any. * How to use the check program (1) load 12/7/88 version of PCL (2) load and run the programs you want to analyze. (3) compile and load check1.lisp and check2.lisp (4) call (pcl::check-precedence) Then, the check program will display the changes if any. If you have a check-pointed lisp-image or sysout containing PCL and your programs, you can start from (3). * A known problem with the check program The gather program contained in the check2.lisp doesn't gather those generic-functions for which all of the methods have only EQL specializers. If your program contains such generic-functions, you need to check by hand. ------- ----- End Forwarded Messages ----- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA12595; Mon, 24 Apr 89 18:13:27 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 24 APR 89 18:05:12 PDT Date: 24 Apr 89 17:51 PDT From: kiuchi.pa@Xerox.COM Subject: check1.lisp (2/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890424-180512-1578@Xerox> ---------- check1.lisp ---------- ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "PCL") ;;; ;;; This file contains: ;;; * a new definition of compute-combination-point ;;; * a new definition of compute-class-precedence-list ;;; ;;; This file is designed to be compiled and loaded in the 12/7/88 ;;; version of PCL. Attempting to load it into later versions of ;;; PCL can cause bad surprises. ;;; ;from miscellaneous places (defun forward-referenced-class-p (x) (typep--class x 'forward-referenced-class)) ;from defs.lisp ;;; ;;; This little macro requires one case for each of the currently defined ;;; kinds of specializers. At macroexpansion time it will signal an error ;;; if an unsupplied case is found. At runtime, it assumes the specializer ;;; argument is a legal specializer. This means there is no error checking ;;; at all at runtime. ;;; (defmacro specializer-case (specializer &body cases) (flet ((find-case (key) (or (cdr (assq key cases)) (error "~S case not found." key)))) (once-only (specializer) `(if (listp ,specializer) (progn . ,(find-case :eql)) (progn . ,(find-case :class)))))) (defmacro specializer-cross-case (specializer-1 specializer-2 &body cases) (let ((otherwise (cdr (assq t cases)))) (flet ((find-case (key) (or (cdr (assq key cases)) (if otherwise '((.specializer-cross-case-otherwise.)) (error "~S case not found." key))))) (once-only (specializer-1 specializer-2) `(flet ,(and otherwise `((.specializer-cross-case-otherwise. () . ,otherwise))) (specializer-case ,specializer-1 (:eql (specializer-case ,specializer-2 (:eql . ,(find-case :eql-eql)) (:class . ,(find-case :eql-class)))) (:class (specializer-case ,specializer-2 (:eql . ,(find-case :class-eql)) (:class . ,(find-case :class-class)))))))))) (defun specializer-eq (a b) (specializer-cross-case a b (:eql-eql (eq (cadr a) (cadr b))) (:class-class (eq a b)) (t nil))) (defun specializer-assoc (specializer alist) (assoc specializer alist :test #'specializer-eq)) (defun sub-specializer-p (x y) (specializer-cross-case y x (:eql-eql (eql (cadr x) (cadr y))) (:eql-class nil) (:class-eql (memq y (class-precedence-list (class-of (cadr x))))) (:class-class (memq y (class-precedence-list x))))) ;;; ;;; ;;; ;;; ;;; This code operates on a special kind of tree called a cptree (combination ;;; point tree). A cptree is just a cpnode. The cpnode contains the actual ;;; data stored at the cpnode, called the entry, and the subnodes. This code ;;; doesn't define a special structure type for cpnodes. It does define an ;;; abstraction for them though. ;;; ;;; The WALK-CPNODE and MAP-NODE functions are useful for operating on entire ;;; trees. ;;; ;;; WALK-CPNODE applies the argument to the entry of each cpnode ;;; in the tree. It proceeds in depth first order. If at any ;;; point, the call to returns non-nil, the walk is ;;; terminated. ;;; ;;; MAP-CPNODE is like walk-cpnode except that it builds up a new tree. ;;; The resultant tree has the same structure as the ;;; argument. The node-entry at each node of the new tree ;;; is the result of calling on the corresponding ;;; node-entry in the old tree. ;;; ;;; If at any point, the second value returned by ;;; is non-nil, the walk is terminated. In this case, the ;;; result tree will have the same structure as the part of ;;; input tree that was walked. ;;; ;;; ;;; Some places in the code depend on CPNODEs being disjoint from lists. ;;; (defmacro make-cpnode (entry subnodes) `(let ((.new-node. (make-array 2))) (setf (cpnode-entry .new-node.) ,entry (cpnode-subnodes .new-node.) ,subnodes) .new-node.)) (defmacro cpnode-entry (node) `(svref ,node 0)) (defmacro cpnode-subnodes (node) `(svref ,node 1)) (defun walk-cpnode (node function) (funcall function (cpnode-entry node)) (dolist (subnode (cpnode-subnodes node)) (walk-cpnode subnode function))) (defun map-cpnode (node function) (make-cpnode (funcall function (cpnode-entry node)) (mapcar #'(lambda (subnode) (map-cpnode subnode function)) (cpnode-subnodes node)))) ;;; ;;; Arrange for all of this to indent nicely in ZWEI. Its amazingly stupid ;;; that this has to be evaluated after the functions are defined, but that ;;; is the way it goes. ;;; #+Genera (progn (zwei:defindentation (walk-cpnode 1 2)) (zwei:defindentation (map-cpnode 1 2))) ;;; ;;; These entry types are used by code in combin.lisp to compute the so-called ;;; combination points of a generic function. The full documentation for ;;; them appears there. They are defined here for the obvious reason. ;;; ;;; ;;; point tree entries are used internally by CROSS-COLUMNS. ;;; (defmacro make-point-entry (classes partial-method-order) `(vector ,classes ,partial-method-order nil ())) (defmacro point-entry-classes (point-entry) `(svref ,point-entry 0)) (defmacro point-entry-pmo (point-entry) `(svref ,point-entry 1)) (defmacro point-entry-flag (point-entry) `(svref ,point-entry 2)) (defmacro point-entry-cross-info (point-entry) `(svref ,point-entry 3)) ;;; ;;; This entry type is used in the result of compute-columns. ;;; (defmacro make-column-entry (class pmo) `(vector ,class ,pmo nil)) (defmacro column-entry-class (column-entry) `(svref ,column-entry 0)) (defmacro column-entry-pmo (column-entry) `(svref ,column-entry 1)) (defmacro column-entry-flag (column-entry) `(svref ,column-entry 2)) ;;; ;;; The result of compute-precedence-dag is a tree with this entry type. ;;; (defmacro make-cpd-entry (class precedence) `(vector ,class ,precedence nil)) (defmacro cpd-entry-class (cpd-entry) `(svref ,cpd-entry 0)) (defmacro cpd-entry-precedence (cpd-entry) `(svref ,cpd-entry 1)) (defmacro cpd-entry-multiple-supers-p (cpd-entry) `(svref ,cpd-entry 2)) ;;; ;;; This entry type is used internally by compute-precedence-dag and friends. ;;; No entry with this type is ever returned by that function. ;;; (defmacro make-cpdi-entry (class precedence) `(vector ,class ,precedence 0 () 'kept)) (defmacro cpdi-entry-class (cpdi-entry) `(svref ,cpdi-entry 0)) (defmacro cpdi-entry-precedence (cpdi-entry) `(svref ,cpdi-entry 1)) (defmacro cpdi-entry-count (cpdi-entry) `(svref ,cpdi-entry 2)) (defmacro cpdi-entry-supers (cpdi-entry) `(svref ,cpdi-entry 3)) (defmacro cpdi-entry-status (cpdi-entry) `(svref ,cpdi-entry 4)) ;from combin.lisp ;;; ;;; ;;; (defun *compute-combination-points (generic-function) (let ((methods (generic-function-methods generic-function))) (if (null (cdr methods)) (list (list (method-type-specifiers (car methods)) methods)) (let* ((precedence ;; *** *** ;; *** stupidly compute this for now. Also have to fix *** ;; *** the lexical function inverse-precedence when this *** ;; *** is fixed *** ;; *** *** (gathering1 (collecting) (iterate ((i (interval :from 0)) (a (list-elements (method-type-specifiers (car methods))))) (progn a) (gather1 i)))) (specializers (mapcar #'method-type-specifiers methods)) (columns (compute-columns specializers methods precedence))) (cross-columns columns methods))))) (defun cross-columns (columns all-methods) (cross-columns-main t (car columns) (cdr columns) all-methods)) (defun cross-columns-main (all-t-left-of-here first rest all-methods) (if (null rest) (cross-columns-null-rest all-t-left-of-here first all-methods) (let ((recurse (cross-columns-main (and all-t-left-of-here (eq first 't)) (car rest) (cdr rest) all-methods))) (if (eq first 't) (cond (all-t-left-of-here (dolist (point recurse) (push *the-class-t* (car point))) recurse) (t (let ((flag (list nil))) (walk-cpnode recurse #'(lambda (point-entry) (unless (eq (point-entry-flag point-entry) flag) (setf (point-entry-flag point-entry) flag) (push *the-class-t* (point-entry-classes point-entry)))))) recurse)) (let ((points (full-on-column-cross first recurse))) (if all-t-left-of-here (progn (dolist (p points) (setf (cadr p) (pmo->total (cadr p)))) points) (rebuild-combination-tree-from-points points))))))) (defun cross-columns-null-rest (all-t-left-of-here first-column all-methods) (if (eq first-column 't) (if all-t-left-of-here `((,*the-class-t*) ,all-methods) (make-cpnode (make-point-entry (list *the-class-t*) all-methods) ())) (if all-t-left-of-here ;; In this case, we can just return a list of combination ;; points, a point tree isn't needed. Note that this also ;; catches the case where there is only one column. (gathering1 (collecting) (walk-cpnode first-column ;Convert from a column tree #'(lambda (column-entry) ;to actual points (unless (column-entry-flag column-entry) (setf (column-entry-flag column-entry) t) (let ((class (column-entry-class column-entry)) (pmo (column-entry-pmo column-entry))) (when pmo (gather1 `((,class) ,(pmo->total pmo))))))))) ;; ;; Need to make a tree because someone to the `left' of this ;; column will need to do a full-on cross with it. ;; (map-cpnode first-column ;Convert from a column tree #'(lambda (column-entry) ;to a combination point tree. (let ((been-here (column-entry-flag column-entry))) (if (and (neq been-here nil) (neq been-here t)) been-here (let* ((class (column-entry-class column-entry)) (pmo (column-entry-pmo column-entry)) (new-entry (make-point-entry (list class) pmo))) (setf (column-entry-flag column-entry) new-entry) new-entry)))))))) (defun full-on-column-cross (column point) (cross-column-with-point column point) (cross-point-with-column point column)) (defun cross-column-with-point (column point) (labels ((walk-column (cnode) (let* ((centry (cpnode-entry cnode)) (cpmo (column-entry-pmo centry))) (unless (eq (column-entry-flag centry) 'been-here) (setf (column-entry-flag centry) 'been-here) (when cpmo (walk-point centry cpmo point t t)) (dolist (subnode (cpnode-subnodes cnode)) (walk-column subnode))))) (walk-point (centry cpmo pnode super-crossed-pmo super-ppmo) (let* ((pentry (cpnode-entry pnode)) (ppmo (point-entry-pmo pentry)) (force nil) (crossed-pmo nil)) (unless (eq (point-entry-flag pentry) centry) ;Been here? (setf (point-entry-flag pentry) centry) (setq crossed-pmo (cross-pmos cpmo ppmo)) (setq force (equal ppmo super-ppmo)) (when (or force (and crossed-pmo (not (equal crossed-pmo super-crossed-pmo)))) (setq super-crossed-pmo crossed-pmo) (push (list centry force crossed-pmo) (point-entry-cross-info pentry))) (dolist (subnode (cpnode-subnodes pnode)) (walk-point centry cpmo subnode super-crossed-pmo ppmo)))))) (walk-column column))) (defun cross-point-with-column (point column) (gathering1 (collecting) (labels ((walk-point (pnode) (let* ((pentry (cpnode-entry pnode)) (pclasses (point-entry-classes pentry))) (unless (eq (point-entry-flag pentry) 'been-here) (setf (point-entry-flag pentry) 'been-here) (walk-column pentry pclasses column t t) (dolist (subnode (cpnode-subnodes pnode)) (walk-point subnode))))) (walk-column (pentry pclasses cnode super-crossed-pmo super-cpmo) (let* ((centry (cpnode-entry cnode)) (cclass (column-entry-class centry)) (cpmo (column-entry-pmo centry))) (unless (eq (column-entry-flag centry) pentry) ;Been here? (setf (column-entry-flag centry) pentry) (destructuring-bind (nil force crossed-pmo) (assq centry (point-entry-cross-info pentry)) (when (and crossed-pmo (or force (not (equal crossed-pmo super-crossed-pmo)) (equal super-cpmo cpmo))) (setq super-crossed-pmo crossed-pmo) (gather1 (list (cons cclass pclasses) crossed-pmo))) (dolist (subnode (cpnode-subnodes cnode)) (walk-column pentry pclasses subnode super-crossed-pmo cpmo))))))) (walk-point point)))) (defun rebuild-combination-tree-from-points (points) (labels ((insert-node (tree node entry methods) (let ((subtrees (cpnode-subnodes tree)) (farther-down-p nil) (between-here-and-sub-p nil)) ;; ;; First try to stick it down below one of our subtrees. ;; Note that it can go below more than one of our subtrees. ;; (dolist (sub subtrees) (when (eq sub node) (return-from insert-node t)) (when (pmo-sub-p methods (point-entry-pmo (cpnode-entry sub))) (setq farther-down-p t) (insert-node sub node entry methods))) ;; ;; Now try to put it between us and a subtree. ;; (dolist (sub subtrees) (when (and (pmo-sub-p (point-entry-pmo (cpnode-entry sub)) methods) (not (equal (point-entry-pmo (cpnode-entry sub)) methods))) (setf (cpnode-subnodes tree) (remove sub (cpnode-subnodes tree))) (push node (cpnode-subnodes tree)) (push sub (cpnode-subnodes node)) (setq between-here-and-sub-p t))) ;; ;; If it couldn't go below any of our subs, and it couldn't ;; go between us and a sub, then it must just be a sub of ;; us. Do that. ;; (unless (or farther-down-p between-here-and-sub-p) (push node (cpnode-subnodes tree)))))) (let* ((t-point (or (dolist (p points) (when (every #'(lambda (x) (eq x *the-class-t*)) (car p)) (setq points (delete p points)) (return p))) (list (make-list (length (caar points)) :initial-element *the-class-t*) ()))) (result (make-cpnode (make-point-entry (car t-point) (cadr t-point)) ()))) (dolist (point points) (let* ((entry (make-point-entry (car point) (cadr point))) (node (make-cpnode entry ()))) (insert-node result node entry (cadr point)))) result))) ;;; ;;; Returns a list of trees with entry type COLUMN-ENTRY. Each tree in the ;;; list is the column combination for one column of the generic function. ;;; The list is in the same order as the precedence. As a special case, if ;;; all the specializers of a column are T, the value for that column will ;;; be the symbol T. ;;; ;;; Each column is a fresh column since the COLUMN-ENTRY-FLAG field of the ;;; entries is intended to be modified by our caller. ;;; (defun compute-columns (specializers methods precedence) (gathering1 (collecting) (dolist (n precedence) (gather1 (compute-one-column n specializers methods))))) (defun compute-one-column (n specializers methods) (let* ((all-t-p t) (specls (mapcar #'(lambda (specializer-list) (let ((specl (nth n specializer-list))) (unless (eq specl *the-class-t*) (setq all-t-p nil)) specl)) specializers))) (if all-t-p 't (compute-one-column-internal specls methods)))) (defun compute-one-column-internal (specializers methods) (let ((been-here-alist ())) ;; CONVERT-1 actually converts a node and recurses. CONVERT ;; deals with sharing in the result DAG by keeping track of ;; whether a node in the precedence has been visited before. (labels ((convert (cpd-node) (let ((cpd-entry (cpnode-entry cpd-node)) (cpd-subnodes (cpnode-subnodes cpd-node))) (if (cpd-entry-multiple-supers-p cpd-entry) ;; ;; Since this node has multiple supers, it is possible ;; to visit it more than once. Deal with the multiple ;; visits stuff. Note, have to maintain the separate ;; alist because we aren't allowed to mutate precedence ;; dags. ;; (let ((been-here (assq cpd-node been-here-alist))) (if been-here (cdr been-here) (let ((new-node (convert-1 cpd-entry cpd-subnodes))) (push (cons cpd-node new-node) been-here-alist) new-node))) ;; ;; No multiple supers means charge ahead! ;; (convert-1 cpd-entry cpd-subnodes)))) (convert-1 (cpd-entry cpd-subnodes) (make-cpnode (make-column-entry (cpd-entry-class cpd-entry) (precedence->pmo (cpd-entry-precedence cpd-entry) specializers methods)) (mapcar #'convert cpd-subnodes)))) (convert (compute-precedence-dag specializers))))) ;;; ;;; Random useful functions for manipulating partial method orders. ;;; ;;; A partial method order is just a set of methods which are ordered by ;;; one column in a combination. A partial method order supplies absolute ;;; ordering information between some methods and no ordering information ;;; between other methods. Its best described by example: ;;; ;;; (M1 M2 M3) Actually, this is a total order. ;;; (M1 (M2 M3) M4) M1 must precede M2, M3 and M4 ;;; M2 must precede M4 ;;; M3 must precede M4 ;;; the order of M2 and M3 is unspecified ;;; ;;; ((M1 M2) (M3 M4)) M1 must precede M3 and M4 ;;; M2 must precede M3 and M4 ;;; ordering of M1 and M2 unspecified ;;; ordering of M3 and M4 unspecified ;;; ;;; In other words, a partial method order is a list whose elements may be ;;; lists. The top-level list provides ordering information. Methods in ;;; the top level list must precede the `flattened' part of the list that ;;; follows them. But, when an element of the top level list is itself a ;;; list, no ordering among those sublist elements is specified. ;;; ;;; The most important operation defined on partial method orders is a kind ;;; of cross product. The result is a partial method order with only those ;;; methods that appeared in both inputs. The order of the result is as ;;; specified by the first input, except that where the first input doesn't ;;; specify ordering between two methods, the ordering is taken from the ;;; second input. If neither input provides ordering then there will be ;;; partial ordering in the result. ;;; (defun precedence->pmo (precedence specializers methods) (gathering1 (collecting) (dolist (p precedence) (let ((last-hit-state nil) (last-hit-p nil) (last-hit-m nil)) (flet ((enqueue (m) (ecase last-hit-state ((nil) (setq last-hit-state 'one last-hit-p p last-hit-m m)) (one (setq last-hit-state 'two last-hit-m (list m last-hit-m))) (two (push m last-hit-m)))) (flush-queue () (ecase last-hit-state ((nil) ()) (one (gather1 last-hit-m)) (two (gather1 (nreverse last-hit-m)))) (setq last-hit-state nil last-hit-p nil))) (do ((s specializers (cdr s)) (m methods (cdr m))) ((null s) (flush-queue)) (when (specializer-eq (car s) p) (enqueue (car m))))))))) (defun pmo->total (pmo) (gathering1 (collecting) (dolist (e pmo) (if (not (listp e)) (gather1 e) (dolist (ee e) (gather1 ee)))))) (defun pmo-nelements (pmo) (let ((n 0)) (dolist (e pmo) (if (not (listp e)) (incf n) (incf n (length e)))) n)) (defun cross-pmos (pmo-1 pmo-2) (let* ((result (list nil)) (tail result) (subsetp-flag t)) (flet ((gather (m) (setq tail (setf (cdr tail) (list m))))) (dolist (e1 pmo-1) (if (not (listp e1)) (if (pmo-memq e1 pmo-2) (gather e1) (unless (eq subsetp-flag '?) (setq subsetp-flag nil))) ;; ;; This element of pmo-1 is a list. That means ;; pmo-1 supplies no ordering information among ;; the elements of this list. Now go use the order ;; of pmo-2 to try and place elements of this ;; list in the result. ;; (progn (setq subsetp-flag '?) (dolist (e2 pmo-2) (if (not (listp e2)) (if (memq e2 e1) (gather e2) ()) ;; ;; Holy Shit Batman, we have come across a list in ;; both pmo-1 and pmo-2. The intersection ;; of the two goes into the result now. ;; (let ((result (intersection e1 e2))) (cond ((null result)) ((cdr result) (gather result)) (t (gather (car result))))))))))) (values (cdr result) (ecase subsetp-flag ((nil) nil) ((t) t) (? (pmo-subsetp pmo-1 (cdr result))))))) (defun pmo-subsetp (pmo-1 pmo-2) (dolist (e1 pmo-1 t) (if (not (listp e1)) (unless (pmo-memq e1 pmo-2) (return-from pmo-subsetp nil)) (dolist (ee1 e1) (unless (pmo-memq ee1 pmo-2) (return-from pmo-subsetp nil)))))) (defun pmo-memq (x pmo) (do* ((tail pmo (cdr tail)) (e (car tail) (car tail))) ((null tail) nil) (if (not (listp e)) (when (eq x e) (return tail)) (when (memq x e) (return tail))))) (defun pmo-sub-p (sub-pmo super-pmo) (dolist (super-e super-pmo t) (if (not (listp super-e)) (unless (setq sub-pmo (pmo-memq super-e sub-pmo)) (return nil)) (let ((farthest sub-pmo)) (dolist (super-ee super-e) (do* ((tail sub-pmo (cdr tail)) (sub-e (car tail) (car tail))) ((null tail) (return-from pmo-sub-p nil)) (if (not (listp sub-e)) (when (eq super-ee sub-e) (return 't)) (when (memq super-ee sub-e) (return 't))) (when (eq farthest tail) (pop farthest)))) (setq sub-pmo farthest))))) ;;; ;;; COMPUTE-PRECEDENCE-DAG ;;; ;;; ;;; The reason this value is split out is that it can be meaningfully cached. ;;; It is reasonable to expect that generic functions will have the same sets ;;; of specializers, so caching this value can save time. This is especially ;;; winning since this is the part of this algorithm that takes the most work. ;;; ;;; The cache must be cleared whenever any class changes its class precedence ;;; list. It does not need to be reset when a class gets a cpl for the very ;;; first time. The cache reseting code could be changed pretty easily to ;;; invalidate less of the cache when something changes. That is left as an ;;; exercise for future users. ;;; (defvar *precedence-dag-cache* (make-hash-table :test #'equal :size 500)) (defvar *enable-precedence-dag-caching* 't) (defun clear-precedence-dag-cache () (clrhash *precedence-dag-cache*)) (defun compute-precedence-dag (classes) (setq classes (remove-duplicates classes)) (if (null *enable-precedence-dag-caching*) (compute-precedence-dag-1 classes) (let ((key (sort (copy-list classes) #'(lambda (c1 c2) (let ((cpl1 (class-precedence-list c1)) (cpl2 (class-precedence-list c2))) (cond ((memq c2 cpl1) t) ((memq c1 cpl2) nil) (t (< (length cpl2) (length cpl1))))))))) (or (gethash key *precedence-dag-cache*) (setf (gethash key *precedence-dag-cache*) (compute-precedence-dag-1 classes)))))) ;;; ;;; The code which actually builds the precedence dag works in three passes. ;;; The first two passes operate on a tree with an entry type specialized to ;;; this code. The third pass uses that specialized tree to produce actual ;;; result tree. ;;; ;;; The specialized entry type used by this code is called CPDI-ENTRY. CPDI ;;; is an abbreviation for Class Precedence Dag Internal. These entries are ;;; created by the macro MAKE-CPDI-ENTRY. These entries have 5 fields: ;;; ;;; CPDI-ENTRY-CLASS ;;; The class object for this entry. ;;; ;;; CPDI-ENTRY-PRECEDENCE ;;; The precedence of CLASSES at this node. ;;; ;;; CPDI-ENTRY-SUPERS ;;; A list of the super nodes of this node. ;;; ;;; CPDI-ENTRY-COUNT ;;; At the end of the first pass, this is the length of ;;; ENTRY-SUPERS. During the second pass, this value is ;;; decremented each time a node is encountered. When this ;;; counter reaches zero, it means all the parents of this ;;; node have been visited. This gets parents first search. ;;; ;;; CPDI-ENTRY-STATUS ;;; The second pass uses this field to mark nodes as being ;;; either KEPT or DELETED. In the third pass this field ;;; is used to know which nodes to place in the result and ;;; to implement structure sharing in the result. The first ;;; a kept subtree is visited, this field is filled with the ;;; result subtree for that subtree so that that result can ;;; be used again if the kept node is encountered again. ;;; ;;; Entries in the returned tree are called CPD-ENTRY. CPD is an abbreviation ;;; for Class Precedence Dag. These have three fields: ;;; ;;; CPD-ENTRY-CLASS ;;; The class object. ;;; ;;; CPD-ENTRY-PRECEDENCE ;;; The precedence at this point in the dag. ;;; ;;; CPD-ENTRY-MULTIPLE-SUPERS-P ;;; A boolean flag indicating whether this subtree has multiple ;;; supers in the dag. Our caller is free to use this as an ;;; optimization when detecting multiple inheritance in the dag. ;;; ;;; ;;; ;;; The first pass is the BUILD pass. This builds a skeleton of the complete ;;; class DAG. This skeleton includes: ;;; * The class named T (the top of the tree). ;;; * Each class in CLASSES. ;;; * Any other class having the following properties: ;;; - has multiple supers ;;; - is a subclass of more than one class in CLASSES ;;; - more than one of the supers is itself a subclass ;;; of some class in CLASSES ;;; ;;; The second pass (REDUCE) goes through and marks some of the nodes deleted. ;;; Nodes are deleted when they have the same precedence as THE ONE of their ;;; parent nodes they inherit from. This pass uses parents first traversal of ;;; the tree. Parents first traversal means that when considering whether to ;;; delete or keep a node, the status of each of its parents is known. Using ;;; the class precedence list of the node, we can determine which of the kept ;;; parents the node will inherit from. ;;; ;;; The third pass (COLLECT) simply builds the returned tree by including one ;;; node for each kept node in the tree produced by pass 1 and 2. ;;; ;;; (defun compute-precedence-dag-1 (classes) (let* ((top-entry (make-cpdi-entry *the-class-t* (remove-if #'(lambda (x) (neq x *the-class-t*)) classes))) (top-of-tree (make-cpnode top-entry ()))) (compute-precedence-dag-pass-1 classes top-of-tree) (compute-precedence-dag-pass-2 top-of-tree) (compute-precedence-dag-pass-3 top-of-tree))) (defun compute-precedence-dag-pass-1 (classes tree) (let ((been-here-alist ())) (labels ((insert (tree new-node new-entry class cpl) (let ((subtrees (cpnode-subnodes tree)) (inserted-somewhere-below-here-p nil)) ;; ;; First see if the new node can be inserted below ;; any of our subtrees. Note that a new node can ;; be below more than one of our subtrees. ;; (dolist (subtree subtrees) (let* ((subentry (cpnode-entry subtree)) (subclass (cpdi-entry-class subentry))) (when (memq subclass cpl) (setq inserted-somewhere-below-here-p t) (insert subtree new-node new-entry class cpl)))) ;; ;; Then see if the new node can be inserted above ;; any of our subtrees. Note that a new node can ;; be above some of our subtrees and below others. ;; (dolist (subtree subtrees) (let* ((subentry (cpnode-entry subtree)) (subclass (cpdi-entry-class subentry))) (when (memq class (class-precedence-list subclass)) (setq inserted-somewhere-below-here-p t) (unlink subtree subentry tree) ;sub not below us (link new-node new-entry tree) ;new below us (link subtree subentry new-node)))) ;sub below new (unless inserted-somewhere-below-here-p (link new-node new-entry tree)))) (build (node class) (unless (or (eq class *the-class-t*) (eq class *the-class-object*)) (dolist (subclass (class-direct-subclasses class)) (build-1 node subclass)))) (build-1 (node subclass) (let ((been-here (assq subclass been-here-alist))) (if been-here ;; ;; If we have already encountered this class, then ;; record this possibly new path to whatever nodes ;; are below it. Note that we are relying on LINK ;; not to record redundant relationships. ;; (dolist (old-node (cdr been-here)) (link old-node (cpnode-entry old-node) node)) ;; ;; ;; (let ((cpl (class-precedence-list subclass))) (if (class-goes-in-p subclass cpl) ;; ;; A new node has to go into the tree for this ;; subclass. Create that node, insert it, and ;; then recurse with it. ;; (let* ((precedence (compute-precedence cpl)) (new-entry (make-cpdi-entry subclass precedence)) (new-node (make-cpnode new-entry ()))) (link new-node new-entry node) (push (list subclass new-node) been-here-alist) (build new-node subclass)) ;; ;; No new node for this class. But we do have ;; to be sure to record this class on the been ;; here alist. ;; (let ((existing (cpnode-subnodes node)) (been-here (list subclass))) (build node subclass) (dolist (new-sub (cpnode-subnodes node)) (unless (memq new-sub existing) (push new-sub (cdr been-here)) (link new-sub (cpnode-entry new-sub) node))) (push been-here been-here-alist))))))) (class-goes-in-p (class cpl) (let ((supers (class-local-supers class))) (or (memq class classes) (and (cdr supers) (let ((state nil)) ;More than one class (dolist (class cpl) ;from classes in cpl? (when (memq class classes) (if (eq state nil) (setq state t) (return 't))))) (let ((state nil)) (block check-supers (dolist (sup supers) (dolist (class (class-precedence-list sup)) (when (memq class classes) (if (null state) (setq state t) (return-from check-supers 't))))))))))) (compute-precedence (cpl) (gathering1 (collecting) (dolist (class cpl) (when (memq class classes) (gather1 class))))) (link (subnode subentry supnode) (unless (memq subnode (cpnode-subnodes supnode)) (push subnode (cpnode-subnodes supnode)) (incf (cpdi-entry-count subentry)) (push supnode (cpdi-entry-supers subentry)))) (unlink (subnode subentry supnode) (when (memq subnode (cpnode-subnodes supnode)) (setf (cpnode-subnodes supnode) (delete subnode (cpnode-subnodes supnode))) (decf (cpdi-entry-count subentry)) (setf (cpdi-entry-supers subentry) (delete supnode (cpdi-entry-supers subentry)))))) (dolist (class classes) (unless (or (eq class *the-class-t*) (assq class been-here-alist)) (let* ((cpl (class-precedence-list class)) (precedence (compute-precedence cpl)) (new-entry (make-cpdi-entry class precedence)) (new-node (make-cpnode new-entry ()))) (insert tree new-node new-entry class cpl) (push (list class new-node) been-here-alist) (build new-node class)))) tree))) (defun compute-precedence-dag-pass-2 (tree) (labels ((reduce (node) (let* ((entry (cpnode-entry node)) (subs (cpnode-subnodes node)) (class ()) (rcpl ()) (supers ()) (precedence ()) (kept-super nil)) (if (> (cpdi-entry-count entry) 1) (decf (cpdi-entry-count entry)) (progn (when (setq supers (cpdi-entry-supers entry)) (setq precedence (cpdi-entry-precedence entry) class (cpdi-entry-class entry) rcpl (reverse (class-precedence-list class)) kept-super (get-kept-super supers rcpl)) (when (and kept-super (equal (cpdi-entry-precedence (cpnode-entry kept-super)) precedence)) (setf (cpdi-entry-status entry) 'deleted))) (dolist (sub subs) (reduce sub)))))) (get-kept-super (supers rcpl) (when supers (let* ((best-super (car supers)) (best-rcpl-tail (memq (cpdi-entry-class (cpnode-entry best-super)) rcpl))) (dolist (s (cdr supers)) (let ((tail (memq (cpdi-entry-class (cpnode-entry s)) best-rcpl-tail))) (when tail (setq best-rcpl-tail tail best-super s)))) (if (eq (cpdi-entry-status (cpnode-entry best-super)) 'kept) (values best-super best-rcpl-tail) (let ((best-sub-super nil) (best-sub-rcpl-tail ())) (dolist (s supers) (multiple-value-bind (sub-super sub-rcpl-tail) (get-kept-super (cpdi-entry-supers (cpnode-entry s)) rcpl) (when (and sub-super (or (null best-sub-super) (tailp sub-rcpl-tail best-sub-rcpl-tail))) (setq best-sub-super sub-super best-sub-rcpl-tail sub-rcpl-tail)))) (values best-sub-super best-sub-rcpl-tail))))))) (reduce tree))) (defun compute-precedence-dag-pass-3 (tree) (labels ((collect (node previous-precedence) (let* ((entry (cpnode-entry node)) (subnodes (cpnode-subnodes node)) (status (cpdi-entry-status entry)) (precedence (cpdi-entry-precedence entry))) (case (cpdi-entry-status entry) (kept (when (sub-precedence-p precedence previous-precedence) (let* ((result-entry (make-cpd-entry (cpdi-entry-class entry) precedence)) (result-node (make-cpnode result-entry (collect-1 subnodes precedence)))) (setf (cpdi-entry-status entry) (list result-node))))) (deleted (collect-1 subnodes previous-precedence)) (t ;; We have been here before, mark the node(s) as ;; having multiple supers and return them. (dolist (node status) (let ((entry (cpnode-entry node))) (setf (cpd-entry-multiple-supers-p entry) 't))) status)))) (collect-1 (subnodes previous-precedence) (gathering1 (joining) (dolist (subnode subnodes) (gather1 (copy-list (collect subnode previous-precedence)))))) (sub-precedence-p (sub sup) (dolist (c sup t) (unless (setq sub (memq c sub)) (return nil))))) (car (collect tree ())))) ;from std-class.lisp ;;; ;;; compute-class-precedence-list ;;; ;;; ;;; Knuth section 2.2.3 has some interesting notes on this. ;;; ;;; What appears here is basically the algorithm presented there. ;;; ;;; The key idea is that we use class-precedence-description (CPD) structures ;;; to store the precedence information as we proceed. The CPD structure for ;;; a class stores two critical pieces of information: ;;; ;;; - a count of the number of "reasons" why the class can't go ;;; into the class precedence list yet. ;;; ;;; - a list of the "reasons" this class prevents others from ;;; going in until after it ;; ;;; A "reason" is essentially a single local precedence constraint. If a ;;; constraint between two classes arises more than once it generates more ;;; than one reason. This makes things simpler, linear, and isn't a problem ;;; as long as we make sure to keep track of each instance of a "reason". ;;; ;;; This code is divided into three phases. ;;; ;;; - the first phase simply generates the CPD's for each of the class ;;; and its superclasses. The remainder of the code will manipulate ;;; these CPDs rather than the class objects themselves. At the end ;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs ;;; of the direct superclasses of the class. ;;; ;;; - the second phase folds all the local constraints into the CPD ;;; structure. The CPD-COUNT of each CPD is built up, and the ;;; CPD-AFTER fields are augmented to include precedence constraints ;;; from the CPD-SUPERS field and from the order of classes in other ;;; CPD-SUPERS fields. ;;; ;;; After this phase, the CPD-AFTER field of a class includes all the ;;; direct superclasses of the class plus any class that immediately ;;; follows the class in the direct superclasses of another. There ;;; can be duplicates in this list. The CPD-COUNT field is equal to ;;; the number of times this class appears in the CPD-AFTER field of ;;; all the other CPDs. ;;; ;;; - In the third phase, classes are put into the precedence list one ;;; at a time, with only those classes with a CPD-COUNT of 0 being ;;; candidates for insertion. When a class is inserted , every CPD ;;; in its CPD-AFTER field has its count decremented. ;;; ;;; In the usual case, there is only one candidate for insertion at ;;; any point. If there is more than one, the specified tiebreaker ;;; rule is used to choose among them. ;;; (defstruct (class-precedence-description (:conc-name nil) (:print-function (lambda (obj str depth) (declare (ignore depth)) (format str "#" (class-name (cpd-class obj)) (cpd-count obj)))) (:constructor make-cpd ())) (cpd-class nil) (cpd-supers ()) (cpd-after ()) (cpd-count 0)) (defun compute-std-cpl (class) (let ((supers (class-local-supers class))) (cond ((null supers) ;First two branches of COND (list class)) ;are implementing the single ((null (cdr supers)) ;inheritance optimization. (cons class (compute-std-cpl (car supers)))) (t (multiple-value-bind (all-cpds nclasses) (compute-std-cpl-phase-1 class supers) (compute-std-cpl-phase-2 all-cpds) (compute-std-cpl-phase-3 class all-cpds nclasses)))))) (defvar *compute-std-cpl-class->entry-table-size* 60) (defun compute-std-cpl-phase-1 (class supers) (let ((nclasses 0) (all-cpds ()) (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test #'eq))) (labels ((get-cpd (c) (or (gethash c table) (setf (gethash c table) (make-cpd)))) (walk (c supers) (if (forward-referenced-class-p c) (cpl-forward-referenced-class-error class c) (let ((cpd (get-cpd c))) (unless (cpd-class cpd) ;If we have already done this ;class before, we can quit. (setf (cpd-class cpd) c) (incf nclasses) (push cpd all-cpds) (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) (dolist (super supers) (walk super (class-local-supers super)))))))) (walk class supers) (values all-cpds nclasses)))) (defun compute-std-cpl-phase-2 (all-cpds) (dolist (cpd all-cpds) (let ((supers (cpd-supers cpd))) (when supers (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) (incf (cpd-count (car supers)) 1) (do* ((t1 supers t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (incf (cpd-count (car t2)) 2) (push (car t2) (cpd-after (car t1)))))))) (defun compute-std-cpl-phase-3 (class all-cpds nclasses) (let ((candidates ()) (next-cpd nil) (rcpl ())) ;; ;; We have to bootstrap the collection of those CPD's that ;; have a zero count. Once we get going, we will maintain ;; this list incrementally. ;; (dolist (cpd all-cpds) (when (zerop (cpd-count cpd)) (push cpd candidates))) (loop (when (null candidates) ;; ;; If there are no candidates, and enough classes have been put ;; into the precedence list, then we are all done. Otherwise ;; it means there is a consistency problem. (if (zerop nclasses) (return (reverse rcpl)) (cpl-inconsistent-error class all-cpds))) ;; ;; Try to find the next class to put in from among the candidates. ;; If there is only one, its easy, otherwise we have to use the ;; famous RPG tiebreaker rule. There is some hair here to avoid ;; having to call DELETE on the list of candidates. I dunno if ;; its worth it but what the hell. ;; (setq next-cpd (if (null (cdr candidates)) (prog1 (car candidates) (setq candidates ())) (block tie-breaker (dolist (c rcpl) (let ((supers (class-local-supers c))) (if (memq (cpd-class (car candidates)) supers) (return-from tie-breaker (pop candidates)) (do ((loc candidates (cdr loc))) ((null (cdr loc))) (let ((cpd (cadr loc))) (when (memq (cpd-class cpd) supers) (setf (cdr loc) (cddr loc)) (return-from tie-breaker cpd)))))))))) (decf nclasses) (push (cpd-class next-cpd) rcpl) (dolist (after (cpd-after next-cpd)) (when (zerop (decf (cpd-count after))) (push after candidates)))))) ;;; ;;; Support code for signalling nice error messages. ;;; (defun cpl-error (class format-string &rest format-args) (error "While computing the class precedence list of the class ~A.~%~A" (if (class-name class) (format nil "named ~S" (class-name class)) class) (apply #'format nil format-string format-args))) (defun cpl-forward-referenced-class-error (class forward-class) (flet ((class-or-name (class) (if (class-name class) (format nil "named ~S" (class-name class)) class))) (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))) (cpl-error class "The class ~A is a forward referenced class.~@ The class ~A is ~A." (class-or-name forward-class) (class-or-name forward-class) (if (null (cdr names)) (format nil "a direct superclass of the class ~A" (class-or-name class)) (format nil "reached from the class ~A by following~@ the direct superclass chain through: ~A~ ~% ending at the class ~A" (class-or-name class) (format nil "~{~% the class ~A,~}" (butlast names)) (car (last names)))))))) (defun find-superclass-chain (bottom top) (labels ((walk (c chain) (if (eq c top) (return-from find-superclass-chain (nreverse chain)) (dolist (super (class-local-supers c)) (walk super (cons super chain)))))) (walk bottom (list bottom)))) (defun cpl-inconsistent-error (class all-cpds) (let ((reasons (find-cycle-reasons all-cpds))) (cpl-error class "It is not possible to compute the class precedence list because~@ there ~A in the local precedence relations.~@ ~A because:~{~% ~A~}." (if (cdr reasons) "are circularities" "is a circularity") (if (cdr reasons) "These arise" "This arises") (format-cycle-reasons (apply #'append reasons))))) (defun format-cycle-reasons (reasons) (flet ((class-or-name (cpd) (let ((class (cpd-class cpd))) (if (class-name class) (format nil "named ~S" (class-name class)) class)))) (mapcar #'(lambda (reason) (ecase (caddr reason) (:super (format nil "the class ~A appears in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)))) (:in-supers (format nil "the class ~A follows the class ~A in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)) (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) (let ((been-here ()) ;List of classes we have visited. (cycle-reasons ())) (labels ((chase (path) (if (memq (car path) (cdr path)) (record-cycle (memq (car path) (nreverse path))) (unless (memq (car path) been-here) (push (car path) been-here) (dolist (after (cpd-after (car path))) (chase (cons after path)))))) (record-cycle (cycle) (let ((reasons ())) (do* ((t1 cycle t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (let ((c1 (car t1)) (c2 (car t2))) (if (memq c2 (cpd-supers c1)) (push (list c1 c2 :super) reasons) (dolist (cpd all-cpds) (when (memq c2 (memq c1 (cpd-supers cpd))) (return (push (list c1 c2 :in-supers cpd) reasons))))))) (push (nreverse reasons) cycle-reasons)))) (dolist (cpd all-cpds) (unless (zerop (cpd-count cpd)) (chase (list cpd)))) cycle-reasons))) ---------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA12626; Mon, 24 Apr 89 18:15:13 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 24 APR 89 18:11:24 PDT Date: 24 Apr 89 17:57 PDT From: kiuchi.pa@Xerox.COM Subject: check2.lisp (3/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890424-181124-1630@Xerox> ---------- check2.lisp ---------- ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "PCL") ;;; ;;; This file contains: ;;; * almost friendly code to check to see if these new ;;; definitions will screw a given system ;;; ;;; This file is designed to be compiled and loaded in the 12/7/88 ;;; version of PCL. Attempting to load it into later versions of ;;; PCL can cause bad surprises ;;; ;;; These are special stuff for computing the changes that will be ;;; caused by new implementation of compute-class-precedence-list ;;; and standard-method-combination in the next version of PCL ;;; ;;; check program for new cpl and combination-points implementations ;;; to use ;;; (1) load 12/7/88 version of PCL by (pcl:load-pcl) ;;; (2) load the program you want to analyze ;;; (3) compile and load check1.lisp and check2.lisp ;;; (4) call (pcl::check-precedence) ;;; ;;; ;;; This first part is basically lifted from gather.lisp. ;;; (defun collect-pcl-external-symbols () (gathering ((result (collecting))) (do-external-symbols (s *the-pcl-package*) (gather s result)))) (defvar *pcl-external-symbols* (collect-pcl-external-symbols)) (defvar *the-lisp-package* (find-package 'lisp)) (defvar *generic-functions* ()) (defvar *classes* ()) (defvar *methods* ()) (defvar *metaobjects* ()) (defun gather-metaobjects (&optional (scope :user)) (check-type scope (or (member :user :all :pcl :clos) package) "A PACKAGE or one of the symbols :user :all :pcl :clos") (setq *generic-functions* () *classes* () *methods* ()) (labels ((walk (class) (when (gatherp class scope) (pushnew class *classes*) (pushnew class *metaobjects*)) (dolist (m (class-direct-methods class)) (when (gatherp m scope) (pushnew m *methods*) (pushnew m *metaobjects*)) (let ((gf (method-generic-function m))) (when (and gf (gatherp gf scope)) (pushnew gf *generic-functions*) (pushnew gf *metaobjects*)))) (dolist (sub (class-direct-subclasses class)) (walk sub)))) (walk (find-class 't)) (format t "~&~D Classes, ~D Generic Functions, ~D Methods." (length *classes*) (length *generic-functions*) (length *methods*)))) (defmethod gatherp ((class standard-class) scope) (let* ((name (class-name class)) (package (and name (symbolp name) (symbol-package name)))) (if (or (null package) (neq (find-class name nil) class)) t (gatherp-internal name package scope)))) (defmethod gatherp ((method standard-method) scope) (let ((generic-function (method-generic-function method))) (and generic-function (gatherp generic-function scope)))) (defmethod gatherp ((gf standard-generic-function) scope) (let* ((name (generic-function-name gf)) (specp (cond ((null name) nil) ((symbolp name) 'symbol) ((and (listp name) (eq (car name) 'setf) (null (cddr name))) 'setf) (t nil))) (package (ecase specp (symbol (symbol-package name)) (setf (symbol-package (cadr name))) ((nil) nil)))) (if (or (null specp) (not (gboundp name)) (neq (gdefinition name) gf)) t (gatherp-internal name package scope)))) (defun gatherp-internal (name package scope) (case scope (:user (and (neq package *the-pcl-package*) (neq package *the-lisp-package*))) (:pcl (eq package *the-pcl-package*)) (:clos (or (eq package *the-lisp-package*) (memq name *pcl-external-symbols*))) (:all t) (otherwise (eq package scope)))) ;;; ;;; Here is the check program ;;; (defvar *changed-classes* ()) (defvar *changed-generic-functions* ()) (defvar *eql-gfs* ()) (defvar *specializer-error-gfs* ()) (defvar *non-standard-qualifier-gfs* ()) (defun check-precedence (&optional (scope :all)) (let ((*classes* ()) (*generic-functions* ()) (*methods* ()) (*metaobjects* ()) (*changed-classes* ()) (*changed-generic-functions* ()) (*eql-gfs* ()) (*specializer-error-gfs* ()) (*non-standard-qualifier-gfs* ())) (format t "~%Phase 1: Gathering metaobjects...~%") (gather-metaobjects scope) (format t "~%~%Phase 2: Analyzing...~%") (gather-changed-metaobjects) (cond ((or *eql-gfs* *specializer-error-gfs* *non-standard-qualifier-gfs* *changed-classes* *changed-generic-functions*) ;we do have some change (format t "~%Phase 3: Description of effects of new precedence computation...~%") (when *eql-gfs* (warn-eql-gfs)) (when *specializer-error-gfs* (warn-specializer-error-gfs)) (when *non-standard-qualifier-gfs* (warn-non-standard-qualifier-gfs)) (when *changed-generic-functions* (warn-generic-function-change)) (when *changed-classes* (warn-class-change))) (t ;we don't have any chage (format t "~%No differences found."))))) ;;; ;;; gather changed objects by checking check the *classes*'s cpl ;;; and *generic-functions*'s combination-points ;;; (defun gather-changed-metaobjects () (dolist (class *classes*) (unless (equal (compute-class-precedence-list class) (compute-std-cpl class)) (push class *changed-classes*))) (labels ((point-lessp (p1 p2) (cond ((eq p1 p2) nil) ((eq (car p1) (car p2)) (point-lessp (cdr p1) (cdr p2))) (t (member (car p2) (member (car p1) *classes*))))) (sort-points (points) (sort points #'(lambda (p1 p2) (point-lessp (car p1) (car p2)))))) ;; set *eql-gfs*, *non-standard-qualifier-gfs*, ;; *specializer-error-gfs* and *generic-functions* (precheck-generic-functions) (let ((old-sorted-points ()) (new-sorted-points ())) (dolist (generic-function *generic-functions*) (push (sort-points (compute-combination-points generic-function)) old-sorted-points)) ;; We need to make sure we are computing new combination-points ;; by using new cpl (unwind-protect (progn (dolist (class *classes*) (setf (class-precedence-list class) (compute-std-cpl class))) (dolist (generic-function *generic-functions*) (push (sort-points (*compute-combination-points generic-function)) new-sorted-points))) (dolist (class *classes*) (setf (class-precedence-list class) (compute-class-precedence-list class)))) (iterate ((old-sort (list-elements (nreverse old-sorted-points))) (new-sort (list-elements (nreverse new-sorted-points))) (generic-function (list-elements *generic-functions*))) (unless (same-method-order-p old-sort new-sort) (push (list generic-function old-sort new-sort) *changed-generic-functions*)))))) ;(defun sort-methods-by-qualifiers (methods) ; (stable-sort methods ; #'(lambda (one another) ; (and (equal (method-type-specifiers one) ; (method-type-specifiers another)) ; (string-lessp (prin1-to-string ; (method-qualifiers one)) ; (prin1-to-string ; (method-qualifiers another))))))) ;;; ;;; check over the all points and if the order of methods of all points ;;; are same it returns t ;;; (defun same-method-order-p (old-points new-points) (unless (eql (length old-points) (length new-points)) (return-from same-method-order-p nil)) (iterate ((old-p-m (list-elements old-points)) (new-p-m (list-elements new-points))) (unless (and (equal (car old-p-m) (car new-p-m)) (same-method-order-p-1 (cadr old-p-m) (cadr new-p-m))) (return-from same-method-order-p nil))) t) ;;; ;;; check two lists of methods each other and if the order of methods ;;; are same it returns t ;;; (defun same-method-order-p-1 (order-1 order-2) (dolist (qualifiers '(() (:before) (:after) (:around))) (let ((methods-1 ()) (methods-2 ())) (dolist (m1 order-1) (when (equal (method-qualifiers m1) qualifiers) (push m1 methods-1))) (dolist (m2 order-2) (when (equal (method-qualifiers m2) qualifiers) (push m2 methods-2))) (unless (equal methods-1 methods-2) (return-from same-method-order-p-1 nil)))) t) ;;; ;;; This check program cannot analyze the behavior of generic functions ;;; which contain EQL methods. The following generic functions warned by ;;; this function should be checked by hand. ;;; ;;; If you have any generic functions such as all methods in this generic ;;; function have all EQL specailizers, you also need to check these by hand. ;;; This check program doesn't say anything because the gather program cannot ;;; gather these kinds of methods and generic functions ;;; (defun warn-eql-gfs () (format t "~%This program cannot analyze the behavior of generic functions~%~ which contain EQL methods. The following generic functions~%~ should be checked by hand:~%~%") (dolist (gf *eql-gfs*) (format t " ~S~%" (generic-function-name gf))) (format t "~%Keep in mind that in 12/7/88 and older versions of PCL,~%~ EQL methods did not interact properly with method combination.~%~ In the next version of PCL, this will work properly.~%~ ~%***~%")) ;;; ;;; 12/7/88 version of PCL only supports standard-method-combination. This ;;; check program only handle standart method combination. ;;; (defun warn-non-standard-qualifier-gfs () (format t "~%This program cannot analyze the behavior of generic functions~%~ which using non-standard method combination. The following~%~ generic functions should be checked by hand:~%~%") (dolist (gf *non-standard-qualifier-gfs*) (format t " ~S~%" (generic-function-name gf))) (format t "~%***~%")) ;;; ;;; wanrs the bugs in your method definitions ;;; (defun warn-specializer-error-gfs () (format t "~%The following generic functions have methods with a different~%~ number of parameter specializers. This program cannot analyze~%~ the behavior of such generic functions. A future version of~%~ PCL will signal an error in such cases.~%~%") (dolist (gf *specializer-error-gfs*) (format t " ~S~%" (generic-function-name gf))) (format t "~%***~%")) ;;; ;;; The check program only works on generic functions filitered by this ;;; precheck. ;;; (defun precheck-generic-functions () (let ((eql-gfs ()) (non-standard-qualifier-gfs ()) (specializer-error-gfs ()) (other-gfs ())) (dolist (gf *generic-functions*) (let* ((methods (generic-function-methods gf)) (no-of-spec-params (length (method-type-specifiers (car methods))))) (block next-gf (dolist (method methods) (let ((specl (method-type-specifiers method)) (qualifiers (method-qualifiers method))) (when (neq (length specl) no-of-spec-params) (push gf specializer-error-gfs) (return-from next-gf)) (unless (or (cadr qualifiers) (memq (car qualifiers) '(() :before :after :around))) (push gf non-standard-qualifier-gfs) (return-from next-gf)) (dolist (spec specl) (specializer-case spec (:eql (push gf eql-gfs) (return-from next-gf)) (:class nil))))) (push gf other-gfs)))) (setq *eql-gfs* eql-gfs *non-standard-qualifier-gfs* non-standard-qualifier-gfs *specializer-error-gfs* specializer-error-gfs *generic-functions* other-gfs))) ;;; ;;; warns the changes of generic functions ;;; (defun warn-generic-function-change () (dolist (gf-and-points *changed-generic-functions*) (destructuring-bind (gf old-points new-points) gf-and-points (multiple-value-bind (different missing extra) (compute-point-diffs old-points new-points) ;; check specializers to make sure (warn-point-diffs gf old-points new-points different missing extra))))) (defun warn-point-diffs (gf old-points new-points different missing extra) (dolist (d different) (warn-gf-difference gf (caar d) (compute-gf-difference (cadar d) (cadadr d)))) (dolist (m missing) (let ((old-super-point (get-super-point old-points (car m) #'compute-class-precedence-list)) (new-super-point (get-super-point new-points (car m) #'compute-std-cpl))) (if (same-method-order-p-1 (cadr m) (cadr old-super-point)) (warn-gf-redundant-point gf m :old) (or (same-method-order-p-1 (cadr m) (cadr new-super-point)) (warn-gf-difference gf (car m) (compute-gf-difference (cadr m) (cadr new-super-point))))))) (dolist (e extra) (let ((old-super-point (get-super-point old-points (car e) #'compute-class-precedence-list)) (new-super-point (get-super-point new-points (car e) #'compute-std-cpl))) (if (same-method-order-p-1 (cadr e) (cadr new-super-point)) (warn-gf-redundant-point gf e :new) (or (same-method-order-p-1 (cadr e) (cadr old-super-point)) (warn-gf-difference gf (car e) (compute-gf-difference (cadr old-super-point) (cadr e)))))))) (defun warn-gf-redundant-point (gf p-m old-or-new) (declare (ignore gf p-m old-or-new)) ;; This is the codes for debugging the new implementation ;; of compute-std-cpl, *compute-combination-points and check program ; (ecase old-or-new ; (:old (format t "~%Generic function ~S had a redundant point~%~ ; This is now fixed in the new implementation" ; (generic-function-name gf))) ; (:new (format t "~%Generic function ~S has a redundant point~%~ ; This is not a real error but should be fixed" ; (Generic-function-name gf)))) ; (format t "~%point: ~S" ; (mapcar #'class-name (car p-m))) ; (format t "~%method: ~S~%" ; (mapcar #'(lambda (method) ; (mapcar #'class-name ; (method-type-specifiers method))) ; (cadr p-m))) ) (defun warn-gf-difference (gf point changes) (iterate ((qualifier (list-elements '(before after around primary))) (change (list-elements changes))) (unless (eq change t) (let ((o-result (car change)) (n-result (cadr change))) (cond ((and (null o-result) (null n-result))) ((null o-result) (format t "~%~%~ When generic-function ~S is called with instance~P of:~%~ ~S~%~ The ~A method~P ~S ~A not applicable in old implementation~%~ Now, the method~P ~A applicable in new implementation" (generic-function-name gf) (length point) (mapcar #'class-name point) qualifier (length n-result) n-result (is-or-are n-result) (length n-result) (is-or-are n-result))) ((null n-result) (format t "~%~%~ When generic-function ~S is called with instance~P of:~%~ ~S~%~ The ~A method~P ~S ~A applicable in old implementation~%~ Now, the method~P ~A not applicable in new implementation" (generic-function-name gf) (length point) (mapcar #'class-name point) qualifier (length o-result) o-result (is-or-are o-result) (length o-result) (is-or-are o-result))) (t (format t "~%~%~ When generic-function ~S is called with instance~P of:~%~ ~S~%~ Order of ~A method~P has changed~%~ Old order of method~P is:~%~ ~S~%~ New order of method~P is:~%~ ~S" (generic-function-name gf) (length point) (mapcar #'class-name point) qualifier (length o-result) (length o-result) o-result (length n-result) n-result))))))) (defun is-or-are (sequence) (if (eq (length sequence) 1) "is" "are")) (defun separate-methods (ordered-methods) (let ((before ()) (after ()) (around ()) (primary ())) (dolist (m ordered-methods) (let ((qualifiers (method-qualifiers m)) (spec (mapcar #'class-name (method-type-specifiers m)))) (cond ((memq ':before qualifiers) (push spec before)) ((memq ':after qualifiers) (push spec after)) ((memq ':around qualifiers) (push spec around)) (t (push spec primary))))) (values before (nreverse after) (nreverse around) (nreverse primary)))) (defun compute-gf-difference (o-methods n-methods) (multiple-value-bind (old-before old-after old-around old-primary) (separate-methods o-methods) (multiple-value-bind (new-before new-after new-around new-primary) (separate-methods n-methods) (list (compute-gf-difference-1 old-before new-before) (compute-gf-difference-1 old-after new-after) (compute-gf-difference-1 old-around new-around) (compute-gf-difference-1 old-primary new-primary))))) (defun compute-gf-difference-1 (old new) (if (equal old new) t (list (subseq old (mismatch old new :test #'equal) (mismatch old new :test #'equal :from-end t)) (subseq new (mismatch old new :test #'equal) (mismatch old new :test #'equal :from-end t))))) (defun get-super-point (points point &optional (compute-fn #'compute-std-cpl)) (let ((list-of-cpl (mapcar #'(lambda (spec) (funcall compute-fn spec)) point)) (result-so-far ())) (dolist (p-m points) (block next-point (let ((p (car p-m)) (label ())) (if (equal p point) (return-from next-point) (iterate ((class (list-elements p)) (cpl (list-elements list-of-cpl))) (let ((foundp (memq class cpl))) (if foundp (push (length foundp) label) (return-from next-point))))) (setq label (nreverse label)) (if result-so-far (when (list-greater-p label (cdr result-so-far)) (setq result-so-far (cons p-m label))) (setq result-so-far (cons p-m label)))))) (if result-so-far (car result-so-far)))) (defun list-greater-p (label label-so-far) (let ((number (car label)) (number-so-far (car label-so-far))) (cond ((> number number-so-far) t) ((= number number-so-far) (list-greater-p (cdr label) (cdr label-so-far)))))) ;;; ;;; compute the different points for each changed generic functiuons ;;; (defun compute-point-diffs (old-points new-points) (let ((different ()) (missing old-points) (extra ())) (dolist (new-point new-points) (let ((old-point (find (car new-point) old-points :key #'car :test #'equal))) (if old-point (progn (unless (same-method-order-p-1 (cadr old-point) (cadr new-point)) (push (list old-point new-point) different)) (setq missing (remove old-point missing :test #'equal))) (push new-point extra)))) (values different missing extra))) ;;; ;;; warn changed classes(cpl, default-initargs and slots[initform/initargs/ ;;; allocation/type] (defun warn-class-change () (dolist (class *changed-classes*) (let ((old-cpl (compute-class-precedence-list class)) (new-cpl (compute-std-cpl class))) (multiple-value-bind (old new) (compute-cpl-difference old-cpl new-cpl) (format t "~%~%Class ~S's class-precedence-list has changed~%~ Old order: ~S~%~ New order: ~S" (class-name class) old new)) (let ((old-default (collect-all-default-initargs class old-cpl)) (new-default (collect-all-default-initargs class new-cpl))) (when (iterate ((old (list-elements old-default)) (new (list-elements new-default))) (unless (and (eq (car old) (car new)) (equal (caddr old) (caddr new))) (return t))) (multiple-value-bind (o-result n-result) (compute-initarg-difference old-default new-default) (warn-initarg-difference class o-result n-result)))) (let ((old-slotds (collect-slotds class (class-local-slots class) old-cpl)) (new-slotds (collect-slotds class (class-local-slots class) new-cpl))) (multiple-value-bind (different missing extra) (compute-slotd-diffs old-slotds new-slotds) (warn-slotd-diffs class different missing extra)))))) (defun compute-cpl-difference (old-cpl new-cpl) (gathering ((old (collecting)) (new (collecting))) (iterate ((o (list-elements old-cpl)) (n (list-elements new-cpl))) (unless (equal o n) (gather (class-name o) old) (gather (class-name n) new))))) (defun compute-initarg-difference (old-default new-default) (gathering ((o-result (collecting)) (n-result (collecting))) (iterate ((o-default (list-elements old-default)) (n-default (list-elements new-default))) (unless (and (eq (car o-default) (car n-default)) (equal (caddr o-default) (caddr n-default))) (gather o-default o-result) (gather n-default n-result))))) (defun warn-initarg-difference (class old-default new-default) (format t "~%Default initargs for class ~S also changed~%~ Old: ~S~%~ New: ~S" (class-name class) (mapcar #'(lambda (old) (cons (car old) (cddr old))) old-default) (mapcar #'(lambda (new) (cons (car new) (cddr new))) new-default))) (defun compute-slotd-diffs (old-slotds new-slotds) (let ((different ()) (missing old-slotds) (extra ())) (dolist (new-slotd new-slotds) (let ((old-slotd (find-slotd (slotd-name new-slotd) old-slotds))) (if old-slotd (progn (unless (slotd-equal old-slotd new-slotd) (push (list old-slotd new-slotd) different)) (setq missing (remove old-slotd missing))) (push new-slotd extra)))) (values different missing extra))) (defun slotd-equal (one another) (flet ((initarg-equal (args1 args2) (and (eql (length args1) (length args2)) (not (dolist (arg1 args1) (unless (memq arg1 args2) (return t))))))) (and (equal (slotd-initform one) (slotd-initform another)) (initarg-equal (slotd-initargs one) (slotd-initargs another)) (eq (slotd-allocation one) (slotd-allocation another)) (equal (slotd-type one) (slotd-type another))))) (defun warn-slotd-diffs (class different missing extra) (when (or different missing extra) (format t "~%Slot information for class ~S has changed" (class-name class)) (dolist (d different) (multiple-value-bind (initform initargs allocation type) (compute-slotd-difference (car d) (cadr d)) (warn-slotd-difference (class-name class) (slotd-name (car d)) initform initargs allocation type))) (dolist (m missing) (format t "~%slot named ~S for class ~S has disappeared by cpl change" (slotd-name m) (class-name class))) (dolist (e extra) (format t "~%slot named ~S for class ~S is added by cpl change" (slotd-name e) (class-name class))))) (defun compute-slotd-difference (old-slotd new-slotd) (let ((initform ()) (initargs ()) (allocation ()) (type ())) (unless (equal (slotd-initform old-slotd) (slotd-initform new-slotd)) (setq initform (list (slotd-initform old-slotd) (slotd-initform new-slotd)))) (unless (equal (slotd-initargs old-slotd) (slotd-initargs new-slotd)) (setq initargs (list (slotd-initargs old-slotd) (slotd-initargs new-slotd)))) (unless (equal (slotd-allocation old-slotd) (slotd-allocation new-slotd)) (setq allocation (list (slotd-allocation old-slotd) (slotd-allocation new-slotd)))) (unless (equal (slotd-type old-slotd) (slotd-type new-slotd)) (setq type (list (slotd-type old-slotd) (slotd-type new-slotd)))) (values initform initargs allocation type))) (defun warn-slotd-difference (class-name slot-name initform initargs allocation type) (format t "~%slot named ~S of class ~S has changed by cpl change:" slot-name class-name) (if initform (format t "~%initform has changed from ~S to ~S" (car initform) (cadr initform))) (if initargs (format t "~%initargs has changed from ~S to ~S" (car initargs) (cadr initargs))) (if allocation (format t "~%allocation has changed from ~S to ~S" (car allocation) (cadr allocation))) (if type (format t "~%type has changed from ~S to ~S" (car type) (cadr type)))) ; ;(defun class-name-or-eql-spec (spec) ; (if (listp spec) ; spec ; (class-name spec))) ---------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA12595; Mon, 24 Apr 89 18:13:27 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 24 APR 89 18:05:12 PDT Date: 24 Apr 89 17:51 PDT From: kiuchi.pa@Xerox.COM Subject: check1.lisp (2/3) To: CommonLoops.pa@Xerox.COM Cc: kiuchi.pa@Xerox.COM Message-Id: <890424-180512-1578@Xerox> ---------- check1.lisp ---------- ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "PCL") ;;; ;;; This file contains: ;;; * a new definition of compute-combination-point ;;; * a new definition of compute-class-precedence-list ;;; ;;; This file is designed to be compiled and loaded in the 12/7/88 ;;; version of PCL. Attempting to load it into later versions of ;;; PCL can cause bad surprises. ;;; ;from miscellaneous places (defun forward-referenced-class-p (x) (typep--class x 'forward-referenced-class)) ;from defs.lisp ;;; ;;; This little macro requires one case for each of the currently defined ;;; kinds of specializers. At macroexpansion time it will signal an error ;;; if an unsupplied case is found. At runtime, it assumes the specializer ;;; argument is a legal specializer. This means there is no error checking ;;; at all at runtime. ;;; (defmacro specializer-case (specializer &body cases) (flet ((find-case (key) (or (cdr (assq key cases)) (error "~S case not found." key)))) (once-only (specializer) `(if (listp ,specializer) (progn . ,(find-case :eql)) (progn . ,(find-case :class)))))) (defmacro specializer-cross-case (specializer-1 specializer-2 &body cases) (let ((otherwise (cdr (assq t cases)))) (flet ((find-case (key) (or (cdr (assq key cases)) (if otherwise '((.specializer-cross-case-otherwise.)) (error "~S case not found." key))))) (once-only (specializer-1 specializer-2) `(flet ,(and otherwise `((.specializer-cross-case-otherwise. () . ,otherwise))) (specializer-case ,specializer-1 (:eql (specializer-case ,specializer-2 (:eql . ,(find-case :eql-eql)) (:class . ,(find-case :eql-class)))) (:class (specializer-case ,specializer-2 (:eql . ,(find-case :class-eql)) (:class . ,(find-case :class-class)))))))))) (defun specializer-eq (a b) (specializer-cross-case a b (:eql-eql (eq (cadr a) (cadr b))) (:class-class (eq a b)) (t nil))) (defun specializer-assoc (specializer alist) (assoc specializer alist :test #'specializer-eq)) (defun sub-specializer-p (x y) (specializer-cross-case y x (:eql-eql (eql (cadr x) (cadr y))) (:eql-class nil) (:class-eql (memq y (class-precedence-list (class-of (cadr x))))) (:class-class (memq y (class-precedence-list x))))) ;;; ;;; ;;; ;;; ;;; This code operates on a special kind of tree called a cptree (combination ;;; point tree). A cptree is just a cpnode. The cpnode contains the actual ;;; data stored at the cpnode, called the entry, and the subnodes. This code ;;; doesn't define a special structure type for cpnodes. It does define an ;;; abstraction for them though. ;;; ;;; The WALK-CPNODE and MAP-NODE functions are useful for operating on entire ;;; trees. ;;; ;;; WALK-CPNODE applies the argument to the entry of each cpnode ;;; in the tree. It proceeds in depth first order. If at any ;;; point, the call to returns non-nil, the walk is ;;; terminated. ;;; ;;; MAP-CPNODE is like walk-cpnode except that it builds up a new tree. ;;; The resultant tree has the same structure as the ;;; argument. The node-entry at each node of the new tree ;;; is the result of calling on the corresponding ;;; node-entry in the old tree. ;;; ;;; If at any point, the second value returned by ;;; is non-nil, the walk is terminated. In this case, the ;;; result tree will have the same structure as the part of ;;; input tree that was walked. ;;; ;;; ;;; Some places in the code depend on CPNODEs being disjoint from lists. ;;; (defmacro make-cpnode (entry subnodes) `(let ((.new-node. (make-array 2))) (setf (cpnode-entry .new-node.) ,entry (cpnode-subnodes .new-node.) ,subnodes) .new-node.)) (defmacro cpnode-entry (node) `(svref ,node 0)) (defmacro cpnode-subnodes (node) `(svref ,node 1)) (defun walk-cpnode (node function) (funcall function (cpnode-entry node)) (dolist (subnode (cpnode-subnodes node)) (walk-cpnode subnode function))) (defun map-cpnode (node function) (make-cpnode (funcall function (cpnode-entry node)) (mapcar #'(lambda (subnode) (map-cpnode subnode function)) (cpnode-subnodes node)))) ;;; ;;; Arrange for all of this to indent nicely in ZWEI. Its amazingly stupid ;;; that this has to be evaluated after the functions are defined, but that ;;; is the way it goes. ;;; #+Genera (progn (zwei:defindentation (walk-cpnode 1 2)) (zwei:defindentation (map-cpnode 1 2))) ;;; ;;; These entry types are used by code in combin.lisp to compute the so-called ;;; combination points of a generic function. The full documentation for ;;; them appears there. They are defined here for the obvious reason. ;;; ;;; ;;; point tree entries are used internally by CROSS-COLUMNS. ;;; (defmacro make-point-entry (classes partial-method-order) `(vector ,classes ,partial-method-order nil ())) (defmacro point-entry-classes (point-entry) `(svref ,point-entry 0)) (defmacro point-entry-pmo (point-entry) `(svref ,point-entry 1)) (defmacro point-entry-flag (point-entry) `(svref ,point-entry 2)) (defmacro point-entry-cross-info (point-entry) `(svref ,point-entry 3)) ;;; ;;; This entry type is used in the result of compute-columns. ;;; (defmacro make-column-entry (class pmo) `(vector ,class ,pmo nil)) (defmacro column-entry-class (column-entry) `(svref ,column-entry 0)) (defmacro column-entry-pmo (column-entry) `(svref ,column-entry 1)) (defmacro column-entry-flag (column-entry) `(svref ,column-entry 2)) ;;; ;;; The result of compute-precedence-dag is a tree with this entry type. ;;; (defmacro make-cpd-entry (class precedence) `(vector ,class ,precedence nil)) (defmacro cpd-entry-class (cpd-entry) `(svref ,cpd-entry 0)) (defmacro cpd-entry-precedence (cpd-entry) `(svref ,cpd-entry 1)) (defmacro cpd-entry-multiple-supers-p (cpd-entry) `(svref ,cpd-entry 2)) ;;; ;;; This entry type is used internally by compute-precedence-dag and friends. ;;; No entry with this type is ever returned by that function. ;;; (defmacro make-cpdi-entry (class precedence) `(vector ,class ,precedence 0 () 'kept)) (defmacro cpdi-entry-class (cpdi-entry) `(svref ,cpdi-entry 0)) (defmacro cpdi-entry-precedence (cpdi-entry) `(svref ,cpdi-entry 1)) (defmacro cpdi-entry-count (cpdi-entry) `(svref ,cpdi-entry 2)) (defmacro cpdi-entry-supers (cpdi-entry) `(svref ,cpdi-entry 3)) (defmacro cpdi-entry-status (cpdi-entry) `(svref ,cpdi-entry 4)) ;from combin.lisp ;;; ;;; ;;; (defun *compute-combination-points (generic-function) (let ((methods (generic-function-methods generic-function))) (if (null (cdr methods)) (list (list (method-type-specifiers (car methods)) methods)) (let* ((precedence ;; *** *** ;; *** stupidly compute this for now. Also have to fix *** ;; *** the lexical function inverse-precedence when this *** ;; *** is fixed *** ;; *** *** (gathering1 (collecting) (iterate ((i (interval :from 0)) (a (list-elements (method-type-specifiers (car methods))))) (progn a) (gather1 i)))) (specializers (mapcar #'method-type-specifiers methods)) (columns (compute-columns specializers methods precedence))) (cross-columns columns methods))))) (defun cross-columns (columns all-methods) (cross-columns-main t (car columns) (cdr columns) all-methods)) (defun cross-columns-main (all-t-left-of-here first rest all-methods) (if (null rest) (cross-columns-null-rest all-t-left-of-here first all-methods) (let ((recurse (cross-columns-main (and all-t-left-of-here (eq first 't)) (car rest) (cdr rest) all-methods))) (if (eq first 't) (cond (all-t-left-of-here (dolist (point recurse) (push *the-class-t* (car point))) recurse) (t (let ((flag (list nil))) (walk-cpnode recurse #'(lambda (point-entry) (unless (eq (point-entry-flag point-entry) flag) (setf (point-entry-flag point-entry) flag) (push *the-class-t* (point-entry-classes point-entry)))))) recurse)) (let ((points (full-on-column-cross first recurse))) (if all-t-left-of-here (progn (dolist (p points) (setf (cadr p) (pmo->total (cadr p)))) points) (rebuild-combination-tree-from-points points))))))) (defun cross-columns-null-rest (all-t-left-of-here first-column all-methods) (if (eq first-column 't) (if all-t-left-of-here `((,*the-class-t*) ,all-methods) (make-cpnode (make-point-entry (list *the-class-t*) all-methods) ())) (if all-t-left-of-here ;; In this case, we can just return a list of combination ;; points, a point tree isn't needed. Note that this also ;; catches the case where there is only one column. (gathering1 (collecting) (walk-cpnode first-column ;Convert from a column tree #'(lambda (column-entry) ;to actual points (unless (column-entry-flag column-entry) (setf (column-entry-flag column-entry) t) (let ((class (column-entry-class column-entry)) (pmo (column-entry-pmo column-entry))) (when pmo (gather1 `((,class) ,(pmo->total pmo))))))))) ;; ;; Need to make a tree because someone to the `left' of this ;; column will need to do a full-on cross with it. ;; (map-cpnode first-column ;Convert from a column tree #'(lambda (column-entry) ;to a combination point tree. (let ((been-here (column-entry-flag column-entry))) (if (and (neq been-here nil) (neq been-here t)) been-here (let* ((class (column-entry-class column-entry)) (pmo (column-entry-pmo column-entry)) (new-entry (make-point-entry (list class) pmo))) (setf (column-entry-flag column-entry) new-entry) new-entry)))))))) (defun full-on-column-cross (column point) (cross-column-with-point column point) (cross-point-with-column point column)) (defun cross-column-with-point (column point) (labels ((walk-column (cnode) (let* ((centry (cpnode-entry cnode)) (cpmo (column-entry-pmo centry))) (unless (eq (column-entry-flag centry) 'been-here) (setf (column-entry-flag centry) 'been-here) (when cpmo (walk-point centry cpmo point t t)) (dolist (subnode (cpnode-subnodes cnode)) (walk-column subnode))))) (walk-point (centry cpmo pnode super-crossed-pmo super-ppmo) (let* ((pentry (cpnode-entry pnode)) (ppmo (point-entry-pmo pentry)) (force nil) (crossed-pmo nil)) (unless (eq (point-entry-flag pentry) centry) ;Been here? (setf (point-entry-flag pentry) centry) (setq crossed-pmo (cross-pmos cpmo ppmo)) (setq force (equal ppmo super-ppmo)) (when (or force (and crossed-pmo (not (equal crossed-pmo super-crossed-pmo)))) (setq super-crossed-pmo crossed-pmo) (push (list centry force crossed-pmo) (point-entry-cross-info pentry))) (dolist (subnode (cpnode-subnodes pnode)) (walk-point centry cpmo subnode super-crossed-pmo ppmo)))))) (walk-column column))) (defun cross-point-with-column (point column) (gathering1 (collecting) (labels ((walk-point (pnode) (let* ((pentry (cpnode-entry pnode)) (pclasses (point-entry-classes pentry))) (unless (eq (point-entry-flag pentry) 'been-here) (setf (point-entry-flag pentry) 'been-here) (walk-column pentry pclasses column t t) (dolist (subnode (cpnode-subnodes pnode)) (walk-point subnode))))) (walk-column (pentry pclasses cnode super-crossed-pmo super-cpmo) (let* ((centry (cpnode-entry cnode)) (cclass (column-entry-class centry)) (cpmo (column-entry-pmo centry))) (unless (eq (column-entry-flag centry) pentry) ;Been here? (setf (column-entry-flag centry) pentry) (destructuring-bind (nil force crossed-pmo) (assq centry (point-entry-cross-info pentry)) (when (and crossed-pmo (or force (not (equal crossed-pmo super-crossed-pmo)) (equal super-cpmo cpmo))) (setq super-crossed-pmo crossed-pmo) (gather1 (list (cons cclass pclasses) crossed-pmo))) (dolist (subnode (cpnode-subnodes cnode)) (walk-column pentry pclasses subnode super-crossed-pmo cpmo))))))) (walk-point point)))) (defun rebuild-combination-tree-from-points (points) (labels ((insert-node (tree node entry methods) (let ((subtrees (cpnode-subnodes tree)) (farther-down-p nil) (between-here-and-sub-p nil)) ;; ;; First try to stick it down below one of our subtrees. ;; Note that it can go below more than one of our subtrees. ;; (dolist (sub subtrees) (when (eq sub node) (return-from insert-node t)) (when (pmo-sub-p methods (point-entry-pmo (cpnode-entry sub))) (setq farther-down-p t) (insert-node sub node entry methods))) ;; ;; Now try to put it between us and a subtree. ;; (dolist (sub subtrees) (when (and (pmo-sub-p (point-entry-pmo (cpnode-entry sub)) methods) (not (equal (point-entry-pmo (cpnode-entry sub)) methods))) (setf (cpnode-subnodes tree) (remove sub (cpnode-subnodes tree))) (push node (cpnode-subnodes tree)) (push sub (cpnode-subnodes node)) (setq between-here-and-sub-p t))) ;; ;; If it couldn't go below any of our subs, and it couldn't ;; go between us and a sub, then it must just be a sub of ;; us. Do that. ;; (unless (or farther-down-p between-here-and-sub-p) (push node (cpnode-subnodes tree)))))) (let* ((t-point (or (dolist (p points) (when (every #'(lambda (x) (eq x *the-class-t*)) (car p)) (setq points (delete p points)) (return p))) (list (make-list (length (caar points)) :initial-element *the-class-t*) ()))) (result (make-cpnode (make-point-entry (car t-point) (cadr t-point)) ()))) (dolist (point points) (let* ((entry (make-point-entry (car point) (cadr point))) (node (make-cpnode entry ()))) (insert-node result node entry (cadr point)))) result))) ;;; ;;; Returns a list of trees with entry type COLUMN-ENTRY. Each tree in the ;;; list is the column combination for one column of the generic function. ;;; The list is in the same order as the precedence. As a special case, if ;;; all the specializers of a column are T, the value for that column will ;;; be the symbol T. ;;; ;;; Each column is a fresh column since the COLUMN-ENTRY-FLAG field of the ;;; entries is intended to be modified by our caller. ;;; (defun compute-columns (specializers methods precedence) (gathering1 (collecting) (dolist (n precedence) (gather1 (compute-one-column n specializers methods))))) (defun compute-one-column (n specializers methods) (let* ((all-t-p t) (specls (mapcar #'(lambda (specializer-list) (let ((specl (nth n specializer-list))) (unless (eq specl *the-class-t*) (setq all-t-p nil)) specl)) specializers))) (if all-t-p 't (compute-one-column-internal specls methods)))) (defun compute-one-column-internal (specializers methods) (let ((been-here-alist ())) ;; CONVERT-1 actually converts a node and recurses. CONVERT ;; deals with sharing in the result DAG by keeping track of ;; whether a node in the precedence has been visited before. (labels ((convert (cpd-node) (let ((cpd-entry (cpnode-entry cpd-node)) (cpd-subnodes (cpnode-subnodes cpd-node))) (if (cpd-entry-multiple-supers-p cpd-entry) ;; ;; Since this node has multiple supers, it is possible ;; to visit it more than once. Deal with the multiple ;; visits stuff. Note, have to maintain the separate ;; alist because we aren't allowed to mutate precedence ;; dags. ;; (let ((been-here (assq cpd-node been-here-alist))) (if been-here (cdr been-here) (let ((new-node (convert-1 cpd-entry cpd-subnodes))) (push (cons cpd-node new-node) been-here-alist) new-node))) ;; ;; No multiple supers means charge ahead! ;; (convert-1 cpd-entry cpd-subnodes)))) (convert-1 (cpd-entry cpd-subnodes) (make-cpnode (make-column-entry (cpd-entry-class cpd-entry) (precedence->pmo (cpd-entry-precedence cpd-entry) specializers methods)) (mapcar #'convert cpd-subnodes)))) (convert (compute-precedence-dag specializers))))) ;;; ;;; Random useful functions for manipulating partial method orders. ;;; ;;; A partial method order is just a set of methods which are ordered by ;;; one column in a combination. A partial method order supplies absolute ;;; ordering information between some methods and no ordering information ;;; between other methods. Its best described by example: ;;; ;;; (M1 M2 M3) Actually, this is a total order. ;;; (M1 (M2 M3) M4) M1 must precede M2, M3 and M4 ;;; M2 must precede M4 ;;; M3 must precede M4 ;;; the order of M2 and M3 is unspecified ;;; ;;; ((M1 M2) (M3 M4)) M1 must precede M3 and M4 ;;; M2 must precede M3 and M4 ;;; ordering of M1 and M2 unspecified ;;; ordering of M3 and M4 unspecified ;;; ;;; In other words, a partial method order is a list whose elements may be ;;; lists. The top-level list provides ordering information. Methods in ;;; the top level list must precede the `flattened' part of the list that ;;; follows them. But, when an element of the top level list is itself a ;;; list, no ordering among those sublist elements is specified. ;;; ;;; The most important operation defined on partial method orders is a kind ;;; of cross product. The result is a partial method order with only those ;;; methods that appeared in both inputs. The order of the result is as ;;; specified by the first input, except that where the first input doesn't ;;; specify ordering between two methods, the ordering is taken from the ;;; second input. If neither input provides ordering then there will be ;;; partial ordering in the result. ;;; (defun precedence->pmo (precedence specializers methods) (gathering1 (collecting) (dolist (p precedence) (let ((last-hit-state nil) (last-hit-p nil) (last-hit-m nil)) (flet ((enqueue (m) (ecase last-hit-state ((nil) (setq last-hit-state 'one last-hit-p p last-hit-m m)) (one (setq last-hit-state 'two last-hit-m (list m last-hit-m))) (two (push m last-hit-m)))) (flush-queue () (ecase last-hit-state ((nil) ()) (one (gather1 last-hit-m)) (two (gather1 (nreverse last-hit-m)))) (setq last-hit-state nil last-hit-p nil))) (do ((s specializers (cdr s)) (m methods (cdr m))) ((null s) (flush-queue)) (when (specializer-eq (car s) p) (enqueue (car m))))))))) (defun pmo->total (pmo) (gathering1 (collecting) (dolist (e pmo) (if (not (listp e)) (gather1 e) (dolist (ee e) (gather1 ee)))))) (defun pmo-nelements (pmo) (let ((n 0)) (dolist (e pmo) (if (not (listp e)) (incf n) (incf n (length e)))) n)) (defun cross-pmos (pmo-1 pmo-2) (let* ((result (list nil)) (tail result) (subsetp-flag t)) (flet ((gather (m) (setq tail (setf (cdr tail) (list m))))) (dolist (e1 pmo-1) (if (not (listp e1)) (if (pmo-memq e1 pmo-2) (gather e1) (unless (eq subsetp-flag '?) (setq subsetp-flag nil))) ;; ;; This element of pmo-1 is a list. That means ;; pmo-1 supplies no ordering information among ;; the elements of this list. Now go use the order ;; of pmo-2 to try and place elements of this ;; list in the result. ;; (progn (setq subsetp-flag '?) (dolist (e2 pmo-2) (if (not (listp e2)) (if (memq e2 e1) (gather e2) ()) ;; ;; Holy Shit Batman, we have come across a list in ;; both pmo-1 and pmo-2. The intersection ;; of the two goes into the result now. ;; (let ((result (intersection e1 e2))) (cond ((null result)) ((cdr result) (gather result)) (t (gather (car result))))))))))) (values (cdr result) (ecase subsetp-flag ((nil) nil) ((t) t) (? (pmo-subsetp pmo-1 (cdr result))))))) (defun pmo-subsetp (pmo-1 pmo-2) (dolist (e1 pmo-1 t) (if (not (listp e1)) (unless (pmo-memq e1 pmo-2) (return-from pmo-subsetp nil)) (dolist (ee1 e1) (unless (pmo-memq ee1 pmo-2) (return-from pmo-subsetp nil)))))) (defun pmo-memq (x pmo) (do* ((tail pmo (cdr tail)) (e (car tail) (car tail))) ((null tail) nil) (if (not (listp e)) (when (eq x e) (return tail)) (when (memq x e) (return tail))))) (defun pmo-sub-p (sub-pmo super-pmo) (dolist (super-e super-pmo t) (if (not (listp super-e)) (unless (setq sub-pmo (pmo-memq super-e sub-pmo)) (return nil)) (let ((farthest sub-pmo)) (dolist (super-ee super-e) (do* ((tail sub-pmo (cdr tail)) (sub-e (car tail) (car tail))) ((null tail) (return-from pmo-sub-p nil)) (if (not (listp sub-e)) (when (eq super-ee sub-e) (return 't)) (when (memq super-ee sub-e) (return 't))) (when (eq farthest tail) (pop farthest)))) (setq sub-pmo farthest))))) ;;; ;;; COMPUTE-PRECEDENCE-DAG ;;; ;;; ;;; The reason this value is split out is that it can be meaningfully cached. ;;; It is reasonable to expect that generic functions will have the same sets ;;; of specializers, so caching this value can save time. This is especially ;;; winning since this is the part of this algorithm that takes the most work. ;;; ;;; The cache must be cleared whenever any class changes its class precedence ;;; list. It does not need to be reset when a class gets a cpl for the very ;;; first time. The cache reseting code could be changed pretty easily to ;;; invalidate less of the cache when something changes. That is left as an ;;; exercise for future users. ;;; (defvar *precedence-dag-cache* (make-hash-table :test #'equal :size 500)) (defvar *enable-precedence-dag-caching* 't) (defun clear-precedence-dag-cache () (clrhash *precedence-dag-cache*)) (defun compute-precedence-dag (classes) (setq classes (remove-duplicates classes)) (if (null *enable-precedence-dag-caching*) (compute-precedence-dag-1 classes) (let ((key (sort (copy-list classes) #'(lambda (c1 c2) (let ((cpl1 (class-precedence-list c1)) (cpl2 (class-precedence-list c2))) (cond ((memq c2 cpl1) t) ((memq c1 cpl2) nil) (t (< (length cpl2) (length cpl1))))))))) (or (gethash key *precedence-dag-cache*) (setf (gethash key *precedence-dag-cache*) (compute-precedence-dag-1 classes)))))) ;;; ;;; The code which actually builds the precedence dag works in three passes. ;;; The first two passes operate on a tree with an entry type specialized to ;;; this code. The third pass uses that specialized tree to produce actual ;;; result tree. ;;; ;;; The specialized entry type used by this code is called CPDI-ENTRY. CPDI ;;; is an abbreviation for Class Precedence Dag Internal. These entries are ;;; created by the macro MAKE-CPDI-ENTRY. These entries have 5 fields: ;;; ;;; CPDI-ENTRY-CLASS ;;; The class object for this entry. ;;; ;;; CPDI-ENTRY-PRECEDENCE ;;; The precedence of CLASSES at this node. ;;; ;;; CPDI-ENTRY-SUPERS ;;; A list of the super nodes of this node. ;;; ;;; CPDI-ENTRY-COUNT ;;; At the end of the first pass, this is the length of ;;; ENTRY-SUPERS. During the second pass, this value is ;;; decremented each time a node is encountered. When this ;;; counter reaches zero, it means all the parents of this ;;; node have been visited. This gets parents first search. ;;; ;;; CPDI-ENTRY-STATUS ;;; The second pass uses this field to mark nodes as being ;;; either KEPT or DELETED. In the third pass this field ;;; is used to know which nodes to place in the result and ;;; to implement structure sharing in the result. The first ;;; a kept subtree is visited, this field is filled with the ;;; result subtree for that subtree so that that result can ;;; be used again if the kept node is encountered again. ;;; ;;; Entries in the returned tree are called CPD-ENTRY. CPD is an abbreviation ;;; for Class Precedence Dag. These have three fields: ;;; ;;; CPD-ENTRY-CLASS ;;; The class object. ;;; ;;; CPD-ENTRY-PRECEDENCE ;;; The precedence at this point in the dag. ;;; ;;; CPD-ENTRY-MULTIPLE-SUPERS-P ;;; A boolean flag indicating whether this subtree has multiple ;;; supers in the dag. Our caller is free to use this as an ;;; optimization when detecting multiple inheritance in the dag. ;;; ;;; ;;; ;;; The first pass is the BUILD pass. This builds a skeleton of the complete ;;; class DAG. This skeleton includes: ;;; * The class named T (the top of the tree). ;;; * Each class in CLASSES. ;;; * Any other class having the following properties: ;;; - has multiple supers ;;; - is a subclass of more than one class in CLASSES ;;; - more than one of the supers is itself a subclass ;;; of some class in CLASSES ;;; ;;; The second pass (REDUCE) goes through and marks some of the nodes deleted. ;;; Nodes are deleted when they have the same precedence as THE ONE of their ;;; parent nodes they inherit from. This pass uses parents first traversal of ;;; the tree. Parents first traversal means that when considering whether to ;;; delete or keep a node, the status of each of its parents is known. Using ;;; the class precedence list of the node, we can determine which of the kept ;;; parents the node will inherit from. ;;; ;;; The third pass (COLLECT) simply builds the returned tree by including one ;;; node for each kept node in the tree produced by pass 1 and 2. ;;; ;;; (defun compute-precedence-dag-1 (classes) (let* ((top-entry (make-cpdi-entry *the-class-t* (remove-if #'(lambda (x) (neq x *the-class-t*)) classes))) (top-of-tree (make-cpnode top-entry ()))) (compute-precedence-dag-pass-1 classes top-of-tree) (compute-precedence-dag-pass-2 top-of-tree) (compute-precedence-dag-pass-3 top-of-tree))) (defun compute-precedence-dag-pass-1 (classes tree) (let ((been-here-alist ())) (labels ((insert (tree new-node new-entry class cpl) (let ((subtrees (cpnode-subnodes tree)) (inserted-somewhere-below-here-p nil)) ;; ;; First see if the new node can be inserted below ;; any of our subtrees. Note that a new node can ;; be below more than one of our subtrees. ;; (dolist (subtree subtrees) (let* ((subentry (cpnode-entry subtree)) (subclass (cpdi-entry-class subentry))) (when (memq subclass cpl) (setq inserted-somewhere-below-here-p t) (insert subtree new-node new-entry class cpl)))) ;; ;; Then see if the new node can be inserted above ;; any of our subtrees. Note that a new node can ;; be above some of our subtrees and below others. ;; (dolist (subtree subtrees) (let* ((subentry (cpnode-entry subtree)) (subclass (cpdi-entry-class subentry))) (when (memq class (class-precedence-list subclass)) (setq inserted-somewhere-below-here-p t) (unlink subtree subentry tree) ;sub not below us (link new-node new-entry tree) ;new below us (link subtree subentry new-node)))) ;sub below new (unless inserted-somewhere-below-here-p (link new-node new-entry tree)))) (build (node class) (unless (or (eq class *the-class-t*) (eq class *the-class-object*)) (dolist (subclass (class-direct-subclasses class)) (build-1 node subclass)))) (build-1 (node subclass) (let ((been-here (assq subclass been-here-alist))) (if been-here ;; ;; If we have already encountered this class, then ;; record this possibly new path to whatever nodes ;; are below it. Note that we are relying on LINK ;; not to record redundant relationships. ;; (dolist (old-node (cdr been-here)) (link old-node (cpnode-entry old-node) node)) ;; ;; ;; (let ((cpl (class-precedence-list subclass))) (if (class-goes-in-p subclass cpl) ;; ;; A new node has to go into the tree for this ;; subclass. Create that node, insert it, and ;; then recurse with it. ;; (let* ((precedence (compute-precedence cpl)) (new-entry (make-cpdi-entry subclass precedence)) (new-node (make-cpnode new-entry ()))) (link new-node new-entry node) (push (list subclass new-node) been-here-alist) (build new-node subclass)) ;; ;; No new node for this class. But we do have ;; to be sure to record this class on the been ;; here alist. ;; (let ((existing (cpnode-subnodes node)) (been-here (list subclass))) (build node subclass) (dolist (new-sub (cpnode-subnodes node)) (unless (memq new-sub existing) (push new-sub (cdr been-here)) (link new-sub (cpnode-entry new-sub) node))) (push been-here been-here-alist))))))) (class-goes-in-p (class cpl) (let ((supers (class-local-supers class))) (or (memq class classes) (and (cdr supers) (let ((state nil)) ;More than one class (dolist (class cpl) ;from classes in cpl? (when (memq class classes) (if (eq state nil) (setq state t) (return 't))))) (let ((state nil)) (block check-supers (dolist (sup supers) (dolist (class (class-precedence-list sup)) (when (memq class classes) (if (null state) (setq state t) (return-from check-supers 't))))))))))) (compute-precedence (cpl) (gathering1 (collecting) (dolist (class cpl) (when (memq class classes) (gather1 class))))) (link (subnode subentry supnode) (unless (memq subnode (cpnode-subnodes supnode)) (push subnode (cpnode-subnodes supnode)) (incf (cpdi-entry-count subentry)) (push supnode (cpdi-entry-supers subentry)))) (unlink (subnode subentry supnode) (when (memq subnode (cpnode-subnodes supnode)) (setf (cpnode-subnodes supnode) (delete subnode (cpnode-subnodes supnode))) (decf (cpdi-entry-count subentry)) (setf (cpdi-entry-supers subentry) (delete supnode (cpdi-entry-supers subentry)))))) (dolist (class classes) (unless (or (eq class *the-class-t*) (assq class been-here-alist)) (let* ((cpl (class-precedence-list class)) (precedence (compute-precedence cpl)) (new-entry (make-cpdi-entry class precedence)) (new-node (make-cpnode new-entry ()))) (insert tree new-node new-entry class cpl) (push (list class new-node) been-here-alist) (build new-node class)))) tree))) (defun compute-precedence-dag-pass-2 (tree) (labels ((reduce (node) (let* ((entry (cpnode-entry node)) (subs (cpnode-subnodes node)) (class ()) (rcpl ()) (supers ()) (precedence ()) (kept-super nil)) (if (> (cpdi-entry-count entry) 1) (decf (cpdi-entry-count entry)) (progn (when (setq supers (cpdi-entry-supers entry)) (setq precedence (cpdi-entry-precedence entry) class (cpdi-entry-class entry) rcpl (reverse (class-precedence-list class)) kept-super (get-kept-super supers rcpl)) (when (and kept-super (equal (cpdi-entry-precedence (cpnode-entry kept-super)) precedence)) (setf (cpdi-entry-status entry) 'deleted))) (dolist (sub subs) (reduce sub)))))) (get-kept-super (supers rcpl) (when supers (let* ((best-super (car supers)) (best-rcpl-tail (memq (cpdi-entry-class (cpnode-entry best-super)) rcpl))) (dolist (s (cdr supers)) (let ((tail (memq (cpdi-entry-class (cpnode-entry s)) best-rcpl-tail))) (when tail (setq best-rcpl-tail tail best-super s)))) (if (eq (cpdi-entry-status (cpnode-entry best-super)) 'kept) (values best-super best-rcpl-tail) (let ((best-sub-super nil) (best-sub-rcpl-tail ())) (dolist (s supers) (multiple-value-bind (sub-super sub-rcpl-tail) (get-kept-super (cpdi-entry-supers (cpnode-entry s)) rcpl) (when (and sub-super (or (null best-sub-super) (tailp sub-rcpl-tail best-sub-rcpl-tail))) (setq best-sub-super sub-super best-sub-rcpl-tail sub-rcpl-tail)))) (values best-sub-super best-sub-rcpl-tail))))))) (reduce tree))) (defun compute-precedence-dag-pass-3 (tree) (labels ((collect (node previous-precedence) (let* ((entry (cpnode-entry node)) (subnodes (cpnode-subnodes node)) (status (cpdi-entry-status entry)) (precedence (cpdi-entry-precedence entry))) (case (cpdi-entry-status entry) (kept (when (sub-precedence-p precedence previous-precedence) (let* ((result-entry (make-cpd-entry (cpdi-entry-class entry) precedence)) (result-node (make-cpnode result-entry (collect-1 subnodes precedence)))) (setf (cpdi-entry-status entry) (list result-node))))) (deleted (collect-1 subnodes previous-precedence)) (t ;; We have been here before, mark the node(s) as ;; having multiple supers and return them. (dolist (node status) (let ((entry (cpnode-entry node))) (setf (cpd-entry-multiple-supers-p entry) 't))) status)))) (collect-1 (subnodes previous-precedence) (gathering1 (joining) (dolist (subnode subnodes) (gather1 (copy-list (collect subnode previous-precedence)))))) (sub-precedence-p (sub sup) (dolist (c sup t) (unless (setq sub (memq c sub)) (return nil))))) (car (collect tree ())))) ;from std-class.lisp ;;; ;;; compute-class-precedence-list ;;; ;;; ;;; Knuth section 2.2.3 has some interesting notes on this. ;;; ;;; What appears here is basically the algorithm presented there. ;;; ;;; The key idea is that we use class-precedence-description (CPD) structures ;;; to store the precedence information as we proceed. The CPD structure for ;;; a class stores two critical pieces of information: ;;; ;;; - a count of the number of "reasons" why the class can't go ;;; into the class precedence list yet. ;;; ;;; - a list of the "reasons" this class prevents others from ;;; going in until after it ;; ;;; A "reason" is essentially a single local precedence constraint. If a ;;; constraint between two classes arises more than once it generates more ;;; than one reason. This makes things simpler, linear, and isn't a problem ;;; as long as we make sure to keep track of each instance of a "reason". ;;; ;;; This code is divided into three phases. ;;; ;;; - the first phase simply generates the CPD's for each of the class ;;; and its superclasses. The remainder of the code will manipulate ;;; these CPDs rather than the class objects themselves. At the end ;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs ;;; of the direct superclasses of the class. ;;; ;;; - the second phase folds all the local constraints into the CPD ;;; structure. The CPD-COUNT of each CPD is built up, and the ;;; CPD-AFTER fields are augmented to include precedence constraints ;;; from the CPD-SUPERS field and from the order of classes in other ;;; CPD-SUPERS fields. ;;; ;;; After this phase, the CPD-AFTER field of a class includes all the ;;; direct superclasses of the class plus any class that immediately ;;; follows the class in the direct superclasses of another. There ;;; can be duplicates in this list. The CPD-COUNT field is equal to ;;; the number of times this class appears in the CPD-AFTER field of ;;; all the other CPDs. ;;; ;;; - In the third phase, classes are put into the precedence list one ;;; at a time, with only those classes with a CPD-COUNT of 0 being ;;; candidates for insertion. When a class is inserted , every CPD ;;; in its CPD-AFTER field has its count decremented. ;;; ;;; In the usual case, there is only one candidate for insertion at ;;; any point. If there is more than one, the specified tiebreaker ;;; rule is used to choose among them. ;;; (defstruct (class-precedence-description (:conc-name nil) (:print-function (lambda (obj str depth) (declare (ignore depth)) (format str "#" (class-name (cpd-class obj)) (cpd-count obj)))) (:constructor make-cpd ())) (cpd-class nil) (cpd-supers ()) (cpd-after ()) (cpd-count 0)) (defun compute-std-cpl (class) (let ((supers (class-local-supers class))) (cond ((null supers) ;First two branches of COND (list class)) ;are implementing the single ((null (cdr supers)) ;inheritance optimization. (cons class (compute-std-cpl (car supers)))) (t (multiple-value-bind (all-cpds nclasses) (compute-std-cpl-phase-1 class supers) (compute-std-cpl-phase-2 all-cpds) (compute-std-cpl-phase-3 class all-cpds nclasses)))))) (defvar *compute-std-cpl-class->entry-table-size* 60) (defun compute-std-cpl-phase-1 (class supers) (let ((nclasses 0) (all-cpds ()) (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test #'eq))) (labels ((get-cpd (c) (or (gethash c table) (setf (gethash c table) (make-cpd)))) (walk (c supers) (if (forward-referenced-class-p c) (cpl-forward-referenced-class-error class c) (let ((cpd (get-cpd c))) (unless (cpd-class cpd) ;If we have already done this ;class before, we can quit. (setf (cpd-class cpd) c) (incf nclasses) (push cpd all-cpds) (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) (dolist (super supers) (walk super (class-local-supers super)))))))) (walk class supers) (values all-cpds nclasses)))) (defun compute-std-cpl-phase-2 (all-cpds) (dolist (cpd all-cpds) (let ((supers (cpd-supers cpd))) (when supers (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) (incf (cpd-count (car supers)) 1) (do* ((t1 supers t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (incf (cpd-count (car t2)) 2) (push (car t2) (cpd-after (car t1)))))))) (defun compute-std-cpl-phase-3 (class all-cpds nclasses) (let ((candidates ()) (next-cpd nil) (rcpl ())) ;; ;; We have to bootstrap the collection of those CPD's that ;; have a zero count. Once we get going, we will maintain ;; this list incrementally. ;; (dolist (cpd all-cpds) (when (zerop (cpd-count cpd)) (push cpd candidates))) (loop (when (null candidates) ;; ;; If there are no candidates, and enough classes have been put ;; into the precedence list, then we are all done. Otherwise ;; it means there is a consistency problem. (if (zerop nclasses) (return (reverse rcpl)) (cpl-inconsistent-error class all-cpds))) ;; ;; Try to find the next class to put in from among the candidates. ;; If there is only one, its easy, otherwise we have to use the ;; famous RPG tiebreaker rule. There is some hair here to avoid ;; having to call DELETE on the list of candidates. I dunno if ;; its worth it but what the hell. ;; (setq next-cpd (if (null (cdr candidates)) (prog1 (car candidates) (setq candidates ())) (block tie-breaker (dolist (c rcpl) (let ((supers (class-local-supers c))) (if (memq (cpd-class (car candidates)) supers) (return-from tie-breaker (pop candidates)) (do ((loc candidates (cdr loc))) ((null (cdr loc))) (let ((cpd (cadr loc))) (when (memq (cpd-class cpd) supers) (setf (cdr loc) (cddr loc)) (return-from tie-breaker cpd)))))))))) (decf nclasses) (push (cpd-class next-cpd) rcpl) (dolist (after (cpd-after next-cpd)) (when (zerop (decf (cpd-count after))) (push after candidates)))))) ;;; ;;; Support code for signalling nice error messages. ;;; (defun cpl-error (class format-string &rest format-args) (error "While computing the class precedence list of the class ~A.~%~A" (if (class-name class) (format nil "named ~S" (class-name class)) class) (apply #'format nil format-string format-args))) (defun cpl-forward-referenced-class-error (class forward-class) (flet ((class-or-name (class) (if (class-name class) (format nil "named ~S" (class-name class)) class))) (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))) (cpl-error class "The class ~A is a forward referenced class.~@ The class ~A is ~A." (class-or-name forward-class) (class-or-name forward-class) (if (null (cdr names)) (format nil "a direct superclass of the class ~A" (class-or-name class)) (format nil "reached from the class ~A by following~@ the direct superclass chain through: ~A~ ~% ending at the class ~A" (class-or-name class) (format nil "~{~% the class ~A,~}" (butlast names)) (car (last names)))))))) (defun find-superclass-chain (bottom top) (labels ((walk (c chain) (if (eq c top) (return-from find-superclass-chain (nreverse chain)) (dolist (super (class-local-supers c)) (walk super (cons super chain)))))) (walk bottom (list bottom)))) (defun cpl-inconsistent-error (class all-cpds) (let ((reasons (find-cycle-reasons all-cpds))) (cpl-error class "It is not possible to compute the class precedence list because~@ there ~A in the local precedence relations.~@ ~A because:~{~% ~A~}." (if (cdr reasons) "are circularities" "is a circularity") (if (cdr reasons) "These arise" "This arises") (format-cycle-reasons (apply #'append reasons))))) (defun format-cycle-reasons (reasons) (flet ((class-or-name (cpd) (let ((class (cpd-class cpd))) (if (class-name class) (format nil "named ~S" (class-name class)) class)))) (mapcar #'(lambda (reason) (ecase (caddr reason) (:super (format nil "the class ~A appears in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)))) (:in-supers (format nil "the class ~A follows the class ~A in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)) (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) (let ((been-here ()) ;List of classes we have visited. (cycle-reasons ())) (labels ((chase (path) (if (memq (car path) (cdr path)) (record-cycle (memq (car path) (nreverse path))) (unless (memq (car path) been-here) (push (car path) been-here) (dolist (after (cpd-after (car path))) (chase (cons after path)))))) (record-cycle (cycle) (let ((reasons ())) (do* ((t1 cycle t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (let ((c1 (car t1)) (c2 (car t2))) (if (memq c2 (cpd-supers c1)) (push (list c1 c2 :super) reasons) (dolist (cpd all-cpds) (when (memq c2 (memq c1 (cpd-supers cpd))) (return (push (list c1 c2 :in-supers cpd) reasons))))))) (push (nreverse reasons) cycle-reasons)))) (dolist (cpd all-cpds) (unless (zerop (cpd-count cpd)) (chase (list cpd)))) cycle-reasons))) ---------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06854; Tue, 25 Apr 89 22:16:16 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 25 APR 89 22:17:11 PDT Return-Path: Redistributed: CommonLoops.pa Received: from ATHENA ([18.72.0.39]) by Xerox.COM ; 25 APR 89 22:15:02 PDT Received: by ATHENA.MIT.EDU (5.45/4.7) id AA24169; Tue, 25 Apr 89 15:20:36 EDT Received: from MITMS1-E52: by XV.MIT.EDU; 11 Mar 88 14:48:06 EST Cc: Kevin_Crowston@XV.MIT.EDU To: info-coral@media-lab.media.mit.edu, CommonLoops.pa@Xerox.COM Subject: problems compiling pcl in Mac Allegro Common Lisp From: Kevin_Crowston@XV.MIT.EDU Date: 25 Apr 89 15:12:42 EDT Message-Id: <0.43520.29067.47143.10228@XV.MIT.EDU> Sender: Kevin_Crowston@XV.MIT.EDU I'm trying to compile "no cute name" pcl in Allegro Common Lisp 1.2.1 and having very little luck. I would be grateful for any advice from someone who has done this successfully. (Someone must have, because the notes say PCL has been tested in Coral 1.2, which I think is the same). I'm running Allegro Lisp on a MacPlus with a Gemini 020 accelerator board with 4M of memory. The machine also has an E-Machines Big Picture display. It seems to work fine running things like MultiFinder, Microsoft Word, MacDraw, etc., so I don't think it's the hardware that's flakey. I haven't tried this yet on a stock Mac II, but I guess that's an obvious next step. If it works there for other people, then I'm curious what it is about the accelerator board that doesn't work. I'm using System Version 6.0.2, with either Finder or Multifinder. Under MultiFinder, I give Allegro 2048K; increasing this to 3000K didn't seem to help. I tried simply following the instructions in get-pcl.text, i.e., load "defsys.lisp" and execute (pcl::compile-pcl). This seems to work fine, except that sometimes the machine will simply crash while trying to load a compiled file. It does this both under Finder and MultiFinder. Usually a bomb box will appear, with a variety of IDs, typically 2, 8 or 10 (I haven't noticed any patterns). Sometimes the machine just freezes and has to be reset and rebooted. What's most annoying is that the behaviour is not repeatable. Sometimes doing the exact same things two times in a row will have different effects. The files that seem to be the problem most often include defs.fasl and macros.fasl, but other files sometimes cause problems. The furthest I've gotten is to dcode-pre2. If the process gets this far, loading this file will always crash the machine. In looking at macros.lisp, I noticed that the file is supposed to be loaded before it's compiled. I tried doing that much by hand, but the new compiled file didn't seem to make much difference in the long run (ie., still crashes at dcode-pre2). Any advice will be appreciated. Kevin Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA13116; Wed, 26 Apr 89 09:23:49 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 26 APR 89 08:48:28 PDT Date: Wed, 26 Apr 89 08:44 PDT From: Gregor.pa@Xerox.COM Subject: Re: problems compiling pcl in Mac Allegro Common Lisp To: Kevin_Crowston@XV.MIT.EDU Cc: info-coral@media-lab.media.mit.edu, CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <0.43520.29067.47143.10228@XV.MIT.EDU> Message-Id: <19890426154429.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no This message I received may be of help to you. Subject: re: problems compiling pcl in Mac Allegro Common Lisp To: Owners-CommonLoops.pa From: BARRYN@s66.prime.com Date: 26 Apr 89 09:55:45 EDT First, get your Allegro Common Lisp updated to v1.2.2 Coral was bought out by Apple, so the customer service has probably deteriorated. Apple (nee Coral) is at 336 Windsor St., Cambridge, Ma. My upgrade was free. Second, check out your inits. I found I could not start Lisp when Tempo II (a "macro" processor) was installed. The underlying problem had something to do with the floating point chip. Seems both programs do something to the OS entries for floating point. Anyway, try taking ALL your inits out of the system folder and try again. Third, try disabling the Gemini board. Allegro CL crashed my SE with Radius accell 25 until I upgraded it to include the floating point chip. PCL "Dec 7th is too painful to have a cute name" runs fine on my SE. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA20772; Wed, 26 Apr 89 13:25:51 -0700 Reply-To: Received: from Chardonnay.ms by ArpaGateway.ms ; 26 APR 89 13:26:10 PDT Return-Path: Redistributed: commonloops.PA Received: from limbo.Berkeley.EDU ([128.32.149.9]) by Xerox.COM ; 26 APR 89 13:09:45 PDT Received: by limbo.Berkeley.EDU (5.61/1.29) id AA17457; Wed, 26 Apr 89 13:08:17 -0700 Date: Wed, 26 Apr 89 13:08:17 -0700 From: konstan@postgres.Berkeley.EDU (Joe Konstan) Message-Id: <8904262008.AA17457@limbo.Berkeley.EDU> To: commonloops.PA@Xerox.COM Subject: Class explosion We are developing a rather large system using PCL and have come across a software engineering problem when using multiple inheritance and orthogonal mix-ins. Basically, we have a collection of what we call "gadgets." Each of these gadgets can (through multiple inheritance) become a widget, a field, or a widget-field (if both features are mixed in). In addition, certain gadgets can have other mixins as well. So far, we have seen two possible solutions to this problem: 1. Bite the bullet: When the mixins are significant (multiple slots, methods defined on the new class) we just do multiple inheritance in the standard way and create the full set of classes. 2. Slot-value discrimination: When there is a set of mixins which are all similar (and mutually exclusive) then the mixins can be handled by having methods which disciminate on the value (or class) of a slot. We do this with macros which expand (method foo) to (real-method (bar foo) foo). This works well for certain things, but can't work well when the mixins are different or compatible. What would be nice would be automatic creation (and changing) of classes triggered by need. For instance, if I could specify that binding a certain slot of any gadget made it a field (or a widget) and the class would be assumed (pcl::|gadget-widget-field| perhaps?) this would simplify the implementation. What do other people do? Is there some feature of PCL I'm overlooking? Joe Konstan Picasso Project Computer Science Division UC Berkeley Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA22717; Wed, 26 Apr 89 15:25:51 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 26 APR 89 15:26:58 PDT Date: Wed, 26 Apr 89 15:22 PDT From: Gregor.pa@Xerox.COM Subject: Re: Class explosion To: Joe Konstan Cc: commonloops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8904262008.AA17457@limbo.Berkeley.EDU> Message-Id: <19890426222235.0.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Your message is not entirely clear to me. What I hear you are saying is that you have a large number of mixins, and you don't want to define the full `cross product' of classes up front. Furthermore, you would like to be able to change the `class' of instances easily. You want to be able to take an instance and cause it to have some behavior from a mixin that it didn't have before. This is easy to do in PCL. You need to use some simple metaobject level functionality. You want to be able to create classes, on the fly, given a list of superclasses. Given that, it is easy to build a facility that adds a mixin to an object simply my making a new on-the-fly class and changing the class of the object. Here is some code can you can use. This code will need some tuning to fit your particular style of using it. In particular, you want to be sure not to create a bunch of dynamic classes each of which have exactly the same class precedence list. You may want to work on add-mixin to achieve this. I can help you with that if you like. One last comment is that the definition of find-dynamic-class below will need to be tweaked slightly in a future release of PCL. But, the change will minor so it is OK for you to depend on this code. ;;; ;;; Note, these functions accept class objects, not class names. ;;; You must call FIND-CLASS on the name before calling these ;;; functions. ;;; (defvar *dynamic-classes* ()) (defun find-dynamic-class (superclasses) (or (find superclasses *dynamic-classes* :key #'class-local-supers ) (let ((new (make-instance 'standard-class))) (update-class new :direct-superclasses superclasses) (push new *dynamic-classes*) new))) (defun add-mixin (object mixin-class) (let ((class (class-of object))) (if (memq mixin-class (class-precedence-list class)) (error "The class of ~S already includes ~S." object mixin-class) (change-class object (find-dynamic-class (list mixin-class class)))))) ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA27068; Wed, 26 Apr 89 20:53:49 -0700 Reply-To: Received: from Riesling.ms by ArpaGateway.ms ; 26 APR 89 20:53:35 PDT Return-Path: Redistributed: CommonLoops.PA Received: from gort.cs.Buffalo.EDU ([128.205.32.1]) by Xerox.COM ; 26 APR 89 20:45:06 PDT Received: by gort.cs.Buffalo.EDU (5.59/1.1) id AA28682; Wed, 26 Apr 89 23:45:02 EDT Date: Wed, 26 Apr 89 23:45:02 EDT From: kumard@cs.Buffalo.EDU (Deepak Kumar) Message-Id: <8904270345.AA28682@gort.cs.Buffalo.EDU> To: CommonLoops.PA@Xerox.COM Subject: CLOS/PCL query (defgeneric, find-method etc) Greetings! Question on CLOS/PCL implementation: The one I have does not have any definitions for the CLOS fns: defgeneric find-method And the function (type-of ) returns a symbol IWMC-CLASS rather than the specific class name as documented in Keene. (Of course I can do a (CLASS-NAME (CLASS-OF )) ) Question: Without having DEFGENERIC how can one use a method combination type other than STANDARD? Thank you. Deepak. P.S. I am using this implementation for instructional purposes in a course CS315--Non-Imperative Programming (Object oriented programming comprises 1/3rd of the syllabus). Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA05724; Thu, 27 Apr 89 11:07:33 -0700 Reply-To: Received: from uunet.uu.net by SAIL.Stanford.EDU with TCP; 27 Apr 89 11:08:02 PDT Received: from unido.UUCP by uunet.uu.net (5.61/1.14) with UUCP id AA06747; Thu, 27 Apr 89 14:06:26 -0400 Received: from slpfs1.uucp by unido.irb.informatik.uni-dortmund.de with uucp via EUnet for uunet id AS06621; Thu, 27 Apr 89 18:28:53 +0100 Received: from tartaros.slpfs1.com by slpfs1.slpfs1.com (3.2/SMI-3.2) id AA02871; Thu, 27 Apr 89 14:02:01 +0200 Received: by tartaros.slpfs1.com (4.0/SMI-3.2) id AA00657; Thu, 27 Apr 89 14:03:14 +0200 Date: Thu, 27 Apr 89 14:03:14 +0200 From: sz%tartaros.uucp%slpfs1.uucp%unido.uucp@uunet.UU.NET (Peter Szabo) Message-Id: <8904271203.AA00657@tartaros.slpfs1.com> To: Common-Lisp-Object-System@Sail.Stanford.edu Subject: joining mailing list Please put me on your mailing list concerning CLOS news. We are working with symbolics and are currently moving from flavors to PCL and hopefully soon to CLOS. In Germany there are no relevant information sources about CLOS/PCL. We would be happy to get at least the file cloops.text Thank you Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA05753; Thu, 27 Apr 89 11:11:14 -0700 Reply-To: Received: from Salvador.ms by ArpaGateway.ms ; 27 APR 89 11:11:21 PDT Return-Path: Redistributed: CommonLoops.PA Received: from uunet.uu.net ([192.48.96.2]) by Xerox.COM ; 27 APR 89 11:07:34 PDT Received: from unido.UUCP by uunet.uu.net (5.61/1.14) with UUCP id AA06824; Thu, 27 Apr 89 14:07:28 -0400 Received: from slpfs1.uucp by unido.irb.informatik.uni-dortmund.de with uucp via EUnet for uunet id AS06627; Thu, 27 Apr 89 18:29:09 +0100 Received: from tartaros.slpfs1.com by slpfs1.slpfs1.com (3.2/SMI-3.2) id AA02877; Thu, 27 Apr 89 14:07:04 +0200 Received: by tartaros.slpfs1.com (4.0/SMI-3.2) id AA00661; Thu, 27 Apr 89 14:08:19 +0200 Date: Thu, 27 Apr 89 14:08:19 +0200 From: sz%tartaros.uucp%slpfs1.uucp%unido.uucp@uunet.UU.NET (Peter Szabo) Message-Id: <8904271208.AA00661@tartaros.slpfs1.com> To: CommonLoops.PA@Xerox.COM Subject: CLOS/PCL Please put me on your mailing list concerning CLOS/PCL news. We are working with symbolics and are currently moving from flavors to PCL and hopefully soon to CLOS. In Germany there are no relevant information sources about CLOS/PCL. We would be happy to get a source copy of an uptodate PCL version. Thank you Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA10145; Thu, 27 Apr 89 14:30:06 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 27 APR 89 14:21:42 PDT Return-Path: <@CUNYVM.CUNY.EDU:umsfjban@mtsunix1.bitnet> Redistributed: CommonLoops.pa Received: from CUNYVM.CUNY.EDU ([128.228.1.2]) by Xerox.COM ; 27 APR 89 14:18:08 PDT Received: from MTSUNIX1.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.1) with BSMTP id 9352; Thu, 27 Apr 89 17:17:27 EDT Received: by deimos.oscs.montana.edu (1.2/Ultrix2.0-B) id AA18170; Thu, 27 Apr 89 13:56:20 mdt Date: Thu, 27 Apr 89 13:56:20 mdt From: umsfjban%MTSUNIX1.BITNET@CUNYVM.CUNY.EDU (Jeff Banfield) Message-Id: <8904271956.AA18170@deimos.oscs.montana.edu> To: CommonLoops.pa@Xerox.COM Subject: help I'm a moderate novice at setting up a lisp system. I have a Mac IIx with the Coral implementation of common lisp. I want to implement CLOS so I copied your pcl.tar.Z, uncompressed it, untarred it and now I have ALL the code but I'm not sure where to start with the implementation. I haven't yet found anything in any of the text files saying " ... and this is what you need to install ...". How about a few hints? Jeff Banfield Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA15402; Thu, 27 Apr 89 19:01:32 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 27 APR 89 18:56:25 PDT Return-Path: Redistributed: CommonLoops.PA Received: from boulder.Colorado.EDU ([128.138.238.18]) by Xerox.COM ; 27 APR 89 18:54:58 PDT Return-Path: Received: by boulder.Colorado.EDU (cu-hub.022489) Received: by sigi.colorado.edu (cu.generic.041888) Date: Thu, 27 Apr 89 19:54:44 MDT From: Andreas Girgensohn Message-Id: <8904280154.AA26603@sigi.colorado.edu> To: CommonLoops.PA@Xerox.COM Subject: Problems with eql method specifiers I'm using the PCL version from 4/20/89 with Genera 7.2. I have a few problems with eql specifiers in methods. Here is an example: (defclass test-superclass () ()) (defclass test-class (test-superclass) ()) (defmethod test-eql ((self test-superclass) x) (format t "~&test-eql other")) (defmethod test-eql ((self test-class) (x (eql 'a))) (format t "~&test-eql a")) (defmethod test-eql ((self test-class) (x (eql 'b))) (format t "~&test-eql b")) > (setq i (make-instance 'test-class)) > (test-eql i 'a) test-eql a > (test-eql i 'b) test-eql other <------ this is wrong! > (test-eql i 'c) test-eql other It works if the "other" method is defined in the same class. Another problem is that I can't compile the two methods "test-eql2"; the compiler runs into an error. A method without an eql specifier seems to be necessary. (defmethod test-eql2 ((self test-class) (x (eql 'a))) (format t "~&test-eql2 a")) (defmethod test-eql2 ((self test-class) (x (eql 'b))) (format t "~&test-eql2 b")) I cannot access my PCL version from 12/7/88 right now so that I don't know whether that version has the same problems. Any help will be appreciated. Andreas Girgensohn andreasg@boulder.colorado.edu Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA28721; Fri, 28 Apr 89 09:38:41 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 28 APR 89 09:02:46 PDT Return-Path: <@EN-C06.Prime.COM,@NET.Prime.COM:doug@zaphod.prime.com> Redistributed: commonloops.pa Received: from EN-C06.Prime.COM ([192.5.58.32]) by Xerox.COM ; 28 APR 89 08:57:49 PDT Received: from NET.Prime.COM by EN-C06.Prime.COM; 28 Apr 89 10:38:30 EDT Received: from primerd.prime.com by NET.Prime.COM; 28 Apr 89 10:35:47 EST Received: from zaphod.prime.com by primerd.prime.com (4.0/SMI-4.0) id AA05354; Fri, 28 Apr 89 10:34:13 EDT Received: from localhost by zaphod.prime.com (4.0/SMI-4.0) id AA09863; Fri, 28 Apr 89 10:34:15 EDT Message-Id: <8904281434.AA09863@zaphod.prime.com> To: commonloops.pa@Xerox.COM Cc: doug@zaphod.prime.com Subject: More persistant object stuff Date: Fri, 28 Apr 89 10:34:13 EDT From: Douglas Rand I continue to play with persistance. Currently I have a simple system which overrides slot-value-using-class to recover unbound instances from a database, and which keeps a transaction queue to update the database. Now for the question: the initialization protocol is well defined with initialize-instance, shared-initialize and reinitialize-instance. Is the protocol for instance creation as well defined at this time? I'd like to override allocate-instance so that the persistant-object class will only have one object corresponding to each database key... do I have to play with metaobjects to do this? Regards, Doug Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA02279; Fri, 28 Apr 89 11:15:29 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 28 APR 89 11:11:28 PDT Return-Path: Redistributed: commonloops.pa Received: from vaxa.isi.edu ([128.9.0.33]) by Xerox.COM ; 28 APR 89 11:05:55 PDT Posted-Date: Fri, 28 Apr 89 10:05:53 PST Message-Id: <8904281805.AA29779@vaxa.isi.edu> Received: from LOCALHOST by vaxa.isi.edu (5.61/5.61) id AA29779; Fri, 28 Apr 89 11:05:56 -0700 To: commonloops.pa@Xerox.COM From: goldman@vaxa.isi.edu Subject: add-slot Date: Fri, 28 Apr 89 10:05:53 PST Sender: goldman@vaxa.isi.edu Can someone give me a formula for using PCL's MOP to add a new slot to an existing class? neil Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA04098; Fri, 28 Apr 89 13:42:20 -0700 Reply-To: Received: from Salvador.ms by ArpaGateway.ms ; 28 APR 89 13:43:31 PDT Return-Path: Redistributed: commonloops.pa Received: from DINO.BBN.COM ([128.89.3.8]) by Xerox.COM ; 28 APR 89 13:27:42 PDT To: Owners-commonloops.pa@Xerox.COM Cc: commonloops.pa@Xerox.COM Subject: Re: add-slot In-Reply-To: Your message of Fri, 28 Apr 89 10:05:53 -0800. <8904281805.AA29779@vaxa.isi.edu> Date: Fri, 28 Apr 89 16:34:49 -0400 From: kanderso@DINO.BBN.COM Message-Id: <890428-134331-5236@Xerox> To: commonloops.pa@xerox.com From: goldman@vaxa.isi.edu Subject: add-slot Date: Fri, 28 Apr 89 10:05:53 PST Sender: goldman@vaxa.isi.edu Can someone give me a formula for using PCL's MOP to add a new slot to an existing class? neil Your' basically doing what normally happens when you re DEFCLASS a class. I think add-named-class should do it for you k Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06698; Fri, 28 Apr 89 15:39:27 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 28 APR 89 15:40:05 PDT Return-Path: Redistributed: CommonLoops.pa Received: from hx.LCS.MIT.EDU ([18.30.0.197]) by Xerox.COM ; 28 APR 89 15:32:21 PDT Received: by hx.LCS.MIT.EDU (5.51/4.7); Fri, 28 Apr 89 18:27:49 EDT Date: Fri, 28 Apr 89 18:27:49 EDT From: waldemar@hx.LCS.MIT.EDU (Waldemar Horwat) Message-Id: <8904282227.AA07718@hx.LCS.MIT.EDU> To: CommonLoops.pa@Xerox.COM Subject: Bugs Cc: waldemar@hx.LCS.MIT.EDU I too am having problems with eql method specifiers. I tried to define a slot-unbound method such as (defmethod slot-unbound (class (instance foo) (slot (eql 'bar))) ...), but the method wasn't called when the an unbound bar slot of the foo class was referenced. This *did* work in the 12/7/88 version of PCL. Also, has the infinite loop bug that I and rich@linus.MITRE.ORG reported been fixed? The eql method specifier bug prevents me from running the program which caused the infinite loop bug in the standard accessor methods, but looking at the code in dcode.lisp it appears that this problem still exists--code in which the infinite loop occurs has not been changed other than to change the lock count code. Waldemar Horwat Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA28721; Fri, 28 Apr 89 09:38:41 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 28 APR 89 09:02:46 PDT Return-Path: <@EN-C06.Prime.COM,@NET.Prime.COM:doug@zaphod.prime.com> Redistributed: commonloops.pa Received: from EN-C06.Prime.COM ([192.5.58.32]) by Xerox.COM ; 28 APR 89 08:57:49 PDT Received: from NET.Prime.COM by EN-C06.Prime.COM; 28 Apr 89 10:38:30 EDT Received: from primerd.prime.com by NET.Prime.COM; 28 Apr 89 10:35:47 EST Received: from zaphod.prime.com by primerd.prime.com (4.0/SMI-4.0) id AA05354; Fri, 28 Apr 89 10:34:13 EDT Received: from localhost by zaphod.prime.com (4.0/SMI-4.0) id AA09863; Fri, 28 Apr 89 10:34:15 EDT Message-Id: <8904281434.AA09863@zaphod.prime.com> To: commonloops.pa@Xerox.COM Cc: doug@zaphod.prime.com Subject: More persistant object stuff Date: Fri, 28 Apr 89 10:34:13 EDT From: Douglas Rand I continue to play with persistance. Currently I have a simple system which overrides slot-value-using-class to recover unbound instances from a database, and which keeps a transaction queue to update the database. Now for the question: the initialization protocol is well defined with initialize-instance, shared-initialize and reinitialize-instance. Is the protocol for instance creation as well defined at this time? I'd like to override allocate-instance so that the persistant-object class will only have one object corresponding to each database key... do I have to play with metaobjects to do this? Regards, Doug Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06698; Fri, 28 Apr 89 15:39:27 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 28 APR 89 15:40:05 PDT Return-Path: Redistributed: CommonLoops.pa Received: from hx.LCS.MIT.EDU ([18.30.0.197]) by Xerox.COM ; 28 APR 89 15:32:21 PDT Received: by hx.LCS.MIT.EDU (5.51/4.7); Fri, 28 Apr 89 18:27:49 EDT Date: Fri, 28 Apr 89 18:27:49 EDT From: waldemar@hx.LCS.MIT.EDU (Waldemar Horwat) Message-Id: <8904282227.AA07718@hx.LCS.MIT.EDU> To: CommonLoops.pa@Xerox.COM Subject: Bugs Cc: waldemar@hx.LCS.MIT.EDU I too am having problems with eql method specifiers. I tried to define a slot-unbound method such as (defmethod slot-unbound (class (instance foo) (slot (eql 'bar))) ...), but the method wasn't called when the an unbound bar slot of the foo class was referenced. This *did* work in the 12/7/88 version of PCL. Also, has the infinite loop bug that I and rich@linus.MITRE.ORG reported been fixed? The eql method specifier bug prevents me from running the program which caused the infinite loop bug in the standard accessor methods, but looking at the code in dcode.lisp it appears that this problem still exists--code in which the infinite loop occurs has not been changed other than to change the lock count code. Waldemar Horwat Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06698; Fri, 28 Apr 89 15:39:27 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 28 APR 89 15:40:05 PDT Return-Path: Redistributed: CommonLoops.pa Received: from hx.LCS.MIT.EDU ([18.30.0.197]) by Xerox.COM ; 28 APR 89 15:32:21 PDT Received: by hx.LCS.MIT.EDU (5.51/4.7); Fri, 28 Apr 89 18:27:49 EDT Date: Fri, 28 Apr 89 18:27:49 EDT From: waldemar@hx.LCS.MIT.EDU (Waldemar Horwat) Message-Id: <8904282227.AA07718@hx.LCS.MIT.EDU> To: CommonLoops.pa@Xerox.COM Subject: Bugs Cc: waldemar@hx.LCS.MIT.EDU I too am having problems with eql method specifiers. I tried to define a slot-unbound method such as (defmethod slot-unbound (class (instance foo) (slot (eql 'bar))) ...), but the method wasn't called when the an unbound bar slot of the foo class was referenced. This *did* work in the 12/7/88 version of PCL. Also, has the infinite loop bug that I and rich@linus.MITRE.ORG reported been fixed? The eql method specifier bug prevents me from running the program which caused the infinite loop bug in the standard accessor methods, but looking at the code in dcode.lisp it appears that this problem still exists--code in which the infinite loop occurs has not been changed other than to change the lock count code. Waldemar Horwat Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06698; Fri, 28 Apr 89 15:39:27 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 28 APR 89 15:40:05 PDT Return-Path: Redistributed: CommonLoops.pa Received: from hx.LCS.MIT.EDU ([18.30.0.197]) by Xerox.COM ; 28 APR 89 15:32:21 PDT Received: by hx.LCS.MIT.EDU (5.51/4.7); Fri, 28 Apr 89 18:27:49 EDT Date: Fri, 28 Apr 89 18:27:49 EDT From: waldemar@hx.LCS.MIT.EDU (Waldemar Horwat) Message-Id: <8904282227.AA07718@hx.LCS.MIT.EDU> To: CommonLoops.pa@Xerox.COM Subject: Bugs Cc: waldemar@hx.LCS.MIT.EDU I too am having problems with eql method specifiers. I tried to define a slot-unbound method such as (defmethod slot-unbound (class (instance foo) (slot (eql 'bar))) ...), but the method wasn't called when the an unbound bar slot of the foo class was referenced. This *did* work in the 12/7/88 version of PCL. Also, has the infinite loop bug that I and rich@linus.MITRE.ORG reported been fixed? The eql method specifier bug prevents me from running the program which caused the infinite loop bug in the standard accessor methods, but looking at the code in dcode.lisp it appears that this problem still exists--code in which the infinite loop occurs has not been changed other than to change the lock count code. Waldemar Horwat Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA00399; Mon, 1 May 89 12:24:43 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 28 APR 89 18:57:13 PDT Date: Fri, 28 Apr 89 18:54 PDT From: Gregor.pa@Xerox.COM Subject: Re: add-slot To: goldman@vaxa.isi.edu Cc: commonloops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8904281805.AA29779@vaxa.isi.edu> Message-Id: <19890429015413.1.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Fri, 28 Apr 89 10:05:53 PST From: goldman@vaxa.isi.edu Can someone give me a formula for using PCL's MOP to add a new slot to an existing class? The following function does this. The initfunction argument must be a function of no arguments that will be called to initialize the slot. Note that it doesn't have any error checking (for example to make sure there isn't already a slot by that name. You will probably want to make some other changes to this function to get the precise interface you want. But, this example shows the basic functionality you need. Let me know if you need any more help with this. (defun add-slot (class name initform initfunction &rest other-slot-options) (let ((slotd (apply #'make-instance 'standard-slot-description :name name :allocation :instance :initform initform :initfunction initfunction other-slot-options)) (old-direct-slots (class-local-slots class))) (update-class class :direct-slots (cons slotd old-direct-slots)))) The following dialogue shows using the add-slot function. (defclass foo () ((x :initform 0) (y :initform 1))) # (describe (make-instance 'foo)) # is an instance of class #: The following slots have :INSTANCE allocation: Z 2 Y 1 X 0 (add-slot (find-class 'foo) 'z '2 #'(lambda () 2)) NIL (describe (make-instance 'foo)) # is an instance of class #: The following slots have :INSTANCE allocation: Z 2 Y 1 X 0 ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA00586; Mon, 1 May 89 12:28:29 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 28 APR 89 21:45:07 PDT Return-Path: Redistributed: commonloops.pa Received: from shrike.Austin.Lockheed.COM ([192.31.24.65]) by Xerox.COM ; 28 APR 89 21:43:54 PDT Received: by shrike.Austin.Lockheed.COM (4.0/1.45); Fri, 28 Apr 89 23:42:39 CDT Date: Fri, 28 Apr 89 23:42:39 CDT From: Daniel A Haug Message-Id: <8904290442.AA00357@shrike.Austin.Lockheed.COM> To: commonloops.pa@Xerox.COM Subject: undefmethod'ing setf forms Cc: haug@AUSTIN.LOCKHEED.COM How do I specify to undefmethod a setf method? Specifically, something like: (defmethod (setf foo) :after ((instance my-class) ...) ...) I tried: (undefmethod (setf foo) :after (my-class)) But it doesn't seem to find the method named (setf foo). dan haug haug@austin.lockheed.com Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA03208; Mon, 1 May 89 15:33:46 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 01 MAY 89 09:45:56 PDT Date: Mon, 1 May 89 08:47 PDT From: Gregor.pa@Xerox.COM Subject: Re: Bugs To: Waldemar Horwat Cc: CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8904282227.AA07718@hx.LCS.MIT.EDU> Message-Id: <19890501154741.1.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Fri, 28 Apr 89 18:27:49 EDT From: waldemar@hx.LCS.MIT.EDU (Waldemar Horwat) I too am having problems with eql method specifiers. OK, there is definitely a problem this way in Passover PCL. I suggest that no one else copy Passover PCL from arisia and that anyone already using it revert for a little bit. I am working on these bugs now. If things go well there will be a May Day PCL. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA03799; Mon, 1 May 89 16:19:19 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 01 MAY 89 12:21:23 PDT Date: Mon, 1 May 89 11:11 PDT From: Gregor.pa@Xerox.COM Subject: PCL distribution for MACs To: CommonLoops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest Message-Id: <19890501181121.9.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no PCL is listed in the most recent issue of APDAlog. It is distributed on Macintosh floppies. This makes it possible for people who don't have FTP access to arisia (but who do have a Macintosh) to get PCL. For $40 you receive a version of PCL and a copy of the CLOS spec (X3J13 document number 88-002R). The APDAlog catalog number is T0259LL/A and you can order by calling: From the U.S. (800)282-2732 From Canada (800)637-0029 International (408)562-3910 FAX (408)562-3971 NOTE: Whenever there is a new release of PCL you want, you should probably wait a couple of months before ordering it from APDAlog. We want to let new PCL's stabilize a bit before sending it to them, and it will take them some time to integrate the new disks into their distribution. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA04253; Mon, 1 May 89 16:50:01 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 01 MAY 89 14:41:06 PDT Return-Path: Redistributed: commonloops.pa Received: from rand.org ([10.3.0.7]) by Xerox.COM ; 01 MAY 89 12:09:30 PDT Received: from blackcomb.rand.org by rand.org; Mon, 1 May 89 11:44:51 PDT Received: from localhost by blackcomb.arpa; Mon, 1 May 89 11:42:01 PDT Message-Id: <8905011842.AA05294@blackcomb.arpa> To: commonloops.pa@Xerox.COM Cc: Stephanie_Cammarata Subject: Slot initializations when changing the class of an instance. Date: Mon, 01 May 89 11:41:59 PDT From: Darrell ;;; Is there a better way to provide slot initializations when the class ;;; of an instance is changed via change-class? What I would really like ;;; is for change-class to accept a list of initargs, similar to ;;; make-instance. I am using the following kludge: (defvar *INITARGS* nil "Temporary global") (defclass CLASS-CHANGEABLE-OBJECT () () (:documentation "The CLASS-CHANGEABLE-OBJECT is a class hook which will allow instances to be initialized when their class is changed.")) (defmethod update-instance-for-different-class :around ((previous CLASS-CHANGEABLE-OBJECT) current &rest initargs) (declare (ignore initargs) (special *INITARGS*)) ;; Initargs are read from the def... form. (apply #'call-next-method previous current *INITARGS*)) (defclass OLD-CLASS (CLASS-CHANGEABLE-OBJECT) ((slot1 :initarg :s1 :initform 0 :accessor s1))) (defclass NEW-CLASS () ((slot1 :initarg :s1 :initform nil :accessor s1) (slot2 :initarg :s2 :initform (very-time-consuming-computation 2) :accessor s2) (slot3 :initarg :s3 :initform (very-time-consuming-computation 3) :accessor s3))) (setq instance (pcl::*make-instance 'old-class :s1 99)) (describe instance) # is an instance of class #: The following slots have :INSTANCE allocation: SLOT1 99 ;;; Now to change the class of instance. (let ((*INITARGS* (list :s2 2 :s3 3))) (change-class instance 'new-class)) (describe instance) # is an instance of class #: The following slots have :INSTANCE allocation: SLOT1 99 SLOT2 2 SLOT3 3 ;;; What would be nice is for: ;;; (change-class instance 'new-class :s2 2 :s3 3) ;;; to accomplish the same thing. Because it might be costly ;;; for the newly added local slots to be initialized to their ;;; :initform's, I want to inject initargs into the primary ;;; update-instance-for-different-class method. But I don't ;;; like the idea of using a global variable for temporary ;;; storage. Why is it that the change-class method does not ;;; accept initargs? ;;; ;;; Thanks, ;;; Darrell Shane Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA05204; Mon, 1 May 89 17:43:02 -0700 Reply-To: Received: from Chardonnay.ms by ArpaGateway.ms ; 01 MAY 89 17:37:49 PDT Return-Path: Redistributed: commonloops.pa Received: from rand.org ([10.3.0.7]) by Xerox.COM ; 01 MAY 89 13:36:25 PDT Received: from blackcomb.rand.org by rand.org; Mon, 1 May 89 12:58:12 PDT Received: from localhost by blackcomb.arpa; Mon, 1 May 89 12:55:20 PDT Message-Id: <8905011955.AA05406@blackcomb.arpa> To: commonloops.pa@Xerox.COM Cc: Stephanie_Cammarata Subject: Changing the :metaclass of a class Date: Mon, 01 May 89 12:55:17 PDT From: Darrell ;;; Why is it that when I change the :metaclass of a class, ;;; the class instance is not changed? For example: (defclass COMPATIBLE-METACLASS-MIXIN () ()) (defmethod CHECK-SUPER-METACLASS-COMPATIBILITY ((class COMPATIBLE-METACLASS-MIXIN) (super STANDARD-CLASS)) t) ;;; Initial metaclass (defclass FIRST-METACLASS (COMPATIBLE-METACLASS-MIXIN STANDARD-CLASS) ((SLOT1 :initform 1 :accessor SLOT1))) ;;; Next metaclass (defclass SECOND-METACLASS (FIRST-METACLASS) ((SLOT2 :initform 2 :accessor SLOT2))) ;;; Initial class. (defclass MYCLASS () () (:metaclass FIRST-METACLASS)) ;;; Notice the class is an instance of the FIRST-METACLASS class. (describe (find-class 'myclass)) The class # is an instance of class #. Name: MYCLASS Class-Precedence-List: (MYCLASS OBJECT T) Local-Supers: (OBJECT) Direct-Subclasses: NIL ;;; Class redefinition (defclass MYCLASS () () (:metaclass SECOND-METACLASS)) ;;; But the class is still an instance of the FIRST-METACLASS class! (describe (find-class 'myclass)) The class # is an instance of class #. Name: MYCLASS Class-Precedence-List: (MYCLASS OBJECT T) Local-Supers: (OBJECT) Direct-Subclasses: NIL Thanks for any assistance, Darrell Shane P.S. I am using "no cute name" PCL running on Franz Allegro CL. Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA18021; Tue, 2 May 89 10:17:43 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 02 MAY 89 10:15:12 PDT Date: Tue, 2 May 89 10:06 PDT From: Gregor.pa@Xerox.COM Subject: Re: Changing the :metaclass of a class To: Darrell Cc: commonloops.pa@Xerox.COM, Stephanie_Cammarata Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8905011955.AA05406@blackcomb.arpa> Message-Id: <19890502170618.0.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Mon, 01 May 89 12:55:17 PDT From: Darrell ;;; Why is it that when I change the :metaclass of a class, ;;; the class instance is not changed? For example: This is because of a structural bug in PCL. Unfortunately, this won't be fixed in this week's release. It should be fixed this month though. Note that in almost all cases, you can just use change-class by hand on the class object. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA18360; Tue, 2 May 89 10:36:54 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 02 MAY 89 10:31:51 PDT Date: Tue, 2 May 89 10:22 PDT From: Gregor.pa@Xerox.COM Subject: CLOS Workshop To: CommonLoops.PA@Xerox.COM, common-lisp-object-system@sail.stanford.edu Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest Message-Id: <19890502172212.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no I have received a number of questions about this, so I thought this might be generally useful information. The second CLOS Users and Implementors workshop will be help at the OOPSLA conference this year. The date is not yet set but will probably be October 2nd. There will be a modest fee, in addition to the OOPSLA registration fee, for attending the workshop. This year's workshop will have a somewhat different format than last year. In particular, attendance at this year's workshop will be more limited. This will make it possible to have a more intensive workshop which we feel is more appropriate at this stage in the growth of the CLOS community. The papers that are submitted will be reviewed by a panel of CLOS experts, and workshop participants will be selected on this basis. What follows it the formal announcement to be included in the advance publicity for OOPSLA: The Second Annual CLOS Users and Implementors Workshop This workshop is for persons with substantial experience with the Common Lisp Object System. The purpose of this workshop is to bring together a wide range of CLOS expertise in a setting which promotes substantive interaction among the participants. The workshop will address current issues in the use, development and implementation of CLOS. In order to promote intensive interaction among workshop participants, attendance will be limited to 30 people. Persons who would like to attend should submit five copies of a short (5 - 10 page) paper describing their work with CLOS. This can include more general work in OO systems as it relates to CLOS. It is permissible for this to be a paper which will be presented in the main track of the conference. Papers must be received by August 1 1989 and should be sent to: Gregor Kiczales Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 ------- Received: from Sail.Stanford.EDU by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA18445; Tue, 2 May 89 10:42:48 -0700 Reply-To: Received: from Xerox.COM by SAIL.Stanford.EDU with TCP; 2 May 89 10:42:02 PDT Received: from Semillon.ms by ArpaGateway.ms ; 02 MAY 89 10:31:51 PDT Date: Tue, 2 May 89 10:22 PDT From: Gregor.pa@Xerox.COM Subject: CLOS Workshop To: CommonLoops.PA@Xerox.COM, common-lisp-object-system@sail.stanford.edu Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest Message-Id: <19890502172212.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no I have received a number of questions about this, so I thought this might be generally useful information. The second CLOS Users and Implementors workshop will be help at the OOPSLA conference this year. The date is not yet set but will probably be October 2nd. There will be a modest fee, in addition to the OOPSLA registration fee, for attending the workshop. This year's workshop will have a somewhat different format than last year. In particular, attendance at this year's workshop will be more limited. This will make it possible to have a more intensive workshop which we feel is more appropriate at this stage in the growth of the CLOS community. The papers that are submitted will be reviewed by a panel of CLOS experts, and workshop participants will be selected on this basis. What follows it the formal announcement to be included in the advance publicity for OOPSLA: The Second Annual CLOS Users and Implementors Workshop This workshop is for persons with substantial experience with the Common Lisp Object System. The purpose of this workshop is to bring together a wide range of CLOS expertise in a setting which promotes substantive interaction among the participants. The workshop will address current issues in the use, development and implementation of CLOS. In order to promote intensive interaction among workshop participants, attendance will be limited to 30 people. Persons who would like to attend should submit five copies of a short (5 - 10 page) paper describing their work with CLOS. This can include more general work in OO systems as it relates to CLOS. It is permissible for this to be a paper which will be presented in the main track of the conference. Papers must be received by August 1 1989 and should be sent to: Gregor Kiczales Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA19443; Tue, 2 May 89 12:06:59 -0700 Reply-To: Received: from Riesling.ms by ArpaGateway.ms ; 02 MAY 89 11:57:23 PDT Return-Path: Redistributed: CommonLoops.pa Received: from vx.acss.umn.edu ([128.101.63.1]) by Xerox.COM ; 02 MAY 89 11:54:25 PDT Date: Tue, 2 May 89 13:54 CST From: FQM6470@vx.acss.umn.edu Subject: Error found in using PCL in GCLISP V3.1 To: CommonLoops.pa@Xerox.COM X-Vms-To: IN%"CommonLoops.pa@xerox.com" Message-Id: <890502-115723-5601@Xerox> While loading PCL in GCLISP v3.1 by Gold Hill, an error was found. The file "Walk.lsp" does not contain he macro "Environmental-macro" and the two related funcrtions for GCLISP. Can anyone help us supplying these functions? Thank you. Bipin C Bora, 125 Mecchanical Engineering, 111 Church St SE, University of Minnesota, Minneapolis, MN 55455. or fqm6470@vx.acss.umn.edu Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA20011; Tue, 2 May 89 12:53:51 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 02 MAY 89 12:54:47 PDT Date: Tue, 2 May 89 12:50 PDT From: Gregor.pa@Xerox.COM Subject: Re: Error found in using PCL in GCLISP V3.1 To: FQM6470@vx.acss.umn.edu Cc: CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: The message of 2 May 89 12:54 PDT from FQM6470@vx.acss.umn.edu Message-Id: <19890502195052.5.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Tue, 2 May 89 13:54 CST From: FQM6470@vx.acss.umn.edu While loading PCL in GCLISP v3.1 by Gold Hill, an error was found. The file "Walk.lsp" does not contain he macro "Environmental-macro" and the two related functions for GCLISP. Can anyone help us supplying these functions? What version of PCL are you using? You can find this out by looking at the variable *pcl-system-date* which is defined in the file defsys.lisp. The newest version of PCL on arisia, should work in Gold Hill. The problem is that it has a couple of other bugs which have been discussed on this list already. There should be a version with the bugs fixed and which works in Gold shortly (next 2 days). No later than the 5th of May! ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA25621; Tue, 2 May 89 18:12:11 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 02 MAY 89 18:12:29 PDT Return-Path: Redistributed: CommonLoops.pa Received: from itsgw.rpi.edu ([128.113.1.3]) by Xerox.COM ; 02 MAY 89 18:09:27 PDT Received: by itsgw.rpi.edu (5.54/13-RPI-Info-Tech-Services); id AA07438; Tue, 2 May 89 21:09:24 EDT for CommonLoops.pa@xerox.com Received: from ralsub.rpi.edu (mars.ral.rpi.edu) by ral.rpi.edu (4.0/M03) id AA19064; Tue, 2 May 89 21:13:45 EDT Received: by ralsub.rpi.edu (4.0/SUB03) id AA20647; Tue, 2 May 89 21:13:09 EDT Date: Tue, 2 May 89 21:13:09 EDT From: sood@ral.rpi.edu Message-Id: <8905030113.AA20647@ralsub.rpi.edu> To: CommonLoops.pa@Xerox.COM Subject: Removal from mailing list. Please remove sood@ral.rpi.edu from the mailing list. Thanks, sood. Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06398; Wed, 3 May 89 08:43:33 -0700 Reply-To: Received: from Chardonnay.ms by ArpaGateway.ms ; 03 MAY 89 07:59:23 PDT Return-Path: Redistributed: CommonLoops.pa Received: from ns-mx.uiowa.edu ([128.255.64.3]) by Xerox.COM ; 03 MAY 89 07:56:10 PDT Received: from herky.cs.uiowa.edu by ns-mx.uiowa.edu (5.59/890218) on Wed, 3 May 89 09:53:13 CDT id AA22862 Received: by herky.cs.uiowa.edu (5.51/1.1) on Wed, 3 May 89 09:59:54 CDT id AA04251 Date: Wed, 3 May 89 09:59:54 CDT From: Dong Ho Lee Message-Id: <8905031459.AA04251@herky.cs.uiowa.edu> To: CommonLoops.pa@Xerox.COM Subject: Removal from Mailing list PLease remove dhlee@herky.cs.uiowa.edu from the mailing list. Thanks, DongHo Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA13834; Wed, 3 May 89 12:12:05 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 03 MAY 89 12:11:21 PDT Return-Path: Redistributed: CommonLoops.PA Received: from rand.org ([10.3.0.7]) by Xerox.COM ; 03 MAY 89 11:52:22 PDT Received: from blackcomb.rand.org by rand.org; Wed, 3 May 89 11:21:20 PDT Received: from localhost by blackcomb.arpa; Wed, 3 May 89 11:18:30 PDT Message-Id: <8905031818.AA06488@blackcomb.arpa> To: CommonLoops.PA@Xerox.COM Subject: A couple questions about up and coming PCL features Date: Wed, 03 May 89 11:18:24 PDT From: Darrell Any idea when defgeneric, generic-flet, and generic-labels will be implemented in PCL? Is there a work-around that can allow me to temporarily define/mask a method? Thanks, Darrell Shane Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA14106; Wed, 3 May 89 12:55:31 -0700 Reply-To: Received: from Riesling.ms by ArpaGateway.ms ; 03 MAY 89 12:55:54 PDT Return-Path: Redistributed: CommonLoops.PA Received: from rand.org ([10.3.0.7]) by Xerox.COM ; 03 MAY 89 12:37:54 PDT Received: from blackcomb.rand.org by rand.org; Wed, 3 May 89 12:01:46 PDT Received: from localhost by blackcomb.arpa; Wed, 3 May 89 11:58:57 PDT Message-Id: <8905031858.AA06517@blackcomb.arpa> To: CommonLoops.PA@Xerox.COM Subject: How can one get a method object? Date: Wed, 03 May 89 11:58:55 PDT From: Darrell First, can I use add-method and remove-method to add a method temporarily? If yes then how can I get a method object to pass to add-method & remove-method? Defmethod returns nil and find-method does not seem to be implemented in the "no cute version" pcl. Thanks, Darrell Shane Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA16018; Wed, 3 May 89 15:06:53 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 03 MAY 89 15:08:29 PDT Date: Wed, 3 May 89 15:02 PDT From: Gregor.pa@Xerox.COM Subject: Re: Problems with eql method specifiers To: Andreas Girgensohn Cc: CommonLoops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8904280154.AA26603@sigi.colorado.edu> Message-Id: <19890503220228.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Thu, 27 Apr 89 19:54:44 MDT From: Andreas Girgensohn I'm using the PCL version from 4/20/89 with Genera 7.2. I have a few problems with eql specifiers in methods. Here is an example: This patch should fix this problem with eql methods. It hasn't been thoroughly tested yet (ha!) but I thought I would send it out right away anyways. This will be included as part of a release I hope to get out Friday. It should work to simply edit points.lisp to have this patch and then compile and load that file into a running PCL. Note that existing generic functions won't be `fixed' unless you first redefine some method on them (easy to do by reloading your code). ;from points.lisp (defun adjust-points-for-eql-methods (points eql-methods eql-classes) (labels ((eql-method-p (method) (memq method eql-methods)) (eql-class-p (class) (rassoc class eql-classes)) (has-eql-method-p (methods) (dolist (m methods) (when (eql-method-p m) (return 't))))) (let ((adjusted ()) (pending ()) (super-eqls ())) ;; ;; Pass 1: ;; ;; In this pass, all points which have no eql methods are separated ;; from those that do. Points without eql methods go on the list ;; adjusted, points with eql methods go on the list pending. ;; (dolist (point points) (destructuring-bind (nil methods) point (if (has-eql-method-p methods) (push point pending) (push point adjusted)))) ;; ;; Pass 2: ;; ;; ;; (flet ((get-super-point (point) (destructuring-bind (classes methods) point (let ((super-classes (gathering1 (collecting) (dolist (c classes) (gather1 (if (eql-class-p c) (cadr (class-precedence-list c)) c)))))) (or (assoc super-classes super-eqls :test #'equal) (let ((adjusted-hit (assoc super-classes adjusted :test #'equal))) (when adjusted-hit (push adjusted-hit super-eqls) adjusted-hit)) (let ((new (list super-classes (remove-if #'eql-method-p methods)))) (push new adjusted) (push new super-eqls) new)))))) (dolist (point pending) (destructuring-bind (classes methods) point (let ((super (get-super-point point))) (push (cons (gathering1 (collecting) (dolist (c classes) (let ((hit (rassq c eql-classes))) (gather1 (if hit (car hit) '..not-an-eql-specializer-object..))))) methods) (cddr super)))))) adjusted))) ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA19547; Wed, 3 May 89 19:30:12 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 03 MAY 89 19:31:29 PDT Date: Wed, 3 May 89 19:27 PDT From: Gregor.pa@Xerox.COM Subject: Re: How can one get a method object? To: Darrell Cc: CommonLoops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8905031858.AA06517@blackcomb.arpa> Message-Id: <19890504022747.2.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Wed, 03 May 89 11:58:55 PDT From: Darrell First, can I use add-method and remove-method to add a method temporarily? If yes then how can I get a method object to pass to add-method & remove-method? Defmethod returns nil and find-method does not seem to be implemented in the "no cute version" pcl. FIND-METHOD is called GET-METHOD in no cute name PCL. Here is some code which may be illustrative for you. Note that you will have to change this code somewhat in a future release, but the basic idea will be the same: (in-package 'pcl) ;;; ;;; Define a one argument method on the generic function GF. The method ;;; has the specializer SPECIALIZER and simply returns the value VALUE. ;;; (defun specialize-to-class (gf specializer value) (let ((method (make-instance 'standard-method :qualifiers () :type-specifiers (list specializer) :arglist '(arg) :function #'(lambda (arg) value)))) (add-method gf method))) (defvar *my-generic-function* (make-instance 'standard-generic-function)) (specialize-to-class *my-generic-function* (find-class 'symbol) "Symbol") (specialize-to-class *my-generic-function* (find-class 'number) "Number") (specialize-to-class *my-generic-function* (find-class 'class) "Class") (specialize-to-class *my-generic-function* (find-class 't) "Other") (funcall *my-generic-function* 'foo) ==> "Symbol" (funcall *my-generic-function* '1) ==> "Number" (funcall *my-generic-function* (find-class 't)) ==> "Class" (funcall *my-generic-function* '(1 2 3)) ==> "Other" You should also note that REMOVE-METHOD can be used to remove a method from a generic function. The generic function GENERIC-FUNCTION-METHODS can be used to to get a list of all the methods on a generic function. So, for example, if you do a defmethod like: (defmethod foo ((p position)) ..) and you want to get rid of it (imagine undefmethod didn't exist). You could say: (let ((method (get-method #'foo () (list (find-class 'position))))) (remove-method #'foo method)) ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA19564; Wed, 3 May 89 19:33:46 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 03 MAY 89 19:34:37 PDT Date: Wed, 3 May 89 19:31 PDT From: Gregor.pa@Xerox.COM Subject: Re: A couple questions about up and coming PCL features To: Darrell Cc: CommonLoops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8905031818.AA06488@blackcomb.arpa> Message-Id: <19890504023124.3.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Wed, 03 May 89 11:18:24 PDT From: Darrell Any idea when defgeneric, generic-flet, and generic-labels will be implemented in PCL? DEFGENERIC will be soon, maybe in this Friday's release. GENERIC-FLET and GENERIC-LABELS will never appear in PCL. In fact, I hope to take them out of CLOS completely. Is there a work-around that can allow me to temporarily define/mask a method? I don't understand this question. It seems to me that you could mean one of two things: 1) Temporily define a generic function: This is what generic-flet and generic-labels were for. Its too bad they can't be implemented in a reasonable way in Common Lisp. 2) Temporarily override a method. This is what WITH-ADDED-METHODS was for. It isn't likely to be implemented in PCL anytime real soon. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA16018; Wed, 3 May 89 15:06:53 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 03 MAY 89 15:08:29 PDT Date: Wed, 3 May 89 15:02 PDT From: Gregor.pa@Xerox.COM Subject: Re: Problems with eql method specifiers To: Andreas Girgensohn Cc: CommonLoops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8904280154.AA26603@sigi.colorado.edu> Message-Id: <19890503220228.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Thu, 27 Apr 89 19:54:44 MDT From: Andreas Girgensohn I'm using the PCL version from 4/20/89 with Genera 7.2. I have a few problems with eql specifiers in methods. Here is an example: This patch should fix this problem with eql methods. It hasn't been thoroughly tested yet (ha!) but I thought I would send it out right away anyways. This will be included as part of a release I hope to get out Friday. It should work to simply edit points.lisp to have this patch and then compile and load that file into a running PCL. Note that existing generic functions won't be `fixed' unless you first redefine some method on them (easy to do by reloading your code). ;from points.lisp (defun adjust-points-for-eql-methods (points eql-methods eql-classes) (labels ((eql-method-p (method) (memq method eql-methods)) (eql-class-p (class) (rassoc class eql-classes)) (has-eql-method-p (methods) (dolist (m methods) (when (eql-method-p m) (return 't))))) (let ((adjusted ()) (pending ()) (super-eqls ())) ;; ;; Pass 1: ;; ;; In this pass, all points which have no eql methods are separated ;; from those that do. Points without eql methods go on the list ;; adjusted, points with eql methods go on the list pending. ;; (dolist (point points) (destructuring-bind (nil methods) point (if (has-eql-method-p methods) (push point pending) (push point adjusted)))) ;; ;; Pass 2: ;; ;; ;; (flet ((get-super-point (point) (destructuring-bind (classes methods) point (let ((super-classes (gathering1 (collecting) (dolist (c classes) (gather1 (if (eql-class-p c) (cadr (class-precedence-list c)) c)))))) (or (assoc super-classes super-eqls :test #'equal) (let ((adjusted-hit (assoc super-classes adjusted :test #'equal))) (when adjusted-hit (push adjusted-hit super-eqls) adjusted-hit)) (let ((new (list super-classes (remove-if #'eql-method-p methods)))) (push new adjusted) (push new super-eqls) new)))))) (dolist (point pending) (destructuring-bind (classes methods) point (let ((super (get-super-point point))) (push (cons (gathering1 (collecting) (dolist (c classes) (let ((hit (rassq c eql-classes))) (gather1 (if hit (car hit) '..not-an-eql-specializer-object..))))) methods) (cddr super)))))) adjusted))) ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06477; Thu, 4 May 89 14:07:21 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 04 MAY 89 10:08:41 PDT Date: Thu, 4 May 89 09:22 PDT From: Gregor.pa@Xerox.COM Subject: Re: A couple questions about up and coming PCL features To: kempf@Sun.COM Cc: Darrell , CommonLoops.PA@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8905041434.AA05671@suntana.sun.com> Message-Id: <19890504162207.2.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Thu, 04 May 89 07:34:15 PDT From: kempf@Sun.COM And what about DEFINE-METHOD-COMBINATION? This won't make tomorrow's release. But it will probably make the next one. There are a couple of implementations for me to use. What has been holding this up is some compiler interface work and a desire not to write some parts of this now and again when I redo the metaobject protocol. ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06553; Thu, 4 May 89 14:10:37 -0700 Reply-To: Received: from Riesling.ms by ArpaGateway.ms ; 04 MAY 89 07:35:21 PDT Return-Path: Redistributed: commonloops.pa Received: from Sun.COM ([192.9.9.1]) by Xerox.COM ; 04 MAY 89 07:33:55 PDT Received: from snail.Sun.COM (snail.Corp.Sun.COM) by Sun.COM (4.1/SMI-4.0) id AA12002; Thu, 4 May 89 07:38:55 PDT Received: from suntana.sun.com by snail.Sun.COM (4.1/SMI-4.1) id AA25326; Thu, 4 May 89 07:32:36 PDT Received: from localhost by suntana.sun.com (4.0/SMI-4.0) id AA05671; Thu, 4 May 89 07:34:18 PDT Message-Id: <8905041434.AA05671@suntana.sun.com> To: Cc: Darrell , CommonLoops.PA@Xerox.COM Subject: Re: A couple questions about up and coming PCL features In-Reply-To: Your message of Wed, 03 May 89 19:31:00 -0700. <19890504023124.3.GREGOR@SPIFF.parc.xerox.com> Date: Thu, 04 May 89 07:34:15 PDT From: kempf@Sun.COM >GENERIC-FLET and GENERIC-LABELS will never appear in PCL. In fact, I >hope to take them out of CLOS completely. And what about DEFINE-METHOD-COMBINATION? jak Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA06735; Thu, 4 May 89 14:21:03 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 04 MAY 89 07:55:55 PDT Return-Path: Redistributed: CommonLoops.pa Received: from vx.acss.umn.edu ([128.101.63.1]) by Xerox.COM ; 04 MAY 89 07:53:57 PDT Date: Thu, 4 May 89 09:54 CST From: BORA@vx.acss.umn.edu Subject: Note on the use of PCL in GCLISP v3.1 in IBM-PS/2 To: CommonLoops.pa@Xerox.COM X-Vms-To: IN%"CommonLoops.pa@xerox.com" Message-Id: <890504-075555-1262@Xerox> To whom it may concern: From: Bipin C. Bora 125 Mechanical Engineering 111 Church Street SE University of Minnesota Minneapolis, MN 55455 Ph: (612) 625-8003 (Off) (612) 625-9881 (Lab) Sub: Problems encountered in using PCL in the GCLISP V3.1. Dear Sir/Madam (s), Hi! I am a new PCL user. I am trying to install the program in Gold Hill Computer's GCLISP v3.1 in an IBM-PS2 system. I am however running into difficulty while compiling the program. I suspect that the "ENVIRONMENTAL_MACRO" and its two related func- tions are missing from the file "WALK.LSP". I think the specific version I have obtained does not contain the macro and the two functions for GCLISP. Is there anyone who has encountered a similar problem? Do I write my own macro and the functions? If someone has already solved this problem, could I please know? My elecronic mailing address is: bora@vx.acss.umn.edu Thank you very much. Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA08833; Thu, 4 May 89 16:12:58 -0700 Reply-To: Received: from Cabernet.ms by ArpaGateway.ms ; 04 MAY 89 16:11:28 PDT Return-Path: Redistributed: CommonLoops.pa Received: from flash.bellcore.com ([128.96.32.20]) by Xerox.COM ; 04 MAY 89 16:00:21 PDT Received: by flash.bellcore.com (5.58/1.1) id AA05553; Thu, 4 May 89 18:59:36 EDT Date: Thu, 4 May 89 18:59:36 EDT From: wxs@flash.bellcore.com (Werner Stuetzle) Message-Id: <8905042259.AA05553@flash.bellcore.com> To: CommonLoops.pa@Xerox.COM Subject: Difficulties with compiling PCL Hello! I am using pcl on a Mac-2. Today I got the latest version from arisia and tried to compile it with release 1.2.2 of Allegro CL. I get a bunch of strange messages. When I try to use PCL anyways, defclass gets in an infinite loop. Here is a copy of the Lisp Listener window: ====================================================================== Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) Compiler warnings for function: MAKE-PROBE Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED) Compiler warnings for function: MAKE-CALL Undeclared free variables (SPECIALIZED-POSITIONS REQUIRED RESTP) 1 > Continuing... Loading binary of HIGH... > Warning: FUNCTION BUILT-IN-WRAPPER-OF originally defined in: (CCL;clos-5-4-89:low.lisp) is now being redefined in: CCL;clos-5-4-89:high.lisp > While executing: "Unknown" > Warning: FUNCTION BUILT-IN-CLASS-OF originally defined in: (CCL;clos-5-4-89:low.lisp) is now being redefined in: CCL;clos-5-4-89:high.lisp > While executing: "Unknown" Compiling COMPAT... T Compiler warnings for function: PCL::UNTRACE-IT Variable not ignored (PCL::METHOD) ? ==================================================================== What am I doing wrong???? Thanks for your help. I have used the older version of PCL. I have one suggestion: I think it would be a good idea to have in the user interface a version of defclass that evaluates its arguments. If you are interested, I can give you an example where that is needed. Regards, Werner Stuetzle Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA03659; Fri, 5 May 89 14:30:55 -0700 Reply-To: Received: from Salvador.ms by ArpaGateway.ms ; 05 MAY 89 14:29:23 PDT Date: Fri, 5 May 89 14:25 PDT From: Gregor.pa@Xerox.COM Subject: Re: undefmethod'ing setf forms To: Daniel A Haug Cc: commonloops.pa@Xerox.COM, haug@AUSTIN.LOCKHEED.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest In-Reply-To: <8904290442.AA00357@shrike.Austin.Lockheed.COM> Message-Id: <19890505212538.4.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no Date: Fri, 28 Apr 89 23:42:39 CDT From: Daniel A Haug How do I specify to undefmethod a setf method? Specifically something like: You wanted to try (undefmethod (setf foo) :after (t my-class)) But, there was a bug in undefmethod that prevented this from working. The following patch fixes that. This will appear in Cinco de Mayo PCL which is about to be released. ;from high.lisp (defmacro undefmethod (&rest args) #+(or (not :lucid) :lcl3.0) (declare (arglist name {method-qualifier}* specializers)) `(undefmethod-1 ',args)) ------- Received: from Xerox.COM by arisia.Xerox.COM with SMTP (5.61+/IDA-1.2.8/gandalf) id AA05038; Fri, 5 May 89 15:52:22 -0700 Reply-To: Received: from Semillon.ms by ArpaGateway.ms ; 05 MAY 89 15:45:32 PDT Date: Fri, 5 May 89 15:42 PDT From: Gregor.pa@Xerox.COM Subject: new version of PCL To: CommonLoops.pa@Xerox.COM Fcc: BD:>Gregor>mail>outgoing-mail-6.text.newest Message-Id: <19890505224245.0.GREGOR@SPIFF.parc.xerox.com> Line-Fold: no There is a new version of PCL. This version has a *pcl-system-date* of "5/5/89 Cinco de Mayo PCL". Arisia is down right now, but this version will appear in the /pcl directly on arisia.xerox.com as soon as it comes back up. Cinco de Mayo PCL completely replaces Passover PCL. Anyone using Passover PCL should switch to Cinco de Mayo right away. Other users should consider moving to Cinco de Mayo shortly. Cinco de Mayo PCL differs from Passover PCL in the following ways: - bugs associated with eql specializers have been fixed - UNDEFMETHOD has been fixed - problems with recursive calls to the compiler in KCL have been fixed - some other minor changes have been made and bugs have been fixed As always, please read the notes.text file completely. Thank you and stay in touch. -------