(FILECREATED "21-SEP-83 12:39:35" {INDIGO}<LOOPS>SOURCES>LOOPSACCESS.;8 44669
changes to: (FNS AddCV)
previous date: "20-SEP-83 18:11:11" {INDIGO}<LOOPS>SOURCES>LOOPSACCESS.;7)
(PRETTYCOMPRINT LOOPSACCESSCOMS)
(RPAQQ LOOPSACCESSCOMS [(* Copyright (c)
1983 by Xerox Corporation)
(* Access functions which don't know the structure of the underlying
datatypes)
(FNS * VARACCESSFNS)
(* Short Synonym for GetObjectRec)
(P (MOVD? (QUOTE GetObjectRec)
(QUOTE $!)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML $)
(LAMA])
(* Copyright (c) 1983 by Xerox Corporation)
(* Access functions which don't know the structure of the underlying datatypes)
(RPAQQ VARACCESSFNS ($ AddCIV AddCV AddMethod DeleteCIV DeleteCV DeleteClassProp FetchCIVDescr
FetchCIVValueOnly FetchCVOnly FetchMethodClass FetchMethodDescr FetchNthDescr
FetchNthDescr! FetchNthValue FetchNthValueOnly GetCVHere GetClass GetClassHere
GetClassIV GetClassOnly GetClassValue GetClassValueOnly GetIt GetItHere
GetItOnly GetLocalState GetLocalStateOnly GetMethod GetMethodHere
GetMethodOnly GetNthValue Parse@ ParseAccess ParseBang ParseExpr ParsePut@
PushClassValue PushNewValue PushValue PutClass PutClassIV PutClassOnly
PutClassValue PutClassValueOnly PutIt PutItNested PutItOnly PutMethod
PutMethodOnly PutNthValue StoreNthValue StoreNthValueOnly))
(DEFINEQ
(%$
[NLAMBDA (name) (* dgb: " 2-JUN-83 13:37")
(* Get object given name quoted)
(GetObjectRec name])
(AddCIV
[LAMBDA (class varName defaultValue otherProps) (* dgb: "20-SEP-83 16:33")
(COND
([AND (NULL varName)
(NULL (SETQ varName (PromptRead "Please type the nave of the new IV: "]
NIL)
((← class HasIV varName)
(PutClassIV class varName defaultValue))
(T [InstallInstanceVariables class (NCONC1 (GetSourceIVs class)
(CONS varName (CONS defaultValue otherProps]
(OR (← class HasIV varName (QUOTE doc))
(PutClassIV class varName (BQUOTE (* Undocumented InstanceVariable added by ,
(USERNAME NIL T)))
(QUOTE doc)))
varName])
(AddCV
[LAMBDA (class varName newValue) (* dgb: "21-SEP-83 11:09")
(* * 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)
(COND
([AND (NULL varName)
(NULL (SETQ varName (PromptRead "Please type name of new CV: "]
NIL)
((FMEMB varName (← class List (QUOTE CVs)))
(AND newValue (PutClassValueOnly class varName newValue))
NIL)
(T (InstallClassVariables class (NCONC1 (GetSourceCVs class)
(LIST varName newValue)))
(OR (← class HasCV varName (QUOTE doc))
(PutClassValue class varName (BQUOTE (* Undocumented CV added by ,
(USERNAME NIL T)))
(QUOTE doc)))
T])
(AddMethod
[LAMBDA (class selector method) (* dgb: " 3-JUN-83 11:42")
(* Adds a method to a class, or replaces the function
named if selecor is already local to class)
(PROG (index freePos sels)
(RETURN (COND
((SETQ index (FindSelectorIndex class selector))
(* already in class)
(PutMethodNth class index method))
(T (UNINTERRUPTABLY
[SETQ freePos (\FreeEntryIndex (SETQ sels (fetch selectors of class]
(replace selectors of class with (\AddBlockEntry sels selector freePos))
(replace methods of class with (\AddBlockEntry (fetch methods
of class)
method freePos))
(replace otherMethodDescription of class
with (\AddBlockEntry (fetch otherMethodDescription of class)
NIL freePos)))])
(DeleteCIV
[LAMBDA (class varName prop) (* dgb: "26-NOV-82 10:33")
(* Deletes an IV from a class, or a property from its
propList if prop is given.)
(ChangedClass class)
(COND
((NULL (← class HasIV varName))
(HELPCHECK varName "is not a local instance variable of class " (ClassName class)
"
Type OK to ignore error and go on."))
(prop (ChangedClass class)
(ObjRemProp (FetchCIVDescr class varName)
prop))
(T (InstallInstanceVariables class (DELASSOC varName (GetSourceIVs class])
(DeleteCV
[LAMBDA (class varName prop) (* dgb: "28-APR-83 17:47")
(* Deletes a classVariable or one of its properties)
(ChangedClass class)
(COND
(prop (ObjRemProp (FetchCVDescr class varName)
prop))
(T (for var varFoundFlg in (fetch cvNames of class) as descr in (fetch cvDescrs of class)
bind newNames newDescr
first (SETQ newNames (CONS))
(SETQ newDescr (CONS))
do (COND
((NEQ var varName)
(TCONC newNames var)
(TCONC newDescr descr))
(T (SETQ varFoundFlg T)))
finally (replace cvNames of class with (CAR newNames))
(replace cvDescrs of class with (CAR newDescr))
(RETURN (AND varFoundFlg varName])
(DeleteClassProp
[LAMBDA (class prop) (* mjs: "15-JUN-82 14:59")
(* Removes property from the class property list.)
(ChangedClass class)
(PROG [(propList (CONS NIL (fetch otherClassDescription of class]
(* Cons's a cell onto the proplist, then deletes it so as to be able to use ObjRemProp. To be changed later if
MetaClass field is reformated to contain a full-fledge descr.)
(RETURN (PROG1 (ObjRemProp prop propList)
(replace otherClassDescription of class with (CDR propList])
(FetchCIVDescr
[LAMBDA (self varName) (* dgb: "28-APR-83 17:47")
(* * Find the description list for the named variable in a class, returning NIL if none is there.)
(PROG NIL (* Short circuit the GetNth with embedded RETURN if no
index is found, i.e. the variable does not exist)
(RETURN (GetCIVNth self (OR (FindVarIndex varName self)
(RETURN NIL])
(FetchCIVValueOnly
[LAMBDA (classRec varName propName) (* dgb: " 2-JUN-83 10:35")
(* Used to fetch the default IV value from the class.
Returns NotSetValue if none found)
(PROG (supers val (class classRec))
(SETQ supers (Supers class))
(COND
((NULL class)
(RETURN NIL)))
LP (OR (NotSetValue (SETQ val (ObjGetProp (FetchCIVDescr class varName)
propName)))
(RETURN val))
ON (COND
((SETQ class (pop supers))
(GO LP)))
(RETURN NotSetValue])
(FetchCVOnly
[LAMBDA (classRec varName propName firstFoundFlg) (* dgb: "28-APR-83 17:47")
(* Maps through a class and its supers and returns property value with no activations. Returns NotSetValue if none
found. If firstFoundFlg=T then returns CONS of value and flg indicating whether prop was found past first CV =
varName seen in inheritance chain)
(COND
((NULL classRec)
(ERROR "No class given to find " varName))
(T (PROG ((supers (Supers classRec))
(class classRec)
descr value passedOnce)
LP [COND
((SETQ descr (FetchCVDescr class varName))
(COND
[(NEQ NotSetValue (SETQ value (ObjGetProp descr propName)))
(RETURN (COND
(firstFoundFlg (CONS value passedOnce))
(T value]
(T (SETQ passedOnce T) (* found classVar but not property)
] (* this is where the substitution goes)
ON (COND
((SETQ class (pop supers)) (* If there is a Super, iterate around the Loop)
(GO LP))) (* Returns NIL if not found)
(COND
(passedOnce (RETURN NotSetValue)))
NoVar
(COND
((HELPCHECK classRec "does not have class variable: " varName
"
Use (AddCV class varName) to add varName,
and then type OK to try again")
(SETQ class classRec)
(GO LP])
(FetchMethodClass
[LAMBDA (class selector) (* dgb: "28-APR-83 17:47")
(PROGN (* dgb: "12-JAN-82 15:20")
(* * FetchMethod is used to look up the supers chain for actions.)
(MapSupersForm (COND
((FindSelectorIndex class selector)
(* First search the selectors stored with this class.)
(RETURN class)))
class])
(FetchMethodDescr
[LAMBDA (self selector) (* dgb: "29-APR-83 11:49")
(PROG NIL (* Short ciruit the GetNth with embedded RETURN if no
index is found, i.e., the property does not exist.)
(RETURN (\GetNthEntry (fetch otherMethodDescription of self)
(OR (FindSelectorIndex self selector)
(RETURN NIL])
(FetchNthDescr
[LAMBDA (self index) (* dgb: " 2-DEC-82 22:14")
(CAR (FNTH (GetValue self (QUOTE indexedVars))
index])
(FetchNthDescr!
[LAMBDA (self index) (* dgb: " 2-DEC-82 22:10")
(OR (FetchNthDescr self index)
(PROG [last numVars (varList (LCONC NIL (GetValue self (QUOTE indexedVars]
(SETQ numVars (LENGTH (CAR varList)))
[for N from 1 to (IDIFFERENCE index numVars) do (SETQ varList (TCONC varList
(SETQ last
(CONS
NotSetValue]
(PutValueOnly self (QUOTE indexedVars)
(CAR varList))
(RETURN last])
(FetchNthValue
[LAMBDA (self index propName) (* dgb: "18-NOV-82 00:49")
(* * Used to fetch value of indexed variable for the mixin class VarLength.)
(PROG [value (descr (CAR (FNTH @indexedVars
index]
[COND
((NULL descr)
(RETURN NotSetValue))
(T (SETQ value (COND
(propName (ObjGetProp descr propName))
(T (CAR descr]
(RETURN (ObjRealValue self index value propName])
(FetchNthValueOnly
[LAMBDA (self index propName) (* dgb: "18-NOV-82 00:49")
(* * Used to fetch value of indexed variable for the mixin class VarLength. Like FetchNthValue except ignores
activeValues.)
(PROG [(descr (CAR (FNTH @indexedVars
index]
(RETURN (COND
((NULL descr)
NotSetValue)
((ObjGetProp descr propName])
(GetCVHere
[LAMBDA (classRec varName propName) (* dgb: "28-APR-83 17:47")
(* Gets the class property here without inheritance or
activeValues. Returns NotSetValue if not found here)
(ObjGetProp (FetchCVDescr classRec varName)
propName])
(GetClass
[LAMBDA (classRec propName) (* dgb: " 2-JUN-83 10:33")
(* Maps through a class and its supers in order to find the value of a property on the class itself.
Returns if property is set, or NotSetValue if none found. Return metaClass if no prop specified.)
(PROG (supers (class classRec)
value)
[COND
((NULL class)
(RETURN NIL))
((type? instance class)
(SETQ class (Class classRec]
(SETQ supers (Supers class))
LP [COND
((NEQ NotSetValue (SETQ value (ObjGetProp (CONS (Class classRec)
(fetch otherClassDescription
of class))
propName)))
(RETURN (ObjRealValue class NIL value propName (QUOTE CLASS]
ON (COND
((SETQ class (pop supers))
(GO LP)))
(RETURN NotSetValue])
(GetClassHere
[LAMBDA (classRec propName) (* dgb: "27-NOV-82 04:05")
(* Gets the class property here without activeValues or
inheritance)
(ObjGetProp (GetClassDescr classRec)
propName])
(GetClassIV
[LAMBDA (self varName prop) (* dgb: "30-NOV-82 11:09")
(* Get the value of an IV from the class)
(COND
((type? class self)
(FetchCIVValueOnly self varName prop))
(T (ERROR self "should be a class to use GetClassIVOnly"])
(GetClassOnly
[LAMBDA (classRec propName firstFoundFlg) (* dgb: "23-APR-83 16:18")
(* Maps through a class and its supers and returns property value with no activations. Returns NotSetValue if none
found. If firstFoundFlg=T then returns CONS of value and flg indicating whether prop was found past first Class in
inheritance chain)
(COND
((NULL propName) (* Return metaClass if no prop specified.)
(Class classRec))
((OR (MapSupersForm (COND
[(NEQ NotSetValue (SETQ value (ObjGetProp (GetClassDescr class)
propName)))
(RETURN (COND
(firstFoundFlg (CONS value passedOnce))
(T value]
(T (* found classVar but not property)
(SETQ passedOnce T)))
classRec descr value passedOnce)
(COND
(firstFoundFlg (CONS NotSetValue T))
(T NotSetValue])
(GetClassValue
[LAMBDA (self varName prop) (* dgb: "26-JAN-83 09:38")
(* Returns the value of a class variable, activating
getFn of an ActiveValue.)
(COND
((type? class self)
(ObjRealValue self varName (FetchCVOnly self varName prop)
prop
(QUOTE CV)))
((type? instance self) (* Coerce an instance into its class)
(GetClassValue (fetch CLASS of self)
varName prop))
(T (PROG ((objClass (GetLispClass self)))
(RETURN (COND
((NULL objClass)
(HELP self "has no class."))
(T (GetClassValue objClass varName prop])
(GetClassValueOnly
[LAMBDA (classRec varName prop) (* dgb: "21-SEP-82 21:45")
(* Returns the localState of a class variable.)
(SELECTQ (TYPENAME classRec)
(instance (* Coerce an instance into its class)
(FetchCVOnly (Class classRec)
varName prop))
(class (FetchCVOnly classRec varName prop))
(PROG ((objClass (GetLispClass classRec)))
(COND
((NULL objClass)
(HELP classRec "has no instance variables."))
(T (GetClassValueOnly objClass varName prop])
(GetIt
[LAMBDA (self varOrSelector propName type) (* dgb: " 9-DEC-82 16:28")
(* * General Get fn)
(SELECTQ type
[(NIL IV)
(COND
[(type? instance self)
(COND
((NUMBERP varOrSelector)
(FetchNthValue self varOrSelector propName))
(T (GetValue self varOrSelector propName]
((type? class self)
(FetchCIVValueOnly self varOrSelector propName))
(T (PROG ((objClass (GetLispClass self)))
(COND
((NULL objClass)
(HELP self "has no instance variables."))
(T (RETURN (← objClass GetValue self varOrSelector propName]
(CV (GetClassValue self varOrSelector propName))
(CLASS (* ambiguous which arg should be used for class
propName)
(GetClass self (OR varOrSelector propName)))
(METHOD (GetMethod self varOrSelector propName))
(ERROR type
"not part of Class. Use one of NIL (for instance variables), CV, CLASS, METHOD"])
(GetItHere
[LAMBDA (self varOrSelector propName type) (* dgb: "12-JAN-83 14:27")
(* * General Get fn with no inheritance or active Values)
(SELECTQ type
[(NIL IV)
(COND
((type? instance self)
(GetIVHere self varOrSelector propName))
((type? class self)
(GetClassIV self varOrSelector propName))
(T (PROG ((objClass (GetLispClass self)))
(COND
((NULL objClass)
(HELP self "has no instance variables."))
(T (RETURN (← objClass GetValueHere self varOrSelector propName]
(CV (GetCVHere self varOrSelector propName))
(CLASS (* ambiguous which arg should be used for class
propName)
(GetClassHere self (OR varOrSelector propName)))
(METHOD (GetMethodHere self varOrSelector propName))
(ERROR type
"not part of Class. Use one of NIL (for instance variables), CV, CLASS, METHOD"])
(GetItOnly
[LAMBDA (self varOrSelector propName type) (* dgb: "12-JAN-83 14:27")
(* * Like GetIt except doesn't check for active values.)
(SELECTQ type
[(NIL IV)
(COND
((type? instance self)
(GetValueOnly self varOrSelector propName))
((type? class self)
(GetClassIV self varOrSelector propName))
(T (PROG ((objClass (GetLispClass self)))
(COND
((NULL objClass)
(HELP self "has no instance variables."))
(T (RETURN (← objClass GetValueOnly self varOrSelector propName]
(CV (GetClassValueOnly self varOrSelector propName))
(CLASS (* ambiguous which arg should be used for propName for
class property)
(GetClassOnly self (OR varOrSelector propName)))
(METHOD (GetMethodOnly self varOrSelector propName))
(ERROR type
"not part of Class. Use one of NIL (for instance variables), CV, CLASS, METHOD"])
(GetLocalState
[LAMBDA (av self varName propName type) (* dgb: "28-APR-83 17:47")
(* * Returns the local state of an activeValue.)
(* dgb: "16-JUN-82 13:03")
(PROG ((locState (fetch localState of av)))
(RETURN (COND
[(type? activeValue locState)
(* * We have a nested active value. Activate getFn of nested value if there is one)
(PROG ((fn (fetch getFn of locState))
(ls (GetLocalState locState self varName propName type)))
(RETURN (COND
(fn (AVApply* fn self varName ls propName locState type))
(T ls]
[(EQ locState NotSetValue) (* We want to get the initial value if this av is in an
instance)
(COND
((NOT (type? instance self))
(RETURN NotSetValue)))
(RETURN (PROG ((ivValue (ObjGetProp (FetchIVDescr self varName)
propName)))
LP (COND
[(type? activeValue ivValue)
(COND
((EQ av ivValue)
(RETURN (GetInitialValue self varName propName)))
(T (SETQ ivValue (fetch localState of ivValue))
(GO LP]
(T (RETURN NotSetValue]
(T locState])
(GetLocalStateOnly
[LAMBDA (activeValue) (* dgb: "17-JUN-82 13:24")
(* * Returns the localState of an activeValue. Does not check whether the value is itself active.)
(fetch localState of activeValue])
(GetMethod
[LAMBDA (classRec selector propName) (* dgb: "27-MAY-83 15:26")
(* Maps through a classRec and its supers in order to find the value of a property on the method specified by
selector. Returns if property is set, or NotSetValue if none found. Invokes activeValues.)
(COND
((NULL propName) (* Here to return a method name)
(FetchMethod classRec selector))
(T (PROG (supers value index (class classRec))
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers class))
LP [COND
((SETQ index (FindSelectorIndex class selector))
(* Method is in class)
(COND
((NEQ NotSetValue (SETQ value (ObjGetProp (CONS NIL
(\GetNthEntry (fetch
otherMethodDescription
of class)
index))
propName)))
(* There is a value for property)
(RETURN (ObjRealValue class NIL value propName (QUOTE METHOD]
ON (COND
((SETQ class (pop supers)) (* If there is a Super, iterate around the Loop)
(GO LP))) (* Returns NotSetValue if not found)
(RETURN NotSetValue])
(GetMethodHere
[LAMBDA (classRec selector propName) (* dgb: "29-APR-83 11:25")
(* Gets method property here or function if prop is NIL.
Returns NotSetValue if not present in this class.)
(PROG ((index (FindSelectorIndex classRec selector)))
(RETURN (COND
((NULL index)
NotSetValue)
(T (ObjGetProp (CONS (GetNthMethod classRec index)
(\GetNthEntry (fetch otherMethodDescription of classRec)
index))
propName])
(GetMethodOnly
[LAMBDA (classRec selector propName) (* dgb: " 2-JUN-83 10:33")
(* Maps through a class and its supers and returns
property value of method with no activations.
Returns NotSetValue if none found.)
(PROG (supers (class classRec)
descr value index)
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers class))
LP [COND
((SETQ index (FindSelectorIndex class selector))
(COND
((NEQ NotSetValue (SETQ value (ObjGetProp (CONS (GetNthMethod class index)
(\GetNthEntry (fetch
otherMethodDescription
of class)
index))
propName)))
(RETURN value]
ON (COND
((SETQ class (pop supers))
(GO LP)))
(RETURN NotSetValue])
(GetNthValue
[LAMBDA (self varIndex prop) (* dgb: "22-NOV-82 23:59")
(COND
((NUMBERP varIndex)
(FetchNthValue self varIndex prop))
(T (GetValue self varIndex prop])
(Parse%@
[LAMBDA (exp type) (* dgb: "17-FEB-83 11:04")
(* exp is a list with 1, 2 or 3 elements. If 1, then it is a reference to a variable of self determined by type.
If 2 elements, then the first one is an expression to be evaluated to give an object and the second like the
previous single element. If 3 then it is like 2 but with a property of that variable specified)
(PROG (trans n val (v (CAR exp))
(obj (QUOTE self)))
[COND
((CDR exp)
(SETQ obj v)
(SETQ v (CADR exp]
[COND
((AND (NLISTP v)
(SETQ n (STRPOSL (CONSTANT (CHCON (QUOTE ←)))
v))) (* This has an embedded assignment)
(RETURN (ParsePut%@ [LIST obj (SUBATOM v 1 (SUB1 n))
(COND
((EQ n (NCHARS v))
(* ← at end)
(AND [NEQ v (SETQ val (CAR (LAST exp]
(OR (AND (ATOM val)
(ParseAccess val (QUOTE IV)
(QUOTE self)
1))
val)))
(T (ParseAccess v (QUOTE IV)
(QUOTE self)
(ADD1 n]
type]
(SETQ trans (ParseAccess v type obj 1))
[COND
((SETQ v (CDDR exp)) (* Now take care of property)
(SETQ trans (ParseAccess (CAR v)
(QUOTE PROP)
trans 1]
(RETURN trans])
(ParseAccess
[LAMBDA (input exprType currentExpr start) (* dgb: " 2-JUN-83 14:13")
(* Parse an expression containing : (iv) :: cv :, prop and those followed by !. expr type is IV CV PROP MSG
PERSP.)
(PROG [a e (n start)
(nt exprType)
(charList (CONSTANT (CHCON (QUOTE ,.:]
(COND
((NULL input) (* Dont Parse NIL)
(RETURN))
((NOT (OR (ATOM input)
(STRINGP input))) (* needs to be evaluated, and not parsed)
(SETQ a input)
(GO MKEXPR)))
BANGLOOP
(SELECTQ (NTHCHAR input n)
(%$ (SETQ nt (QUOTE LOOPSNAME)))
(! [COND
((EQ nt (QUOTE MSG))
(SETQ nt (QUOTE MSG!]
(SETQ e (ParseBang input (QUOTE IV)
currentExpr
(ADD1 n)
a))
(SETQ a (CAR e))
(SETQ n (CDR e))
(GO MKEXPR))
(\ (SETQ nt (QUOTE LISP)))
[: (SELECTQ (NTHCHAR input (add n 1))
(: (SETQ nt (QUOTE CV)))
(, (SETQ nt (QUOTE PROP)))
(PROGN (SETQ nt (QUOTE IV))
(GO BANGLOOP]
(, (SETQ nt (QUOTE PERSP)))
(%. (SETQ nt (QUOTE MSG)))
(GO ENDSYMBOL))
(add n 1)
(GO BANGLOOP)
ENDSYMBOL
[SETQ a (SUBATOM input n (COND
((SETQ n (STRPOSL charList input n))
(* there is some infix operator)
(SUB1 n))
(T (* through the end of the input)
NIL] (* Create next level of nesting)
(OR (EQ nt (QUOTE LISP))
(SETQ a (KWOTE a)))
MKEXPR
(SETQ e (ParseExpr nt currentExpr a))
(COND
((NULL n) (* No further nesting)
(RETURN e)))
(* * Get new exprType. n will end up pointing to first char of operator. type is irrelevant)
(RETURN (ParseAccess input NIL e n])
(ParseBang
[LAMBDA (input exprType currentExpr start) (* dgb: " 2-JUN-83 13:56")
(* Parse an expression after a bang containing : (iv) :: cv :, prop and those followed by !.
expr type is IV CV PROP MSG PERSP.)
(PROG [a (n start)
(nt exprType)
(charList (CONSTANT (CHCON (QUOTE ,.:]
(SELECTQ (NTHCHAR input n)
(\ (SETQ nt (QUOTE LISP)))
[: (SELECTQ (NTHCHAR input (add n 1))
(: (SETQ nt (QUOTE CV)))
(, (ERROR "Can't have a property at top level"))
(PROGN (SETQ nt (QUOTE IV))
(GO ENDSYMBOL]
(, (ERROR "Can't use perspective as name"))
(%. (SETQ nt (QUOTE MSG)))
(GO ENDSYMBOL))
(add n 1)
ENDSYMBOL
[SETQ a (SUBATOM input n (COND
((SETQ n (STRPOSL charList input n))
(* there is some infix operator)
(SUB1 n))
(T (* through the end of the input)
NIL] (* Create next level of nesting)
MKEXPR
(RETURN (CONS [ParseExpr nt (QUOTE self)
(COND
((EQ nt (QUOTE LISP))
a)
(T (KWOTE a]
n])
(ParseExpr
[LAMBDA (type currentExpr firstAtom) (* dgb: " 2-JUN-83 14:10")
(SELECTQ type
(LISP (COND
((NEQ currentExpr (QUOTE self))
(ERROR "\ must follow ! or appear at beginning" input)))
firstAtom)
(LOOPSNAME (COND
((NEQ currentExpr (QUOTE self))
(ERROR "$ must appear at beginning" input)))
(LIST (QUOTE GetObjectRec)
firstAtom))
(IV (LIST (QUOTE GetValue)
currentExpr firstAtom))
(CV (LIST (QUOTE GetClassValue)
currentExpr firstAtom))
(PROP (NCONC1 currentExpr firstAtom))
(MSG! (LIST (QUOTE ←!)
currentExpr firstAtom))
(MSG (LIST (QUOTE ←)
currentExpr
(CADR firstAtom)))
(PERSP (LIST (QUOTE ←)
currentExpr
(QUOTE GetPersp)
firstAtom))
(SHOULDNT "Bad exprType in ParseAccess"])
(ParsePut%@
[LAMBDA (arg type) (* dgb: "16-FEB-83 16:07")
(* Produce translation for ←%@ and ←%@%@)
(PROG (first trans (last (LAST arg)))
(SETQ trans (Parse%@ (LDIFF arg last)
type))
(RPLACA trans (SELECTQ (SETQ first (CAR trans))
(GetValue (QUOTE PutValue))
(GetClassValue (QUOTE PutClassValue))
(GO CHECKSEND)))
(RPLACD (CDDR trans)
(CONS (CAR last)
(CDDDR trans)))
(RETURN trans)
CHECKSEND
(COND
((AND (EQ first (QUOTE ←))
(EQ (CADDR trans)
(QUOTE GetPersp)))
(RPLACA (CDDR trans)
(QUOTE AddPersp))
(RPLACD (CDDDR trans)
(CONS (CAR last)
(CDDDDR trans)))
(RETURN trans)))
(SHOULDNT "Bad translation in Parse@"])
(PushClassValue
[LAMBDA (self varName newValue propName) (* mjs: "30-JUN-82 17:41")
(* * Add new value to list that is value of a class variable.)
(PutClassValue self varName (CONS newValue (GetClassValue self varName propName))
propName])
(PushNewValue
[LAMBDA (self varName newValue prop) (* dgb: "17-JUN-82 15:37")
(* * Push new value onto list that is prop or value of instance variable.)
(PROG ((oldValues (GetValue self varName prop)))
(RETURN (OR (FMEMB newValue oldValues)
(PutValue self varName (CONS newValue oldValues)
prop])
(PushValue
[LAMBDA (self varName item prop) (* dgb: "14-MAR-83 16:02")
(* * Push new value onto list that is value of an instance variable or property.)
(PutValue self varName (CONS item (LISTP (GetValue self varName prop)))
prop])
(PutClass
[LAMBDA (classRec newValue propName) (* dgb: "27-NOV-82 04:04")
(COND
[(NULL propName) (* Change class if no propName given.)
(ChangedClass classRec)
(replace metaClass of classRec with (OR (GetClassRec newValue)
(AND (HELPCHECK newValue
"is not a class. Type OK to replace metaclass of "
classRec "with $Class")
$Class]
[T (PROG [av (oldValue (GetClassOnly classRec propName (QUOTE FirstFoundFlg]
(* See GetClassPropOnly.)
(COND
([NOT (type? activeValue (SETQ av (CAR oldValue]
(* * Not an active value. Just store new value away)
(RETURN (PutClassOnly classRec newValue propName)))
((AND (CDR oldValue)
(NEQ (QUOTE SHARED)
(fetch localState of av)))
(* * Not local active value which is not shared)
(PutClassOnly classRec (SETQ av (CopyAV av))
propName)))
(PROG ((fn (fetch putFn of av)))
(COND
[fn (SETQ newValue (AVApply* fn classRec NIL propName newValue av
(QUOTE CLASS]
(T (ChangedClass classRec)
(PutLocalState av newValue classRec NIL propName]
newValue])
(PutClassIV
[LAMBDA (self varName newValue propName) (* dgb: "30-NOV-82 11:12")
(* Store value in a class description of an IV. One may only store in values of local variables.
Use AddCIV to add IV locally)
(COND
([NOT (FMEMB varName (← self List (QUOTE IVs]
(ERROR varName (CONCAT "is not a local IV, so cannot be changed in " self)))
(T (ObjPutProp (FetchCIVDescr self varName)
propName newValue])
(PutClassOnly
[LAMBDA (classRec newValue propName) (* dgb: "27-NOV-82 04:04")
[COND
[(NULL propName)
(replace metaClass of classRec with (OR (GetClassRec newValue)
(AND (HELPCHECK newValue
"not a class. Type OK to replace metaclass of "
classRec " with $Class.")
$Class]
(T (PROG ((ocd (fetch otherClassDescription of classRec)))
(COND
(ocd (LISTPUT ocd propName newValue))
(T (replace otherClassDescription of classRec with (LIST propName newValue]
(* Mark the class as changed, so that it will be dumped
later.)
(ChangedClass classRec)
newValue])
(PutClassValue
[LAMBDA (classRec varName newValue propName) (* dgb: "28-APR-83 17:47")
(* * Puts value in a class variable %. Activates putFn if an ActiveValue.)
(COND
((type? instance classRec)
(PutClassValue (Class classRec)
varName newValue propName))
[(type? class classRec)
(PROG ((supers (Supers classRec))
(class classRec)
descr index oldValue)
(* This is not a MapSupersForm because we want to be able to return a NIL oldValue if given, and yet cause an
error if no classVar of this name is found)
LP [COND
((SETQ index (FindIndex varName (fetch cvNames of class)))
(SETQ descr (GetNth (fetch cvDescrs of class)
index))
(COND
((NULL descr) (* Here if no value previously set for class variable.)
(SETQ descr (CONS NotSetValue))
(PutNth (fetch cvDescrs of class)
index descr)))
[SETQ oldValue (COND
(propName (ObjGetProp descr propName))
(T (CAR descr]
(ChangedClass classRec)
(RETURN (ObjSetValue class varName newValue descr oldValue propName (QUOTE CV]
ON (COND
((SETQ class (pop supers)) (* If there is a Super, iterate around the Loop)
(GO LP)))
(COND
((HELPCHECK varName " not found in " classRec
"Use (AddCV class name)
to add the variable to the desired class.Then type OK to try again")
(* If the user returns from HELPCHECK, then try again to
set the value)
(SETQ class classRec)
(GO LP]
(T (PROG ((objClass (GetLispClass classRec)))
(COND
((NULL objClass)
(HELP classRec "has no class variables."))
(T (RETURN (PutClassValue objClass varName newValue propName])
(PutClassValueOnly
[LAMBDA (classRec varName newValue propName) (* dgb: "28-APR-83 17:47")
(* Stores a localState for an class variable.
Never activates attached procedures or checks type of
value.)
(SELECTQ (TYPENAME classRec)
(instance (PutClassValueOnly (Class classRec)
varName newValue propName))
[class (PROG (supers (class classRec)
descr index value oldValue)
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers classRec))
LP (COND
((SETQ index (FindIndex varName (fetch cvNames of class)))
(SETQ descr (GetNth (fetch cvDescrs of class)
index))
(COND
((NULL descr) (* Here if no value previously set for class variable.)
(SETQ descr (CONS NotSetValue))
(PutNth (fetch cvDescrs of class)
index descr)))
(COND
(propName (ObjPutProp descr propName newValue))
(T (RPLACA descr newValue)))
(ChangedClass classRec)
(RETURN newValue)))
ON (COND
((SETQ class (pop supers)) (* If there is a Super, iterate around the Loop)
(GO LP)))
(COND
((HELPCHECK varName " not found in " classRec
"Use (AddCV class name)
to add the variable to the desired class.Then type OK to try again")
(* If the user returns from HELPCHECK, then try again)
(SETQ class classRec)
(GO LP]
(PROG ((objClass (GetLispClass classRec)))
(COND
((NULL objClass)
(HELP classRec "has no instance variables."))
(T (RETURN (PutClassValueOnly objClass varName newValue propName])
(PutIt
[LAMBDA (self varOrSelector newValue propName type) (* dgb: "12-JAN-83 14:31")
(* * General put fn)
(SELECTQ type
[(NIL IV)
(COND
((type? class self) (* no activation of active values when putting into iv
description in class)
(PutClassIV self varOrSelector newValue propName))
[(type? instance self)
(COND
((NUMBERP varOrSelector)
(StoreNthValue self varOrSelector newValue propName))
(T (PutValue self varOrSelector newValue propName]
(T (PROG ((objClass (GetLispClass self)))
(COND
((NULL objClass)
(HELP self "has no instance variables."))
(T (RETURN (← objClass PutValue self varOrSelector newValue propName]
(CV (PutClassValue self varOrSelector newValue propName))
(CLASS (* ambiguous which arg should be used for class
propname)
(PutClass self newValue (OR varOrSelector propName)))
(METHOD (PutMethod self varOrSelector newValue propName))
(ERROR type
"not part of Class.
Use one of NIL (for instance variables), CV, CLASS, METHOD"])
(PutItNested
[LAMBDA (self varName newValue propName type) (* dgb: "22-NOV-82 15:14")
(* Put newValue as value of varName, or as nested local state of any active value found there
(by inheritance or directly) without invoking active value functions)
(PROG ((oldValue (GetItHere self varName propName type)))
[COND
[(EQ oldValue NotSetValue) (* No local value)
(SETQ oldValue (GetItOnly self varName propName type))
(COND
((type? activeValue oldValue) (* Copy down nonlocal value)
(SETQ newValue (PutLocalState! (CopyAV oldValue)
newValue]
(T (COND
((type? activeValue oldValue)
(SETQ newValue (PutLocalState! oldValue newValue]
(RETURN (PutItOnly self varName newValue propName type])
(PutItOnly
[LAMBDA (self varOrSelector newValue propName type) (* dgb: "12-JAN-83 14:30")
(* * Like PutIt except that does not check for active values.)
(SELECTQ type
[(NIL IV)
(COND
((type? class self)
(PutClassIV self varOrSelector newValue propName))
(T (PutValueOnly self varOrSelector newValue propName]
(CV (PutClassValueOnly self varOrSelector newValue propName))
(CLASS (* ambiguous which arg should have been used as name of
prop for class properties)
(PutClassOnly self newValue (OR varOrSelector propName)))
(METHOD (PutMethodOnly self varOrSelector newValue propName))
(ERROR type
"not part of Class.
Use one of NIL (for instance variables), CV, CLASS, METHOD"])
(PutMethod
[LAMBDA (classRec selector newValue propName) (* sm: " 9-SEP-83 14:23")
(* Puts a value for a property on of a local method for
selector.)
(COND
((NULL propName)
(AddMethod classRec selector newValue))
(T [PROG (fn (oldValue (GetMethodHere classRec selector propName)))
(COND
((NOT (type? activeValue oldValue))
(* * Not an active value. Just store new value away)
(RETURN (PutMethodOnly classRec selector newValue propName)))
(fn (fetch putFn of oldValue)))
(COND
[(SETQ fn (fetch putFn of oldValue))
(SETQ newValue (AVApply* fn classRec propName newValue oldValue (QUOTE METHOD]
(T (ChangedClass classRec) (* Mark as changed here for file system even though
PutLocalState marks the object)
(PutLocalState oldValue newValue classRec selector propName]
newValue])
(PutMethodOnly
[LAMBDA (class selector newValue propName) (* dgb: "29-MAY-83 21:37")
(* Sets property value of method with no activations if
it is local)
(PROG (descr omd (index (FindSelectorIndex class selector)))
(COND
(index (ChangedClass class)
[COND
((SETQ descr (\GetNthEntry (SETQ omd (fetch otherMethodDescription of class))
index))
(LISTPUT descr propName newValue))
(T (\PutNthEntry omd index (LIST propName newValue]
(RETURN newValue))
(T (ERROR selector (CONCAT "not a local method of " class])
(PutNthValue
[LAMBDA (self varIndex newValue propName) (* dgb: "23-NOV-82 00:11")
(* Store away a value for an indexed variable)
(COND
((NUMBERP varIndex)
(StoreNthValue self varIndex newValue propName))
(T (PutValue self varIndex newValue propName])
(StoreNthValue
[LAMBDA (self index newValue propName) (* dgb: " 2-DEC-82 18:35")
(* * Store value for nth indexed variable. Used by objects having a VarLength mixin.)
(PROG ((descr (FetchNthDescr! self index)))
(RETURN (ObjSetValue self index newValue descr (ObjGetProp descr propName)
propName])
(StoreNthValueOnly
[LAMBDA (self index newValue propName) (* dgb: "18-NOV-82 00:49")
(* * Store away value for nth indexed variable. Used by objects having a VarLength mixin. Same as StoreNthValue
except ignores activeValues.)
(PROG [(descr (CAR (FNTH @indexedVars
index]
(RETURN (COND
((NULL descr) (* Here if no value set yet.)
(PROG (varLst numVars)
(SETQ varLst (GetValueOnly self (QUOTE indexedVars)))
(SETQ numVars (LENGTH varLst)) (* First allocate space for any vars of lower index.)
[SETQ varLst (APPEND varLst (for i from 1 to (SUB1 (IDIFFERENCE index
numVars))
collect (CONS NotSetValue]
(* Then stick the newValue on the end.)
[SETQ varLst (NCONC1 varLst (COND
(propName (LIST NotSetValue propName newValue))
(T (CONS newValue]
(PutValueOnly self (QUOTE indexedVars)
varLst)
(RETURN newValue)))
(T (* Usual case.)
(ObjPutProp descr propName newValue])
)
(* Short Synonym for GetObjectRec)
(MOVD? (QUOTE GetObjectRec)
(QUOTE $!))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML $)
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1529 44424 ($ 1539 . 1761) (AddCIV 1763 . 2399) (AddCV 2401 . 3239) (AddMethod 3241 .
4290) (DeleteCIV 4292 . 4938) (DeleteCV 4940 . 5793) (DeleteClassProp 5795 . 6454) (FetchCIVDescr 6456
. 6959) (FetchCIVValueOnly 6961 . 7605) (FetchCVOnly 7607 . 9031) (FetchMethodClass 9033 . 9549) (
FetchMethodDescr 9551 . 9995) (FetchNthDescr 9997 . 10178) (FetchNthDescr! 10180 . 10724) (
FetchNthValue 10726 . 11207) (FetchNthValueOnly 11209 . 11632) (GetCVHere 11634 . 11991) (GetClass
11993 . 12883) (GetClassHere 12885 . 13199) (GetClassIV 13201 . 13564) (GetClassOnly 13566 . 14530) (
GetClassValue 14532 . 15298) (GetClassValueOnly 15300 . 15979) (GetIt 15981 . 17051) (GetItHere 17053
. 18061) (GetItOnly 18063 . 19094) (GetLocalState 19096 . 20405) (GetLocalStateOnly 20407 . 20684) (
GetMethod 20686 . 22082) (GetMethodHere 22084 . 22673) (GetMethodOnly 22675 . 23588) (GetNthValue
23590 . 23819) (Parse@ 23821 . 25297) (ParseAccess 25299 . 27352) (ParseBang 27354 . 28622) (ParseExpr
28624 . 29485) (ParsePut@ 29487 . 30391) (PushClassValue 30393 . 30694) (PushNewValue 30696 . 31075)
(PushValue 31077 . 31372) (PutClass 31374 . 32720) (PutClassIV 32722 . 33201) (PutClassOnly 33203 .
33970) (PutClassValue 33972 . 35880) (PutClassValueOnly 35882 . 37757) (PutIt 37759 . 39007) (
PutItNested 39009 . 39875) (PutItOnly 39877 . 40731) (PutMethod 40733 . 41762) (PutMethodOnly 41764 .
42449) (PutNthValue 42451 . 42818) (StoreNthValue 42820 . 43191) (StoreNthValueOnly 43193 . 44422))))
)
STOP