(FILECREATED "13-Mar-84 17:40:51" {INDIGO}<LOOPS>SOURCES>LOOPSKERNEL.;54 72245
changes to: (VARS KERNELFNS)
previous date: " 9-Mar-84 01:05:32" {INDIGO}<LOOPS>SOURCES>LOOPSKERNEL.;53)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LOOPSKERNELCOMS)
(RPAQQ LOOPSKERNELCOMS [(* Copyright (c)
1982 by Xerox Corporation)
(* Metabraid of kernel classes in the system)
(CLASSES * KERNELCLASSES)
(VARS (DumpMethodsInClass)
(DefaultObject ($ Object))
(OBJECT ($ Object)))
(METHODS Class.CreateInstance Class.DefMethod Class.DefRSM Class.EM! Class.Edit Class.Edit!
Class.EditMethod Class.EditMethodObject Class.FetchMethod Class.FileIn Class.FileOut
Class.Fringe Class.Initialize Class.InstallEditSource Class.List Class.List!
Class.MakeEditSource Class.MakeFileSource Class.MakeFullEditSource Class.New
Class.NewClass Class.NewTemp Class.NewWithValues Class.Old Class.Rename
Class.RenameMethod Class.ReplaceSupers Class.SetName Class.Specialize
Class.SubClasses Class.Subclass Class.UnSetName DestroyedClass.DestroyClass
DestroyedClass.DestroyInstance DestroyedClass.SubClasses DestroyedObject.Destroy!
MetaClass.CreateClass MetaClass.DestroyInstance MetaClass.New
MetaClass.NewWithValues Method.ChangeClassName Method.ChangeName Method.EditMethod
Method.FileOut Method.MakeFileSource Method.NewInstance Method.OldInstance
Object.ChangeClass Object.Class Object.ClassName Object.Destroy Object.Destroy!
Object.DoMethod Object.Edit Object.FileOut Object.IVMissing Object.InstallEditSource
Object.InstallFileSource Object.Instantiate Object.List Object.List!
Object.MakeEditSource Object.MakeFileSource Object.MessageNotUnderstood
Object.NameString Object.NewInstance Object.NoObjectForMsg Object.OldInstance
Object.Prototype Object.Rename Object.SetName Object.UnSetName)
(* * Functions called by kernel classses)
(FNS * KERNELFNS)
(P (MOVD (QUOTE FullInstallMethod)
(QUOTE InstallMethod)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA METHCOM)
(NLAML)
(LAMA])
(* Copyright (c) 1982 by Xerox Corporation)
(* Metabraid of kernel classes in the system)
(RPAQQ KERNELCLASSES (AbstractClass Class DestroyedClass DestroyedObject MetaClass Method Object))
(DEFCLASSES AbstractClass Class DestroyedClass DestroyedObject MetaClass Method Object)
[DEFCLASS AbstractClass
(MetaClass MetaClass doc
(* * Abstract classes are placeholders in the inheritance network, which cannot themselves be instantiated.)
Edited: (* mjs: "30-JUN-82 16:41")
)
(Supers MetaClass)]
[DEFCLASS Class
(MetaClass MetaClass doc
(* * This is the default metaClass for all classes)
Edited: (* dgb: "19-NOV-82 16:55")
)
(Supers Object)]
[DEFCLASS DestroyedClass
(MetaClass AbstractClass Edited: (* dgb: "26-NOV-82 19:24")
doc (* Becomes the class for any destroyed class)
)
(Supers DestroyedObject)]
[DEFCLASS DestroyedObject
(MetaClass Class Edited: (* sm: "12-SEP-83 16:25"))
(Supers Object)]
[DEFCLASS MetaClass
(MetaClass MetaClass Edited: (* mjs: "30-JUN-82 16:38"))
(Supers Class)]
[DEFCLASS Method
(MetaClass Class doc (* Connects class to function implementing method, plus
properties)
Edited: (* dgb: "18-OCT-83 15:25")
)
(Supers Object)
(ClassVariables (ivProperties (doc args)
doc (* names of IVs which should be made properties of the
method)
))
(InstanceVariables (className NIL doc (* name of class in which this method appears)
)
(selector NIL doc (* An atom which is the selector for the method;)
)
(method NIL doc (* Atom name of unction which does the work other
properties of this IV are properties of the method)
)
(args NIL doc (* arguments of the method))
(doc NIL doc (* documentation of the method)))]
[DEFCLASS Object
(MetaClass Class doc (* Default behavior stored here)
Edited: (* edited: "13-NOV-83 16:30")
)
(Supers)]
(RPAQQ DumpMethodsInClass NIL)
(RPAQ DefaultObject ($ Object))
(RPAQ OBJECT ($ Object))
[METH Class CreateInstance NIL
(* Creates the data structure for an instance based on the class)]
[METH Class DefMethod (selector args exp)
(* Adds a method for selector to class. If args and expr are NIL, puts user into editor)]
[METH Class DefRSM (selector ruleSetName)
(* Installs a RuleSet as a method in the class. If ruleSetName is NIL, then DefRSM creates a
RuleSet, invokes the RuleSet editor, compiles the RuleSet, and installs it as a method in
the class. Also initializes the workspace instance variable.)]
[METH Class EM! NIL
(* provide a menu of all methods and allow editing of any, making method local if it is not
already)]
[METH Class Edit (commands)
(* Use Interlisp editor on source of object)]
[METH Class Edit! (commands)
(* Use Interlisp editor on source of class including inherited values)]
[METH Class EditMethod (selector commands)
(* Called by Class.EditMethod. Finds the function associated with selector in class, and calls
editor on it)]
[METH Class EditMethodObject (selector)
(* Edit the object corresponding to the method)]
[METH Class FetchMethod (selector)
(* Find the name of the function which implements this method in this class)]
[METH Class FileIn (fileSource)
(* Create an instance from expr, which was read from a file)]
[METH Class FileOut NIL
(* Print out a class definition to a file)]
[METH Class Fringe NIL
(* List classes which have now subclasses)]
[METH Class Initialize (self)
(* Run initial expression for IVs with active value defaults with ls = INITIAL or gfn =
AtCreation. In that case, makes a value which is the expression in GetFn. Other active
values are copied to instance by PutValue)]
[METH Class InstallEditSource NIL
(* make class conform to new edited description)]
[METH Class List (type name)
(* Fn to list local parts of a class.)]
[METH Class List! (type name verboseFlg)
(* Recursive version of List message. Omits things inherited from Object and Class unless
verboseFlg is T. Sets it to T for Class and Object)]
[METH Class MakeEditSource NIL
(* Make a source for editing the class)]
[METH Class MakeFileSource NIL
(* Make a source for editing the class)]
[METH Class MakeFullEditSource NIL
(* Make source including inherited values)]
[METH Class New (name)
(* Creates an instance of a particular class. The variable name if given is used to name the
object. Called by (← class New)
%. NewEntity creates the Entity record and UID)]
[METH Class NewClass (init1 init2 init3)
(* Just returns newly created class)]
[METH Class NewTemp NIL
(* Patch to make it work. Same as New)]
[METH Class NewWithValues (description)
(* * Creates a new instance, substituting values given explicitly in description Does not
initialize variables in the usual way.)
(method NewWithValues)]
[METH Class Old (fileSource)
(* Find an old object or create a new one with this uid)]
[METH Class Rename (newName environment)
(* Same as SetName. Classes can have only one name)]
[METH Class RenameMethod (oldSelector newSelector)
(* Rename selector, and change function name)]
[METH Class ReplaceSupers (supers)
(* replace supers of class by new supers list)]
[METH Class SetName (newClassName)
(* Change the newClassName of the class, forgetting old name. Change the names of all methods
which are of the form oldName.selector)]
[METH Class Specialize (newName)
(* Creates a class with name newName with self as its only super. If newName is NIL, then makes
up an unused name consisting of current name followed by integer)]
[METH Class SubClasses NIL
(* Returns a list of immediate subclasses currently known for this class.)]
[METH Class Subclass (super)
NIL]
[METH Class UnSetName (name)
(* Unname class)]
[METH DestroyedClass DestroyClass (classToDestroy)
(* Destroy the class specified by smashing its contents)]
[METH DestroyedClass DestroyInstance (class self)
(* smash back pointer to entity rec, the list of vars and var descriptions)]
[METH DestroyedClass SubClasses NIL
(* Non subclasses)]
[METH DestroyedObject Destroy! NIL
(* Do nothing. I am already destroyed)]
[METH MetaClass CreateClass (name supers)
(* Create the data object for a class, checking the inputs)]
[METH MetaClass DestroyInstance NIL
(* Destroy the class specified by smashing its contents)]
[METH MetaClass New (name supers)
(* * New method for MetaClass. Since MetaClass is its own metaClass, this needs to work
correctly whether the self is Class or MetaClass or a subClass of MetaClass. Work is done by
DefineClass in LOOPS.)]
[METH MetaClass NewWithValues (selector superFlg)
(* * Invoked when a selector is not found for an object during a message sending operation.
Attempts to do spelling correction on the selector. Causes an error if this fails.)
(method MessageNotUnderstood)]
[METH Method ChangeClassName (newClassName)
(* Change name of class -- called when className is changed)]
[METH Method ChangeName (oldMethName newMethName newSelector)
(* Change the name of the method and update the file)]
[METH Method EditMethod NIL
(* Edit the method defintion)]
[METH Method FileOut (file)
(* Print out filesource for methods)]
[METH Method MakeFileSource NIL
NIL]
[METH Method NewInstance NIL
NIL]
[METH Method OldInstance NIL
(* Adds Method to those known in class.)]
[METH Object ChangeClass (newClass)
(* Change object to be new class, keeping old IVs)]
[METH Object Class NIL
(* Returns class of object)]
[METH Object ClassName NIL
(* Returns className of class of object)
(method ClassName)]
[METH Object Destroy NIL
(* All the work is normally done by the class in DestroyInstance)]
[METH Object Destroy! NIL
(* Same as Object.Destroy except when self is a class)]
[METH Object DoMethod (selector class arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10)
(* Message form of DoMethod. Maximum of 10 arguments allowed)]
[METH Object Edit (commands)
(* Use Interlisp editor on source of object)]
[METH Object FileOut (file)
(* Print out file source on file so it can be reread)]
[METH Object IVMissing (varName createDescrFlg)
(* * Called from macro FetchIVDescr when there is no IV varName. If varName is an IV the class,
or user requests, then Object.IVMisssing adds IV to the instance. Returns the IVDescr as
needed for FetchIVDescr.)]
[METH Object InstallEditSource (editedDescription)
(* Blank instance and make it conform to new description)]
[METH Object InstallFileSource (fileSource)
(* Fill the given instance based on expression fileSource read from file, and name it)]
[METH Object Instantiate NIL
(* same as copyShallow)]
[METH Object List (type name)
(* For type= IVs, list the iv names in instance. For IVProps lists IV properties for name found
in instance. Otherwise lists properties inherited from class)]
[METH Object List! (type name verboseFlg)
(* * Recursive form of List for objects. Omits things inherited from Object unless verboseFlg
is T.)]
[METH Object MakeEditSource NIL
(* Get a lst showing all instance variables, values, and properties for Editing)]
[METH Object MakeFileSource (file)
(* create a list structure source to be dumped on a file)]
[METH Object MessageNotUnderstood (selector superFlg)
(* * Invoked when a selector is not found for an object during a message sending operation.
Attempts to do spelling correction on the selector. Causes an error if this fails.)]
[METH Object NameString NIL
(*)]
[METH Object NewInstance NIL
(* This allows initialization by the classes of objects themselves, rather than going to a
metaClass)]
[METH Object NoObjectForMsg (selector)
(* Called from FethMethodOrHelp when self is not an object with a class. A specialized response
to this can be tailored in a given LOOPS application by first reseting the global LISP
variable DefaultObject to point to an object. This default object will field NoObjectForMsg
messages from FetchMethodOrHelp. The method for NoObjectForMsg on DefaultObject should
return a default value, usually dependent on the selector. This version of NoObjectForMsg
just calls the user.)]
[METH Object OldInstance NIL
(* Allow fixup of object after reading in. Default is to do nothing)]
[METH Object Prototype NIL
(* * Find an instance of class on CV Prototype, or create an puts one there. Used to send
messages for effect to a prototype object)]
[METH Object Rename (newName environment)
(* Remove an old name, and give it new name)]
[METH Object SetName (name)
(* Call on NameEntity)]
[METH Object UnSetName (name)
(* Unname entity)]
(DEFINEQ
(Class.CreateInstance
[LAMBDA (self oldObject oldInstanceFlg) (* dgb: "13-OCT-83 22:06")
(* Creates the data structure for an instance based on the class. If oldObject is given, then just makes it
"blank". If oldInstanceFlg=T, then it does not mark the object as modified.)
(BlankInstance self oldObject oldInstanceFlg])
(Class.DefMethod
[LAMBDA (self selector args exp) (* dgb: "21-JUL-83 17:29")
(* Adds a method for selector to class.
If args and expr are NIL, puts user into editor)
(PROG NIL
(OR selector (SETQ selector (PromptRead "Type the selector for the new method: "))
(RETURN (PrintStatus "No method defined.")))
(RETURN (DefineMethod self selector args exp])
(Class.DefRSM
[LAMBDA (self selector ruleSetName) (* dgb: " 9-NOV-83 11:20")
(* Installs a RuleSet as a method in the class. If ruleSetName is NIL, then DefRSM creates a RuleSet, invokes the
RuleSet editor, compiles the RuleSet, and installs it as a method in the class. Also initializes the workspace
instance variable.)
(DefRSM self selector ruleSetName])
(Class.EM!
[LAMBDA (self) (* dgb: "24-Feb-84 10:31")
(* provide a menu of all methods and allow editing of
any, making method local if it is not already)
(PROG (selector)
(OR [SETQ selector (MENU (create MENU
ITEMS ←(SORT (← self List!(QUOTE Methods]
(RETURN))
(OR (FindLocalMethod self selector)
(PROGN (PrintStatus "Making " selector " local method of " self)
(← self MakeLocalMethod selector)))
(RETURN (← self EditMethod selector])
(Class.Edit
[LAMBDA (self commands) (* dgb: " 5-OCT-83 07:54")
(* Use Interlisp editor on source of class)
(PROG ((editSource (← self MakeEditSource)))
LP (COND
((NULL (EDITE editSource commands self (QUOTE CLASSES)
(QUOTE ChangeEditedClass)))
(SETQ commands NIL)
(GO LP)))
(RETURN (SETQ LASTCLASS (ClassName self])
(Class.Edit!
[LAMBDA (self commands) (* dgb: "31-OCT-83 09:11")
(* Use Interlisp editor on source of class including
inherited values)
(PROG ((editSource (← self MakeFullEditSource)))
LP (COND
((NULL (EDITE editSource commands self (QUOTE CLASSES)
(QUOTE ChangeEditedClass)))
(SETQ commands NIL)
(GO LP)))
(RETURN (SETQ LASTCLASS (ClassName self])
(Class.EditMethod
[LAMBDA (class selector commands) (* dgb: "29-Feb-84 08:50")
(* Called by Class.EditMethod.
Finds the function associated with selector in class,
and calls editor on it)
(PROG (index method selectors ruleSet)
TRYAGAIN
(COND
((NULL selector)
(COND
([NULL (SETQ selectors (SORT (← class List (QUOTE Selectors]
(* No selectors in class)
(RETURN NIL)))
(OR (SETQ selector (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ← selectors)))
(RETURN NIL))
(GO TRYAGAIN))
((SETQ method (FindLocalMethod class selector))
(GO OUT))
[(SETQ method (FetchMethod class selector))
(COND
((EQ (QUOTE YES)
(INTTY (CONCAT selector " is not a local method of " class
". Should I make it local for editing? ")
(QUOTE (YES NO))
"Type yes to edit locally defined copy of method"))
(SETQ method (← class MakeLocalMethod selector))
(GO OUT]
((SETQ selector (FIXSPELL selector 60 (← class List!(QUOTE Selectors))
T NIL NIL (QUOTE PICKONE)
T))
(GO TRYAGAIN))) (* If one falls through then nothing to be done)
(PrintStatus selector " is not a selector of " class)
(RETURN NIL)
OUT (RETURN (COND
([NEQ NotSetValue (SETQ ruleSet (GetMethod class selector (QUOTE RuleSet]
(* Here if the method is implemented by a RuleSet.)
(← (GetObjectRec ruleSet)
ER))
((NULL (GETDEF method))
(PrintStatus method " is not a known function."))
(T (PROG1 (APPLY (QUOTE EDITF)
(CONS method commands))
(← class CommentMethods (LIST selector)
T])
(Class.EditMethodObject
[LAMBDA (self selector) (* dgb: " 9-NOV-83 12:03")
(* Edit the object corresponding to the method)
(PROG NIL
(OR selector [SETQ selector (MENU (create MENU
ITEMS ←(SORT (← self List (QUOTE Methods]
(RETURN NIL))
(← (OR (GetMethodObj self selector)
(RETURN NIL))
Edit])
(Class.FetchMethod
[LAMBDA (self selector) (* dgb: "29-Feb-84 08:50")
(* Find the name of the function which implements this
method in this class)
(FetchMethod self selector])
(Class.FileIn
[LAMBDA (self fileSource) (* dgb: " 4-OCT-83 11:41")
(* Create an instance from expr, which was read from a
file)
(PROG ((obj (← self Old fileSource)))
(← obj InstallFileSource fileSource)
(RETURN (← obj OldInstance])
(Class.FileOut
[LAMBDA (self file) (* dgb: " 5-OCT-83 11:00")
(* Print out a class definition to a file)
(RESETVAR FIRSTCOL 16 (PROG ((source (← self MakeFileSource)))
(COND
((NULL source)
(HELPCHECK className
" is not defined as a class.
Type OK to ignore this class and go on.")
(RETURN NIL)))
(printout file "[DEFCLASS " .FONT LAMBDAFONT (CADR source)
.FONT DEFAULTFONT 3 .PPFTL (CDDR source)
"]" T T)))
self])
(Class.Fringe
[LAMBDA (self) (* dgb: "30-DEC-83 11:32")
(* List classes which have now subclasses)
(for C in (← self List!(QUOTE Subs)) when (NULL (← (GetClassRec C)
List
(QUOTE Subs)))
collect C])
(Class.Initialize
[LAMBDA (class self) (* dgb: "18-JAN-83 17:25")
(* Run initial expression for IVs with active value defaults with ls = INITIAL or gfn = AtCreation.
In that case, makes a value which is the expression in GetFn. Other active values are copied to instance by
PutValue)
(* Clean slow code (for varName value in (← self List (QUOTE IVs)) do (* * for all properties in IV, including NIL
for IV value, Fire initialization function which exist.) (for prop in (CONS NIL (← self List!
(QUOTE IVPROPS) varName)) when (NEQ NotSetValue (SETQ value (FireInit self varName (GetValueOnly self varName
prop)))) do (PutValueOnly self varName value prop))))
(FastClassInitialize class self)
self])
(Class.InstallEditSource
[LAMBDA (self editedDescription) (* dgb: " 5-OCT-83 09:26")
(* make class conform to new edited description)
(PROG ((className (ClassName self)))
(COND
((CheckClassSource editedDescription className)
(* Dont't install the class if there are errors.
Bounce back to editor)
(RINGBELLS 1)
(PROMPTPRINT className " not defined -- bad form " T)
(RETFROM (QUOTE EDITE)
NIL))
(T (InstallClassSource className editedDescription)
(PutClass self (EDITDATE NIL INITIALS)
(QUOTE Edited:))
(MARKASCHANGED (ClassName self)
(QUOTE CLASSES])
(Class.List
[LAMBDA (self type name) (* dgb: "29-Feb-84 15:43")
(* Fn to list local parts of a class.)
(SELECTQ (SETQ type (U-CASE type))
(IVS (APPEND (fetch (class localIVs) of self)))
(CVS (APPEND (fetch cvNames of self)))
((METHODS SELECTORS)
(\ListFromBlock (fetch selectors of self)))
(FUNCTIONS (\ListFromBlock (fetch methods of self)))
((SUPERS SUPERCLASSES)
(for x in (fetch localSupers of self) collect (ClassName x)))
((SUBS SUBCLASSES)
(for sub in (fetch subClasses of self) collect (ClassName sub)))
[(META METACLASS)
(CONS (ClassName (fetch metaClass of self))
(APPEND (fetch otherClassDescription of self]
(PROG [(descr (SELECTQ type
((IV IVPROPS NIL)
(FetchCIVDescr self name))
((CV CVPROPS)
(FetchCVDescr self name))
((CLASS)
(fetch otherClassDescription of self))
((METHOD)
(FetchMethodDescr self name))
(LoopsHelp type "not recognized part of class"]
(RETURN (SELECTQ type
((CLASS METHOD)
(ListPropNames descr))
(ListPropNames (CDR descr])
(Class.List!
[LAMBDA (class type name verboseFlg) (* dgb: "23-APR-83 16:18")
(* Recursive version of List message. Omits things inherited from Object and Class unless verboseFlg is T.
Sets it to T for Class and Object)
(COND
((FMEMB (ClassName class)
(QUOTE (Class Object)))
(SETQ verboseFlg T)))
(SETQ type (U-CASE type))
(SELECTQ type
((META METACLASS)
(← class List type))
((IVS NIL)
(APPEND (fetch ivNames of class)))
[(SUPERS SUPERCLASSES)
(PROG (name (nameList (CONS)))
(MapSupersForm (COND
((NOT (FMEMB (SETQ name (ClassName class))
(CAR nameList)))
(TCONC nameList name)))
class)
(RETURN (CDAR nameList]
((SUBS SUBCLASSES) (* List all subclasses of class)
(SubsTree class))
(PROG (attList) (* Here if need to recur to collect items.)
(MapSupersUnlessBadList [COND
(verboseFlg NIL)
(T (QUOTE (Object Class]
(for item in (← class List type name)
do (pushnew attList item))
class)
(RETURN (SELECTQ type
(CLASS (DREVERSE attList))
attList])
(Class.MakeEditSource
[LAMBDA (self) (* dgb: "30-OCT-83 11:29")
(* Make a source for editing the class)
(LIST (CONS (QUOTE MetaClass)
(GetSourceMeta self))
(CONS (QUOTE Supers)
(GetSourceSupers self))
(CONS (QUOTE ClassVariables)
(GetSourceCVs self))
(CONS (QUOTE InstanceVariables)
(GetSourceIVs self])
(Class.MakeFileSource
[LAMBDA (self file) (* dgb: " 7-DEC-83 09:21")
(* creates a list structure source of a class to be
dumped on a file)
(PROG (tail (cvs (GetSourceCVs self))
(ivs (GetSourceIVs self)))
[SETQ tail (NCONC [AND cvs (BQUOTE ((ClassVariables ,. cvs]
[AND ivs (BQUOTE ((InstanceVariables ,. ivs]
(AND DumpMethodsInClass (BQUOTE ((Methods ,. (GetSourceMethods self]
(RETURN (BQUOTE (DEFCLASS , (ClassName self)
(MetaClass ,. (GetSourceMeta self))
(Supers ,. (GetSourceSupers self))
,. tail])
(Class.MakeFullEditSource
[LAMBDA (self) (* dgb: "31-OCT-83 09:10")
(* Make source including inherited values)
(NCONC (← self MakeEditSource)
(LIST (CONS (QUOTE IVsInherited)
(GetSourceInhIVs self))
(CONS (QUOTE CVsInherited)
(GetSourceInhCVs self])
(Class.New
[LAMBDA (class name arg1 arg2 arg3 arg4 arg5) (* dgb: "24-DEC-83 11:54")
(* Creates an instance of a particular class.
The variable name if given is used to name the object.)
(← (← class CreateInstance)
NewInstance name arg1 arg2 arg3 arg4 arg5])
(Class.NewClass
[LAMBDA (self init1 init2 init3) (* dgb: "22-SEP-83 14:19")
(* Just returns newly created class)
self])
(Class.NewTemp
[LAMBDA (self) (* dgb: "27-OCT-83 10:49")
(* Patch to make it work. Same as New)
(← self New])
(Class.Old
[LAMBDA (self fileSource) (* dgb: "28-DEC-83 08:10")
(* Find an old object or create a new one with this uid)
(PROG (uid (names (CAR fileSource)))
[SETQ uid (COND
((STRINGP names)
(MKNAME names))
(T (MKNAME (CAR (LAST names]
(RETURN (NewObject self uid])
(Class.Rename
[LAMBDA (self newName environment) (* dgb: "12-JAN-83 14:19")
(* Same as SetName. Classes can have only one name)
[COND
((NULL newName)
(SETQ newName (HELPCHECK
"Can't rename a class without specifying name. Type
RETURN <newName>
to continue and rename class: "
self]
(← self SetName newName environment])
(Class.RenameMethod
[LAMBDA (self oldSelector newSelector) (* dgb: "18-MAR-83 16:30")
(* Rename selector, and change function name)
(RenameMethod (ClassName self)
oldSelector newSelector])
(Class.ReplaceSupers
[LAMBDA (self supers) (* dgb: "27-AUG-82 13:05")
(* replace supers of class by new supers list)
(OR (EQ (QUOTE NoUpdateRequired)
(InstallSupers self supers))
(ChangedClass self])
(Class.SetName
[LAMBDA (self newClassName) (* dgb: "18-JAN-84 11:35")
(* Change the newClassName of the class, forgetting old
name. Change the names of all methods which are of the
form oldName.selector)
(PROG (newFnName file fnFile namePair changeMsg (oldName (ClassName self)))
(COND
((EQ oldName newClassName)
(RETURN NIL)))
(DeleteObjectName self oldName)
(NameEntity self newClassName)
(replace className of self with newClassName)
(ChangedClass self)
(for selector in (← self List (QUOTE Selectors)) do (← ($! (MethName oldName selector))
ChangeClassName newClassName))
[COND
([SETQ file (CAR (WHEREIS oldName (QUOTE CLASSES]
(ADDTOFILE newClassName (QUOTE CLASSES)
file)
(DELFROMFILE oldName (QUOTE CLASSES)
file)
(SETQ changeMsg (CONCAT "Exit with OK to change
" oldName " to " newClassName ";
Exit with STOP to abort change."))
(EDITCALLERS oldName file (BQUOTE ((E (PROMPTPRINT , changeMsg))
TTY:(R , oldName , newClassName]
(RETURN self])
(Class.Specialize
[LAMBDA (self newName) (* mjs: "21-FEB-83 07:57")
(* Creates a class with name newName with self as its only super. If newName is NIL, then makes up an unused name
consisting of current name followed by integer)
[OR newName (PROG ((N 0)
(myName (ClassName self)))
LP (COND
([GetObjectRec (SETQ newName (PACK* myName (SETQ N (ADD1 N]
(GO LP]
(← (Class self)
New newName (LIST (ClassName self])
(Class.SubClasses
[LAMBDA (self) (* dgb: "28-SEP-82 14:34")
(* Returns a list of immediate subclasses currently
known for this class.)
(for c in (fetch subClasses of self) collect (OR (CAR (LISTP c))
c])
(Class.Subclass
[LAMBDA (self super) (* dgb: "23-APR-83 16:18")
(MapSupersForm (COND
((EQ class superClass)
(RETURN T)))
self
(superClass (GetClassRec super])
(Class.UnSetName
[LAMBDA (self name) (* dgb: "18-JAN-84 11:30")
(* Unname class)
(PROG (files)
(AND (DeleteObjectName self name)
(COND
(CurrentNameTable (Modified self T))
((SETQ files (WHEREIS name (QUOTE CLASSES)))
(DELFROMFILE name (QUOTE CLASSES)
files])
(DestroyedClass.DestroyClass
[LAMBDA (self classToDestroy) (* dgb: "26-DEC-83 15:22")
(* Destroy the class specified by smashing its contents)
(PROG (super entity (uid (fetch OBJUID of classToDestroy)))
(* First delete from knowledge of file system)
(DELDEF (ClassName classToDestroy)
(QUOTE CLASSES)) (* Remove from subClasses lists of each super.)
(for superName in (← classToDestroy List (QUOTE Supers)) when (SETQ super (GetClassRec
superName))
do (replace subClasses of super with (for sub in (fetch subClasses of super)
when (NEQ classToDestroy (COND
((LISTP sub)
(CAR sub))
(T sub)))
collect sub)))
(* smash back pointer to entity rec, the list of vars
and var descriptions)
(replace otherClassDescription of classToDestroy with NIL)
(replace OBJUID of classToDestroy with NIL)
(replace VARNAMES of classToDestroy with NIL)
(replace VARDESCRS of classToDestroy with NIL) (* It is a classToDestroy so smash its list of subs and
Supers)
(replace supers of classToDestroy with (LIST ($ DestroyedObject)))
(replace metaClass of classToDestroy with ($ DestroyedClass))
(DeleteObjectUID self)
(RETURN (QUOTE DestroyedClass])
(DestroyedClass.DestroyInstance
[LAMBDA (self class self) (* dgb: "26-DEC-83 15:23")
(* smash back pointer to entity rec, the list of vars
and var descriptions)
(replace class of self with ($ DestroyedObject))
(replace VARNAMES of self with NIL)
(replace VARDESCRS of self with NIL)
(replace otherIVs of self with NIL) (* now smash the entity record)
(replace OBJUID of self with NIL)
(DeleteObjectUID self])
(DestroyedClass.SubClasses
[LAMBDA (self) (* dgb: " 5-OCT-83 07:56")
(* Non subclasses)
NIL])
(DestroyedObject.Destroy!
[LAMBDA (self) (* dgb: "27-MAY-83 11:44")
(* Do nothing. I am already destroyed)
self])
(MetaClass.CreateClass
[LAMBDA (self name supers) (* dgb: "22-SEP-83 14:17")
(* Create the data object for a class, checking the
inputs)
(DefineClass name supers self])
(MetaClass.DestroyInstance
[LAMBDA (classToDestroy) (* dgb: "26-DEC-83 15:24")
(* Destroy the class specified by smashing its contents)
(PROG (super entity (uid (fetch OBJUID of classToDestroy)))
(* First delete from knowledge of file system)
(DELDEF (ClassName classToDestroy)
(QUOTE CLASSES)) (* Remove from subClasses lists of each super.)
(for superName in (← classToDestroy List (QUOTE Supers)) when (SETQ super (GetClassRec
superName))
do (replace subClasses of super with (for sub in (fetch subClasses of super)
when (NEQ classToDestroy (COND
((LISTP sub)
(CAR sub))
(T sub)))
collect sub)))
(* smash back pointer to entity rec, the list of vars
and var descriptions)
(replace otherClassDescription of classToDestroy with NIL)
(replace OBJUID of classToDestroy with NIL)
(replace VARNAMES of classToDestroy with NIL)
(replace VARDESCRS of classToDestroy with NIL) (* It is a classToDestroy so smash its list of subs and
Supers)
(replace supers of classToDestroy with (LIST ($ DestroyedObject)))
(replace metaClass of classToDestroy with ($ DestroyedClass))
(DeleteObjectUID classToDestroy)
(RETURN (QUOTE DestroyedClass])
(MetaClass.New
[LAMBDA (self name supers init1 init2 init3) (* dgb: "22-SEP-83 14:20")
(* * New method for MetaClass. Since MetaClass is its own metaClass, this needs to work correctly whether the self
is Class or MetaClass or a subClass of MetaClass. Work is done by DefineClass in LOOPS.)
(← (← self CreateClass name supers)
NewClass init1 init2 init3])
(Method.ChangeClassName
[LAMBDA (self newClassName) (* dgb: "17-JAN-84 15:54")
(* Change name of class -- called when className is
changed)
(PROG (newMethName (oldMethName (GetObjectName self))
(selector (@ selector)))
(SETQ newMethName (MethName newClassName selector))
(COND
((EQ oldMethName (@ method))
(COPYDEF oldMethName newMethName (QUOTE FNS))
(←@
method newMethName)))
(AddMethod (GetClassRec newClassName)
selector
(@ method))
(←@
className newClassName)
(← self ChangeName oldMethName newMethName)
(RETURN newMethName])
(Method.ChangeName
[LAMBDA (self oldMethName newMethName newSelector) (* dgb: "17-JAN-84 15:54")
(* Change the name of the method and update the file)
[PROG (file)
(← self UnSetName oldMethName)
(UNMARKASCHANGED oldMethName (QUOTE METHODS))
(UNMARKASCHANGED oldMethName (QUOTE FNS))
(UNMARKASCHANGED oldMethName (QUOTE INSTANCES))
(← self SetName newMethName)
(←@
selector newSelector)
(COND
([SETQ file (CAR (WHEREIS oldMethName (QUOTE METHODS]
(ADDTOFILE newMethName (QUOTE METHODS)
file)
(DELFROMFILE oldMethName (QUOTE METHODS)
file]
self])
(Method.EditMethod
[LAMBDA (self) (* dgb: "27-NOV-83 16:28")
(* Edit the method defintion)
(← ($! (@ className))
EditMethod
(@ selector])
(Method.FileOut
[LAMBDA (self file) (* dgb: "30-OCT-83 11:24")
(* Print out filesource for methods)
(PROG (pos (source (← self MakeFileSource)))
(printout file "[" .FONT DEFAULTFONT (CAR source)
,)
(SETQ pos (POSITION file))
(printout file (CADR source)
.FONT LAMBDAFONT ,, (CADDR source)
,
(CADDDR source)
.FONT DEFAULTFONT .TAB pos .PPVTL (CDDDDR source)
"]" T))
self])
(Method.MakeFileSource
[LAMBDA (self) (* dgb: " 7-DEC-83 10:24")
(* Returns form (Method <className> <selector> <method>
<args> <doc> . <otherProps>))
(PROG (className source (name (GetObjectName self)))
(AND (NEQ (SETQ className (← self ClassName))
(QUOTE Method))
(←@
method:,methodClass className))
(SETQ source (IVSource self))
(for iv in (QUOTE (className selector args doc)) do (SETQ source (DELASSOC iv source)))
[COND
([AND (EQ name (@ method))
(NULL (CDDR (FASSOC (QUOTE method)
source] (* Has default name and no properties)
(SETQ source (DELASSOC (QUOTE method)
source]
(RETURN (CONS (QUOTE METH)
(NCONC (LIST (@ className)
(@ selector)
(@ args)
(@ doc))
source])
(Method.NewInstance
[LAMBDA (self name arg1 arg2) (* dgb: "17-OCT-83 14:41")
(* Mark as changed for file system)
(←Super
self NewInstance name arg1 arg2)
(MARKASCHANGED (GetObjectName self)
(QUOTE METHODS)
T)
self])
(Method.OldInstance
[LAMBDA (self) (* dgb: " 7-DEC-83 10:17")
(* Adds Method to those known in class.)
(PROG ((class (GetClassRec cName)))
[OR class (AND (HELPCHECK (@ className)
"not a currently defined class.
Cannot add method to class. Type OK to create class and go on.")
(SETQ class (← ($ Class)
New
(@ className]
(AddMethod class (@ selector)
(@ method))
(AND (SETQ methClass ($! (@ method:,methodClass)))
(← self ChangeClass methClass])
(Object.ChangeClass
[LAMBDA (self newClass) (* edited: "13-NOV-83 17:14")
(* Change object to be new class, keeping old IVs)
(PROG [(source (IVSource self))
(classRec (COND
((type? class newClass)
newClass)
(T (OR (GetClassRec newClass)
(ERROR newClass " not a class for ChangeClass"]
(RETURN (FillInst source (BlankInstance newClass self])
(Object.Class
[LAMBDA (self) (* dgb: "27-AUG-82 13:07")
(* Returns class of object)
(Class self])
(Object.Destroy
[LAMBDA (self) (* dgb: "26-DEC-83 22:44")
(* All the work is normally done by the class in
DestroyInstance)
(← (Class self)
DestroyInstance self])
(Object.Destroy!
[LAMBDA (self) (* dgb: "28-APR-83 18:40")
(* Same as Object.Destroy except when self is a class)
(COND
((type? class self)
(DoMethod self (QUOTE Destroy!)
(%$ Class)))
(T (← self Destroy])
(Object.DoMethod
[LAMBDA (self selector class arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10)
(* dgb: "28-APR-83 18:40")
(* Message form of DoMethod. Maximum of 10 arguments
allowed)
(DoMethod self selector class arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10])
(Object.Edit
[LAMBDA (self commands) (* dgb: " 4-OCT-83 11:34")
(* Use Interlisp editor on source of object)
(EDITE (← self MakeEditSource)
commands self (QUOTE INSTANCES)
(QUOTE ChangeEditedInstance))
self])
(Object.FileOut
[LAMBDA (self file) (* dgb: "30-OCT-83 11:25")
(* Print out file source on file so it can be reread)
(PROG (pos (source (← self MakeFileSource)))
(* * Always bold the third thing in the source. Assume first is a function to install instance e.g. DEFINST and
second is a clasName The third is a critical identifier.)
(printout file "[" .FONT DEFAULTFONT (CAR source)
,)
(SETQ pos (POSITION file))
(printout file (CADR source)
.FONT LAMBDAFONT , .P2 (CADDR source)
.FONT DEFAULTFONT .TAB pos .PPVTL (CDDDR source)
"]" T))
self])
(Object.IVMissing
[LAMBDA (self varName createDescrFlg) (* dgb: " 9-DEC-82 16:25")
(* * Called from macro FetchIVDescr when there is no IV varName. If varName is an IV the class, or user requests,
then Object.IVMisssing adds IV to the instance. Returns the IVDescr as needed for FetchIVDescr.)
(PROG (fixedName)
[COND
[(type? instance self)
(COND
[(FIXP varName)
(RETURN (COND
(createDescrFlg (FetchNthDescr! self varName))
(T (OR (FetchNthDescr self varName)
(ERROR varName (CONCAT "out of bounds for " self]
[(FMEMB varName (← (Class self)
List!(QUOTE IVs)))
(COND
((NUMBERP (fetch otherIVs of self))
(ReadLeafObj self))
(T (FillIVs self (Class self)
(IVSource self)
T]
((SETQ fixedName (FIXSPELL varName 60 (← self List (QUOTE IVs))
T))
(SETQ varName fixedName))
(T (HELPCHECK varName " not an IV of " self "
Type OK to automatically add it.")
(AddIV self varName]
(T (ERROR varName (CONCAT " not an IV of " self]
(RETURN (GetIVDescr self varName createDescrFlg])
(Object.InstallEditSource
[LAMBDA (self editedDescription) (* dgb: " 4-OCT-83 11:33")
(* Blank instance and make it conform to new
description)
(BlankInstance (Class self)
self)
(FillInst editedDescription self])
(Object.InstallFileSource
[LAMBDA (self fileSource) (* dgb: "13-OCT-83 22:06")
(* Fill the given instance based on expression
fileSource read from file, and name it)
(NameObject self (LISTP (CAR fileSource)
NIL))
(FillInst (CDR fileSource)
self)
self])
(Object.Instantiate
[LAMBDA (self) (* dgb: "27-AUG-82 13:22")
(* same as copyShallow)
(← self CopyShallow])
(Object.List
[LAMBDA (self type name) (* dgb: " 9-DEC-82 16:26")
(* For type= IVs, list the iv names in instance. For IVProps lists IV properties for name found in instance.
Otherwise lists properties inherited from class)
(SELECTQ (U-CASE type)
[(IV IVPROPS NIL)
(ListPropNames (CDR (COND
((FIXP name)
(FetchNthDescr self name))
(T (GetIVDescr self name]
[IVS (APPEND (fetch iNames of self)
(for vl in (fetch otherIVs of self) collect (CAR vl]
(← (Class self)
List type name])
(Object.List!
[LAMBDA (self type name verboseFlg) (* mjs: "30-JUN-82 14:00")
(* * Recursive form of List for objects. Omits things inherited from Object unless verboseFlg is T.)
(SELECTQ (U-CASE type)
(IVS (← self List type name))
((IV IVPROPS NIL)
(UNION (← self List type name)
(← (Class self)
List! type name)))
(← (Class self)
List! type name verboseFlg])
(Object.MakeEditSource
[LAMBDA (self) (* dgb: "13-OCT-83 22:06")
(* Get a lst showing all instance variables, values, and
properties for Editing)
(IVSource self T])
(Object.MakeFileSource
[LAMBDA (self file) (* dgb: "13-OCT-83 22:06")
(* create a list structure source to be dumped on a
file)
(CONS (QUOTE DEFINST)
(CONS (ClassName self)
(CONS (GetObjectNames self)
(IVSource self T])
(Object.MessageNotUnderstood
[LAMBDA (self selector superFlg) (* mjs: " 7-OCT-82 09:26")
(* * Invoked when a selector is not found for an object during a message sending operation.
Attempts to do spelling correction on the selector. Causes an error if this fails.)
(* dgb: "25-FEB-82 12:42")
(COND
((FIXSPELL selector 60 (← (Class self)
List!(QUOTE METHODS)
NIL
(QUOTE verboseFlg))
T))
(T (ERROR (LIST (COND
(superFlg (QUOTE ←Super))
(T (QUOTE ←)))
self selector (QUOTE --))
"not understood"])
(Object.NameString
[LAMBDA (self) (* dgb: "17-FEB-83 11:10")
(*)
(PROG ((name (GetObjectName self)))
(RETURN (COND
(name (CONCAT "$" name))
(T (CONCAT (ClassName self)
"."
(CAR (LOC self))
"."
(CDR (LOC self])
(Object.NewInstance
[LAMBDA (self name arg1 arg2 arg3 arg4 arg5) (* dgb: "17-OCT-83 13:37")
(* This allows initialization by the classes of objects
themselves, rather than going to a metaClass)
(* Run initial expression for IVs with active value defaults with ls = INITIAL or gfn = AtCreation.
In that case, makes a value which is the expression in GetFn. Other active values are copied to instance by
PutValue)
(* Clean slow code (for varName value in (← self List (QUOTE IVs)) do (* * for all properties in IV, including NIL
for IV value, Fire initialization function which exist.) (for prop in (CONS NIL (← self List!
(QUOTE IVPROPS) varName)) when (NEQ NotSetValue (SETQ value (FireInit self varName (GetValueOnly self varName
prop)))) do (PutValueOnly self varName value prop))))
(AND name (← self SetName name))
(FastClassInitialize (Class self)
self)
self])
(Object.NoObjectForMsg
[LAMBDA (self selector) (* dgb: "21-SEP-82 23:33")
(* Called from FethMethodOrHelp when self is not an object with a class. A specialized response to this can be
tailored in a given LOOPS application by first reseting the global LISP variable DefaultObject to point to an
object. This default object will field NoObjectForMsg messages from FetchMethodOrHelp. The method for
NoObjectForMsg on DefaultObject should return a default value, usually dependent on the selector.
This version of NoObjectForMsg just calls the user.)
(COND
((type? instance self)
(replace CLASS of self with (%$ Object))
(ERROR self "had no class. Has been made an Object."))
(T (ERROR self (CONCAT "has no class."])
(Object.OldInstance
[LAMBDA (self) (* dgb: " 4-OCT-83 11:27")
(* Allow fixup of object after reading in.
Default is to do nothing)
self])
(Object.Prototype
[LAMBDA (self) (* dgb: " 9-Mar-84 01:04")
(* * Find an instance of class on CV Prototype, or create an puts one there. Used to send messages for effect to a
prototype object)
(PROG (proto)
[COND
((← self HasCV (QUOTE Prototype))
(SETQ proto (GetClassValue self (QUOTE Prototype]
[COND
((NEQ self (Class proto))
(PutCVHere self (QUOTE Prototype)
(SETQ proto (← self New]
(RETURN proto])
(Object.Rename
[LAMBDA (self newName) (* dgb: "24-DEC-83 12:43")
(* Remove an old name, and give it new name)
(PROG ((oldName (GetObjectName self)))
(COND
(oldName (← self UnSetName oldName)))
(← self SetName newName])
(Object.SetName
[LAMBDA (self name) (* dgb: "26-DEC-83 15:01")
(* Call on NameEntity)
[AND (NameEntity self name)
(COND
(CurrentNameTable (Modified self T))
(T (MARKASCHANGED name (QUOTE INSTANCES]
self])
(Object.UnSetName
[LAMBDA (self name) (* dgb: "18-JAN-84 11:31")
(* Unname entity)
(PROG (files)
(AND (DeleteObjectName self name)
(COND
(CurrentNameTable (Modified self T))
((SETQ files (WHEREIS self (QUOTE INSTANCES)))
(DELFROMFILE name (QUOTE INSTANCES)
files])
)
(* * Functions called by kernel classses)
(RPAQQ KERNELFNS (AddCIV AddCV AddIV AllSubClasses Class? ClassIVAddDelete ClassName CopyDeepDescr
CopyInstance CopyLoopsStruc DeleteIV DumpInstanceFacts GetLastDefaultValue
GetMethodObj GetValue IVSublis METHCOM MapIVs MapIVs! MessageNotUnderstood
MessageValue MethName NewWithValues PutValue SubsTree TypeInMethods WhoHas))
(DEFINEQ
(AddCIV
[LAMBDA (class varName defaultValue otherProps) (* dgb: "10-Feb-84 23:37")
(COND
([AND (NULL varName)
(NULL (SETQ varName (PromptRead "Please type the name of the new IV: "]
NIL)
((← class HasIV varName)
(PutClassIV class varName defaultValue))
(T [InstallInstanceVariables class (NCONC1 (GetSourceIVs class)
(CONS varName (CONS defaultValue otherProps]
(OR (FMEMB (QUOTE doc)
(← class List!(QUOTE IVPROPS)
varName))
(PutClassIV class varName (BQUOTE (* Undocumented InstanceVariable added by ,
(USERNAME NIL T)))
(QUOTE doc)))
varName])
(AddCV
[LAMBDA (class varName newValue) (* dgb: "21-SEP-83 11:09")
(* * Adds a class variable with given newValue. Returns NIL if variable already is in class -- though it does
change the value to newValue. Returns varName if variable was added)
(COND
([AND (NULL varName)
(NULL (SETQ varName (PromptRead "Please type name of new CV: "]
NIL)
((FMEMB varName (← class List (QUOTE CVs)))
(AND newValue (PutClassValueOnly class varName newValue))
NIL)
(T (InstallClassVariables class (NCONC1 (GetSourceCVs class)
(LIST varName newValue)))
(OR (← class HasCV varName (QUOTE doc))
(PutClassValue class varName (BQUOTE (* Undocumented CV added by ,
(USERNAME NIL T)))
(QUOTE doc)))
T])
(AddIV
[LAMBDA (self name value prop) (* dgb: "20-SEP-83 16:43")
(* Adds an IV to instance. If it is not in regular set,
puts it in assoc List on otherIVs)
(OR name (ERROR "A name must be given to add an IV"))
[COND
((← self HasIV name)
(PutValueOnly self name value prop))
(T (FillIVs self (Class self)
(NCONC1 (IVSource self)
(CONS name (COND
(prop (LIST NotSetValue prop value))
(T (LIST value]
value])
(AllSubClasses
[LAMBDA (class currentSubs) (* mjs: "15-JUN-82 09:45")
(* Gets all subclasses recursively, making sure there
are no duplicates. Called from Class.List!)
(for SUB in (fetch subClasses of class) do [OR (FMEMB (SETQ SUB (OR (CAR (LISTP SUB))
SUB))
currentSubs)
(SETQ currentSubs (AllSubClasses SUB
(CONS SUB
currentSubs]
finally (RETURN currentSubs])
(Class?
[LAMBDA (className object) (* dgb: "28-SEP-82 14:32")
(* * Returns Class of an object if found, and NIL otherwise.)
(← object InstOf! className])
(ClassIVAddDelete
[LAMBDA (self datum window) (* dgb: "22-JUN-82 11:18")
(* Function called from the inspector to add or delete
an instance variable from a class)
(PROG [name (varName (AND (← self InstOf (QUOTE InspectorClassIVs))
(%@ iv]
(SELECTQ [MENU (MenuGetOrCreate AddDeleteMenu (QUOTE (Add Delete]
[Add (SETQ name (INTTY "Type name to be added: " NIL NIL T))
(COND
(varName (PutValueOnly (%@ class)
varName NIL name))
(T (← (%@ class)
Add
(QUOTE IV)
name NIL]
[Delete (SETQ name (INTTY "Type name to be deleted: " NIL NIL T))
(COND
(varName (← (%@ class)
Delete
(QUOTE IVProp)
varName name))
(T (← (%@ class)
Delete
(QUOTE IV)
name]
NIL)
(INSPECTW.REDISPLAY window])
(ClassName
[LAMBDA (self) (* dgb: "29-Feb-84 15:43")
(* Returns className of class of object)
(COND
((type? class self)
(ffetch className of self))
((type? instance self)
(ffetch className of (ffetch class of self)))
(T (LoopsHelp self "has no class name"])
(CopyDeepDescr
[LAMBDA (descr) (* dgb: "11-NOV-82 02:29")
(* * Copies instances active vlues and lists, but bottoms out on anything else)
(SELECTQ (TYPENAME descr)
(instance (← descr CopyDeep))
[activeValue (create activeValue
localState ←(CopyDeepDescr (fetch localState of descr))
getFn ←(CopyDeepDescr (fetch getFn of descr))
putFn ←(CopyDeepDescr (fetch putFn of descr]
(LISTP (for val in descr collect (CopyDeepDescr val)))
descr])
(CopyInstance
[LAMBDA (oldInstance newInstance) (* dgb: "24-DEC-83 12:40")
(* make a new instance with the same contents as self,
or copy into an instance if given)
[SETQ newInstance (FillIVs newInstance (Class oldInstance)
(MAPCAR (IVSource oldInstance)
(FUNCTION APPEND] (* Copy IVSource down one layer of list structure.)
(COND
((AND (fetch OBJUID of oldInstance)
(NULL (fetch OBJUID of newInstance))) (* Old one not temporary, but new one has non OBJUID
yet)
(UID newInstance)))
newInstance])
(CopyLoopsStruc
[LAMBDA (desc) (* dgb: "11-NOV-82 02:29")
(SELECTQ (TYPENAME desc)
(instance (← desc CopyDeep))
[LISTP (CONS (CopyLoopsStruc (CAR desc))
(CopyLoopsStruc (CDR desc]
desc])
(DeleteIV
[LAMBDA (self varName propName) (* dgb: " 1-NOV-83 09:31")
(* Removes an IV from an Instance.
No longer shares IVName List with class.
Some programs which depend on IV may not work.)
(COND
((NULL (← self HasIV varName))
(ERROR varName "Not instance variable in this instance"))
[(NULL propName)
(AND (← (Class self)
HasIV varName)
(ERROR varName "in class. Cannot be deleted from instance"))
(replace otherIVs of self with (DELASSOC varName (fetch otherIVs of self]
(T (ObjRemProp (FetchIVDescr self varName)
propName)))
self])
(DumpInstanceFacts
[LAMBDA (instanceRec fileHandle) (* DECLARATIONS: (RECORD fileInstance
(cls . idesc)))
(* dgb: " 6-DEC-82 13:41")
(* * This prints an expression on the file which specifies the contents of an instance record.
Called by (← object DumpFacts))
(PROG ((filePos (GETFILEPTR fileHandle)))
(PRIN1 (QUOTE i)
fileHandle)
(PRINT (create fileInstance
cls ←(fetch class of instanceRec)
idesc ←(NCONC
[for name exceptions descr in (fetch iNames of instanceRec) as i
from 0 when [NEQ (QUOTE Any)
(SETQ exceptions (GetValueOnly instanceRec name
(QUOTE DontSave]
collect (SETQ descr (GetVarNth instanceRec i))
(* Collect a list of properties, omitting those on the list which is the value of the property DontSave.
Value should be on that list if the value is not to be dumped.)
(CONS name (COND
((EQ NotSetValue exceptions)
descr)
((NULL (CDR descr))
(COND
((FMEMB (QUOTE Value)
exceptions)
NIL)
(T descr)))
(T (CONS (COND
((FMEMB (QUOTE Value)
exceptions)
(* value is to be omitted)
NotSetValue)
(T (CAR descr)))
(for pair on (CDR descr) by (CDDR pair)
when (NOT (FMEMB (CAR pair)
exceptions))
join (LIST (CAR pair)
(CADR pair]
(fetch otherIVs of instanceRec)))
fileHandle)
(RETURN filePos])
(GetLastDefaultValue
[LAMBDA NIL (* mjs: " 2-AUG-82 17:03")
(* * See FetchMethodOrHelp and Object.NoObjectForMsg. This hack allows users to pass back values for the
application of methods to objects not known at the time of a SEND.)
LastDefaultValue])
(GetMethodObj
[LAMBDA (class selector createIfNotFoundFlg) (* dgb: "17-OCT-83 13:35")
(* Method objects have names of form className.selector.
If not found, and createIfNotFoundFlg=T then create a
new one, filling in className and selector)
(PROG (obj (methName (PACK* (ClassName class)
(QUOTE %.)
selector)))
(RETURN (OR (GetObjectRec methName)
(AND createIfNotFoundFlg (PROGN (SETQ obj (← ($ Method)
New methName))
(←@
\obj:className
(ClassName class))
(←@
\obj:selector selector)
obj])
(GetValue
[LAMBDA (self varName prop) (* dgb: "21-OCT-83 06:54")
(* Used to return the value of an "instance variable" for an object. Calls general Get function for non standard
objects -
GetValue activates getFn if the value is an ActiveValue.)
(COND
[(type? instance self)
(PROG (value (descr (FetchIVDescr self varName)))
[COND
([OR (NULL descr)
(NotSetValue (SETQ value (ObjGetProp descr prop]
(* no value found in the instance or in locally in the
class if self is a class)
(SETQ value (FetchCIVValueOnly (ffetch class of self)
varName prop]
(RETURN (ObjRealValue self varName value prop]
(T (GetIt self varName prop (QUOTE IV])
(IVSublis
[LAMBDA (value alist) (* dgb: "18-NOV-82 01:06")
(* Copy value putting in substitutions for items on
alist. Called from Object.Sublis)
(PROG ((pair (FASSOC value alist)))
(RETURN (COND
(pair [COND
((NULL (CDR pair))
(COND
((type? instance value) (* This will fix up alist as a side effect)
(← value Sublis alist))
(T (RPLACD pair (LIST (IVSublis value alist]
(CADR pair))
[(LISTP value)
(COND
((EQ (QUOTE *)
(CAR value)) (* A comment)
(APPEND value))
(T (CONS (IVSublis (CAR value)
alist)
(IVSublis (CDR value)
alist]
((type? activeValue value)
(create activeValue
localState ←(IVSublis (fetch localState of value)
alist)
getFn ←(IVSublis (fetch getFn of value)
alist)
putFn ←(IVSublis (fetch putFn of value)
alist)))
(T value])
(METHCOM
[NLAMBDA MS (* dgb: "21-OCT-83 07:39")
(* Computes file package commands for METHODS)
(LIST (CONS (QUOTE INSTANCES)
MS)
(CONS (QUOTE FNS)
(for M in MS when (GETD M) collect M])
(MapIVs
[LAMBDA (self mapfn) (* dgb: "24-NOV-82 15:22")
(* maps through self applying
(mapfn self ivName propName) for all IVnames and all
props, including NIL for the value itself)
(for ivName in (← self List (QUOTE IVs)) do (for propName in (CONS NIL (← self List (QUOTE
IVPROPS)
ivName))
do (mapfn self ivName propName])
(MapIVs!
[LAMBDA (self mapfn) (* dgb: "24-NOV-82 15:23")
(* maps through self applying (mapfn self ivName propName) for all IVnames and all props including inherited ones
and NIL for the value itself)
(for ivName in (← self List!(QUOTE IVs)) do (for propName in (CONS NIL (← self List!(QUOTE
IVPROPS)
ivName))
do (APPLY* mapfn self ivName propName])
(MessageNotUnderstood
[LAMBDA (self selector superFlg) (* mjs: "30-JUN-82 14:04")
(* * Invoked when a selector is not found for an object during a message sending operation.
Attempts to do spelling correction on the selector. Causes an error if this fails.)
(* dgb: "25-FEB-82 12:42")
(COND
((FIXSPELL selector 60 (← self List!(QUOTE METHODS)
NIL
(QUOTE verboseFlg))
T))
(T (ERROR (LIST (COND
(superFlg (QUOTE ←Super))
(T (QUOTE ←)))
self selector (QUOTE --))
"not understood"])
(MessageValue
[LAMBDA (value) (* dgb: " 6-JUN-83 17:56")
(* Return from Object.MessageNotUnderstood so that value
is returned)
(SETQ LastDefaultValue value)
(RETFROM (QUOTE Object.MessageNotUnderstood)
(QUOTE ReturnDefaultValue])
(MethName
[LAMBDA (classOrName selector) (* dgb: "13-OCT-83 22:06")
(* Make name of form className.selector)
(PACK* (COND
((type? class classOrName)
(ClassName classOrName))
(T classOrName))
"." selector])
(NewWithValues
[LAMBDA (class description) (* dgb: "24-DEC-83 12:37")
(* * Creates a new instance, substituting values given explicitly in description Does not initialize variables in
the usual way.)
(FillIVs NIL class description])
(PutValue
[LAMBDA (self varName newValue propName) (* dgb: "13-OCT-83 22:06")
(* * Puts newValue as value for varName in self on propname. Activates putFn if current value is an activeValue.)
(COND
[(type? instance self)
(PROG (value (descr (FetchIVDescr! self varName)))
[COND
((EQ NotSetValue (SETQ value (ObjGetProp descr propName)))
(* Value not set locally. Get value from class.)
(SETQ value (ObjGetProp (FetchCIVDescr (Class self)
varName)
propName))
(COND
((type? activeValue value)
(COND
((FMEMB (fetch getFn of value)
ImplicitReplaceFns)
(* * Special case. One of FirstFetch AtCreation. Just puts the new value into the instance)
(RETURN (ObjPutProp descr propName newValue)))
((NEQ (QUOTE SHARED)
(fetch localState of value)) (* Here to copy an active value if it was inherited
unchanged, and is now being changed.)
(Modified self T)
(SETQ value (CopyAV value))
(ObjPutProp descr propName value]
(RETURN (ObjSetValue self varName newValue descr value propName]
(T (PutIt self varName newValue propName (QUOTE IV])
(SubsTree
[LAMBDA (class currentList) (* dgb: " 1-OCT-82 09:44")
(* Compute the SubsTree starting at class given, adding
elements to currentList)
[for cl in (← (GetClassRec class)
List
(QUOTE Subs))
do (COND
((NOT (FMEMB cl currentList))
(SubsTree cl (SETQ currentList (NCONC1 currentList cl]
currentList])
(TypeInMethods
[LAMBDA (com name type) (* dgb: "29-DEC-83 12:42")
(PROG [(methList (COND
((EQ (CADR com)
(QUOTE *))
(EVAL (CADDR com)))
(T (CDR com]
(RETURN (SELECTQ type
[(METHODS INSTANCES)
(SELECTQ name
((NIL T)
methList)
(COND
((LITATOM name)
(FMEMB name methList))
(T (INTERSECTION name methList]
[FNS (SELECTQ name
(NIL (for M in methList when (EQ M (@($! M)
method))
collect M))
(T T)
(COND
[(LITATOM name)
(AND (FMEMB name methList)
(EQ name (@($! name)
method]
(T (for M in methList
when (AND (FMEMB M name)
(EQ M (@($! M)
method)))
collect M]
NIL])
(WhoHas
[LAMBDA (name type files editFlg) (* dgb: "30-DEC-83 14:35")
[COND
((NULL files)
(SETQ files FILELST))
((LITATOM files (SETQ files (LIST files]
(for f in files join (for cl in (FILECOMSLST f (QUOTE CLASSES))
collect [COND
(editFlg (COND
((FMEMB type (QUOTE (NIL Method METHOD)))
(← ($! cl)
EditMethod name))
(T (← ($! cl)
Edit]
cl
when (SELECTQ type
((NIL Method METHOD)
(FindLocalMethod ($! cl)
name))
(IV (← self HasIV name))
(CV (← self HasCV name))
NIL])
)
(MOVD (QUOTE FullInstallMethod)
(QUOTE InstallMethod))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA METHCOM)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS LOOPSKERNEL COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14299 53756 (Class.CreateInstance 14309 . 14680) (Class.DefMethod 14682 . 15180) (
Class.DefRSM 15182 . 15609) (Class.EM! 15611 . 16249) (Class.Edit 16251 . 16721) (Class.Edit! 16723 .
17246) (Class.EditMethod 17248 . 19221) (Class.EditMethodObject 19223 . 19683) (Class.FetchMethod
19685 . 19991) (Class.FileIn 19993 . 20373) (Class.FileOut 20375 . 20980) (Class.Fringe 20982 . 21351)
(Class.Initialize 21353 . 22177) (Class.InstallEditSource 22179 . 22995) (Class.List 22997 . 24380) (
Class.List! 24382 . 25700) (Class.MakeEditSource 25702 . 26145) (Class.MakeFileSource 26147 . 26849) (
Class.MakeFullEditSource 26851 . 27248) (Class.New 27250 . 27622) (Class.NewClass 27624 . 27848) (
Class.NewTemp 27850 . 28082) (Class.Old 28084 . 28497) (Class.Rename 28499 . 28938) (
Class.RenameMethod 28940 . 29231) (Class.ReplaceSupers 29233 . 29554) (Class.SetName 29556 . 30832) (
Class.Specialize 30834 . 31352) (Class.SubClasses 31354 . 31728) (Class.Subclass 31730 . 31966) (
Class.UnSetName 31968 . 32377) (DestroyedClass.DestroyClass 32379 . 34124) (
DestroyedClass.DestroyInstance 34126 . 34768) (DestroyedClass.SubClasses 34770 . 34986) (
DestroyedObject.Destroy! 34988 . 35224) (MetaClass.CreateClass 35226 . 35522) (
MetaClass.DestroyInstance 35524 . 37277) (MetaClass.New 37279 . 37693) (Method.ChangeClassName 37695
. 38465) (Method.ChangeName 38467 . 39206) (Method.EditMethod 39208 . 39482) (Method.FileOut 39484 .
40051) (Method.MakeFileSource 40053 . 41040) (Method.NewInstance 41042 . 41389) (Method.OldInstance
41391 . 42027) (Object.ChangeClass 42029 . 42532) (Object.Class 42534 . 42754) (Object.Destroy 42756
. 43065) (Object.Destroy! 43067 . 43416) (Object.DoMethod 43418 . 43844) (Object.Edit 43846 . 44180)
(Object.FileOut 44182 . 44933) (Object.IVMissing 44935 . 46099) (Object.InstallEditSource 46101 .
46444) (Object.InstallFileSource 46446 . 46849) (Object.Instantiate 46851 . 47081) (Object.List 47083
. 47722) (Object.List! 47724 . 48177) (Object.MakeEditSource 48179 . 48482) (Object.MakeFileSource
48484 . 48851) (Object.MessageNotUnderstood 48853 . 49517) (Object.NameString 49519 . 49913) (
Object.NewInstance 49915 . 50973) (Object.NoObjectForMsg 50975 . 51816) (Object.OldInstance 51818 .
52094) (Object.Prototype 52096 . 52639) (Object.Rename 52641 . 52999) (Object.SetName 53001 . 53337) (
Object.UnSetName 53339 . 53754)) (54151 71958 (AddCIV 54161 . 54827) (AddCV 54829 . 55659) (AddIV
55661 . 56232) (AllSubClasses 56234 . 56816) (Class? 56818 . 57034) (ClassIVAddDelete 57036 . 57973) (
ClassName 57975 . 58407) (CopyDeepDescr 58409 . 59017) (CopyInstance 59019 . 59733) (CopyLoopsStruc
59735 . 60010) (DeleteIV 60012 . 60747) (DumpInstanceFacts 60749 . 62535) (GetLastDefaultValue 62537
. 62874) (GetMethodObj 62876 . 63584) (GetValue 63586 . 64437) (IVSublis 64439 . 65588) (METHCOM
65590 . 65924) (MapIVs 65926 . 66462) (MapIVs! 66464 . 66952) (MessageNotUnderstood 66954 . 67599) (
MessageValue 67601 . 67978) (MethName 67980 . 68320) (NewWithValues 68322 . 68624) (PutValue 68626 .
69933) (SubsTree 69935 . 70415) (TypeInMethods 70417 . 71275) (WhoHas 71277 . 71956)))))
STOP