(FILECREATED "19-Jun-84 10:25:49" {INDIGO}<LOOPS>SOURCES>LOOPSACCESS.;20 45823
changes to: (FNS PutValue GetValue)
previous date: "17-Apr-84 15:59:22" {INDIGO}<LOOPS>SOURCES>LOOPSACCESS.;19)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(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 ($ DeleteCIV DeleteCV DeleteClassProp FetchCIVDescr FetchCIVValueOnly FetchCVOnly
FetchMethodClass FetchMethodDescr FetchNthDescr FetchNthDescr! FetchNthValue
FetchNthValueOnly GetCVHere GetClass GetClassHere GetClassIV GetClassIVHere
GetClassOnly GetClassValue GetClassValueOnly GetIt GetItHere GetItOnly
GetLocalState GetLocalStateOnly GetMethod GetMethodHere GetMethodOnly
GetNthValue GetValue Parse@ ParseAccess ParseBang ParseExpr ParsePut@
PushClassValue PushNewValue PushValue PutCIVHere PutCVHere PutClass PutClassIV
PutClassOnly PutClassValue PutClassValueOnly PutIt PutItNested PutItOnly
PutMethod PutMethodOnly PutNthValue PutValue StoreNthValue StoreNthValueOnly))
(DEFINEQ
(%$
[NLAMBDA (name) (* dgb: " 2-JUN-83 13:37")
(* Get object given name quoted)
(GetObjectRec name])
(DeleteCIV
[LAMBDA (class varName prop) (* dgb: "15-Feb-84 14:50")
(* 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: "13-OCT-83 22:06")
(* 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-Feb-84 17:25")
(PROGN (* dgb: "12-JAN-82 15:20")
(* * MapSupersForm is used to look up the supers chain for class)
(MapSupersForm (COND
((FindSelectorIndex class selector)
(* First search the selectors stored with this class.)
(RETURN class)))
class])
(FetchMethodDescr
[LAMBDA (self selector) (* dgb: "18-OCT-83 20:50")
(* Computes Method descr from method object)
(PROG (meth)
(RETURN (AND (FindSelectorIndex self selector)
(SETQ meth (GetMethodObj self selector))
(BQUOTE (args NIL doc NIL ,. (CDR (FetchIVDescr meth (QUOTE method])
(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: "27-NOV-83 14:34")
(* Get the value of an IV from the class)
(COND
((type? class self)
(ObjGetProp (FetchCIVDescr self varName)
prop))
(T (ERROR self "should be a class to use GetClassIV"])
(GetClassIVHere
[LAMBDA (self varName prop) (* dgb: " 9-Apr-84 12:22")
(* Get the value of an IV from the class)
(COND
((type? class self)
(COND
((FMEMB varName (fetch localIVs of self))
(ObjGetProp (FetchCIVDescr self varName)
prop))
(T NotSetValue)))
(T (ERROR self "should be a class to use GetClassIV"])
(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: "29-Feb-84 15:36")
(* 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)
(LoopsHelp self "has no class."))
(T (GetClassValue objClass varName prop])
(GetClassValueOnly
[LAMBDA (classRec varName prop) (* dgb: "29-Feb-84 15:36")
(* 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)
(LoopsHelp classRec "has no instance variables."))
(T (GetClassValueOnly objClass varName prop])
(GetIt
[LAMBDA (self varOrSelector propName type) (* dgb: "29-Feb-84 15:37")
(* * 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)
(LoopsHelp 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: " 9-Apr-84 12:24")
(* * General Get fn with no inheritance or active Values)
(SELECTQ type
[(NIL IV)
(COND
((type? instance self)
(GetIVHere self varOrSelector propName))
((type? class self)
(GetClassIVHere self varOrSelector propName))
(T (PROG ((objClass (GetLispClass self)))
(COND
((NULL objClass)
(LoopsHelp 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: "29-Feb-84 15:37")
(* * 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)
(LoopsHelp 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: "29-Feb-84 08:49")
(* 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 methObj (class classRec))
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers class))
LP [COND
((SETQ index (FindSelectorIndex class selector))
(* Method is in class)
(SETQ methObj (GetMethodObj class selector T))
[SETQ value (COND
((FMEMB propName (GetClassValue methObj (QUOTE ivProperties)))
(GetValue methObj propName))
(T (GetValue methObj (QUOTE method)
propName]
(COND
((NEQ NotSetValue value) (* There is a value for property)
(RETURN value]
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: "13-OCT-83 22:06")
(* Gets method property here or function if prop is NIL.
Returns NotSetValue if not present in this class.)
(COND
((NULL propName)
(FetchLocalMethod classRec selector))
(T (PROG (methObj (index (FindSelectorIndex classRec selector)))
(RETURN (COND
((NULL index)
NotSetValue)
(T (SETQ methObj (GetMethodObj classRec selector T))
(* Find or create method object)
(COND
((FMEMB propName (@ \methObj::ivProperties))
(GetIVHere methObj propName))
(T (GetIVHere methObj (QUOTE method)
propName])
(GetMethodOnly
[LAMBDA (classRec selector propName) (* dgb: "13-OCT-83 22:06")
(* 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 (GetMethodHere classRec selector 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])
(GetValue
[LAMBDA (self varName prop) (* dgb: "21-OCT-83 06:54")
(* Used to return the value of an "instance variable" for an object. Calls general Get function for non standard
objects -
GetValue activates getFn if the value is an ActiveValue.)
(COND
[(type? instance self)
(PROG (value (descr (FetchIVDescr self varName)))
[COND
([OR (NULL descr)
(NotSetValue (SETQ value (ObjGetProp descr prop]
(* no value found in the instance or in locally in the
class if self is a class)
(SETQ value (FetchCIVValueOnly (ffetch class of self)
varName prop]
(RETURN (ObjRealValue self varName value prop]
(T (GetIt self varName prop (QUOTE IV])
(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])
(PutCIVHere
[LAMBDA (self varName value prop) (* dgb: "17-Apr-84 12:56")
(* Put a value locally even if not a local variable of
class)
[AddCIV self varName (COND
((NULL prop)
value)
(T (GetClassIV self varName)))
(COND
(prop (LIST prop value]
value])
(PutCVHere
[LAMBDA (self varName value) (* dgb: "22-DEC-83 22:43")
(* Put a ClassVariable locally with value if if not
local now)
(AddCV self varName value)
value])
(PutClass
[LAMBDA (classRec newValue propName) (* dgb: "22-DEC-83 22:27")
(ChangedClass classRec)
(COND
[(NULL propName) (* Change class if no propName given.)
(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 (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: "29-Feb-84 15:37")
(* * 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)
(LoopsHelp classRec "has no class variables."))
(T (RETURN (PutClassValue objClass varName newValue propName])
(PutClassValueOnly
[LAMBDA (classRec varName newValue propName) (* dgb: "29-Feb-84 15:37")
(* 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)
(LoopsHelp classRec "has no instance variables."))
(T (RETURN (PutClassValueOnly objClass varName newValue propName])
(PutIt
[LAMBDA (self varOrSelector newValue propName type) (* dgb: "29-Feb-84 15:40")
(* * 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)
(LoopsHelp 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) (* dgb: "20-OCT-83 15:05")
(* Puts a value for a property on of a local method for
selector. Activates activeValues if found on
methodObject)
(PROG (methObj (index (FindSelectorIndex classRec selector)))
(RETURN (COND
((NULL propName)
(DefineMethod classRec selector newValue))
((NULL index)
(ERROR selector (CONCAT "not a local method of " class)))
(T (SETQ methObj (GetMethodObj classRec selector T))
(* Find or create method object)
(COND
((FMEMB propName (@ \methObj::ivProperties))
(PutValue methObj propName newValue))
(T (PutValue methObj (QUOTE method)
newValue propName)))
newValue])
(PutMethodOnly
[LAMBDA (classRec selector newValue propName) (* dgb: "13-OCT-83 22:06")
(* Puts a value for a property on of a local method for
selector.)
(PROG (methObj (index (FindSelectorIndex classRec selector)))
(RETURN (COND
((NULL propName)
(DefineMethod classRec selector newValue))
((NULL index)
(ERROR selector (CONCAT "not a local method of " class)))
(T (SETQ methObj (GetMethodObj classRec selector T))
(* Find or create method object)
(COND
((FMEMB propName (@ \methObj::ivProperties))
(PutValueOnly methObj propName newValue))
(T (PutValueOnly methObj (QUOTE method)
newValue propName)))
newValue])
(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])
(PutValue
[LAMBDA (self varName newValue propName) (* dgb: "26-Apr-84 13:13")
(* * Puts newValue as value for varName in self on propname. Activates putFn if current value is an activeValue.)
(COND
[(type? instance self)
(PROG (value (descr (FetchIVDescr! self varName)))
[COND
((EQ NotSetValue (SETQ value (ObjGetProp descr propName)))
(* Value not set locally. Get value from class.)
(SETQ value (FetchCIVValueOnly (ffetch class of self)
varName propName))
(COND
((type? activeValue value)
(COND
((FMEMB (fetch getFn of value)
ImplicitReplaceFns)
(* * Special case. One of FirstFetch AtCreation. Just puts the new value into the instance)
(RETURN (ObjPutProp descr propName newValue)))
((NEQ (QUOTE SHARED)
(fetch localState of value)) (* Here to copy an active value if it was inherited
unchanged, and is now being changed.)
(Modified self T)
(SETQ value (CopyAV value))
(ObjPutProp descr propName value]
(RETURN (ObjSetValue self varName newValue descr value propName]
(T (PutIt self varName newValue propName (QUOTE IV])
(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 )
)
(PUTPROPS LOOPSACCESS COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1625 45513 ($ 1635 . 1857) (DeleteCIV 1859 . 2505) (DeleteCV 2507 . 3360) (
DeleteClassProp 3362 . 4021) (FetchCIVDescr 4023 . 4526) (FetchCIVValueOnly 4528 . 5172) (FetchCVOnly
5174 . 6599) (FetchMethodClass 6601 . 7116) (FetchMethodDescr 7118 . 7543) (FetchNthDescr 7545 . 7726)
(FetchNthDescr! 7728 . 8272) (FetchNthValue 8274 . 8755) (FetchNthValueOnly 8757 . 9180) (GetCVHere
9182 . 9539) (GetClass 9541 . 10431) (GetClassHere 10433 . 10747) (GetClassIV 10749 . 11123) (
GetClassIVHere 11125 . 11585) (GetClassOnly 11587 . 12551) (GetClassValue 12553 . 13324) (
GetClassValueOnly 13326 . 14010) (GetIt 14012 . 15087) (GetItHere 15089 . 16106) (GetItOnly 16108 .
17144) (GetLocalState 17146 . 18455) (GetLocalStateOnly 18457 . 18734) (GetMethod 18736 . 20116) (
GetMethodHere 20118 . 20941) (GetMethodOnly 20943 . 21722) (GetNthValue 21724 . 21953) (GetValue 21955
. 22814) (Parse@ 22816 . 24292) (ParseAccess 24294 . 26347) (ParseBang 26349 . 27617) (ParseExpr
27619 . 28480) (ParsePut@ 28482 . 29386) (PushClassValue 29388 . 29689) (PushNewValue 29691 . 30070) (
PushValue 30072 . 30367) (PutCIVHere 30369 . 30776) (PutCVHere 30778 . 31072) (PutClass 31074 . 32394)
(PutClassIV 32396 . 32875) (PutClassOnly 32877 . 33644) (PutClassValue 33646 . 35559) (
PutClassValueOnly 35561 . 37441) (PutIt 37443 . 38696) (PutItNested 38698 . 39564) (PutItOnly 39566 .
40420) (PutMethod 40422 . 41348) (PutMethodOnly 41350 . 42220) (PutNthValue 42222 . 42589) (PutValue
42591 . 43907) (StoreNthValue 43909 . 44280) (StoreNthValueOnly 44282 . 45511)))))
STOP