(FILECREATED " 9-SEP-83 14:35:43" {INDIGO}<LOOPS>SOURCES>LOOPSAV.;6 17893
changes to: (FNS PutLocalState)
previous date: "22-JUL-83 15:06:39" {INDIGO}<LOOPS>SOURCES>LOOPSAV.;5)
(PRETTYCOMPRINT LOOPSAVCOMS)
(RPAQQ LOOPSAVCOMS [(* Copyright (c)
Xerox Corporation, 1983)
(VARS ImplicitReplaceFns)
(FNS * AVFNS)
(P (SETALLSYNTAX %# (MACRO FIRST HashMacro])
(* Copyright (c) Xerox Corporation, 1983)
(RPAQQ ImplicitReplaceFns (AtCreation FirstFetch))
(RPAQQ AVFNS (ALISTUNION AttachListAP AtCreation CopyAV DefAVP FirstFetch GetFromIV GetIndirect
GetSuperClassValue GettingBrokenVariable GettingTracedVariable
HasActiveGetFn HasActivePutFn MakeActiveValue NoUpdatePermitted PutIndirect
PutLocalState PutLocalState! PutLocalStateOnly RemoteCall RemoteSend
RemoveListAP ReplaceActiveValue ReplaceMe SendAVMessage
SettingBrokenVariable SettingTracedVariable SnapLink StoreUnmarked
UnSnapLink UnionSuperValue))
(DEFINEQ
(ALISTUNION
[LAMBDA (L1 L2) (* dgb: " 7-JUN-83 17:56")
(* Does not include any element on list L1 which is
either on L2 or which has its car as elt of L2)
(PROG ((newList (CONS)))
[for e in L1 do (COND
([AND (NOT (FMEMB e L2))
(OR (ATOM e)
(NOT (FASSOC (CAR e)
L2]
(TCONC newList e]
(RETURN (CAR (LCONC newList L2])
(AttachListAP
[LAMBDA (object ivName avProc prop receiver selector otherArgs)
(* dgb: " 5-APR-83 16:22")
(* Puts an active value put procedure avProc on the
instance variable value exactly once, and adds value to
the list on ivname:,prop)
(PROG (propVals currentVal)
(SETQ propVals (LISTP (GetIVHere object ivName prop)))
(SETQ currentVal (GetValueOnly object ivName))
[COND
((NOT (HasActivePutFn currentVal avProc))
(MakeActiveValue object ivName NIL avProc (QUOTE EMBED]
(PutValueOnly object ivName (CONS (CONS receiver (CONS selector otherArgs))
propVals)
prop)
(RETURN (GetValue object ivName])
(AtCreation
[LAMBDA (self varName locState propName av type) (* dgb: "22-SEP-82 00:02")
(* * For active values -
will evaluate form in localState at first fetch request, and replace it as value of variable.
This will only happen for new variables, since old ones had value created at creation.)
(ReplaceActiveValue av (COND
((LISTP locState)
(EVAL locState))
(T (AVApply* locState self varName)))
self varName propName type])
(CopyAV
[LAMBDA (av) (* mjs: "24-FEB-82 11:18")
(* Copy an activeValue)
(create activeValue
localState ←(COPY (fetch localState of av))
getFn ←(COPY (fetch getFn of av))
putFn ←(fetch putFn of av])
(DefAVP
[LAMBDA (fnName putFlg) (* mjs: "17-FEB-83 12:52")
(* Defines a form for an active value procedure, and throws you in the editor to complete it.
putFlg is used to determine if a newValue argument should be used)
(DEFINE (SUBPAIR (QUOTE (fnName))
(LIST fnName)
[COND
[putFlg (QUOTE ((fnName (self varName newValue propName activeVal type)
(* This is a putFn. ***NOTE*** The value of this function will be returned as the value of any enclosing PutValue.
This usually means that you want to return the value returned by PutLocalState.)
(PutLocalState activeVal newValue self varName
propName type]
(T (QUOTE ((fnName (self varName localSt propName activeVal type)
(* This is a getFn. The value of this getFn is returned
as the value of the enclosing GetValue.)
localSt]
T))
(APPLY* (QUOTE EDITF)
fnName])
(FirstFetch
[LAMBDA (self varName locState propName av type) (* dgb: "22-SEP-82 00:04")
(* * For active values -
will evaluate form in localState at first fetch. Replaces active value with new value. locState will be evaled if
it is a list, ele applied as a function name.)
(ReplaceActiveValue av (COND
((LISTP locState)
(EVAL locState))
(T (AVApply* locState self varName)))
self varName propName type])
(GetFromIV
[LAMBDA (self varName localSt propName activeVal type) (* mjs: "22-JUL-83 10:51")
(* This is a getFn. The value of this getFn is returned
as the value of the enclosing GetValue.)
(GetValue self localSt])
(GetIndirect
[LAMBDA (self varName ls propName activeVal type) (* dgb: "17-JUN-82 09:33")
(* Expects the local state of the activeValue to be a
list of the form (object varname propName) where
propName is optional)
(APPLY (QUOTE GetIt)
ls])
(GetSuperClassValue
[LAMBDA (class varName propName) (* dgb: " 7-JUN-83 17:38")
(for c in (Supers class) bind value when (NEQ NotSetValue (SETQ value (FetchCVOnly c varName
propName)))
do (RETURN (ObjRealValue class varName value propName (QUOTE CV))) finally (RETURN NotSetValue]
)
(GettingBrokenVariable
[LAMBDA (self varName value propName av type) (* dgb: "30-JUL-82 09:19")
(BREAK1 value T GettingValue (?=(self varName propName value])
(GettingTracedVariable
[LAMBDA (self varName value propName av) (* dgb: "29-JUL-82 15:12")
(BREAK1 value T TracedValue (TRACE ?=(self varName propName)
GO])
(HasActiveGetFn
[LAMBDA (value getF) (* ls: "14-FEB-83 14:08")
(* Returns active Value containing getFn or NIL)
(AND (type? activeValue value)
(OR (AND (EQ getF (fetch getFn of value))
value)
(HasActiveGetFn (fetch localState of value)
getF])
(HasActivePutFn
[LAMBDA (value putF) (* dgb: "21-JAN-83 01:23")
(* Returns active Value containing PutFn or NIL)
(AND (type? activeValue value)
(OR (AND (EQ putF (fetch putFn of value))
value)
(HasActivePutFn (fetch localState of value)
putF])
(MakeActiveValue
[LAMBDA (self varOrSelector newGetFn newPutFn newLocalSt propName type)
(* dgb: "18-MAR-83 18:01")
(* Makes the slot named varOrSelector of self be an active value, and puts in getfn and newPutFn if given.
If the getFn, putFn, or localState as given are NIL, uses the old value. If newGetFn or newPutFn is T, then makes
corresponding part of active value be NIL. Uses old active value if one was there, unless newLocalSt=EMBED.)
(PROG (av (oldValue (GetItHere self varOrSelector propName type)))
[COND
((AND (type? activeValue oldValue)
(NEQ newLocalSt (QUOTE EMBED)))
(SETQ av oldValue))
(T (SETQ av (create activeValue
localState ← oldValue]
[COND
(newGetFn (replace getFn of av with (COND
((EQ newGetFn T)
NIL)
(T newGetFn]
[COND
(newPutFn (replace putFn of av with (COND
((EQ newPutFn T)
NIL)
(T newPutFn]
(COND
((AND newLocalSt (NEQ newLocalSt (QUOTE EMBED)))
(replace localState of av with newLocalSt)))
(PutItOnly self varOrSelector av propName type)
(RETURN av])
(NoUpdatePermitted
[LAMBDA (self entry value propName av) (* dgb: " 4-MAR-82 16:34")
(ERROR "No entry permitted on " (LIST self entry propName])
(PutIndirect
[LAMBDA (self varName newValue propName activeVal type) (* dgb: "17-JUN-82 09:54")
(* Expects the local state of the activeValue to be a
list of the form (object varname propName) where
propName is optional)
(PROG ((ls (GetLocalState activeVal)))
(RETURN (PutIt (CAR ls)
(CADR ls)
newValue
(CADDR ls)
(CADDDR ls])
(PutLocalState
[LAMBDA (activeVal newValue self varName propName type) (* sm: " 9-SEP-83 14:25")
(* * Replaces the local state of an active value. Checks to see if the local state of the activeValue is itself
active.)
(PROG (fn locState)
[COND
((AND (type? instance self)
(OR (NULL type)
(EQ type (QUOTE IV)))
(EQ NotSetValue (GetIVHere self varName propName)))
(* If this is an active Value inherited from the class,
copy it in the instance itself)
(PutValueOnly self varName (SETQ activeVal (CopyAV (GetClassIV (Class self)
varName propName]
(COND
[(type? activeValue (SETQ locState (fetch localState of activeVal)))
(COND
((SETQ fn (fetch putFn of locState)) (* This is the case of nesting putFns where there is a
fn)
(RETURN (AVApply* fn self varName newValue propName locState type)))
(T (replace localState of locState with newValue]
(T (* not nested case)
(replace localState of activeVal with newValue)))
(AND self (Modified self T))
(RETURN newValue])
(PutLocalState!
[LAMBDA (activeVal newls) (* dgb: "22-NOV-82 15:23")
[PROG (oldls (av activeVal))
LP (COND
((type? activeValue (SETQ oldls (fetch localState of av)))
(SETQ av oldls)
(GO LP))
(T (replace localState of av with newls]
activeVal])
(PutLocalStateOnly
[LAMBDA (activeVal newValue) (* dgb: "17-JUN-82 13:20")
(* * replaces the local state of an activeValue. Does not check whether the localState is active.)
(* dgb: "16-JUN-82 10:57")
(replace localState of activeVal with newValue])
(RemoteCall
[LAMBDA (call) (* dgb: "18-FEB-83 17:35")
(* * A Remote call received here. Get object from UID, and apply method. -
call is of form (objUID selector arg1 arg2 ...))
(DECLARE: (LOCALVARS . T)
(SPECVARS classForMethod))
(PROG [classForMethod (oBj (GetObjFromUID (CAR call]
(RETURN (APPLY (FetchMethodOrHelp oBj (CADR call))
(CONS oBj (CDDR call])
(RemoteSend
[LAMBDA (self varName newValue propName activeVal type) (* dgb: "18-FEB-83 17:38")
(* This is a putFn for changing attached instruments. call is of form ((objUID machineID) selector . otherArgs). -
args for RemoteCall are (objUID selector . args))
(for call in (GetIt self varName (QUOTE remoteCalls)
type)
do (REMOTEVAL [LIST (QUOTE RemoteCall)
(KWOTE (CONS (CAAR call)
(CONS (CADR call)
(CONS newValue (CDDR call]
(CADAR call)
0))
(PutLocalState activeVal newValue self varName propName type])
(RemoveListAP
[LAMBDA (object ivName avProc prop value noErrorFlg) (* dgb: "23-JUN-83 14:12")
(* Removes value on the list on ivname:,prop for an active value, put procedure avProc on the instance.
Removes avProc if there are no more necessary attachments)
(PROG (propVals av)
(PutValueOnly object ivName [SETQ propVals (DELASSOC value (LISTP (GetIVHere object ivName
prop]
prop)
(AND propVals (RETURN T)) (* still others left)
(COND
((SETQ av (HasActivePutFn (GetValueOnly object ivName)
avProc)) (* none left. Remove the active value)
(ReplaceActiveValue av (fetch localState of av)
object ivName))
(T (OR noErrorFlg (HELPCHECK avProc "not found on object"])
(ReplaceActiveValue
[LAMBDA (activeVal newVal self varName propName type) (* dgb: "18-MAR-83 17:59")
(* * Used to replace an active value in a potentially nested set of active values associated with some value or
property.)
(PROG (nextValue locValue (testValue (GetItOnly self varName propName type)))
(COND
((NOT (type? activeValue testValue)) (* Must be inherited from class for this to make sense.
Used to cause (ERROR activeVal
"not found by ReplaceActiveValue."))
(PutItOnly self varName newVal propName type)
(GO OUT))
((EQ activeVal testValue)
(PutItOnly self varName newVal propName type)
(GO OUT))
((AND (type? instance self)
(OR (NULL type)
(EQ type (QUOTE IV)))
(EQ NotSetValue (GetIVHere self varName propName)))
(* Replacing an instance value, with active Value not in
instance)
(PutValueOnly self varName (SubstInAV activeVal newVal testValue)
propName)
(GO OUT)))
LP (COND
((OR (EQ activeVal (SETQ nextValue (fetch localState of testValue)))
(NOT (type? activeValue nextValue))) (* Replace in deepest nesting place if not found
earlier)
(replace localState of testValue with newVal)
(Modified self T)
(RETURN newVal)))
(SETQ testValue nextValue)
(GO LP)
OUT (RETURN newVal])
(ReplaceMe
[LAMBDA (self varName newValue propName activeVal type) (* dgb: "21-SEP-82 22:28")
(* This is a putFn for ---)
(ReplaceActiveValue activeVal newValue self varName propName type])
(SendAVMessage
[LAMBDA (self varName newValue propName activeVal) (* dgb: "17-FEB-83 18:52")
(* This is a putFn for changing attached instruments. msg is of form (obj selector otherArgs). -
newValue is filled in before otherArgs)
(for msg in (GetIVHere self varName (QUOTE avMessages))
bind (nv ←(PutLocalState activeVal newValue self varName propName))
classForMethod oBj
do [APPLY (FetchMethodOrHelp (SETQ oBj (CAR msg))
(CADR msg))
(CONS oBj (CONS nv (CDDR msg]
finally (RETURN nv])
(SettingBrokenVariable
[LAMBDA (self varName newValue propName activeVal type) (* dgb: " 3-AUG-82 22:55")
(* Go into a lisp break when a variable is to be set.
OK will cause variable to be given value)
(BREAK1 (PutLocalState activeVal newValue self varName propName type)
T SettingVariable (?=(self varName propName newValue])
(SettingTracedVariable
[LAMBDA (self varName newValue propName activeValue) (* dgb: "29-JUL-82 15:17")
(PROG ((oldValue (GetLocalState activeValue self varName newValue propName)))
(RETURN (BREAK1 (PutLocalState activeValue newValue self varName propName)
T SettingVariable (TRACE ?=(self varName propName oldValue)
GO])
(SnapLink
[LAMBDA (self varName locState propName av type) (* dgb: "27-NOV-82 03:47")
(* * Will be used as a getFn for values which will not be fetched from the database until referenced)
(PutValueOnly self varName (GetObjectRec (MKNAME (fetch localState of av])
(StoreUnmarked
[LAMBDA (self varName newValue propName activeVal type) (* dgb: "28-SEP-82 18:56")
(* This is a putFn which replaces its value without
marking the object as changed, or calling any active
values)
(replace localState of activeVal with newValue])
(UnSnapLink
[LAMBDA (self varname propName) (* dgb: "16-DEC-81 23:19")
(PROG ((value (GetValueOnly self varname propName)))
(COND
((type? instance value)
(PutValueOnly self varname (create activeValue
localState ←(UID value)
getFn ←(QUOTE SnapLink)
putFn ←(QUOTE PutInValue))
propName)
(RETURN (UID value)))
(T (RETURN NIL])
(UnionSuperValue
[LAMBDA (self varName localSt propName activeVal type) (* dgb: " 8-JUN-83 09:17")
(* This is a getFn. The value of this getFn is returned
as the value of the enclosing GetValue.)
(ALISTUNION (LISTP (GetSuperClassValue self varName propName))
(LISTP localSt])
)
(SETALLSYNTAX %# (MACRO FIRST HashMacro))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1005 17829 (ALISTUNION 1015 . 1542) (AttachListAP 1544 . 2398) (AtCreation 2400 . 2904)
(CopyAV 2906 . 3271) (DefAVP 3273 . 4347) (FirstFetch 4349 . 4833) (GetFromIV 4835 . 5149) (
GetIndirect 5151 . 5517) (GetSuperClassValue 5519 . 5890) (GettingBrokenVariable 5892 . 6077) (
GettingTracedVariable 6079 . 6278) (HasActiveGetFn 6280 . 6683) (HasActivePutFn 6685 . 7089) (
MakeActiveValue 7091 . 8388) (NoUpdatePermitted 8390 . 8568) (PutIndirect 8570 . 9038) (PutLocalState
9040 . 10370) (PutLocalState! 10372 . 10721) (PutLocalStateOnly 10723 . 11109) (RemoteCall 11111 .
11579) (RemoteSend 11581 . 12195) (RemoveListAP 12197 . 13048) (ReplaceActiveValue 13050 . 14625) (
ReplaceMe 14627 . 14902) (SendAVMessage 14904 . 15496) (SettingBrokenVariable 15498 . 15931) (
SettingTracedVariable 15933 . 16301) (SnapLink 16303 . 16614) (StoreUnmarked 16616 . 17003) (
UnSnapLink 17005 . 17440) (UnionSuperValue 17442 . 17827)))))
STOP