(FILECREATED "19-Jun-84 10:28:49" {INDIGO}<LOOPS>SOURCES>LOOPSAV.;10 20244
changes to: (FNS Temporary)
previous date: "26-DEC-83 18:30:05" {INDIGO}<LOOPS>SOURCES>LOOPSAV.;9)
(* Copyright (c) 1984 by Xerox Corporation)
(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 HasAV
HasActiveGetFn HasActivePutFn MakeActiveValue NoUpdatePermitted PutIndirect
PutLocalState PutLocalState! PutLocalStateOnly RemoteCall RemoteSend
RemoveListAP ReplaceActiveValue ReplaceMe SendAVMessage
SettingBrokenVariable SettingTracedVariable SnapLink StoreUnmarked SubstInAV
Temporary UnSnapLink UnionSuperValue UpdateMethodsList))
(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 (self varName propName activeVal) (* sm: " 7-NOV-83 19:04")
(PROG [(class (COND
((type? instance self)
(Class self))
(T self]
(RETURN (for c in (for sup on (CONS class (Supers class)) bind cls eachtime (SETQ cls
(CAR sup))
when (AND (← cls HasCV varName)
(HasAV (GetItHere cls varName propName (QUOTE CV))
activeVal))
do (RETURN (CDR sup)))
bind value when [AND (← c HasCV varName)
(NEQ NotSetValue (SETQ value (GetItHere c varName propName
(QUOTE CV]
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])
(HasAV
[LAMBDA (value activeVal) (* sm: " 7-NOV-83 18:43")
(* Returns T if activeVal is contained in value else
NIL)
(AND (type? activeValue value)
(OR (EQ activeVal value)
(HasAV (fetch localState of value)
activeVal])
(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) (* dgb: "13-OCT-83 22:06")
(* * 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])
(SubstInAV
[LAMBDA (oldLS newLS av) (* dgb: "11-NOV-82 02:29")
(* Substitutes, copying, newLS for oldLS in a nested set
of active values.)
(PROG ((ls (fetch localState of av)))
(RETURN (create activeValue
getFn ←(fetch getFn of av)
putFn ←(fetch putFn of av)
localState ←(COND
((EQ ls oldLS)
newLS)
((NOT (type? activeValue ls)) (* Nested value not found. This is just a copy of av)
ls)
(T (SubstInAV oldLS newLS ls])
(Temporary
[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) (* sm: " 7-NOV-83 18:19")
(* This is a getFn. The value of this getFn is returned
as the value of the enclosing GetValue.)
(ALISTUNION (LISTP (GetSuperClassValue self varName propName activeVal))
(LISTP localSt])
(UpdateMethodsList
[LAMBDA (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])
)
(SETALLSYNTAX %# (MACRO FIRST HashMacro))
(PUTPROPS LOOPSAV COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1091 20124 (ALISTUNION 1101 . 1628) (AttachListAP 1630 . 2484) (AtCreation 2486 . 2990)
(CopyAV 2992 . 3357) (DefAVP 3359 . 4433) (FirstFetch 4435 . 4919) (GetFromIV 4921 . 5235) (
GetIndirect 5237 . 5603) (GetSuperClassValue 5605 . 6381) (GettingBrokenVariable 6383 . 6568) (
GettingTracedVariable 6570 . 6769) (HasAV 6771 . 7149) (HasActiveGetFn 7151 . 7554) (HasActivePutFn
7556 . 7960) (MakeActiveValue 7962 . 9259) (NoUpdatePermitted 9261 . 9439) (PutIndirect 9441 . 9909) (
PutLocalState 9911 . 11243) (PutLocalState! 11245 . 11594) (PutLocalStateOnly 11596 . 11982) (
RemoteCall 11984 . 12452) (RemoteSend 12454 . 13068) (RemoveListAP 13070 . 13921) (ReplaceActiveValue
13923 . 15498) (ReplaceMe 15500 . 15775) (SendAVMessage 15777 . 16369) (SettingBrokenVariable 16371 .
16804) (SettingTracedVariable 16806 . 17174) (SnapLink 17176 . 17487) (StoreUnmarked 17489 . 17876) (
SubstInAV 17878 . 18531) (Temporary 18533 . 18916) (UnSnapLink 18918 . 19353) (UnionSuperValue 19355
. 19749) (UpdateMethodsList 19751 . 20122)))))
STOP