(FILECREATED "20-SEP-83 18:12:32" {INDIGO}<LOOPS>SOURCES>LOOPSUTILITY.;6 25002
changes to: (FNS AddIV)
previous date: "22-JUL-83 15:06:05" {INDIGO}<LOOPS>SOURCES>LOOPSUTILITY.;5)
(PRETTYCOMPRINT LOOPSUTILITYCOMS)
(RPAQQ LOOPSUTILITYCOMS ((* Copyright (c)
1982 by Xerox Corporation)
(* * Functions the user expects to call)
(FNS * LOOPSUSERFNS)))
(* Copyright (c) 1982 by Xerox Corporation)
(* * Functions the user expects to call)
(RPAQQ LOOPSUSERFNS (AddIV AddValue BreakIt BreakMethod CalledFns ClassName CopyInstance DC DELASSOC
DM DefTemplate DeleteIV DeleteMethod GetObjectNames HELPCHECK MapSupers
MatchIVs MatchListDescr MatchDescr MoveClassVariable MoveMethod
MoveVariable PPC RemoveClassDef RenameInClass RenameMethod
RenameMethodFunction SplitAtom TraceIt TraceMethod UnBreakIt
FindObjectNames))
(DEFINEQ
(AddIV
[LAMBDA (self name value prop) (* dgb: "20-SEP-83 16:43")
(* Adds an IV to instance. If it is not in regular set,
puts it in assoc List on otherIVs)
(OR name (ERROR "A name must be given to add an IV"))
[COND
((← self HasIV name)
(PutValueOnly self name value prop))
(T (FillIVs self (Class self)
(NCONC1 (IVSource self)
(CONS name (COND
(prop (LIST NotSetValue prop value))
(T (LIST value]
value])
(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: "28-APR-83 18:40")
(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])
(ClassName
[LAMBDA (self) (* dgb: "19-NOV-82 15:22")
(* Returns className of class of object)
(COND
((type? class self)
(ffetch className of self))
((type? instance self)
(ffetch className of (ffetch class of self)))
(T (HELP self "has no class name"])
(CopyInstance
[LAMBDA (oldInstance newInstance) (* dgb: "28-FEB-83 15:52")
(* make a new instance with the same contents as self,
or copy into an instance if given)
[SETQ newInstance (FillIVs newInstance (Class oldInstance)
(MAPCAR (IVSource oldInstance)
(FUNCTION APPEND] (* Copy IVSource down one layer of list structure.)
(COND
((AND (fetch OBJUID of oldInstance)
(NULL (fetch OBJUID of newInstance))) (* Old one not temporary, but new one has non OBJUID
yet)
(NewEntity newInstance)))
newInstance])
(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])
(DeleteIV
[LAMBDA (self varName propName) (* dgb: "18-NOV-82 01:33")
(* Removes an IV from an Instance.
No longer shares IVName List with class.
Some programs which depend on IV may not work.)
(OR varName (ERROR "Name of variable to be deleted not specified"))
(PROG (source descr)
(SETQ source (GetInstanceSource self))
[COND
([NULL (SETQ descr (FASSOC varName (CDDR source]
(RETURN (QUOTE NotFound]
(COND
(propName (ObjRemProp (CDR descr)
propName))
(T (DREMOVE descr source)))
(RETURN (EVAL source])
(DeleteMethod
[LAMBDA (class selector prop) (* dgb: " 2-JUN-83 19:10")
(PROG (oth index pl fn freePos sel)
TRYAGAIN
(SETQ index (FindSelectorIndex (SETQ class (GetClassRec class))
selector))
(COND
((NULL index)
(SETQ selector (HELPCHECK class " does not contain the selector " selector
"Type
RETURN 'selectorName
to try again"))
(GO TRYAGAIN)))
(ChangedClass class)
(COND
((EQ prop T) (* T is special Flag for deleteing the function
definition too)
(SETQ prop NIL)
(CLEARW PROMPTWINDOW)
(printout PROMPTWINDOW (CHARACTER 7)
"Deleting function definition for "
(SETQ fn (GetMethod class selector))
T)
(DELDEF fn)))
(COND
[prop
(* * Replace current description by a new one. Do CONS so ObjRemProp works)
(SETQ oth (fetch otherMethodDescription of class))
(RETURN (PROG1 (ObjRemProp (SETQ pl (CONS NIL (\GetNthEntry oth index)))
prop)
(\PutNthEntry oth index (CDR pl]
(T (* \DeleteNthEntry requires knowing the freePos.
Must compute it from selectors because it checks for
occurrence of NIL in block to mark end)
(UNINTERRUPTABLY
(PROGN [SETQ freePos (\FreeEntryIndex (SETQ sel (fetch selectors of class]
(\DeleteNthEntry sel index freePos)
(\DeleteNthEntry (fetch methods of class)
index freePos)
(\DeleteNthEntry (fetch otherMethodDescription of class)
index freePos)))])
(GetObjectNames
[LAMBDA (object noNameFlg) (* dgb: " 5-JUN-83 20:31")
(COND
[(NULL (fetch OBJUID of object)) (* if a temporary object, give it a name, unless
noNameFlg set)
(AND (NULL noNameFlg)
(LIST (UID object]
(T (PROG (objectNames)
(MAPHASH GlobalNameTable (FUNCTION FindObjectNames))
(AND CurrentNameTable (MAPHASH CurrentNameTable (FUNCTION FindObjectNames)))
(RETURN objectNames])
(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])
(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: "13-JUN-83 17:04")
(* This is an undoable function which removes a class
definiton 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))
(UnNameEntity 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])
(RenameMethod
[LAMBDA (className oldSelector newSelector) (* dgb: "18-MAR-83 16:28")
(* Rename selector in class, and rename method also if
it is composite)
(SETQ className (GoodClassName className NIL T))
(PROG (newLocalFn oldDef (localFn (FindLocalMethod (GetClassRec className)
oldSelector))
fnPair)
(RETURN (COND
((NULL localFn)
(printout T oldSelector " not found in " className)
NIL)
((EQ [CAR (SETQ fnPair (SplitAtom localFn (QUOTE %.]
className)
(SETQ oldDef (CDR (GETDEF localFn)))
(DeleteMethod (GetClassRec className)
oldSelector)
(DELDEF localFn)
(DM className newSelector (CAR oldDef)
(CDR oldDef)))
(T (DeleteMethod (GetClassRec className)
oldSelector)
(DM className newSelector localFn])
(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])
(SplitAtom
[LAMBDA (atom splitChar) (* dgb: "22-JUN-82 11:14")
(* * Used to split method names etc at splitChar. Takes an atom and a char and returns a list of two atoms.
e.g. SplitAtom (A.B %.) -> (A B) Returns NIL if splitChar is not in atom)
(PROG ((pos (STRPOS splitChar atom)))
(RETURN (COND
((NULL pos)
NIL)
(T (CONS (SUBATOM atom 1 (SUB1 pos))
(SUBATOM atom (ADD1 pos])
(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: "28-APR-83 18:40")
(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])
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (903 24980 (AddIV 913 . 1484) (AddValue 1486 . 1840) (BreakIt 1842 . 2207) (BreakMethod
2209 . 2485) (CalledFns 2487 . 3221) (ClassName 3223 . 3650) (CopyInstance 3652 . 4372) (DC 4374 .
4832) (DELASSOC 4834 . 5015) (DM 5017 . 5456) (DefTemplate 5458 . 5701) (DeleteIV 5703 . 6415) (
DeleteMethod 6417 . 8148) (GetObjectNames 8150 . 8678) (HELPCHECK 8680 . 9110) (MapSupers 9112 . 9514)
(MatchIVs 9516 . 10356) (MatchListDescr 10358 . 12755) (MatchDescr 12757 . 14387) (MoveClassVariable
14389 . 15347) (MoveMethod 15349 . 16789) (MoveVariable 16791 . 17541) (PPC 17543 . 17767) (
RemoveClassDef 17769 . 18468) (RenameInClass 18470 . 20112) (RenameMethod 20114 . 21087) (
RenameMethodFunction 21089 . 21710) (SplitAtom 21712 . 22198) (TraceIt 22200 . 22594) (TraceMethod
22596 . 22872) (UnBreakIt 22874 . 24487) (FindObjectNames 24489 . 24978)))))
STOP