(FILECREATED "13-Mar-84 17:37:21" {INDIGO}<LOOPS>SOURCES>LOOPSEDIT.;22 26609
changes to: (FNS InstallMethods NewMethodFormat)
previous date: "29-Feb-84 15:57:54" {INDIGO}<LOOPS>SOURCES>LOOPSEDIT.;21)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LOOPSEDITCOMS)
(RPAQQ LOOPSEDITCOMS [(* Copyright (c)
1982 by Xerox Corporation)
(* * Functions used to create classes and instances)
(FNS * EDITFNS)
(ADDVARS (DT.EDITMACROS (class ObjSource ObjInstallSource)
(instance ObjSource ObjInstallSource)
(activeValue AvSource AvInstallSource])
(* Copyright (c) 1982 by Xerox Corporation)
(* * Functions used to create classes and instances)
(RPAQQ EDITFNS (AvInstallSource AvSource ChangeEditedClass ChangeEditedInstance ChangedClass
CheckAlist CheckClassSource CheckMetaClass CheckSupers
ComputeSupersList DefineClass EC EI EM EditClassSource GetClassSource
GetInstanceSource GetSourceCVs GetSourceIVs GetSourceInhCVs
GetSourceInhIVs GetSourceMeta GetSourceMethods GetSourceSupers
GoodClassName InstallClassSource InstallClassVariables
InstallInstanceVariables InstallMetaClass InstallMethods
InstallSupers ListPropNames NewMethodFormat ObjInstallSource
ObjSource OddLengthList RenameClassVariable RenameVariable))
(DEFINEQ
(AvInstallSource
[LAMBDA (av expr) (* dgb: "11-NOV-83 18:23")
(AND (OR (EQ 3 (LENGTH expr))
(ERROR "Too many items for activeValue"))
(create activeValue localState←(CAR expr)
getFn←(CADR expr)
putFn←(CADDR expr])
(AvSource
[LAMBDA (av) (* dgb: "11-NOV-83 18:20")
(LIST av:localState av:getFn av:putFn])
(ChangeEditedClass
[LAMBDA (self expression type flg) (* dgb: " 5-OCT-83 07:50")
(* What is done if an class is changed)
(AND flg (← self InstallEditSource expression))
self])
(ChangeEditedInstance
[LAMBDA (self expression type flg) (* dgb: " 4-OCT-83 11:34")
(* What is done if an instance is changed)
(← self InstallEditSource expression)
(AND (GetObjectName self)
(MARKASCHANGED (GetObjectName self)
(QUOTE INSTANCES)))
self])
(ChangedClass
[LAMBDA (classOrName) (* dgb: "26-DEC-83 14:18")
(* Fn to mark a class as having been edited. Called when class is edited or defined. Note: See function Modified
for marking an object as changed. See the Cleanup fns for informing the file package about changed definitions.)
(* dgb: "24-FEB-82 10:36")
(PROG (classRec) (* Allow input to be the class or class Name)
(SELECTQ (TYPENAME classOrName)
(class (SETQ classRec classOrName)
(SETQ classOrName (ClassName classOrName)))
(SETQ classRec (GetClassRec classOrName)))
(COND
(CurrentNameTable (Modified classRec T))
(T (MARKASCHANGED classOrName (QUOTE CLASSES])
(CheckAlist
[LAMBDA (type form) (* dgb: "18-JUN-82 09:42")
(* * Called from CheckClassSource to check formatting of lists in source. Checks the list form to make sure that
each element is a list starting with an atom. Complains on violations, and returns T if any errors were found, NIL
otherwise)
(for pair in form bind errorOccurred do (COND
((NLISTP pair)
(printout T type
"s must be given in a list (name prop1 val1 ...)"
T)
(RETURN T))
((NOT (LITATOM (CAR pair)))
(printout T type , .P2 (CAR pair)
" should be atomic to be a name" T)
(SETQ errorOccurred T))
((OddLengthList (CDDR pair))
(printout T (CAR pair)
" has a property list which is not of even length."
T)
(SETQ errorOccurred T)))
finally (RETURN errorOccurred])
(CheckClassSource
[LAMBDA (source className) (* dgb: "31-OCT-83 09:14")
(* Checks the list structure form of the definition to make sure that no simple problems exist.
If there are problems, notifies the user and calls ERROR. This should cause the user to end up back in the
editor.)
(for item in source bind form ERRFLG
do (SETQ form (CDR item))
(SELECTQ (CAR item)
(MetaClass (SETQ ERRFLG (OR (CheckMetaClass form)
ERRFLG)))
(Supers (SETQ ERRFLG (OR (CheckSupers form)
ERRFLG)))
(ClassVariables (SETQ ERRFLG (OR (CheckAlist "ClassVariable" form)
ERRFLG)))
(InstanceVariables (SETQ ERRFLG (OR (CheckAlist "InstanceVariable" form)
ERRFLG)))
(Methods (SETQ ERRFLG (OR (CheckAlist "Method" form)
ERRFLG)))
((IVsInherited CVsInherited) (* Do nothing. There to aid in editing)
)
(PROGN (printout T item , " is not a recognized item for class definition" T)
(SETQ ERRFLG T)))
finally (RETURN ERRFLG])
(CheckMetaClass
[LAMBDA (form) (* mjs: " 1-JUL-82 16:45")
(* * Checks to see if the metaClass is a real class and the property list length is even.)
(PROG (metaClass)
(SETQ metaClass (CAR form))
(COND
((NULL form)
(RETURN))
((NULL metaClass)
(RPLACA form (QUOTE Class)))
((NULL (GoodClassName metaClass form))
(printout T "MetaClass " metaClass " is not a defined class" T)
(RETURN T)))
(COND
((NULL (OddLengthList form))
(printout T "Property list of class is not of even length" T)
(RETURN T)))
(RETURN NIL])
(CheckSupers
[LAMBDA (supersForm) (* mjs: " 1-JUL-82 16:47")
(* Checks the supersForm of supersForm to make sure that
each name is a defined class.)
(PROG (errorOccurred extendedSupers) (* First check that class names are valid.)
[for tail on supersForm bind super do (SETQ super (CAR tail))
(OR (COND
((LISTP super)
(GoodClassName (CAR super)
super))
(T (GoodClassName super tail)))
(PROGN (printout T super
" must be replaced in definition, or defined as a class."
T)
(SETQ errorOccurred T]
(RETURN errorOccurred])
(ComputeSupersList
[LAMBDA (localSupers inheritList) (* dgb: "28-APR-83 17:07")
(* Compute closure of localSupers, removing earlier
duplicates)
(COND
((NULL localSupers)
inheritList)
(T (PROG (temp (first (CAR localSupers)))
(SETQ temp (ComputeSupersList (fetch localSupers of first)
(ComputeSupersList (CDR localSupers)
inheritList)))
(RETURN (COND
((FMEMB first temp)
temp)
(T (CONS first temp])
(DefineClass
[LAMBDA (name supers self) (* dgb: "29-Feb-84 15:40")
(* Defines a new class. className is the name of the new class or metaClass. supers is a list of class designators
as follows: Each class designator is an atom which is a class designator -- treated recursively in inheritance -
or a singleton list of such a className -- treated as a patch of behavior. If DefineClass was invoked via a
(← self New) message, -
self is the class to which the message was sent (either Class or MetaClass or subclass of MetaClass.) If some
super is not yet a defined class, DefineClass asks the user to correct the list. Default on supers is
(Object) if self is Class, and is Class if self is MetaClass or one of its subClasses.)
(PROG (classRec (Supers supers)) (* Default case is that new class is not a MetaClass.)
LPName
(COND
((NULL (AND name (LITATOM name)))
(SETQ name (LoopsHelp name
"must be a LITATOM to be a class name.
Definition aborted.
Type ↑ to return."))
(GO LPName)))
(SETQ self (OR self $Class)) (* Set default Supers according to whether you are being
created by MetaClass itself)
[SETQ Supers (COND
[Supers (COND
((NULL (CheckSupers Supers))
Supers)
(T (ERROR supers "is a bad supers list"]
((EQ self ($ MetaClass))
(LIST (QUOTE Class)))
(T (LIST (QUOTE Object] (* Substitute self as the metaClass in the
classTemplate, and substitute the supers too.)
(* Install the new class)
[InstallClassSource name (BQUOTE ((MetaClass , self Edited: , (EDITDATE NIL INITIALS))
(Supers ,. Supers)
(InstanceVariables)
(Methods)
(ClassVariables]
(* PutClass will mark this class as changed)
(SETQ LASTCLASS name)
(RETURN (GetClassRec name])
(EC
[LAMBDA (className coms) (* mjs: "21-JUL-82 08:11")
(* Edit the symbolic class definition)
(PROG ((name className))
(COND
((NULL name)
(SETQ name LASTCLASS)))
[COND
((LISTP name)
(SETQ name (CAR name]
(COND
((NULL (SETQ name (GoodClassName name)))
(ERROR className "not editable")))
(RETURN (← (GetClassRec name)
Edit coms])
(EI
[LAMBDA (INST commands) (* dgb: "12-OCT-82 23:47")
(← (COND
((type? instance INST)
INST)
((LITATOM INST)
(GetObjectRec INST))
(T (EVAL INST)))
Edit commands])
(EM
[LAMBDA (className selector commands) (* dgb: " 6-DEC-83 11:19")
(PROG (temp (cn className))
LP [COND
([NULL (SETQ cn (CAR (NLSETQ (GoodClassName cn NIL T]
(OR (AND (NULL selector)
(SETQ temp (SplitAtom className (QUOTE %.)))
(SETQ cn (CAR temp))
(SETQ selector (CDR temp))
(GO LP))
(ERROR cn "not a class name"]
(RETURN (← (GetClassRec cn)
EditMethod selector commands])
(EditClassSource
[LAMBDA (EXP COMS NAME) (* dgb: "29-NOV-82 13:38")
(* Edit source description for class)
(DECLARE (SPECVARS CHANGEDFLG NAME))
(PROG (CHANGEDFLG)
LP [SETQ EXP (EDITE EXP COMS NAME (QUOTE CLASSES)
(FUNCTION (LAMBDA (ATM EXPR TYPE FLG)
(COND
(FLG (SETQ CHANGEDFLG T))
(T (RETFROM (QUOTE EC)
NAME]
[COND
(CHANGEDFLG (* Here if the source has changed at all)
(COND
((NULL (ERSETQ (EVAL EXP)))
(* Evaluate form to install class. If there was an error, then value of ERSETQ was NIL. This implies a syntax
error, so loop back to editor)
(SETQ COMS NIL)
(GO LP))
(T (* Evaluation was succesful, class was changed.
PutClass will mark the class object as changed.)
(PutClass (GetClassRec NAME)
(EDITDATE NIL INITIALS)
(QUOTE Edited:]
(RETURN (SETQ LASTCLASS NAME])
(GetClassSource
[LAMBDA (className) (* dgb: "13-OCT-83 22:06")
(* Computes an editable list structure which represents
the "source" for a class definition)
(PROG [(classRec (COND
((LITATOM className)
(GetObjectRec className))
((type? class className) (* In this case it should be a class record itself)
(PROG1 className (SETQ className (ClassName className]
(COND
((NOT (type? class classRec))
(RETURN NIL)))
(RETURN (← classRec MakeFileSource])
(GetInstanceSource
[LAMBDA (self) (* dgb: "11-NOV-82 02:57")
(* * Computes a list structure which can be edited, and which when evaluated will reset contents of instance)
[COND
((ATOM self)
(SETQ self (GetObjectRec self]
(COND
((type? instance self)
(CONS (QUOTE DEFINST)
(CONS (ClassName self)
(CONS (GetObjectNames self)
(IVSource self])
(GetSourceCVs
[LAMBDA (classRec) (* dgb: " 3-FEB-82 10:02")
(* Gets part of source for class -- list of local CVs
values and properties)
(for varName in (fetch (class cvNames) of classRec) as varDescr in (fetch (class cvDescrs)
of classRec)
collect (CONS varName varDescr])
(GetSourceIVs
[LAMBDA (classRec) (* dgb: "26-NOV-82 10:32")
(for varName in (fetch (class localIVs) of classRec) collect (CONS varName (FetchCIVDescr
classRec
varName])
(GetSourceInhCVs
[LAMBDA (self) (* dgb: "31-OCT-83 08:54")
(* Get a full description of all the IVs and their
properties)
(for iv in (← self List!(QUOTE CVs)) collect (CONS iv (CONS (GetClassValue self iv)
(for prop in (← self List!(QUOTE
CVProps)
iv)
join (LIST prop
(GetClassValue self iv
prop])
(GetSourceInhIVs
[LAMBDA (self) (* dgb: "31-OCT-83 09:38")
(* Get a full description of all the IVs and their
properties)
(for iv in (← self List!(QUOTE IVs)) collect (NCONC (LIST iv (GetClassIV self iv))
(for prop in (← self List!(QUOTE IVProps)
iv)
join (LIST prop (GetClassIV self iv prop])
(GetSourceMeta
[LAMBDA (classRec) (* dgb: "27-JAN-82 22:45")
(CONS (ClassName (fetch metaClass of classRec))
(fetch otherClassDescription of classRec])
(GetSourceMethods
[LAMBDA (classRec) (* dgb: "18-OCT-83 22:30")
(PROG ((sels (fetch selectors of classRec))
(meths (fetch (class methods) of classRec)))
(RETURN (COND
((NULL sels)
NIL)
[(LISTP sels)
(SORT (for selector in sels as method in meths collect (CONS selector
(CONS method
methProps]
(T (SORT (for I from 0 by 2 bind sel until (NULL (SETQ sel (\GetNthEntry sels I)))
collect (BQUOTE (, sel , (\GetNthEntry meths I)
args , (GetMethod classRec sel (QUOTE args))
doc , (GetMethod classRec sel (QUOTE doc])
(GetSourceSupers
[LAMBDA (classRec) (* dgb: "23-APR-83 16:56")
(for s in (fetch (class localSupers) of classRec) collect (ClassName s])
(GoodClassName
[LAMBDA (classNameOrClass tail errFlg) (* dgb: "26-JUN-83 23:20")
(* * Checks classNameOrClass to see if defines a class. If not tries to make a spelling correction, or define a
new class. If tail is specified, it will stuff any corrections into the (CAR tail). If errFlg is T, will cause an
error class name is invalid and it can not fix it by spelling correction. Returns a class classNameOrClass or NIL)
(COND
((type? class classNameOrClass)
(fetch className of classNameOrClass))
(T (OR (AND (GetClassRec classNameOrClass)
classNameOrClass)
(FIXSPELL classNameOrClass NIL AllObjectNames T tail NIL (QUOTE PICKONE)
T)
(OR (AND errFlg (ERROR classNameOrClass "is not a defined class"))
(COND
((EQ (QUOTE Y)
(ASKUSER NIL (QUOTE Y)
(LIST "Should" classNameOrClass "be defined as a new class")
NIL))
(← ($ Class)
New classNameOrClass)
classNameOrClass])
(InstallClassSource
[LAMBDA (className source) (* dgb: "26-DEC-83 14:50")
(* Called by DEFCLASS to actually create the class record from the Source. Calls CheckClassSource to check the
syntactic sourceForm of the source and causes an error if there is one. If editing, this causes the user to be
thrown back into the editor.)
(PROG (item (classRec (GetClassRec className))
sourceForm)
[COND
((NULL classRec) (* Create class record.)
(SETQ classRec (NewClass className)))
(T (MARKASCHANGED className (QUOTE CLASSES]
(* * Now install in order MetaClass Supers ClassVariables InstanceVariables Methods)
[COND
((SETQ sourceForm (FASSOC (QUOTE MetaClass)
source))
(InstallMetaClass classRec (CDR sourceForm]
[COND
((SETQ sourceForm (FASSOC (QUOTE Supers)
source))
(InstallSupers classRec (CDR sourceForm]
[COND
((SETQ sourceForm (FASSOC (QUOTE ClassVariables)
source))
(InstallClassVariables classRec (CDR sourceForm]
[COND
((SETQ sourceForm (FASSOC (QUOTE Methods)
source))
(InstallMethods classRec (CDR sourceForm]
(COND
((SETQ sourceForm (FASSOC (QUOTE InstanceVariables)
source))
(InstallInstanceVariables classRec (CDR sourceForm])
(InstallClassVariables
[LAMBDA (classRec form) (* dgb: " 6-JUN-82 17:52")
(/replace cvNames of classRec with (MAPCAR form (QUOTE CAR)))
(/replace cvDescrs of classRec with (MAPCAR form (QUOTE CDR])
(InstallInstanceVariables
[LAMBDA (classRec form) (* dgb: "22-OCT-82 17:11")
(* * Starting with form of ivName decription pairs, this installs the new descriptions in the class.
If the same set of IVs is given as is currently in the class, it just updates the values and properties in the
current list by smashing the cell stored in ivDescrs. Otherwise causes an update of IVDescrs, and of subs of this
class.)
(PROG [(varNames (for pair in form collect (CAR pair]
(COND
[(EQUAL varNames (fetch localIVs of classRec)) (* no new IVs)
(for pair descr in form do
(* * Fix up descriptions)
(SETQ descr (FetchCIVDescr classRec (CAR pair)))
[COND
((NULL descr)
(PutValueOnly classRec (CAR pair)
(CADR pair))
(SETQ descr (FetchCIVDescr classRec (CAR pair]
(COND
((NEQ descr (CDR pair))
(* * Smash the cell which is the descr so that subclasses sharing this descr will see the update)
(/RPLACA descr (CADR pair))
(/RPLACD descr (CDDR pair]
(T
(* * Some significant change in IVs. Set up for updating by putting only local description in ivDescrs)
(/replace localIVs of classRec with varNames)
(/replace ivNames of classRec with varNames)
[/replace ivDescrs of classRec with (for pair in form collect (OR (CDR pair)
(LIST NIL]
(UpdateIVDescrs classRec])
(InstallMetaClass
[LAMBDA (classRec form) (* dgb: " 6-JUN-82 17:51")
(/replace metaClass of classRec with (GetClassRec (CAR form)))
(/replace otherClassDescription of classRec with (CDR form])
(InstallMethods
[LAMBDA (classRec form) (* dgb: "13-Mar-84 17:31")
(* Called by InstallClassSource for Methods only)
(/replace selectors of classRec with (\BlockFromList form (FUNCTION CAR)))
(/replace methods of classRec with (\BlockFromList form (FUNCTION CADR)))
(for methForm in form bind file files methName fnName sel (cName ←(ClassName classRec))
do (DefMethObj cName (SETQ sel (pop methForm))
(SETQ fnName (pop methForm))
(LISTGET methForm (QUOTE args))
(LISTGET methForm (QUOTE doc))
(for X by (CDDR X) on methForm when (AND (NEQ (QUOTE doc)
(CAR X))
(NEQ (QUOTE args)
(CAR X)))
join (LIST (CAR X)
(CADR X])
(InstallSupers
[LAMBDA (classRec form) (* dgb: "29-Feb-84 11:42")
(* * Install the list of super classes in the classRec. Special case check for Object and NULL supers list)
(PROG [class addList deleteList (currentSupers (fetch localSupers of classRec))
(newSupers (for name in (OR form (QUOTE (Object))) collect (GetClassRec
(COND
((LISTP name)
(* This is a patch to take care of old versions of Loops
in which class names could be put in parens)
(CAR name))
(T name]
(COND
((EQ (QUOTE Object)
(fetch className of classRec))
(RETURN)))
[COND
((EQUAL currentSupers newSupers) (* no change in supers)
(RETURN (QUOTE NoUpdateRequired]
(FlushMethodCache)
(replace localSupers of classRec with newSupers)
(replace supers of classRec with (ComputeSupersList newSupers))
(SETQ addList (LDIFFERENCE newSupers currentSupers))
(SETQ deleteList (LDIFFERENCE currentSupers newSupers))
(* For new items on newSupers, add back pointers, and
for deleted items on current supers delete back
pointers)
[for super in addList do (/replace subClasses of super with (CONS classRec
(fetch subClasses
of super]
[for super in deleteList do (/replace subClasses of super
with (REMOVE classRec (fetch subClasses of super]
(* Now put new supers list in class, and update the
instance variables)
(UpdateClassIVs classRec])
(ListPropNames
[LAMBDA (lst) (* dgb: " 8-DEC-81 23:18")
(for x in lst by (CDDR x) collect x])
(NewMethodFormat
[LAMBDA (file) (* dgb: "13-Mar-84 17:31")
(* * Change method of storing methods on file so that methods are independent entities on file)
(for C in (FILECOMSLST file (QUOTE CLASSES)) do (for sel methName in (← ($! C)
List
(QUOTE Methods))
do (SETQ methName (MethName C sel))
(DELFROMFILE methName (QUOTE FNS)
file)
(ADDTOFILE methName (QUOTE METHODS)
file])
(ObjInstallSource
[LAMBDA (obj expression) (* dgb: "11-NOV-83 18:21")
(← obj InstallEditSource expression])
(ObjSource
[LAMBDA (self) (* dgb: "11-NOV-83 18:21")
(← self MakeEditSource])
(OddLengthList
[LAMBDA (pairList) (* dgb: "18-JUN-82 09:39")
(* * Syntax checking function used by CheckAList and CheckMetaClass)
(for p on pairList by (CDDR p) do (COND
((NULL (CDR p))
(RETURN T)))
finally (RETURN NIL])
(RenameClassVariable
[LAMBDA (className oldVarName newVarName) (* dgb: "18-NOV-82 03:20")
(* Renames the variable in the class, but does NOT look for references of the variable in the methods.
Returns newVarName if successful, NIL otherwise)
(PROG (source varList)
(OR (SETQ source (GetClassSource className))
(RETURN NIL))
(OR (SETQ varList (FASSOC oldVarName (FASSOC (QUOTE ClassVariables)
source)))
(RETURN NIL))
(RPLACA varList newVarName)
(EVAL source)
(RETURN newVarName])
(RenameVariable
[LAMBDA (className oldVarName newVarName classVarFlg) (* dgb: "10-NOV-82 16:06")
(* Renames the variable in the class, but does NOT look for references of the variable in the methods.
Returns newVarName if successful, NIL otherwise)
(PROG (source varList)
(OR (SETQ source (GetClassSource className))
(RETURN NIL))
(OR (SETQ varList (FASSOC oldVarName (FASSOC (COND
(classVarFlg (QUOTE ClassVariables))
(T (QUOTE InstanceVariables)))
source)))
(RETURN NIL))
(RPLACA varList newVarName)
(EVAL source)
(RETURN newVarName])
)
(ADDTOVAR DT.EDITMACROS (class ObjSource ObjInstallSource)
(instance ObjSource ObjInstallSource)
(activeValue AvSource AvInstallSource))
(PUTPROPS LOOPSEDIT COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1363 26376 (AvInstallSource 1373 . 1659) (AvSource 1661 . 1810) (ChangeEditedClass 1812
. 2094) (ChangeEditedInstance 2096 . 2465) (ChangedClass 2467 . 3322) (CheckAlist 3324 . 4302) (
CheckClassSource 4304 . 5456) (CheckMetaClass 5458 . 6161) (CheckSupers 6163 . 6975) (
ComputeSupersList 6977 . 7576) (DefineClass 7578 . 9743) (EC 9745 . 10273) (EI 10275 . 10511) (EM
10513 . 11003) (EditClassSource 11005 . 12140) (GetClassSource 12142 . 12805) (GetInstanceSource 12807
. 13261) (GetSourceCVs 13263 . 13726) (GetSourceIVs 13728 . 13997) (GetSourceInhCVs 13999 . 14533) (
GetSourceInhIVs 14535 . 15018) (GetSourceMeta 15020 . 15244) (GetSourceMethods 15246 . 15966) (
GetSourceSupers 15968 . 16177) (GoodClassName 16179 . 17201) (InstallClassSource 17203 . 18675) (
InstallClassVariables 18677 . 18951) (InstallInstanceVariables 18953 . 20579) (InstallMetaClass 20581
. 20850) (InstallMethods 20852 . 21747) (InstallSupers 21749 . 23724) (ListPropNames 23726 . 23894) (
NewMethodFormat 23896 . 24454) (ObjInstallSource 24456 . 24611) (ObjSource 24613 . 24748) (
OddLengthList 24750 . 25080) (RenameClassVariable 25082 . 25696) (RenameVariable 25698 . 26374)))))
STOP