(FILECREATED "22-SEP-83 15:19:55" {INDIGO}<LOOPS>SOURCES>LOOPSEDIT.;6 24999
changes to: (FNS DefineClass)
previous date: "20-SEP-83 12:05:40" {INDIGO}<LOOPS>SOURCES>LOOPSEDIT.;5)
(PRETTYCOMPRINT LOOPSEDITCOMS)
(RPAQQ LOOPSEDITCOMS ((* Copyright (c)
1982 by Xerox Corporation)
(* * Functions used to create classes and instances)
(FNS * EDITFNS)))
(* Copyright (c) 1982 by Xerox Corporation)
(* * Functions used to create classes and instances)
(RPAQQ EDITFNS (ChangedClass CheckAlist CheckClassSource CheckMetaClass CheckSupers ComputeSupersList
DefineClass EC EI EM EditClassSource EditMethod GetClassSource
GetInstanceSource GetSourceCVs GetSourceIVs GetSourceMeta
GetSourceMethods GetSourceSupers GoodClassName InstallClassSource
InstallClassVariables InstallInstanceVariables InstallMetaClass
InstallMethods InstallSupers ListPropNames OddLengthList
RenameClassVariable RenameVariable))
(DEFINEQ
(ChangedClass
[LAMBDA (classOrName) (* dgb: " 6-JUN-82 17:16")
(* 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)))
(MARKASCHANGED classOrName (QUOTE CLASSES))
(Modified classRec T])
(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) (* mjs: " 1-JUL-82 16:48")
(* 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)))
(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: "22-SEP-83 14:35")
(* 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 (HELP 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: " 1-MAR-83 14:15")
(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])
(EditMethod
[LAMBDA (class selector commands) (* dgb: "19-SEP-83 13:36")
(* Called by Class.EditMethod.
Finds the function associated with selector in class,
and calls editor on it)
(PROG (index method selectors ruleSet)
TRYAGAIN
(COND
((NULL selector)
(COND
([NULL (SETQ selectors (SORT (← class List (QUOTE Selectors]
(* No selectors in class)
(RETURN NIL)))
(OR (SETQ selector (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ← selectors)))
(RETURN NIL))
(GO TRYAGAIN))
((SETQ method (FindLocalMethod class selector))
(GO OUT))
[(SETQ method (FetchMethod class selector))
(COND
((EQ (QUOTE YES)
(INTTY (CONCAT selector " is not a local method of " class
". Should I make it local for editing? ")
(QUOTE (YES NO))
"Type yes to edit locally defined copy of method"))
(SETQ method (← class MakeLocalMethod selector))
(GO OUT]
((SETQ selector (FIXSPELL selector 60 (← class List!(QUOTE Selectors))
T NIL NIL (QUOTE PICKONE)
T))
(GO TRYAGAIN))) (* If one falls through then nothing to be done)
(PrintStatus selector " is not a selector of " class)
(RETURN NIL)
OUT (RETURN (COND
([NEQ NotSetValue (SETQ ruleSet (GetItHere class selector (QUOTE RuleSet)
(QUOTE METHOD]
(* Here if the method is implemented by a RuleSet.)
(← (GetObjectRec ruleSet)
ER))
((NULL (GETDEF method))
(PrintStatus method " is not a known function."))
(T (PROG1 (APPLY (QUOTE EDITF)
(CONS method commands))
(← class CommentMethods (LIST selector)
T])
(GetClassSource
[LAMBDA (className) (* dgb: " 3-FEB-82 09:58")
(* Computes an editable list structure which represents
the "source" for a class definition)
(PROG [(classRec (COND
((LITATOM className)
(GetClassRec className))
(T (* In this case it should be a class record itself)
(PROG1 className (SETQ className (ClassName className]
(COND
((NULL classRec)
(RETURN NIL)))
(RETURN (LIST (QUOTE DEFCLASS)
className
(CONS (QUOTE MetaClass)
(GetSourceMeta classRec))
(CONS (QUOTE Supers)
(GetSourceSupers classRec))
(CONS (QUOTE ClassVariables)
(GetSourceCVs classRec))
(CONS (QUOTE InstanceVariables)
(GetSourceIVs classRec))
(CONS (QUOTE Methods)
(GetSourceMethods classRec])
(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])
(GetSourceMeta
[LAMBDA (classRec) (* dgb: "27-JAN-82 22:45")
(CONS (ClassName (fetch metaClass of classRec))
(fetch otherClassDescription of classRec])
(GetSourceMethods
[LAMBDA (classRec) (* dgb: "25-MAY-83 16:10")
(PROG ((sels (fetch selectors of classRec))
(meths (fetch (class methods) of classRec))
(oth (fetch (class otherMethodDescription) of classRec)))
(RETURN (COND
((NULL sels)
NIL)
[(LISTP sels)
(SORT (for selector in sels as method in meths as methProps in oth
collect (CONS selector (CONS method methProps]
(T (for I from 0 by 2 bind sel until (NULL (SETQ sel (\GetNthEntry sels I)))
collect (CONS sel (CONS (\GetNthEntry meths I)
(\GetNthEntry oth I])
(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: "25-AUG-82 18:21")
(* 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]
(* * 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: "29-APR-83 10:33")
(* Called by InstallClassSource for Methods only)
(/replace selectors of classRec with (\BlockFromList form (FUNCTION CAR)))
(/replace methods of classRec with (\BlockFromList form (FUNCTION CADR)))
(/replace otherMethodDescription of classRec with (\BlockFromList form (FUNCTION CDDR])
(InstallSupers
[LAMBDA (classRec form) (* dgb: "25-MAY-83 15:07")
(* * 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)))
(replace localSupers of classRec with newSupers)
(replace supers of classRec with (ComputeSupersList newSupers))
[COND
((EQUAL currentSupers newSupers) (* no change in supers)
(RETURN (QUOTE NoUpdateRequired]
(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])
(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])
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1012 24977 (ChangedClass 1022 . 1850) (CheckAlist 1852 . 2830) (CheckClassSource 2832
. 4076) (CheckMetaClass 4078 . 4781) (CheckSupers 4783 . 5595) (ComputeSupersList 5597 . 6196) (
DefineClass 6198 . 8358) (EC 8360 . 8888) (EI 8890 . 9126) (EM 9128 . 9618) (EditClassSource 9620 .
10755) (EditMethod 10757 . 12753) (GetClassSource 12755 . 13745) (GetInstanceSource 13747 . 14201) (
GetSourceCVs 14203 . 14666) (GetSourceIVs 14668 . 14937) (GetSourceMeta 14939 . 15163) (
GetSourceMethods 15165 . 15885) (GetSourceSupers 15887 . 16096) (GoodClassName 16098 . 17120) (
InstallClassSource 17122 . 18543) (InstallClassVariables 18545 . 18819) (InstallInstanceVariables
18821 . 20447) (InstallMetaClass 20449 . 20718) (InstallMethods 20720 . 21231) (InstallSupers 21233 .
23179) (ListPropNames 23181 . 23349) (OddLengthList 23351 . 23681) (RenameClassVariable 23683 . 24297)
(RenameVariable 24299 . 24975)))))
STOP