(FILECREATED "29-Feb-84 16:02:22" {INDIGO}<LOOPS>SOURCES>LOOPSUTILITY.;25 66764
changes to: (FNS Class.DestroyClass Class.DestroyInstance)
previous date: "29-Feb-84 09:02:41" {INDIGO}<LOOPS>SOURCES>LOOPSUTILITY.;24)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LOOPSUTILITYCOMS)
(RPAQQ LOOPSUTILITYCOMS ((* Copyright (c)
1982 by Xerox Corporation)
(* * Functions the user expects to call)
(FNS * LOOPSUSERFNS)
(METHODS AbstractClass.New Class.Add Class.AddCV Class.AddIV Class.BreakMethod
Class.CommentMethods Class.Copy Class.CopyCV Class.CopyIV Class.CopyMethod
Class.Delete Class.Destroy Class.Destroy! Class.DestroyClass Class.DestroyInstance
Class.HasCV Class.HasIV Class.HasIV! Class.MakeLocalMethod Class.MethodDoc
Class.MethodSummary Class.MoveMethod Class.OnFile Class.PP Class.PP! Class.PPM
Class.PPMethod Class.PPV! Class.PrintSummary Class.Put Class.UnbreakMethod
Object.AddIV Object.At Object.BreakIt Object.ChangeAssocKB Object.CopyDeep
Object.CopyShallow Object.Get Object.HasIV Object.DeleteIV Object.Inspect
Object.InstOf Object.InstOf! Object.PP Object.PP! Object.PPIVs Object.PPV!
Object.PrintOn Object.Put Object.ReturnDefaultValue Object.SaveInIT Object.Sublis
Object.TraceIt Object.Understands Object.WhereIs)))
(* Copyright (c) 1982 by Xerox Corporation)
(* * Functions the user expects to call)
(RPAQQ LOOPSUSERFNS (AddValue BreakIt BreakMethod CalledFns DC DELASSOC DM DefTemplate GetObjectNames
HELPCHECK MapSupers MatchIVs MatchListDescr MatchDescr
MoveClassVariable MoveMethod MoveMethodsToFile MoveVariable PPC
RemoveClassDef RenameInClass RenameMethodFunction TraceIt TraceMethod
UnBreakIt FindObjectNames))
(DEFINEQ
(AddValue
[LAMBDA (self entry item prop) (* dgb: "14-MAR-83 13:17")
(* Adds item to the END of a list of items which is
current value)
(PutValue self entry (APPEND (LISTP (GetValue self entry prop))
(LIST item))
prop])
(BreakIt
[LAMBDA (self varName propName type brkOnGetAlsoFlg) (* mjs: " 2-AUG-82 15:36")
(* 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. Sends message to self)
(← self BreakIt varName propName type brkOnGetAlsoFlg])
(BreakMethod
[LAMBDA (className selector) (* dgb: "29-Feb-84 08:50")
(APPLY* (QUOTE BREAK)
(OR (FetchMethod (GetObjectRec (GoodClassName className NIL T))
selector)
(ERROR selector (CONCAT " not found in " className])
(CalledFns
[LAMBDA (classes definedFlg) (* dgb: "29-APR-83 10:18")
(* * Finds names of all functions called from a set of classes. If definedFlg =NIL then gets all fns.
If =T then defined fns. If =1 then undefined fns)
[COND
((LITATOM classes)
(SETQ classes (LIST classes]
(for className in classes bind fns do (for fn in (\ListFromBlock (fetch methods
of (GetClassRec className)))
do (AND [OR (NULL definedFlg)
(AND (EQ definedFlg T)
(FNTYP fn))
(AND (EQ definedFlg 1)
(NOT (FNTYP fn]
(pushnew fns fn)))
finally (RETURN (SORT fns])
(DC
[LAMBDA (name supers) (* edited: "30-JUN-83 16:26")
(* Defines a new class with name and supers. If one of the Supers is not defined, and the user says not to define
it, throws the user into the editor)
(AND (GetObjectRec name)
(HELPCHECK name
"is already a defined object.
Type OK to go on and define this class anyway."))
(← ($ Class)
New name supers])
(DELASSOC
[LAMBDA (key alist) (* dgb: "11-NOV-82 03:58")
(for P in alist when (NOT (EQ key (CAR P))) collect P])
(DM
[LAMBDA (className selector argsOrFn expr) (* dgb: " 6-JUN-82 18:09")
(* * Define a new method (or replace an old one). If expr is NIL then argsOrFn should be a function Name, else it
should be a list of arguments, and expr should be the function definition)
(SETQ className (GoodClassName className NIL T))
(← (GetClassRec className)
DefMethod selector argsOrFn expr])
(DefTemplate
[LAMBDA (className super) (* dgb: "21-JUN-82 13:45")
(DefineClass className (LIST super))
(replace metaClass of (GetClassRec className) with $Template)
className])
(GetObjectNames
[LAMBDA (object) (* dgb: "28-DEC-83 10:03")
(* Returns the names of an object including its UID)
(PROG [(uid (LIST (UID object)))
(names (OR (AND CurrentNameTable (GETHASH object CurrentNameTable))
(GETHASH object ObjNameTable]
(RETURN (COND
((NULL names)
uid)
((LITATOM names)
(CONS names uid))
(T (APPEND names uid])
(HELPCHECK
[LAMBDA (mess1 mess2 mess3 mess4) (* dgb: "11-NOV-82 02:29")
(* Print out up to four messages and go into a break.
OK will then return T)
(PRIN1 mess1 T)
(AND mess2 (PRIN1 mess2 T))
(AND mess3 (PRIN1 mess3 T))
(AND mess4 (PRIN1 mess4 T))
(TERPRI T)
(BREAK1 T T (QUOTE HELPCHECK])
(MapSupers
[LAMBDA (classRec applyFn) (* dgb: "23-APR-83 16:18")
(* Maps through a class and its supers in order.
Returns the first non null value returned by the
function)
(MapSupersForm (RETURN (OR (APPLY* applyFn class)
(GO ON)))
classRec])
(MatchIVs
[LAMBDA (self ivDescrs alist) (* dgb: "21-MAR-83 10:53")
(* Match each of the instance variable descriptions of self against the description in the list of ivDescrs.
Each description there is of the form -
(ivName ivValue propName1 propValue ...) -
Extra props on the iv, and ivs not mentioned are ignored)
(for ivDescr ivName ivProp val in ivDescrs finally (RETURN alist)
do [SETQ val (GetIVHere self (SETQ ivName (CAR ivDescr]
(OR (SETQ alist (MatchDescr val (CADR ivDescr)
alist))
(RETURN NIL))
(for ivTail on (CDDR ivDescr) do (OR (SETQ alist (MatchDescr (GetValue self ivName
(CAR ivTail))
(CADR ivTail)
alist))
(RETURN NIL])
(MatchListDescr
[LAMBDA (self description alist) (* dgb: "21-MAR-83 11:45")
(AND [SELECTQ (CAR description)
[=: (* Remember this item as named by CADR -
then match to CADDR)
(SETQ alist (MatchDescr self (CADDR description)
(CONS (CONS (CADR description)
self)
alist]
[= (* The same as a previosuly named item)
(EQ self (CDR (FASSOC (CADR description)
alist]
((TEST Test test) (* Force a functional test.)
(APPLY* (CADR description)
self))
(EVAL (* Evaluate the form and then use it for matching)
(SETQ alist (MatchDescr self (EVAL (CADR description))
alist)))
[(a an An A) (* A class type, or for non objects, a test)
(COND
[(type? instance self) (* Match class and IV descriptions)
(AND (← self InstOf!(CADR description))
(SETQ alist (MatchIVs self (CDDR description)
alist]
(T (AND (GETD (CADR description))
(APPLY* (CADR description)
self]
((NOT Not not) (* Matches if description does not match)
(NOT (MatchDescr self (CADR description)
alist)))
[(OR Or or) (* Matches if one matches. Returns alist from that
match.)
(for descr al in (CDR description) do (AND (SETQ al (MatchDescr self descr alist))
(RETURN (SETQ alist al]
[(AND And and) (* Matches if all match -- probably not needed)
(for descr in (CDR description) finally (RETURN T)
do (OR (SETQ alist (MatchDescr self descr alist))
(RETURN NIL]
(QUOTE (* Quoted expressions must be EQUAL to object)
(EQUAL self (CADR description)))
(COND
((LISTP self) (* Recursive match)
(AND (EQ (LENGTH description)
(LENGTH self))
(for descr in description as obj in self finally (RETURN T)
do (OR (SETQ alist (MatchDescr obj descr alist))
(RETURN NIL]
alist])
(MatchDescr
[LAMBDA (self description alist) (* dgb: "21-MAR-83 10:51")
(* * match against a description. A List beginning with A is thought of as a description of an object.
The next atom is the name of its class (or a superClass). Additional list elements are thought of as describing
IVs, except for (=: name descr) which defines this name as being the object just specified;
and (= name) which mean that the object matched is eq to the named object. An IV description is
(ivName ivValueDescription prop1 prop1Desc ...) RETURNS the alist or NIL.)
[OR alist (SETQ alist (CONS (CONS NIL self] (* So that when alist is returned it is not NIL)
(AND (COND
((NULL description) (* NIL matches anything)
T)
((STRINGP description) (* Test strings are a substring of self)
(STRPOS description self))
((Object? description) (* Objects which are descriptions follow a protocol for
matching)
(SETQ alist (← description Match self)))
((LISTP description)
(SETQ alist (MatchListDescr self description alist)))
((type? instance self) (* description had better be a LITATOM, and the name of
a class. Everything else returns NIL)
(← self InstOf! description))
(T (* self and description are two atoms, or two datatypes)
(EQUAL self description)))
alist])
(MoveClassVariable
[LAMBDA (oldClassName newClassName varName) (* dgb: "22-NOV-82 19:16")
(* * Moves a class variable and its properties to a new class and deletes it from the old class.)
(PROG (oldClass newClass)
(SETQ oldClassName (GoodClassName oldClassName NIL T))
(SETQ newClassName (GoodClassName newClassName NIL T))
(SETQ oldClass (GetClassRec oldClassName))
(SETQ newClass (GetClassRec newClassName))
[COND
([NOT (FMEMB varName (← oldClass List (QUOTE CVs]
(ERROR varName (CONCAT "is not a CV of " oldClass " so cannot be moved from there"]
(AddCV newClass varName (GetClassValue oldClass varName))
(for propName in (← oldClass List (QUOTE CVPROPS)
varName)
do (PutClassValue newClass varName (GetClassValue oldClass varName propName)
propName))
(DeleteCV oldClass varName])
(MoveMethod
[LAMBDA (oldClassName newClassName selector newSelector files)
(* dgb: "14-MAR-83 13:19")
(* Move a method from oldClassName to newClassName,
renaming function if appropriate)
(SETQ oldClassName (GoodClassName oldClassName NIL T))
(OR newClassName (SETQ newClassName oldClassName))
(SETQ newClassName (GoodClassName newClassName NIL T))
(OR newSelector (SETQ newSelector selector))
(PROG (oldDef newLocalFn (oldClass (GetClassRec oldClassName))
(newClass (GetClassRec newClassName))
(localFn (FindLocalMethod (GetClassRec oldClassName)
selector))
fnPair)
(COND
((NULL localFn)
(printout T selector " not found in " oldClassName)
(RETURN NIL))
[(EQ [CAR (SETQ fnPair (SplitAtom localFn (QUOTE %.]
oldClassName)
(SETQ oldDef (CDR (GETDEF localFn)))
(DELDEF localFn)
(SETQ newLocalFn (DM newClassName newSelector (CAR oldDef)
(CDDR oldDef]
(T (AddMethod newClass selector localFn)))
(for prop in (← oldClass List (QUOTE Method)
selector)
do (PutMethodOnly newClass newSelector (GetMethodOnly oldClass selector prop)
prop))
(DeleteMethod oldClass selector)
(RETURN (OR newLocalFn localFn])
(MoveMethodsToFile
[LAMBDA (file) (* dgb: " 1-NOV-83 16:57")
(* Move a method to this file if it has the same name as
a function on this file)
(for FN in (FILEFNSLST file) bind obj (MYMETHODS ←(FILECOMSLST file (QUOTE METHODS)))
do (AND (SETQ obj (GetObjectRec FN))
(← obj InstOf!(QUOTE Method))
(NOT (FMEMB FN MYMETHODS))
(MOVEITEM file FN (QUOTE METHODS])
(MoveVariable
[LAMBDA (oldClassName newClassName varName) (* dgb: "22-NOV-82 16:29")
(* * Moves an instance variable and it description to new class, deleting it from old)
(SETQ oldClassName (GoodClassName oldClassName NIL T))
(SETQ newClassName (GoodClassName newClassName NIL T))
(PROG (descr (oldC (GetClassRec oldClassName))
(newC (GetClassRec newClassName)))
[COND
([NOT (FMEMB varName (← oldC List (QUOTE IVs]
(ERROR varName (CONCAT "not a local IV of " oldC " so can not be moved from there"]
(SETQ descr (FetchCIVDescr oldC varName))
(AddCIV newC varName (CAR descr)
(CDR descr))
(DeleteCIV oldC varName)
(RETURN newC])
(PPC
[LAMBDA (className) (* dgb: "10-NOV-82 16:11")
(PROG NIL
(← (OR (GetClassRec className)
(RETURN "No such class"))
PP)
(RETURN className])
(RemoveClassDef
[LAMBDA (name) (* dgb: "26-DEC-83 17:36")
(* This removes a class definition from the current
world)
(PROG (file (classRec (GetClassRec name)))
(COND
((NULL classRec)
(RETURN NIL)))
(AND (SETQ file (WHEREIS name (QUOTE CLASSES)))
(DELFROMFILE name (QUOTE CLASSES)
file))
(DeleteObjectName classRec name)
(RETURN classRec) (* Returns old facts if it is succesful in deleting, NIL
otherwise)
])
(RenameInClass
[LAMBDA (className name newName place prop) (* dgb: "30-NOV-81 13:36")
(* * This is a general function for adding information to a class. It does this by modifying the source for the
class. Called by DefineMethod DM and others of that ilk. place is one of Methods, InstanceVariables, etc prop is
an optional property name for variables e.g. CONSTRAINTS for the otherSlotDescription. name is which one to add to
e.g varName and newName is what is the primary associated quantity e.g. default for variable or implementing
function for Methods)
(PROG (propForm valForm (source (GetClassSource className)))
(COND
((NULL source)
(ERROR className "not a defined class"))
([NULL (SETQ propForm (FASSOC (OR place (QUOTE InstanceVariables))
(CDDR source]
(ERROR place "not part of class definition"))
(prop (SELECTQ place
(Supers (ERROR prop "is not available for this aspect of definition"))
NIL)))
[SELECTQ place
[MetaClass (COND
((NULL prop)
(COND
((EQ (CADR propForm)
name)
(RPLACA (CDR propForm)
newName)))
(GO OUT))
(T (SETQ valForm propForm]
(Supers (RPLACD propForm (DSUBST newName name (CDR propForm)))
(GO OUT))
(SETQ valForm (FASSOC name (CDR propForm]
[COND
((NULL prop)
(RPLACA valForm newName))
(T (for X on (CDDR valForm) by (CDDR X) do (COND
((EQ (CAR X)
prop)
(RPLACA X newName)
(RETURN X]
OUT (EVAL source])
(RenameMethodFunction
[LAMBDA (className oldFnName newFnName) (* dgb: "28-APR-83 18:40")
(* * Renames a function used as a method in className)
(SETQ className (GoodClassName className NIL T))
(PROG ((classRec (GetClassRec className))
index)
[COND
((NULL (SETQ index (FindSelectorIndex classRec oldFnName)))
(ERROR oldFnName (CONCAT "not used as function in " className]
(RENAME oldFnName newFnName NIL (WHEREIS oldFnName))
(AddMethod classRec (GetNthMethod classRec index)
newFnName)
(RETURN newFnName])
(TraceIt
[LAMBDA (self varName propName type traceGetAlsoFlg) (* mjs: " 2-AUG-82 15:34")
(* makes an active value which will cause tracing when
this variable is changed. Will also trace on fetches if
traceGetAlsoFlg=T.)
(← self TraceIt varName propName type traceGetAlsoFlg])
(TraceMethod
[LAMBDA (className selector) (* dgb: "29-Feb-84 08:50")
(APPLY* (QUOTE TRACE)
(OR (FetchMethod (GetObjectRec (GoodClassName className NIL T))
selector)
(ERROR selector (CONCAT " not found in " className])
(UnBreakIt
[LAMBDA (self varName propName type) (* DECLARATIONS: (RECORD brkRec
(brkSelf brkVarName brkAv brkPropName brkType)))
(* dgb: "15-AUG-82 23:22")
(* Finds the active value which has been used to Break or trace this value on the list BrokenVariables, extracts
the old value, and removes same from list. Does all of them if self=NIL)
(COND
[(NULL self)
(for V in BrokenVariables bind do (ReplaceActiveValue (fetch brkAv of V)
(fetch localState
of (fetch brkAv of V))
(fetch brkSelf of V)
(fetch brkVarName of V)
(fetch brkPropName of V)
(fetch brkType of V))
finally (RETURN (PROG1 BrokenVariables (SETQ BrokenVariables NIL]
(T (for V in BrokenVariables bind do [COND
((AND (EQ self (fetch brkSelf of V))
(EQ varName (fetch brkVarName of V))
(EQ propName (fetch brkPropName of V))
(EQ type (fetch brkType of V)))
(ReplaceActiveValue (fetch brkAv of V)
(fetch localState
of (fetch brkAv of V))
self varName propName type)
(SETQ BrokenVariables (DREMOVE V BrokenVariables))
(RETURN (LIST self varName propName]
finally (HELPCHECK (LIST self varName propName)
"not broken. Type OK to go on."])
(FindObjectNames
[LAMBDA (entity key) (* dgb: "22-NOV-82 10:31")
(* Subfunction of GetObjectNames)
(DECLARE (USEDFREE object objectNames))
(COND
((EQ (fetch localRecord of entity)
object)
(COND
((NEQ key (fetch UID of entity))
(SETQ objectNames (CONS key objectNames)))
(T (SETQ objectNames (NCONC1 objectNames (MKSTRING key])
)
[METH AbstractClass New NIL
(* Stop abstract class from being instantiated)]
[METH Class Add (type name value prop)
(* Type is one of IV IVPROP CV CVPROP META METHOD. Adds the specified type to the class)]
[METH Class AddCV (varName newValue)
(* * 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)]
[METH Class AddIV (varName defaultValue otherProps)
(* Add a local IV to a class)]
[METH Class BreakMethod (selector)
(* Break selected method, or give choice if selector is NIL)]
[METH Class CommentMethods (selectors useDefaultComment)
(* 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 (*))]
[METH Class Copy (name)
(* * Create a new class that is a copy of some existing class. Copies the variables and
RuleSets. self is the class being copied.)]
[METH Class CopyCV (cvName toClass)
(* Copy the cvName and properties to toClass.)]
[METH Class CopyIV (ivName toClass)
(* Copy the ivName and properties to toClass.)]
[METH Class CopyMethod (selector newClass newSelector)
(* Copy method from self to newClass. newSelector defaults to selector)]
[METH Class Delete (type name prop)
(* Deletes the specified type from class. type is one of IV IVPROP CV CVPROP META METHOD)]
[METH Class Destroy NIL
(* Destroys (deletes)
a class by putting NIL as localRecord of entity. Undoable.)]
[METH Class Destroy! NIL
(* * Recursive version of Destroy. Destroys class and its subclasses.)]
[METH Class DestroyClass (classToDestroy)
(* Destroy the class specified by smashing its contents)]
[METH Class DestroyInstance (self)
(* smash back pointer to entity rec, the list of vars and var descriptions)]
[METH Class HasCV (CVName prop)
(* Tests if class has the specified class variable)]
[METH Class HasIV (IVName prop)
(* Tests if class has the specified instance variable)]
[METH Class HasIV! (IVName prop)
(* Tests if class has the specified instance variable)]
[METH Class MakeLocalMethod (selector dontBitchFlg)
(* make an inherited method be local)]
[METH Class MethodDoc (selector)
(* Show documentation for method in PPDefault window)]
[METH Class MethodSummary (dontPrintFlg printFile)
(* prints a summary of the methods in a class)]
[METH Class MoveMethod (newClass selector)
(* Move method specified by selector from this class to newClass)]
[METH Class OnFile (file)
(* See if class is on given file. Returns file if none given)]
[METH Class PP (file)
(* Prettyprint the class.)]
[METH Class PP! (file)
(* * Method for prettyPrinting self at all levels.)]
[METH Class PPM (selector)
(* Prettyprint the function which implements selector in this class. Prettyprint RuleSet if
method)
(method Class.PPMethod)]
[METH Class PPMethod (selector)
(* Prettyprint the function which implements selector in this class. Prettyprint RuleSet if
method)]
[METH Class PPV! (file)
(* * Method for prettyPrinting a self at all levels.)]
[METH Class PrintSummary (file)
(* Print a summary of elements of class)]
[METH Class Put (type name value prop)
(* Type is one of IV IVPROP CV CVPROP META METHOD. Adds the specified type to the class)
(method Class.Add)]
[METH Class UnbreakMethod (selector)
(* Break selected method, or give choice if selector is NIL)]
[METH Object AddIV (name value prop)
(* Adds an IV to instance. If it is not in regular set, puts it in assoc List on otherIVs)
(method AddIV)]
[METH Object At (varName prop)
(* 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.)
(method GetValue)]
[METH Object BreakIt (varName propName type brkOnGetAlsoFlg)
(* 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)]
[METH Object ChangeAssocKB (newKBName)
(* Marks object as changed and makes newKBName be its associatedKB)]
[METH Object CopyDeep (KBC)
(* * Copies the unit, sharing the iName list, copying instances, activeValues and lists)]
[METH Object CopyShallow (newInstance)
(* make a new instance with the same contents as self, or copy into an instance if given)
(method CopyInstance)]
[METH Object Get (varName propName)
(* Method indirection for GetValue)]
[METH Object HasIV (ivName prop)
(* Check to see if IV is on self. If so, return T)]
[METH Object DeleteIV (varName propName)
(* Removes an IV from an Instance. No longer shares IVName List with class. Some programs which
depend on IV may not work.)
(method DeleteIV)]
[METH Object Inspect (INSPECTLOC)
(* Inspect the object as class or instance, using INSPECTLOC as a region for the inspect
window, if it is given)]
[METH Object InstOf (class)
(* test if self is an instance of class)]
[METH Object InstOf! (class)
(* * Recursive version of InstOf.)]
[METH Object PP (file)
(* Pretty print an instance on a file)]
[METH Object PP! (file)
(* * Method for prettyPrinting a non-class object at all levels)]
[METH Object PPIVs (file)
(* * Called to prettyPrint a class definition on a file by the FILEPKGTYPE CLASSES and by the
PP: method in Class)]
[METH Object PPV! (file)
(* * Method for prettyPrinting a non-class object at all levels.)]
[METH Object PrintOn (file)
(* * This is the default printing function for object. It distinguishes between temporary
object, named objects, and others)]
[METH Object Put (varName newValue propName)
(* Method indirection for PutValue)]
[METH Object ReturnDefaultValue NIL
(* Returns LastDefaultValue.)]
[METH Object SaveInIT NIL
(* Save object in Lisp variable IT. Useful in Inspector)]
[METH Object Sublis (alist)
(* Copy this instance, substituting as specified by alist)]
[METH Object TraceIt (varName propName type traceGetAlsoFlg)
(* makes an active value which will cause tracing when this variable is changed. Will also
trace on fetches if traceGetAlsoFlg=T. Message on Object)]
[METH Object Understands (selector)
(* Tests if object will respond to selector)]
[METH Object WhereIs (name type propName)
(* Searches the supers hierarchy until it finds the class from which type is inherited.
type=NIL is METHODS)]
(DEFINEQ
(AbstractClass.New
[LAMBDA (self) (* mjs: "21-JUL-82 09:26")
(* Stop abstract class from being instantiated)
(ERROR self "Abstract class cannot be instantiated"])
(Class.Add
[LAMBDA (self type name value prop) (* dgb: "20-OCT-83 14:15")
(* 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.AddCV
[LAMBDA (self varName newValue) (* dgb: " 9-NOV-83 11:15")
(* * 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)
(AddCV self varName newValue])
(Class.AddIV
[LAMBDA (self varName defaultValue otherProps) (* dgb: " 9-NOV-83 11:17")
(* Add a local IV to a class)
(AddCIV self varName defaultValue otherProps])
(Class.BreakMethod
[LAMBDA (self selector) (* dgb: "29-Feb-84 08:50")
(* Break selected method, or give choice if selector is
NIL)
[AND (NULL selector)
(SETQ selector (MENU (create MENU
ITEMS ←(← self List (QUOTE Methods]
(COND
[selector (PROMPTPRINT (CONS (QUOTE Breaking)
(APPLY* (QUOTE BREAK)
(OR (FetchMethod self selector)
(ERROR selector (CONCAT " not found in " (ClassName
self]
(T (QUOTE NothingBroken])
(Class.CommentMethods
[LAMBDA (class selectors useDefaultComment) (* dgb: "29-Feb-84 08:50")
(* 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]
(T (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) (* dgb: "29-Feb-84 08:50")
(* 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 newSelector (GetMethod self selector prop)
prop))
(RETURN newFn])
(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: "29-Feb-84 15:46")
(* 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 (LoopsHelp classToDestroy "not a class for DestroyClass"]
(DeleteObjectName class (ClassName class))
(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 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))
(DeleteObjectUID class)
(RETURN (QUOTE DestroyedClass])
(Class.DestroyInstance
[LAMBDA (class self) (* dgb: "29-Feb-84 15:46")
(* smash back pointer to entity rec, the list of vars
and var descriptions)
(PROG (name entity)
(COND
((NULL (type? instance self))
(LoopsHelp self "not instance for DestroyInstance"))
(T (DeleteObjectName self)
(DeleteObjectUID self)
(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)
])
(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.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.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.MethodSummary
[LAMBDA (self dontPrintFlg printFile) (* dgb: " 6-DEC-83 13:16")
(* prints a summary of the methods in a class)
(COND
(dontPrintFlg (GetSourceMethods self))
(T (PRINTDEF (GetSourceMethods self)
NIL NIL NIL NIL (OR printFile PPDefault))
(TERPRI (OR printFile PPDefault])
(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.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) (* dgb: "29-Feb-84 08:50")
(* * 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)) bind (locals ←(← self List (QUOTE IVS)))
do (printout file .FONT (COND
((FMEMB iv locals)
BOLDFONT)
(T DEFAULTFONT))
" " iv " " .FONT DEFAULTFONT (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)) bind (locals ←(← self List (QUOTE CVS)))
do (printout file .FONT (COND
((FMEMB cv locals)
BOLDFONT)
(T DEFAULTFONT))
" " cv " " .FONT DEFAULTFONT (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)))
bind (locals ←(← self List (QUOTE SELECTORS)))
do (printout file .FONT (COND
((FMEMB selector locals)
BOLDFONT)
(T 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) (* dgb: "29-Feb-84 08:50")
(* 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.UnbreakMethod
[LAMBDA (self selector) (* dgb: "29-Feb-84 08:50")
(* Break selected method, or give choice if selector is
NIL)
[AND (NULL selector)
(SETQ selector (MENU (create MENU
ITEMS ←(← self List (QUOTE Methods]
(COND
[selector (APPLY* (QUOTE UNBREAK)
(OR (FetchMethod self selector)
(ERROR selector (CONCAT " not found in " className]
(T (QUOTE NothingUnbroken])
(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.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.Get
[LAMBDA (self varName propName) (* dgb: "21-OCT-83 06:55")
(* Method indirection for GetValue)
(GetValue self varName propName])
(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.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.PP
[LAMBDA (self file) (* dgb: "19-OCT-83 21:56")
(* Pretty print an instance on a file)
(PrettyPrintInstance self file])
(Object.PP!
[LAMBDA (self file) (* dgb: "29-Feb-84 08:50")
(* * 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.Put
[LAMBDA (self varName newValue propName) (* dgb: "21-OCT-83 06:58")
(* Method indirection for PutValue)
(PutValue self varName newValue propName])
(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: "29-Feb-84 08:50")
(* 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])
)
(PUTPROPS LOOPSUTILITY COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1797 20743 (AddValue 1807 . 2161) (BreakIt 2163 . 2528) (BreakMethod 2530 . 2806) (
CalledFns 2808 . 3542) (DC 3544 . 4002) (DELASSOC 4004 . 4185) (DM 4187 . 4626) (DefTemplate 4628 .
4871) (GetObjectNames 4873 . 5384) (HELPCHECK 5386 . 5816) (MapSupers 5818 . 6220) (MatchIVs 6222 .
7062) (MatchListDescr 7064 . 9461) (MatchDescr 9463 . 11093) (MoveClassVariable 11095 . 12053) (
MoveMethod 12055 . 13495) (MoveMethodsToFile 13497 . 14040) (MoveVariable 14042 . 14792) (PPC 14794 .
15018) (RemoveClassDef 15020 . 15694) (RenameInClass 15696 . 17338) (RenameMethodFunction 17340 .
17961) (TraceIt 17963 . 18357) (TraceMethod 18359 . 18635) (UnBreakIt 18637 . 20250) (FindObjectNames
20252 . 20741)) (27867 66676 (AbstractClass.New 27877 . 28162) (Class.Add 28164 . 29503) (Class.AddCV
29505 . 29852) (Class.AddIV 29854 . 30108) (Class.BreakMethod 30110 . 30721) (Class.CommentMethods
30723 . 32353) (Class.Copy 32355 . 33438) (Class.CopyCV 33440 . 33922) (Class.CopyIV 33924 . 34385) (
Class.CopyMethod 34387 . 36457) (Class.Delete 36459 . 37216) (Class.Destroy 37218 . 37760) (
Class.Destroy! 37762 . 38231) (Class.DestroyClass 38233 . 40715) (Class.DestroyInstance 40717 . 41490)
(Class.HasCV 41492 . 41896) (Class.HasIV 41898 . 42314) (Class.HasIV! 42316 . 42734) (
Class.MakeLocalMethod 42736 . 43222) (Class.MethodDoc 43224 . 44277) (Class.MethodSummary 44279 .
44688) (Class.MoveMethod 44690 . 45024) (Class.OnFile 45026 . 45397) (Class.PP 45399 . 45693) (
Class.PP! 45695 . 48659) (Class.PPMethod 48661 . 49620) (Class.PPV! 49622 . 51569) (Class.PrintSummary
51571 . 52394) (Class.UnbreakMethod 52396 . 52944) (Object.BreakIt 52946 . 53538) (
Object.ChangeAssocKB 53540 . 53911) (Object.CopyDeep 53913 . 54515) (Object.Get 54517 . 54763) (
Object.HasIV 54765 . 55183) (Object.Inspect 55185 . 55542) (Object.InstOf 55544 . 55857) (
Object.InstOf! 55859 . 56066) (Object.PP 56068 . 56315) (Object.PP! 56317 . 58863) (Object.PPIVs 58865
. 59309) (Object.PPV! 59311 . 61401) (Object.PrintOn 61403 . 62121) (Object.Put 62123 . 62378) (
Object.ReturnDefaultValue 62380 . 62836) (Object.SaveInIT 62838 . 63108) (Object.Sublis 63110 . 64753)
(Object.TraceIt 64755 . 65398) (Object.Understands 65400 . 65684) (Object.WhereIs 65686 . 66674)))))
STOP