(FILECREATED "22-SEP-83 15:21:20" {INDIGO}<LOOPS>SOURCES>LOOPSKERNEL.;22 96123
changes to: (FNS MetaClass.CreateClass Class.NewClass Class.CreateInstance MetaClass.New
Class.New Object.NewInstance)
(CLASSES MetaClass Class)
previous date: "21-SEP-83 12:40:51" {INDIGO}<LOOPS>SOURCES>LOOPSKERNEL.;21)
(PRETTYCOMPRINT LOOPSKERNELCOMS)
(RPAQQ LOOPSKERNELCOMS [(* Copyright (c)
1982 by Xerox Corporation)
(* Metabraid of kernel classes in the system)
(CLASSES * KERNELCLASSES)
(VARS (DefaultObject ($ Object))
(OBJECT ($ Object)))
(* * Functions called by kernel classses)
(FNS * KERNELFNS)
(* Patch to allow the inspector to take a region to put the window in)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA NILL])
(* Copyright (c) 1982 by Xerox Corporation)
(* Metabraid of kernel classes in the system)
(RPAQQ KERNELCLASSES (AbstractClass Class DestroyedClass DestroyedObject MetaClass Object))
(DEFCLASSES AbstractClass Class DestroyedClass DestroyedObject MetaClass 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)
(ClassVariables)
(InstanceVariables)
(Methods (New AbstractClass.New args NIL doc (* Stop abstract class from being instantiated)
))]
[DEFCLASS Class
(MetaClass MetaClass doc
(* * This is the default metaClass for all classes)
Edited: (* dgb: "19-NOV-82 16:55")
)
(Supers Object)
(ClassVariables)
(InstanceVariables)
(Methods (Add Class.Add args (type name value prop)
doc (* Type is one of IV IVPROP CV CVPROP META METHOD.
Adds the specified type to the class)
)
(CommentMethods Class.CommentMethods args (selectors useDefaultComment)
doc
(* Add args as property of method. Insert comment in class from function. Ask for comment if none available, and
if useDefaultComment is NIL, else insert DefaultComment which is initially bound to (*))
)
(Copy Class.Copy args (name)
doc
(* * Create a new class that is a copy of some existing class. Copies the variables and RuleSets.
self is the class being copied.)
)
(CopyCV Class.CopyCV args (cvName toClass)
doc (* Copy the cvName and properties to toClass.)
)
(CopyIV Class.CopyIV args (ivName toClass)
doc (* Copy the ivName and properties to toClass.)
)
(CopyMethod Class.CopyMethod args (selector newClass newSelector)
doc (* Copy method from self to newClass.
newSelector defaults to selector)
)
(DefMethod Class.DefMethod args (selector args exp)
doc (* Adds a method for selector to class.
If args and expr are NIL, puts user into editor)
)
(Delete Class.Delete args (type name prop)
doc (* Deletes the specified type from class.
type is one of IV IVPROP CV CVPROP META METHOD)
)
(Destroy Class.Destroy args NIL doc (* Destroys (deletes) a class by putting NIL as
localRecord of entity. Undoable.))
(Destroy! Class.Destroy! args NIL doc
(* * Recursive version of Destroy. Destroys class and its subclasses.)
)
(DestroyInstance Class.DestroyInstance args (self)
doc (* smash back pointer to entity rec, the list of vars
and var descriptions)
)
(DisplaySubClasses Class.DisplaySubClasses Doc
(* Displays the subclasses in a tree.)
args
(otherClassNames window/title)
doc (* Display subclasses of class)
)
(DumpFacts DumpClassFacts args (fileHandle)
doc
(* * Invoked when dumping a class onto a kb. Called by (← class DumpFacts))
)
(EM! Class.EM! args NIL doc (* provide a menu of all methods and allow editing of
any, making method local if it is not already)
)
(Edit Class.Edit args (commands)
doc (* Calls the Interlisp Editor on the source for class)
)
(EditMethod EditMethod args (selector commands)
doc (* Called by Class.EditMethod.
Finds the function associated with selector in class,
and calls editor on it)
)
(FetchMethod Class.FetchMethod args (selector)
doc (* Find the name of the function which implements this
method in this class)
)
(HasCV Class.HasCV args (CVName prop)
doc (* Tests if class has the specified class variable)
)
(HasIV Class.HasIV args (IVName prop)
doc (* Tests if class has the specified instance variable)
)
(HasIV! Class.HasIV! args (IVName prop)
doc (* Tests if class has the specified instance variable)
)
(Initialize Class.Initialize doc
(* 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)
args
(self))
(InspectFetch Class.InspectFetch doc (* fetch summaries of class for the inspector --
different for Metaclass Supers etc)
args
(datum property))
(InspectPropCommand Class.InspectPropCommand doc
(* No changes allowed on properties)
args NIL)
(InspectProperties Class.InspectProperties doc
(* (part of Class Inspector))
args
(datum))
(InspectStore Class.InspectStore args (datum property newValue window)
doc (* Can't change the class from the inspector using the
summary)
)
(InspectTitle Class.InspectTitle args (datum)
doc (* Return a string for a title in inspect window)
)
(InspectTitleMenu Class.InspectTitleMenu args NIL doc
(* Menu for commands for the inspector))
(InspectValueCommand Class.InspectValueCommand args (datum property value window)
doc (* What to do when a class value is selected)
)
(List Class.List args (type name)
doc (* Fn to list local parts of a class.)
)
(List! Class.List! args (type name verboseFlg)
doc
(* Recursive version of List message. Omits things inherited from Object and Class unless verboseFlg is T.
Sets it to T for Class and Object)
)
(MakeLocalMethod Class.MakeLocalMethod args (selector dontBitchFlg)
doc (* make an inherited method be local)
)
(MethodDoc Class.MethodDoc args (selector)
doc (* Show documentation for method in PPDefault window)
)
(MoveMethod Class.MoveMethod args (newClass selector)
doc (* Move method specified by selector from this class to
newClass)
)
(New Class.New args (name)
doc
(* 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)
)
(NewTemp Class.NewTemp args (name)
doc
(* Creates an instance of a particular class. Called by (← class NewTemp). initValues are just passed on to
Initialize in order. No Entity record and UID are created)
)
(NewWithValues NewWithValues args (description)
doc
(* * Creates a new instance, substituting values given explicitly in description Does not initialize variables in
the usual way.)
)
(OnFile Class.OnFile args (file)
doc (* See if class is on given file.
Returns file if none given)
)
(PP Class.PP args (file)
doc (* Prettyprint the class.)
)
(PP! Class.PP! args (file)
doc
(* * Method for prettyPrinting self at all levels.)
)
(PPM Class.PPMethod args (selector)
doc (* Prettyprint the function which implements selector in
this class. Prettyprint RuleSet if method)
)
(PPMethod Class.PPMethod args (selector)
doc (* Prettyprint the function which implements selector in
this class. Prettyprint RuleSet if method)
)
(PPV! Class.PPV! args (file)
doc
(* * Method for prettyPrinting a self at all levels.)
)
(PrintSummary Class.PrintSummary args (file)
doc (* Print a summary of elements of class)
)
(Put Class.Add args (type name value prop)
doc (* Type is one of IV IVPROP CV CVPROP META METHOD.
Adds the specified type to the class)
)
(Rename Class.Rename args (newName environment)
doc (* Same as SetName. Classes can have only one name)
)
(RenameMethod Class.RenameMethod args (oldSelector newSelector)
doc (* Rename selector, and change function name)
)
(ReplaceSupers Class.ReplaceSupers args (supers)
doc (* replace supers of class by new supers list)
)
(SetName Class.SetName args (name)
doc (* Change the name of the class, forgetting old name.
Change the names of all methods which are of the form
oldName.selector)
)
(Specialize Class.Specialize args (newName)
doc
(* 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)
)
(SubClasses Class.SubClasses args NIL doc (* Returns a list of immediate subclasses currently
known for this class.))
(Subclass Class.Subclass args (super))
(TitleCommand Class.TitleCommand args (datum window)
doc (* Do commands in title field)
)
(DestroyClass Class.DestroyClass args (classToDestroy)
doc (* Destroy the class specified by smashing its contents)
)
(AddIV AddCIV args (varName defaultValue otherProps))
(AddCV AddCV args (varName newValue)
doc
(* * 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)
)
(DefRSM DefRSM args (selector ruleSetName)
doc
(* 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.)
)
(NewClass Class.NewClass args (init1 init2 init3)
doc (* Just returns newly created class)
)
(CreateInstance Class.CreateInstance args NIL doc
(* Creates the data structure for an instance based on
the class)))]
[DEFCLASS DestroyedClass
(MetaClass AbstractClass Edited: (* dgb: "26-NOV-82 19:24")
doc (* Becomes the class for any destroyed class)
)
(Supers DestroyedObject)
(ClassVariables)
(InstanceVariables)
(Methods (PrintOn DestroyedClass.PrintOn doc (* Print out DestroyedClass))
(DestroyInstance DestroyedClass.DestroyInstance args (class self)
doc (* smash back pointer to entity rec, the list of vars
and var descriptions)
)
(DestroyClass DestroyedClass.DestroyClass args (classToDestroy)
doc (* Destroy the class specified by smashing its contents)
))]
[DEFCLASS DestroyedObject
(MetaClass Class Edited: (* sm: "12-SEP-83 16:25"))
(Supers Object)
(ClassVariables)
(InstanceVariables)
(Methods (PP DestroyedObject.PP)
(PrintOn DestroyedObject.PrintOn)
(Destroy! NILL doc NIL))]
[DEFCLASS MetaClass
(MetaClass MetaClass Edited: (* mjs: "30-JUN-82 16:38"))
(Supers Class)
(ClassVariables)
(InstanceVariables)
(Methods (DestroyInstance MetaClass.DestroyInstance doc
(* Destroy the class specified by smashing its contents)
args NIL)
(New MetaClass.New args (name supers)
doc
(* * 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.)
)
(NewTemp MessageNotUnderstood args (selector superFlg)
doc
(* * 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.)
)
(NewWithValues MessageNotUnderstood args (selector superFlg)
doc
(* * 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.)
)
(CreateClass MetaClass.CreateClass args (name supers)
doc (* Create the data object for a class, checking the
inputs)
))]
[DEFCLASS Object
(MetaClass Class Edited: (* mjs: "15-JUL-82 11:27"))
(Supers)
(ClassVariables)
(InstanceVariables)
(Methods (AddIV AddIV args (name value prop)
doc (* Adds an IV to instance. If it is not in regular set,
puts it in assoc List on otherIVs)
)
(AssocKB Object.AssocKB args (newKBName)
doc (* Change assocKB of this object to newKBName)
)
(At GetValue doc
(* 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.)
args
(varName prop))
(BreakIt Object.BreakIt args (varName propName type brkOnGetAlsoFlg)
doc
(* makes an active value which will cause break when the on this value is to be changed. If brkOnGetAlsoFlg=T then
will also break when value is fetched. Message on Object)
)
(Class Object.Class doc (* Returns class of object)
args NIL)
(ClassName ClassName doc (* Returns className of class of object)
args NIL)
(CopyDeep Object.CopyDeep args (KBC)
doc
(* * Copies the unit, sharing the iName list, copying instances, activeValues and lists)
)
(CopyShallow CopyInstance doc (* make a new instance with the same contents as self,
or copy into an instance if given)
args
(newInstance))
(DeleteIV DeleteIV doc (* Removes an IV from an Instance.
No longer shares IVName List with class.
Some programs which depend on IV may not work.)
args
(varName propName))
(Destroy Object.Destroy doc (* marks object as deleted by putting NIL as localRecord
of entity and saving UID if it was an old entity.)
args NIL)
(Destroy! Object.Destroy! doc (* Same as Object.Destroy except when self is a class)
args NIL)
(DoMethod Object.DoMethod args
(selector class arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10)
doc (* Message form of DoMethod. Maximum of 10 arguments
allowed)
)
(DumpFacts DumpInstanceFacts args (fileHandle)
doc (* dgb: " 6-DEC-82 13:41")
)
(Edit Object.Edit args (commands)
doc (* Use Interlisp editor on source of object)
)
(HasIV Object.HasIV args (ivName prop)
doc (* Check to see if IV is on self.
If so, return T)
)
(IVMissing Object.IVMissing args (varName createDescrFlg)
doc
(* * 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.)
)
(Inspect Object.Inspect doc (* Inspect the object as class or instance, using
INSPECTLOC as a region for the inspect window, if it is
given)
args
(INSPECTLOC))
(InspectFetch Object.InspectFetch doc (* part of Object Inspector)
args
(datum property window))
(InspectPropCommand Object.InspectPropCommand doc
(* Part of object inspector)
args
(datum property window))
(InspectProperties Object.InspectProperties doc
(* List the set of IVs for an instance)
args
(datum))
(InspectStore Object.InspectStore doc (* Store a value in the instance)
args
(datum property newValue window))
(InspectTitle Object.InspectTitle doc (* part of Object Inspector)
args
(datum))
(InspectTitleMenu Object.InspectTitleMenu doc (* Put a menu for the Instance Title Command)
args NIL)
(InspectValueCommand Object.InspectValueCommand doc
(* part of Object Inspector)
args
(datum property value window))
(InstOf Object.InstOf doc (* test if self is an instance of class)
args
(class))
(InstOf! Object.InstOf! doc
(* * Recursive version of InstOf.)
args
(class))
(Instantiate Object.Instantiate args NIL doc (* same as copyShallow))
(List Object.List args (type name)
doc
(* 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)
)
(List! Object.List! args (type name verboseFlg)
doc
(* * Recursive form of List for objects. Omits things inherited from Object unless verboseFlg is T.)
)
(MessageNotUnderstood Object.MessageNotUnderstood doc
(* * 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.)
args
(selector superFlg))
(NameString Object.NameString args NIL doc (*))
(NoObjectForMsg Object.NoObjectForMsg args (selector)
doc
(* 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.)
)
(PP PrettyPrintInstance args (file)
doc (* PrettyPrint an instance definition on file.)
)
(PP! Object.PP! doc
(* * Method for prettyPrinting a non-class object at all levels)
args
(file))
(PPV! Object.PPV! args (file)
doc
(* * Method for prettyPrinting a non-class object at all levels.)
)
(PrintOn Object.PrintOn doc
(* * This is the default printing function for object. It distinguishes between temporary object, named objects,
and others)
args
(file))
(Put PutValue doc
(* * Puts newValue as value for varName in self on propname. Activates putFn if current value is an activeValue.)
args
(varName newValue propName))
(Rename Object.Rename args (newName environment)
doc (* Remove an old name, and give it new name)
)
(ReturnDefaultValue Object.ReturnDefaultValue args NIL doc
(* Returns LastDefaultValue.))
(SetName NameEntity args (name globalNameFlg)
doc
(* * Associate a name with entity in current environment or in global environment if globalNameFlg=T.
An object can have more than one name.)
)
(Sublis Object.Sublis args (alist)
doc (* Copy this instance, substituting as specified by
alist)
)
(TitleCommand Object.TitleCommand args (datum window)
doc (* Puts up menu of selections for instances for the
Inspector)
)
(TraceIt Object.TraceIt args (varName propName type traceGetAlsoFlg)
doc (* makes an active value which will cause tracing when
this variable is changed. Will also trace on fetches if
traceGetAlsoFlg=T. Message on Object)
)
(UnSetName UnNameEntity doc (* If name actually names self in environment then
delete the association between self and name)
args
(name environment))
(Understands Object.Understands doc (* Tests if object will respond to selector)
args
(selector))
(WhereIs Object.WhereIs args (name type propName)
doc (* Searches the supers hierarchy until it finds the
class from which type is inherited.
type=NIL is METHODS)
)
(NewInstance Object.NewInstance args NIL doc (* This allows initialization by the classes of objects
themselves, rather than going to a metaClass)
))]
(RPAQ DefaultObject ($ Object))
(RPAQ OBJECT ($ Object))
(* * Functions called by kernel classses)
(RPAQQ KERNELFNS (AllSubClasses Class.Add Class.CommentMethods Class.Copy Class.CopyCV Class.CopyIV
Class.CopyMethod Class.CreateInstance Class.DefMethod Class.Delete
Class.Destroy Class.Destroy! Class.DestroyClass Class.DestroyInstance
Class.DisplaySubClasses Class.EM! Class.Edit Class.FetchMethod
Class.HasCV Class.Initialize Class.HasIV Class.HasIV! Class.List
Class.List! Class.MakeLocalMethod Class.MethodDoc Class.MoveMethod
Class.New Class.NewClass Class.NewTemp Class.OnFile Class.PP
Class.PP! Class.PPMethod Class.PPV! Class.PrintSummary Class.Rename
Class.RenameMethod Class.ReplaceSupers Class.SetName Class.Specialize
Class.SubClasses Class.Subclass Class? ClassIVAddDelete CopyDeepDescr
CopyLoopsStruc DefRSM DestroyedClass.DestroyClass
DestroyedClass.DestroyInstance DestroyedClass.PrintOn
DestroyedObject.Destroy! DestroyedObject.PP DestroyedObject.PrintOn
GetLastDefaultValue IVSublis MapIVs MapIVs! MessageNotUnderstood
MessageValue MetaClass.CreateClass MetaClass.DestroyInstance
MetaClass.New NILL Object.AssocKB Object.AssocKB? Object.BreakIt
Object.ChangeAssocKB Object.Class Object.CopyDeep Object.Destroy
Object.Destroy! Object.DoMethod Object.Edit Object.HasIV
Object.IVMissing Object.Inspect Object.InstOf Object.InstOf!
Object.Instantiate Object.List Object.List!
Object.MessageNotUnderstood Object.NameString Object.NewInstance
Object.NoObjectForMsg Object.PP! Object.PPIVs Object.PPV!
Object.PrintOn Object.Rename Object.ReturnDefaultValue
Object.SaveInIT Object.Sublis Object.TraceIt Object.Understands
Object.WhereIs SubsTree AbstractClass.New))
(DEFINEQ
(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.Add
[LAMBDA (self type name value prop) (* dgb: "27-AUG-82 12:55")
(* Type is one of IV IVPROP CV CVPROP META METHOD.
Adds the specified type to the class)
(OR name (ERROR "You must specify a name to add a " type))
(SETQ type (U-CASE type))
(COND
(prop (* here if property name given.
Value is taken to be property value.)
(SELECTQ type
((IVPROP IV NIL)
(PutValueOnly self name value prop))
((CVPROP CV)
(PutClassValueOnly self name value prop))
((META METACLASS CLASS)
(PutClassOnly self name value))
((METHOD SELECTOR)
(PutMethod self name value prop))
(ERROR type "is not an alterable property of class.
Use one of IV CLASS METHOD ")))
(T (* here if no property name given.
Taken as regular value.)
(SELECTQ type
(IV (AddCIV self name value))
(CV (AddCV self name value))
((META METACLASS)
(PutClass self value))
((METHOD SELECTOR)
(AddMethod self name value))
(ERROR type "is not an alterable part of class.
Use one of IV CV META METHOD"])
(Class.CommentMethods
[LAMBDA (class selectors useDefaultComment) (* dgb: "26-JAN-83 14:19")
(* Add args as property of method. Insert comment in class from function. Ask for comment if none available, and
if useDefaultComment is NIL, else insert DefaultComment which is initially bound to (*))
(for sel in (OR selectors (← (SETQ class (GetClassRec class))
List
(QUOTE Selectors)))
bind fn def comment args
do [COND
[[NLSETQ (SETQ def (GETDEF (SETQ fn (← class FetchMethod sel]
[COND
([NOT (EQUAL (SETQ args (CDR (ARGLIST fn)))
(GetMethod class sel (QUOTE args]
(PutMethod class sel args (QUOTE args]
(COND
([NEQ (QUOTE *)
(CAR (SETQ comment (CAR (NTH def 4] (* It's not a comment describing the fn)
(COND
((AND useDefaultComment DefaultComment)
(* Insert DefaultComment in Method)
(SETQ comment DefaultComment)
(APPLY (QUOTE EDITF)
(LIST fn (LIST -4 comment]
(def (PrintStatus (CHARACTER 7)
"Please comment the function " fn "
")
(APPLY (QUOTE EDITF)
fn)
(SETQ def (GETDEF fn)) (* Remember comment and args of method -
minus self)
(SETQ comment (CAR (NTH def 4]
(COND
((AND def (NEQ (CAR comment)
(QUOTE *)))
(PrintStatus (CHARACTER 7)
fn " has not been commented.
"))
([NOT (EQUAL comment (GetMethod class sel (QUOTE doc]
(PutMethod class sel comment (QUOTE doc])
(Class.Copy
[LAMBDA (self name) (* dgb: " 9-FEB-83 08:18")
(* * Create a new class that is a copy of some existing class. Copies the variables and RuleSets.
self is the class being copied.)
(PROG (newClass supers ivs cvs oldRuleSetName oldRuleSet newRuleSetName newRuleSet)
[COND
((NULL name) (* Prompt for name if needed.)
(SETQ name (INTTY "Name of new class: " NIL "Name of new class" T]
(* Make the new class.)
(SETQ supers (← self List (QUOTE Supers)))
(SETQ newClass (← (Class self)
New name supers))
(for iv in (← self List (QUOTE IVS)) do (← self CopyIV iv newClass))
(for cv in (← self List (QUOTE CVS)) do (← self CopyCV cv newClass))
(for selector in (← self List (QUOTE Methods)) do (← self CopyMethod selector newClass
selector))
(RETURN newClass])
(Class.CopyCV
[LAMBDA (self cvName toClass) (* dgb: " 9-FEB-83 08:13")
(* Copy the cvName and properties to toClass.)
(← toClass Add (QUOTE CV)
cvName
(COPY (GetClassValueOnly self cvName)))
(for prop in (← self List (QUOTE CV)
cvName)
do (PutClassValueOnly toClass cvName (COPY (GetClassValueOnly self cvName prop))
prop])
(Class.CopyIV
[LAMBDA (self ivName toClass) (* dgb: " 9-FEB-83 08:13")
(* Copy the ivName and properties to toClass.)
(← toClass Add (QUOTE IV)
ivName
(COPY (GetClassIV self ivName)))
(for prop in (← self List (QUOTE IV)
ivName)
do (PutClassIV toClass ivName (COPY (GetClassIV self ivName prop))
prop])
(Class.CopyMethod
[LAMBDA (self selector newClass newSelector) (* mjs: "25-JUL-83 16:55")
(* Copy method from self to newClass.
newSelector defaults to selector)
(OR newSelector (SETQ newSelector selector))
(PROG (def newFn oldRuleSet oldRuleSetName newRuleSetName newRuleSet (myMethName
(FindLocalMethod (GetClassRec self)
selector)))
[COND
((NULL myMethName)
(COND
((SETQ myMethName (FetchMethod self selector))
(HELPCHECK selector " is not local for " self "
To copy anyway, type OK"))
(T (ERROR selector (CONCAT "is not a selector for " self]
(COND
((NOT (SETQ def (GETDEF myMethName)))
(ERROR myMethName " is not a defined function")))
[OR (type? class newClass)
(SETQ newClass (OR (GetClassRec newClass)
(AND (HELPCHECK newClass
" is not a class. Type OK to use oldClass: ")
self]
[COND
([NEQ NotSetValue (SETQ oldRuleSetName (GetItHere self selector (QUOTE RuleSet)
(QUOTE METHOD]
(* Treat specially those that are implemented by
RuleSets.)
(SETQ oldRuleSet (GetObjectRec oldRuleSetName))
(SETQ newRuleSetName (PACK* selector (ClassName newClass)
(QUOTE Rules)))
(SETQ newRuleSet (← oldRuleSet CopyRules newRuleSetName newClass))
(SETQ newFn (DefRSM newClass selector newRuleSetName)))
(T (* Define the method)
(SETQ newFn (DM (ClassName newClass)
newSelector
(COPY (CADR def))
(COPY (CDDDR def]
(for prop in (DREMOVE (QUOTE RuleSet)
(← self List (QUOTE Method)
selector))
do (* Copy all the properties)
(PutMethod newClass selector (GetMethod self selector prop)
prop))
(RETURN newFn])
(Class.CreateInstance
[LAMBDA (self) (* dgb: "22-SEP-83 14:38")
(* Creates the data structure for an instance based on
the class)
(BlankInstance self])
(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.Delete
[LAMBDA (self type name prop) (* dgb: "27-AUG-82 12:57")
(* Deletes the specified type from class.
type is one of IV IVPROP CV CVPROP META METHOD)
(OR name (ERROR "You must specify a name to delete a " type))
(SELECTQ (U-CASE type)
((IV IVPROP NIL)
(DeleteCIV self name prop))
((CV CVPROP)
(DeleteCV self name prop))
[(META METACLASS CLASS)
(COND
(prop (DeleteClassProp self prop))
(T (PutClass self (QUOTE Class]
((METHOD SELECTOR)
(DeleteMethod self name prop))
(ERROR type "is not an alterable part of class. Use one of
IV CV META METHOD"])
(Class.Destroy
[LAMBDA (class) (* dgb: "27-MAY-83 07:48")
(* Destroys (deletes) a class by putting NIL as
localRecord of entity. Undoable.)
(COND
((fetch subClasses of class)
(HELPCHECK class
"has subclasses. You cannot Destroy classes
that have subclasses. Type OK to use Destroy! if that is what you want. ")
(← class Destroy!))
(T (← (Class class)
DestroyClass class])
(Class.Destroy!
[LAMBDA (class) (* dlsb: " 3-JAN-83 14:46")
(* * Recursive version of Destroy. Destroys class and its subclasses.)
(PROG ((subClasses (fetch subClasses of class)))
[COND
(subClasses (replace subClasses of class with NIL)
(for sc in subClasses do (← (OR (CAR (LISTP sc))
sc)
Destroy!]
(← class Destroy])
(Class.DestroyClass
[LAMBDA (self classToDestroy) (* dgb: "20-SEP-83 17:35")
(* Destroy the class specified by smashing its contents)
(PROG (super entity (uid (fetch OBJUID of classToDestroy)))
(* First delete from knowledge of file system)
[COND
((NULL (type? class classToDestroy))
(RETURN (HELP classToDestroy "not a class for DestroyClass"]
(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 className of classToDestroy with (QUOTE *aDestroyedClass*))
(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 localSupers of classToDestroy with (replace supers of classToDestroy
with (LIST ($ DestroyedObject]
(replace selectors of classToDestroy with NIL)
(replace methods of classToDestroy with NIL)
(replace cvNames of classToDestroy with NIL)
(replace cvDescrs of classToDestroy with NIL)
(replace localIVs of classToDestroy with NIL)
(replace ivNames of classToDestroy with NIL)
(replace ivDescrs of classToDestroy with NIL)
(replace metaClass of classToDestroy with ($ DestroyedClass))
(replace otherMethodDescription of classToDestroy with NIL)
(AND uid (type? Entity (SETQ entity (GetEntityRec uid)))
(replace localRecord of entity with NIL))
(RETURN (QUOTE DestroyedClass])
(Class.DestroyInstance
[LAMBDA (class self) (* sm: "12-SEP-83 16:14")
(* smash back pointer to entity rec, the list of vars
and var descriptions)
(PROG (name)
(COND
((NULL (type? instance self))
(HELP self "not instance for DestroyInstance"))
(T [COND
((SETQ name (GetObjectName self))
(← self UnSetName name)
(UNMARKASCHANGED name (QUOTE INSTANCES]
(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)
(AND uid (type? Entity (SETQ entity (GetEntityRec uid)))
(replace localRecord of entity with NIL])
(Class.DisplaySubClasses
[LAMBDA (self otherClassNames window/title) (* dgb: "30-SEP-82 11:16")
(* Display subclasses of class)
(SETQ Browser (← (%$ ClassBrowser)
New))
(← Browser Show [COND
((NULL otherClassNames)
self)
((EQ self OBJECT)
otherClassNames)
(T (CONS self (OR (LISTP otherClassNames)
(LIST otherClassNames]
window/title])
(Class.EM!
[LAMBDA (self) (* dgb: "21-FEB-83 10:08")
(* 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: "27-AUG-82 12:58")
(* Calls the Interlisp Editor on the source for class)
(EditClassSource (GetClassSource self)
commands
(ClassName self])
(Class.FetchMethod
[LAMBDA (self selector) (* dgb: "28-APR-83 18:40")
(* Find the name of the function which implements this
method in this class)
(FetchMethod self selector])
(Class.HasCV
[LAMBDA (self CVName prop) (* dgb: "11-NOV-82 03:43")
(* Tests if class has the specified class variable)
(COND
[prop (AND (Class.HasCV self CVName)
(FMEMB prop (← self List!(QUOTE CVProps)
CVName]
(T (AND (FMEMB CVName (← self List!(QUOTE CVs)))
T])
(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.HasIV
[LAMBDA (self IVName prop) (* dgb: "12-JAN-83 16:06")
(* Tests if class has the specified instance variable)
(COND
(prop (AND (← self HasIV IVName)
(FMEMB prop (SEND self List!(QUOTE IVProps)
IVName))
T))
(T (AND (FMEMB IVName (SEND self List (QUOTE IVs)))
T])
(Class.HasIV!
[LAMBDA (self IVName prop) (* dgb: "12-JAN-83 16:07")
(* Tests if class has the specified instance variable)
(COND
(prop (AND (← self HasIV! IVName)
(FMEMB prop (SEND self List!(QUOTE IVProps)
IVName))
T))
(T (AND (FMEMB IVName (SEND self List!(QUOTE IVs)))
T])
(Class.List
[LAMBDA (self type name) (* dgb: "29-APR-83 10:24")
(* 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))
(HELP 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.MakeLocalMethod
[LAMBDA (self selector dontBitchFlg) (* dgb: "11-FEB-83 12:50")
(* make an inherited method be local)
(PROG ((methClass (FetchMethodClass self selector)))
(COND
((EQ self methClass)
(OR dontBitchFlg (PrintStatus selector " is already local in " self))
(RETURN NIL)))
(RETURN (← methClass CopyMethod selector self selector])
(Class.MethodDoc
[LAMBDA (self selector) (* dgb: "13-JUN-83 20:57")
(* Show documentation for method in PPDefault window)
(PROG (items menu temp (sel selector))
[OR selector (COND
([SETQ items (SORT (← self List!(QUOTE Selectors]
(SETQ menu (create MENU
ITEMS ← items
CHANGEOFFSETFLG ← T)))
(T (WRITE "No methods in " self)
(RETURN NIL]
LP (COND
[(OR sel (SETQ sel (MENU menu)))
[SETQ temp (ClassName (← self WhereIs sel (QUOTE Method]
(printout PPDefault T T "class: " .FONT LAMBDAFONT (ClassName self)
.FONT DEFAULTFONT (COND
((EQ temp (ClassName self))
"")
(T (CONCAT " (from " temp ")")))
" selector: " .FONT LAMBDAFONT sel .FONT DEFAULTFONT "
args: " (GetMethod self sel (QUOTE args))
"
doc: "
(GetMethod self sel (QUOTE doc]
(T (RETURN NIL)))
(AND selector (RETURN NIL))
(SETQ sel NIL)
(GO LP])
(Class.MoveMethod
[LAMBDA (self newClass selector) (* dgb: "27-AUG-82 13:03")
(* Move method specified by selector from this class to
newClass)
(MoveMethod (ClassName self)
(ClassName newClass)
selector])
(Class.New
[LAMBDA (class name arg1 arg2 arg3 arg4 arg5) (* dgb: "22-SEP-83 14:51")
(* 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)
(← (← 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 (class name) (* dgb: "18-JAN-83 17:00")
(* Creates an instance of a particular class. Called by (← class NewTemp). initValues are just passed on to
Initialize in order. No Entity record and UID are created)
(PROG ((self (BlankInstance class NIL)))
(← class Initialize self) (* Install IV description)
(AND name (← self SetName name))
(RETURN self])
(Class.OnFile
[LAMBDA (self file) (* mjs: " 6-MAY-82 13:18")
(* See if class is on given file.
Returns file if none given)
(PROG [(myfile (WHEREIS self (QUOTE CLASSES]
(RETURN (COND
(file (EQ myfile file))
(T file])
(Class.PP
[LAMBDA (self file) (* dgb: " 3-DEC-82 14:21")
(* Prettyprint the class.)
(PrettyPrintClass (ClassName self)
(OR file (AND (EQ T (OUTPUT))
PPDefault])
(Class.PP!
[LAMBDA (self file) (* sm: " 8-AUG-83 18:24")
(* * Method for prettyPrinting self at all levels.)
(* (OR file (AND (EQ T (OUTPUT))
(SETQ file PPDefault))))
(SETQ file (OR file PPDefault))
(RESETLST (RESETSAVE FIRSTCOL 16)
(RESETSAVE ([LAMBDA (X)
(DSPFONT X file]
NIL))
(PROGN (printout file .FONT LAMBDAFONT self) (* PP Class props)
(printout file T .FONT BOLDFONT "MetaClass and its Properties" T)
(printout file .FONT DEFAULTFONT " " (ClassName (Class self)))
(for cp in (← self List!(QUOTE CLASS))
do (printout file .FONT COMMENTFONT " " cp " " (GetClassOnly self cp)))
(* List supers)
(printout file T .FONT BOLDFONT "Supers")
(printout file T .FONT DEFAULTFONT " " (← self List!(QUOTE SUPERS)))
(* PP instance variables and props)
(printout file T .FONT BOLDFONT "Instance Variable Descriptions" T)
(for iv in (← self List!(QUOTE IVS))
do (printout file .FONT DEFAULTFONT " " iv " " (GetValueOnly self iv))
(for ivp in (← self List!(QUOTE IV)
iv)
do (printout file .FONT COMMENTFONT " " ivp " " (GetValueOnly self iv
ivp)))
(TERPRI file)) (* PP Class Variables & props)
(printout file .FONT BOLDFONT "Class Variables" T)
(for cv in (← self List!(QUOTE CVS))
do (printout file .FONT DEFAULTFONT " " cv " " (GetClassValueOnly self cv))
(for cvp in (← self List!(QUOTE CV)
cv)
do (printout file .FONT COMMENTFONT " " cvp " " (GetClassValueOnly
self cv cvp)))
(TERPRI file)) (* PP Methods and props)
(printout file .FONT BOLDFONT "Methods" T)
(for selector in (SORT (← self List!(QUOTE SELECTORS)))
do (printout file .FONT DEFAULTFONT " " selector " " (FetchMethod self
selector))
(for methodProp in (← self List!(QUOTE METHOD)
selector)
do (printout file .FONT COMMENTFONT " " methodProp " "
(GetMethodOnly self selector methodProp)))
(TERPRI file))
(printout file .FONT DEFAULTFONT T))
self])
(Class.PPMethod
[LAMBDA (self selector) (* sm: " 4-AUG-83 11:57")
(* Prettyprint the function which implements selector in
this class. Prettyprint RuleSet if method)
(PROG (ruleSet items)
[COND
((NULL selector)
(COND
([OR [NULL (SETQ items (← self List (QUOTE selectors]
(NULL (SETQ selector (MENU (create MENU
ITEMS ← items]
(RETURN NIL]
(RESETFORM (OUTPUT PPDefault)
(TERPRI PPDefault)
(COND
([NEQ NotSetValue (SETQ ruleSet (GetMethod self selector (QUOTE RuleSet]
(* Special case if method is a RuleSet.)
(← (GetObjectRec ruleSet)
PPR))
(T (* Usual Case for Methods.)
(PRETTYPRINT (LIST (← self FetchMethod selector])
(Class.PPV!
[LAMBDA (self file) (* sm: " 5-AUG-83 10:57")
(* * Method for prettyPrinting a self at all levels.)
(OR file (AND (EQ T (OUTPUT))
(SETQ file PPDefault)))
(RESETLST (RESETSAVE FIRSTCOL 16)
(RESETSAVE ([LAMBDA (X)
(DSPFONT X file]
NIL))
(PROGN (printout file .FONT LAMBDAFONT self) (* PP Class props)
(printout file T .FONT BOLDFONT "MetaClass and its Properties" T)
(printout file .FONT DEFAULTFONT " " (ClassName (Class self)))
(for cp in (← self List!(QUOTE CLASS))
do (printout file .FONT COMMENTFONT " " cp " " (GetClassOnly self cp)))
(* List supers)
(printout file T .FONT BOLDFONT "Supers")
(printout file T .FONT DEFAULTFONT " " (← self List!(QUOTE SUPERS)))
(* PP instance variables and props)
(printout file T .FONT BOLDFONT "Instance Variable Descriptions" T)
(for iv in (← self List!(QUOTE IVS))
do (printout file .FONT DEFAULTFONT " " iv " " (GetValueOnly self iv))
(for ivp in (← self List!(QUOTE IV)
iv)
do (printout file .FONT COMMENTFONT " " ivp " " (GetValueOnly self iv
ivp)))
(TERPRI file)) (* PP Class Variables & props)
(printout file .FONT BOLDFONT "Class Variables" T)
(for cv in (← self List!(QUOTE CVS))
do (printout file .FONT DEFAULTFONT " " cv " " (GetClassValueOnly self cv))
(for cvp in (← self List!(QUOTE CV)
cv)
do (printout file .FONT COMMENTFONT " " cvp " " (GetClassValueOnly
self cv cvp)))
(TERPRI file))
(printout file .FONT DEFAULTFONT T))
self])
(Class.PrintSummary
[LAMBDA (self file) (* sm: " 8-AUG-83 17:14")
(* Print a summary of elements of class)
[PROG (temp)
(SETQ file (OR file PPDefault))
(RESETLST (RESETSAVE ([LAMBDA (X)
(DSPFONT X file]
NIL))
(PROGN (printout file T T .FONT LAMBDAFONT " " self T .FONT BOLDFONT "Supers" T
3 .FONT DEFAULTFONT .PARA 10 0 (← self List (QUOTE SUPERS))
[for type in (QUOTE (IVs CVs Methods))
do (printout file T .FONT BOLDFONT type T 3 .PARA 3 0
(SORT (SETQ temp (← self List type)))
.FONT DEFAULTFONT T 2 .PARA 2 0
(SORT (LDIFFERENCE (← self List! type)
temp]
T]
self])
(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 name) (* dgb: " 6-JUL-83 12:57")
(* Change the name of the class, forgetting old name.
Change the names of all methods which are of the form
oldName.selector)
(PROG (newName file namePair (oldName (ClassName self)))
(NameEntity self name)
(UnNameEntity self oldName)
(replace className of self with name)
(ChangedClass self)
(AND (SETQ file (WHEREIS oldName (QUOTE CLASSES)))
(CHANGECALLERS oldName newName (QUOTE CLASSES)
file))
(for fn in (← self List (QUOTE Functions)) do (COND
([EQ oldName (CAR (SETQ namePair
(SplitAtom
fn
(QUOTE %.]
(* This is a method of the form className.selector)
(SETQ newName (PACK* name (QUOTE %.)
(CDR namePair)))
(COND
(file (RENAME fn newName (QUOTE FNS)
file))
(T (COPYDEF fn newName (QUOTE FNS))
(DELDEF fn)
(DefineMethod self (CDR namePair)
newName])
(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?
[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])
(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])
(CopyLoopsStruc
[LAMBDA (desc) (* dgb: "11-NOV-82 02:29")
(SELECTQ (TYPENAME desc)
(instance (← desc CopyDeep))
[LISTP (CONS (CopyLoopsStruc (CAR desc))
(CopyLoopsStruc (CDR desc]
desc])
(DefRSM
[LAMBDA (className selector ruleSetName) (* dgb: "20-SEP-83 16:56")
(* 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.)
(PROG (ruleSet classRec) (* Check that class exists.)
(COND
((NOT (SETQ classRec (GetClassRec className)))
(PROMPT "Class" className " not found.")
(RETURN NIL)))
(OR selector (SETQ selector (PromptRead "Type selector for RuleSet Method: "))
(RETURN))
[COND
((Object? className)
(SETQ className (ClassName className] (* Create RuleSet if not specified.)
[COND
((NULL ruleSetName)
(SETQ ruleSetName (PACK* selector className))
(* Make the RuleSet.)
(SETQ ruleSet (← ($ RuleSet)
New NIL ruleSetName)) (* Edit and Compile the RuleSet.)
(←@
ruleSet workSpace className)
(← ruleSet ER))
(T (SETQ ruleSet (GetObjectRec ruleSetName))
(←@
ruleSet workSpace className)
(SETQ ruleSet (GetObjectRec ruleSetName] (* Create the installation fn.)
(* Install and document the RuleSet as a method.)
(PutMethod classRec selector ruleSetName)
(PutMethod classRec selector ruleSetName (QUOTE RuleSet))
(RETURN ruleSetName])
(DestroyedClass.DestroyClass
[LAMBDA (self classToDestroy) (* dgb: "27-MAY-83 08:00")
(* 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))
(AND uid (type? Entity (SETQ entity (GetEntityRec uid)))
(replace localRecord of entity with NIL))
(RETURN (QUOTE DestroyedClass])
(DestroyedClass.DestroyInstance
[LAMBDA (self class self) (* dgb: "27-MAY-83 08:00")
(* 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)
(AND uid (type? Entity (SETQ entity (GetEntityRec uid)))
(replace localRecord of entity with NIL])
(DestroyedClass.PrintOn
[LAMBDA (self file) (* dgb: "26-NOV-82 19:26")
(* Print out DestroyedClass)
(PRIN1 (QUOTE DestroyedClass)
file])
(DestroyedObject.Destroy!
[LAMBDA (self) (* dgb: "27-MAY-83 11:44")
(* Do nothing. I am already destroyed)
self])
(DestroyedObject.PP
[LAMBDA (self file) (* sm: "12-SEP-83 16:32")
(* Prints "***Destroyed Object***")
(printout (OR file PPDefault)
T "***Destroyed Object***" T])
(DestroyedObject.PrintOn
[LAMBDA (self file) (* sm: "12-SEP-83 16:31")
(* Prints simple form for a DestroyedObject)
(PRIN1 "***DestroyedObject***" file])
(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])
(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])
(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])
(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: "19-APR-83 15:43")
(* 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))
(AND uid (type? Entity (SETQ entity (GetEntityRec uid)))
(replace localRecord of entity with NIL))
(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])
(Object.AssocKB
[LAMBDA (self newKBName) (* dgb: "19-JAN-83 12:24")
(* Change assocKB of this object to newKBName)
(COND
[(NULL newKBName)
(PROG ((uid (fetch OBJUID of self)))
(RETURN (COND
((NULL uid)
NIL)
(T (EntityKB (GetEntityRec uid]
(T (PROG ((uid (UID self T))) (* UID insures that there is an entity record)
(Modified self T)
(replace storedIn of (GetEntityRec uid) with newKBName)
(RETURN newKBName])
(Object.AssocKB?
[LAMBDA (self) (* dgb: "19-JAN-83 12:24")
(PROG ((uid (fetch OBJUID of self)))
(RETURN (COND
((NULL uid)
NIL)
(T (EntityKB (GetEntityRec uid])
(Object.BreakIt
[LAMBDA (self varName propName type brkOnGetAlsoFlg) (* mjs: " 2-AUG-82 15:35")
(* makes an active value which will cause break when the on this value is to be changed. If brkOnGetAlsoFlg=T then
will also break when value is fetched. Message on Object)
(push BrokenVariables (LIST self varName (MakeActiveValue self varName (AND brkOnGetAlsoFlg
(QUOTE
GettingBrokenVariable))
(QUOTE SettingBrokenVariable)
(QUOTE EMBED)
propName type)
propName type))
self])
(Object.ChangeAssocKB
[LAMBDA (self newKBName) (* dgb: "19-JAN-83 11:41")
(* Marks object as changed and makes newKBName be its
associatedKB)
(Modified self T)
(replace storedIn of (GetEntityRec (UID self T)) with newKBName])
(Object.Class
[LAMBDA (self) (* dgb: "27-AUG-82 13:07")
(* Returns class of object)
(Class self])
(Object.CopyDeep
[LAMBDA (oldInstance KBC) (* dgb: "19-JAN-83 12:24")
(* * Copies the unit, sharing the iName list, copying instances, activeValues and lists)
(PROG ((source (CopyDeepDescr (IVSource oldInstance)))
newInstance)
(SETQ newInstance (FillIVs NIL (Class oldInstance)
source)
(COND
((fetch OBJUID of oldInstance) (* Has an OBJUID so this is not a temporary object.
Create OBJUID for new object)
(NewEntity newInstance)))
(RETURN newInstance])
(Object.Destroy
[LAMBDA (self) (* dgb: "19-APR-83 15:37")
(* marks object as deleted by putting NIL as localRecord
of entity and saving UID if it was an old entity.)
(PROG (entity (uid (fetch OBJUID of self)))
(COND
((type? class self)
(Class.Destroy self))
(T (← (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) (* edited: "31-MAY-83 15:54")
(* Use Interlisp editor on source of object)
(PROG [name (newInst (EVAL (EDITE (GetInstanceSource self)
commands]
(COND
((AND (NULL CurrentEnvironment)
(SETQ name (GetObjectName newInst)))
(MARKASCHANGED name (QUOTE INSTANCES])
(Object.HasIV
[LAMBDA (self ivName prop) (* mjs: "15-JUN-82 17:21")
(* Check to see if IV is on self.
If so, return T)
(COND
[prop (AND (← self HasIV ivName)
(FMEMB prop (SEND self List!(QUOTE IVProps)
ivName]
(T (AND (FMEMB ivName (← self List!(QUOTE IVs)))
T])
(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.Inspect
[LAMBDA (self INSPECTLOC) (* sm: "12-SEP-83 15:54")
(* Inspect the object as class or instance, using
INSPECTLOC as a region for the inspect window, if it is
given)
(INSPECT self NIL INSPECTLOC])
(Object.InstOf
[LAMBDA (self class) (* dgb: "12-JAN-83 15:58")
(* test if self is an instance of class)
(EQ (ClassName (Class self))
(COND
((LITATOM class)
class)
(T (ClassName class])
(Object.InstOf!
[LAMBDA (self class) (* dgb: "26-JAN-83 09:51")
(* * Recursive version of InstOf.)
(← (Class self)
Subclass class])
(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.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: "22-SEP-83 14:48")
(* 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.PP!
[LAMBDA (self file) (* sm: " 5-AUG-83 10:58")
(* * Method for prettyPrinting a non-class object at all levels)
(OR file (SETQ file PPDefault))
(RESETLST (RESETSAVE FIRSTCOL 16)
(RESETSAVE ([LAMBDA (X)
(DSPFONT X file]
NIL))
(PROG ((class (Class self))) (* PP Class Variables & props)
(printout file .FONT LAMBDAFONT self T)
(printout file .FONT BOLDFONT "Instance Variables" T)
(for iv in (← self List!(QUOTE IVS)) unless (EQ iv (QUOTE indexedVars))
do (printout file .FONT DEFAULTFONT " " iv " " (GetValueOnly self iv))
(for ivp in (← self List!(QUOTE IV)
iv)
do (printout file .FONT COMMENTFONT " " ivp " " (GetValueOnly self iv
ivp)))
(TERPRI file))
[COND
((← self InstOf!(QUOTE VarLength)) (* Special printing for indexed variables.)
(printout file .FONT BOLDFONT "Indexed Variables" T)
(for iv in (GetValueOnly self (QUOTE indexedVars)) as index from 1
to (← self Length)
do (printout file .FONT DEFAULTFONT " " index .TAB0 4 (GetValueOnly
self index))
(for ivp in (← self List!(QUOTE IV)
index)
do (printout file .FONT COMMENTFONT " " ivp " "
(GetValueOnly self index ivp)))
(TERPRI file]
(printout file .FONT BOLDFONT "Class Variables" T)
(for cv in (← class List!(QUOTE CVS))
do (printout file .FONT DEFAULTFONT " " cv " " (GetClassValueOnly class cv))
(for cvp in (← class List!(QUOTE CV)
cv)
do (printout file .FONT COMMENTFONT " " cvp " " (GetClassValueOnly
class cv cvp)))
(TERPRI file)) (* PP instance variables and props)
(* PP Methods and props)
(printout file .FONT BOLDFONT "Methods" T)
(for selector in (SORT (← class List!(QUOTE SELECTORS)))
do (printout file .FONT DEFAULTFONT " " selector " " (FetchMethod class
selector))
(for methodProp in (← class List!(QUOTE METHOD)
selector)
do (printout file .FONT COMMENTFONT " " methodProp " "
(GetMethodOnly class selector methodProp)))
(TERPRI file))
(printout file .FONT DEFAULTFONT T))
self])
(Object.PPIVs
[LAMBDA (self file) (* dgb: " 2-MAR-82 17:09")
(* * Called to prettyPrint a class definition on a file by the FILEPKGTYPE CLASSES and by the PP: method in Class)
(PROG [(vars (for v in (← self List (QUOTE IVs)) collect (LIST v (GetValueOnly self v]
(printout file "[ " .FONT LAMBDAFONT self T .FONT DEFAULTFONT 3 .PPFTL vars "]" T T])
(Object.PPV!
[LAMBDA (self file) (* sm: " 5-AUG-83 10:59")
(* * Method for prettyPrinting a non-class object at all levels.)
(OR file (SETQ file PPDefault))
(RESETLST (RESETSAVE FIRSTCOL 16)
(RESETSAVE ([LAMBDA (X)
(DSPFONT X file]
NIL))
(PROG ((class (Class self))) (* PP Class Variables & props)
(printout file .FONT LAMBDAFONT self T)
(printout file .FONT BOLDFONT "Instance Variables" T)
(for iv in (← self List!(QUOTE IVS)) unless (EQ iv (QUOTE indexedVars))
do (printout file .FONT DEFAULTFONT " " iv " " (GetValueOnly self iv))
(for ivp in (← self List!(QUOTE IV)
iv)
do (printout file .FONT COMMENTFONT " " ivp " " (GetValueOnly self iv
ivp)))
(TERPRI file))
[COND
((← self InstOf!(QUOTE VarLength)) (* Special printing for indexed variables.)
(printout file .FONT BOLDFONT "Indexed Variables" T)
(for iv in (GetValueOnly self (QUOTE indexedVars)) as index from 1
to (← self Length)
do (printout file .FONT DEFAULTFONT " " index .TAB0 4 (GetValueOnly
self index))
(for ivp in (← self List!(QUOTE IV)
index)
do (printout file .FONT COMMENTFONT " " ivp " "
(GetValueOnly self index ivp)))
(TERPRI file]
(printout file .FONT BOLDFONT "Class Variables" T)
(for cv in (← class List!(QUOTE CVS))
do (printout file .FONT DEFAULTFONT " " cv " " (GetClassValueOnly class cv))
(for cvp in (← class List!(QUOTE CV)
cv)
do (printout file .FONT COMMENTFONT " " cvp " " (GetClassValueOnly
class cv cvp)))
(TERPRI file)) (* PP instance variables and props)
(* PP Methods and props)
(printout file .FONT DEFAULTFONT T))
self])
(Object.PrintOn
[LAMBDA (self file) (* dgb: "19-JAN-83 12:24")
(* * This is the default printing function for object. It distinguishes between temporary object, named objects,
and others)
[PROG (name (uid (fetch OBJUID of self)))
(COND
((NULL uid) (* A temporary object)
(PRIN1 "#&" file)
(PRIN2 (LIST (ClassName self)
(EntityAddress self))
file))
((SETQ name (GetObjectName self))
(PRIN1 "#$" file)
(PRIN1 name file))
(T (PRIN1 "#&" file)
(PRIN2 (LIST (ClassName self)
(MKSTRING uid))
file]
self])
(Object.Rename
[LAMBDA (self newName environment) (* dgb: "18-MAR-82 10:08")
(* Remove an old name, and give it new name)
(PROG ((oldName (GetObjectName self)))
(COND
(oldName (← self UnSetName oldName environment)))
(← self SetName newName environment])
(Object.ReturnDefaultValue
[LAMBDA (self) (* dgb: " 6-JUN-83 17:38")
(* Returns LastDefaultValue.)
(* Useful if one wants to have a MessageNotUnderstood function which does the work required.
It can then set LastDefaultValue and return (QUOTE ReturnDefaultValue) as the selector to be used)
LastDefaultValue])
(Object.SaveInIT
[LAMBDA (self) (* dgb: "22-JUL-83 16:23")
(* Save object in Lisp variable IT.
Useful in Inspector)
(SETQ IT self])
(Object.Sublis
[LAMBDA (self alist) (* mjs: "17-FEB-83 12:58")
(* Copy this instance, substituting as specified by
alist)
(* alist items are either one or two element lists (key substKey). If a two element list, then the substKey is
substituted for key. If it contains only key, then the first time the key is found, a copy is made then, and used
from then on. Sublis copies all lists and active values. It searches lists recursively EXCEPT if they begin with
*, to avoid searching comments.)
(PROG (myObj (myPair (FASSOC self alist)))
[COND
((NULL (CDR myPair)) (* Need a copied object)
(SETQ myObj (BlankInstance (Class self))) (* If there is a pair, insert the new object)
(AND myPair (RPLACD myPair (LIST myObj]
[COND
((NULL myPair) (* self is not on the alist)
(SETQ alist (NCONC1 alist (SETQ myPair (LIST self myObj]
[for iv val in (← self List (QUOTE IVs)) do (for prop in (CONS NIL (← self List
(QUOTE IVPROPS)
iv))
do
(* Subst for value (the NIL property) and all
properties)
(SETQ val (IVSublis (GetIVHere self iv
prop)
alist))
(COND
((NEQ val NotSetValue)
(PutValueOnly myObj iv val prop]
(RETURN myObj])
(Object.TraceIt
[LAMBDA (self varName propName type traceGetAlsoFlg) (* mjs: " 2-AUG-82 15:31")
(* makes an active value which will cause tracing when
this variable is changed. Will also trace on fetches if
traceGetAlsoFlg=T. Message on Object)
(push BrokenVariables (LIST self varName (MakeActiveValue self varName (AND traceGetAlsoFlg
(QUOTE
GettingTracedVariable))
(QUOTE SettingTracedVariable)
(QUOTE EMBED)
propName type)
propName type))
self])
(Object.Understands
[LAMBDA (self selector) (* dgb: "28-APR-83 18:40")
(* Tests if object will respond to selector)
(AND (FetchMethod (Class self)
selector)
T])
(Object.WhereIs
[LAMBDA (self name type propName) (* dgb: "23-APR-83 16:18")
(* Searches the supers hierarchy until it finds the
class from which type is inherited.
type=NIL is METHODS)
(PROG ((realType (U-CASE type)))
LP [SETQ realType (SELECTQ realType
((METHOD METHODS T NIL)
(QUOTE METHODS))
((IVPROP IVPROPS)
(QUOTE IVPROPS))
((IV IVS)
(QUOTE IVS))
((CV CVS)
(QUOTE CVS))
(PROGN (SETQ realType (HELPCHECK
"Use one of METHODS IVS CVS for type.
RETURN on of these atoms to go on"))
(GO LP]
(RETURN (COND
(propName (MapSupersForm (COND
((FMEMB propName (← class List realType name))
(RETURN class)))
self))
(T (MapSupersForm (COND
((FMEMB name (← class List realType))
(RETURN class)))
self])
(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])
(AbstractClass.New
[LAMBDA (self) (* mjs: "21-JUL-82 09:26")
(* Stop abstract class from being instantiated)
(ERROR self "Abstract class cannot be instantiated"])
)
(* Patch to allow the inspector to take a region to put the window in)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA NILL)
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (26217 95886 (AllSubClasses 26227 . 26809) (Class.Add 26811 . 28150) (
Class.CommentMethods 28152 . 29766) (Class.Copy 29768 . 30851) (Class.CopyCV 30853 . 31335) (
Class.CopyIV 31337 . 31798) (Class.CopyMethod 31800 . 33859) (Class.CreateInstance 33861 . 34152) (
Class.DefMethod 34154 . 34652) (Class.Delete 34654 . 35407) (Class.Destroy 35409 . 35948) (
Class.Destroy! 35950 . 36419) (Class.DestroyClass 36421 . 39092) (Class.DestroyInstance 39094 . 40088)
(Class.DisplaySubClasses 40090 . 40557) (Class.EM! 40559 . 41197) (Class.Edit 41199 . 41510) (
Class.FetchMethod 41512 . 41818) (Class.HasCV 41820 . 42224) (Class.Initialize 42226 . 43050) (
Class.HasIV 43052 . 43468) (Class.HasIV! 43470 . 43888) (Class.List 43890 . 45256) (Class.List! 45258
. 46576) (Class.MakeLocalMethod 46578 . 47064) (Class.MethodDoc 47066 . 48119) (Class.MoveMethod
48121 . 48451) (Class.New 48453 . 48837) (Class.NewClass 48839 . 49063) (Class.NewTemp 49065 . 49572)
(Class.OnFile 49574 . 49945) (Class.PP 49947 . 50241) (Class.PP! 50243 . 52802) (Class.PPMethod 52804
. 53762) (Class.PPV! 53764 . 55711) (Class.PrintSummary 55713 . 56536) (Class.Rename 56538 . 56977) (
Class.RenameMethod 56979 . 57270) (Class.ReplaceSupers 57272 . 57593) (Class.SetName 57595 . 58878) (
Class.Specialize 58880 . 59398) (Class.SubClasses 59400 . 59774) (Class.Subclass 59776 . 60012) (
Class? 60014 . 60230) (ClassIVAddDelete 60232 . 61169) (CopyDeepDescr 61171 . 61779) (CopyLoopsStruc
61781 . 62056) (DefRSM 62058 . 63725) (DestroyedClass.DestroyClass 63727 . 65570) (
DestroyedClass.DestroyInstance 65572 . 66308) (DestroyedClass.PrintOn 66310 . 66568) (
DestroyedObject.Destroy! 66570 . 66806) (DestroyedObject.PP 66808 . 67099) (DestroyedObject.PrintOn
67101 . 67372) (GetLastDefaultValue 67374 . 67711) (IVSublis 67713 . 68862) (MapIVs 68864 . 69400) (
MapIVs! 69402 . 69890) (MessageNotUnderstood 69892 . 70537) (MessageValue 70539 . 70916) (
MetaClass.CreateClass 70918 . 71214) (MetaClass.DestroyInstance 71216 . 73057) (MetaClass.New 73059 .
73473) (Object.AssocKB 73476 . 74102) (Object.AssocKB? 74104 . 74359) (Object.BreakIt 74361 . 74953) (
Object.ChangeAssocKB 74955 . 75326) (Object.Class 75328 . 75548) (Object.CopyDeep 75550 . 76156) (
Object.Destroy 76158 . 76643) (Object.Destroy! 76645 . 76994) (Object.DoMethod 76996 . 77422) (
Object.Edit 77424 . 77868) (Object.HasIV 77870 . 78288) (Object.IVMissing 78290 . 79454) (
Object.Inspect 79456 . 79813) (Object.InstOf 79815 . 80128) (Object.InstOf! 80130 . 80337) (
Object.Instantiate 80339 . 80569) (Object.List 80571 . 81210) (Object.List! 81212 . 81665) (
Object.MessageNotUnderstood 81667 . 82331) (Object.NameString 82333 . 82727) (Object.NewInstance 82729
. 83787) (Object.NoObjectForMsg 83789 . 84630) (Object.PP! 84632 . 87177) (Object.PPIVs 87179 . 87623
) (Object.PPV! 87625 . 89715) (Object.PrintOn 89717 . 90435) (Object.Rename 90437 . 90819) (
Object.ReturnDefaultValue 90821 . 91277) (Object.SaveInIT 91279 . 91549) (Object.Sublis 91551 . 93198)
(Object.TraceIt 93200 . 93843) (Object.Understands 93845 . 94129) (Object.WhereIs 94131 . 95115) (
SubsTree 95117 . 95597) (AbstractClass.New 95599 . 95884)))))
STOP