(FILECREATED "26-Jun-84 14:02:59" {INDIGO}<LOOPS>SOURCES>LOOPSMETHODS.;31 38795
changes to: (FNS DefMethObj DeleteMethod MoveMethod)
previous date: "22-Jun-84 11:54:59" {INDIGO}<LOOPS>SOURCES>LOOPSMETHODS.;30)
(* Copyright (c) 1984 by Xerox Corporation)
(PRETTYCOMPRINT LOOPSMETHODSCOMS)
(RPAQQ LOOPSMETHODSCOMS [(* Copyright (c)
1983 by Xerox Corporation)
(MACROS * METHODMACROS)
(MACROS * OTHERLOOPSMACROS)
(FNS * METHODSFNS)
(GLOBALVARS UseMethodCacheFlg ClassBlock SelectorBlock MethodBlock)
[VARS (LoopsDebugFlg T)
(UseMethodCacheFlg T)
(ClassBlock (NCREATE (QUOTE VMEMPAGEP)))
(SelectorBlock (NCREATE (QUOTE VMEMPAGEP)))
(MethodBlock (NCREATE (QUOTE VMEMPAGEP]
(P (MOVD (QUOTE ←)
(QUOTE SEND)))
(P (ADDTOVAR NLAMA ←← ←Super ←! ← ←SuperFringe DoMethod DoFringeMethods))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA ←← ←Super ←! ← ←SuperFringe METH DoMethod
DoFringeMethods)
(NLAML)
(LAMA])
(* Copyright (c) 1983 by Xerox Corporation)
(RPAQQ METHODMACROS (AVApply* DOAPPLY* DoMethod FetchMethod FindSelectorIndex MapSupersForm? SEND
SENDSUPER ← ←! ←IV ←New ←Proto ←Super ←Try))
(DECLARE: EVAL@COMPILE
(PUTPROPS AVApply* MACRO [(FRST . REST)
(COND
((LISTP FRST)
(EVAL FRST))
(T (DOAPPLY* FRST . REST])
(PUTPROPS DOAPPLY* MACRO (arg (CONS (QUOTE APPLY*)
arg)))
(PUTPROPS DoMethod MACRO [(obj action class . args)
(PROG ((obj% obj))
(RETURN (DOAPPLY*(OR (FetchMethod (OR class (fetch CLASS
of obj% ))
action)
(ERROR action "not found for DoMethod"))
obj% . args])
(PUTPROPS FetchMethod MACRO (OPENLAMBDA (classRec selector)
(* dgb: " 9-JUN-83 22:27")
(* Returns the function for selector or NIL)
(PROG (pos meth index supers (class classRec))
(OR (type? class classRec)
(RETURN))
(OR UseMethodCacheFlg (GO ON))
[SETQ pos (LOGAND 254 (LOGXOR (\LOLOC classRec)
(\LOLOC selector]
(* pos is an even postion on the page, computed from the
xor of the selector and the classRec addresses)
[COND
((AND (EQ classRec (\GETBASEPTR ClassBlock pos))
(EQ selector (\GETBASEPTR SelectorBlock pos)))
(RETURN (\GETBASEPTR MethodBlock pos]
ON (SETQ supers (fetch supers of classRec))
LP (COND
((SETQ index (FindSelectorIndex class selector))
(GO OUT))
((SETQ class (pop supers))
(GO LP))
(T (RETURN NIL)))
OUT (SETQ meth (GetNthMethod class index))
(COND
(UseMethodCacheFlg (\PUTBASEPTR ClassBlock pos
classRec)
(\PUTBASEPTR SelectorBlock pos
selector)
(\PUTBASEPTR MethodBlock pos meth))
)
(RETURN meth))))
(PUTPROPS FindSelectorIndex MACRO [OPENLAMBDA (class selector)
(PROG NIL (* Prog is only so one can bomb out in case of NIL
selectors of class)
(RETURN (\FindEntryIndex selector
(OR (fetch selectors
of class)
(RETURN])
(PUTPROPS MapSupersForm? MACRO ((mappingForm classRec . progArgs)
(* dgb: "12-JAN-82 14:55")
(* Maps through a class and its supers in order. Returns if form has return statement, or NIL when finished %.
form can use class as free variable)
(PROG (supers (class classRec) . progArgs)
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers class))
LP
mappingForm (* this is where the substitution goes)
ON (COND
((SETQ class (pop supers))
(* If there is a Super, iterate around the Loop)
(GO LP))) (* Returns NotSetValue if not found)
(RETURN NotSetValue))))
(PUTPROPS SEND MACRO ((obj action . args)
(← obj action . args)))
(PUTPROPS SENDSUPER MACRO ((obj action . args)
(←Super
obj action . args)))
(PUTPROPS ← MACRO (messForm (RESETVAR NOSPELLFLG T
(DWIMIFY [BQUOTE (PROG ((objectFor←Macro
,
(CAR messForm)))
(DECLARE (LOCALVARS objectFor←Macro))
(RETURN (APPLY* (FetchMethodOrHelp
objectFor←Macro
(QUOTE , (CADR messForm)))
objectFor←Macro
,.
(CDDR messForm]
T))))
(PUTPROPS ←! MACRO [(obj action . args)
(PROG ((oBj obj))
(RETURN (PROG (classForMethod)
(RETURN (DOAPPLY*(FetchMethodOrHelp oBj action)
oBj . args])
(PUTPROPS ←IV MACRO (messForm (DWIMIFY [BQUOTE (PROG ((oBj , (CAR messForm)))
(DECLARE (LOCALVARS oBj))
(RETURN (APPLY* (IVFunction oBj
(QUOTE ,
(CADR
messForm)))
oBj ,. (CDDR messForm]
T)))
(PUTPROPS ←New MACRO [form (COND
((NULL (CDR form))
(LIST (QUOTE ←)
(CAR form)
(QUOTE New)))
(T (SUBPAIR (QUOTE (obj action . args))
form
(QUOTE (PROG (classForMethod (obj% (← obj New)))
(DOAPPLY*(FetchMethodOrHelp obj% (QUOTE action)
)
obj% . args)
(RETURN obj% ])
(PUTPROPS ←Proto MACRO ((obj . args)
(← (← obj Prototype) . args)))
(PUTPROPS ←Super MACRO [(obj action . args)
(PROG ((obj% obj))
(DECLARE (LOCALVARS . T))
(RETURN (DOAPPLY*(GetSuperMethod obj% (QUOTE action))
obj% . args])
(PUTPROPS ←Try MACRO [(obj action . args)
(PROG ((obj% obj))
(RETURN (DOAPPLY*(OR (FetchMethod obj% (QUOTE action))
(RETURN (QUOTE NotSent)))
obj% . args])
)
(RPAQQ OTHERLOOPSMACROS (ExtractObj MapSupersForm MapSupersUnlessBadList MenuGetOrCreate
NextSuperClass))
(DECLARE: EVAL@COMPILE
(PUTPROPS ExtractObj MACRO ((datum)
(OR (CAR (LISTP datum))
datum)))
(PUTPROPS MapSupersForm MACRO ((mappingForm classRec . progArgs)
(* dgb: "12-JAN-82 14:55")
(* Maps through a class and its supers in order. Returns if form has return statement, or NIL when finished %.
form can use class as free variable)
(PROG (supers (class classRec) . progArgs)
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers class))
LP
mappingForm (* 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)
(RETURN NIL))))
(PUTPROPS MapSupersUnlessBadList MACRO ((badList mappingForm classRec . progArgs)
(* dgb: "12-JAN-82 14:55")
(* Maps through a class and its supers in order. Returns if form has return statement, or NIL when finished %.
form can use class as free variable)
(PROG (supers (class classRec) . progArgs)
(COND
((NULL class)
(RETURN NIL)))
(SETQ supers (Supers class))
LP (* Skip if super is on badList.)
(OR (FMEMB (ClassName class)
badList)
mappingForm)
(* this is where the substitution goes)
ON (COND
((SETQ class (pop supers))
(GO LP)))
(* Returns NIL if not found)
(RETURN NIL))))
(PUTPROPS MenuGetOrCreate MACRO [(name items)
(COND
((type? MENU (GETTOPVAL (QUOTE name)))
name)
(T (SETTOPVAL (QUOTE name)
(create MENU
CHANGEOFFSETFLG ← T
ITEMS ← items])
(PUTPROPS NextSuperClass MACRO [NIL (COND
((SETQ class (pop supers))
(* * This code assumes that LP is a defined PROG label and supers and class are bound)
(* If there is a Super, iterate around the Loop)
(GO LP])
)
(RPAQQ METHODSFNS (AddMethod ApplyMethod ApplyMethodInTtyProcess DefMethObj DefineMethod DeleteMethod
DoFringeMethods DoMethod IVFunction InstallMethod LoopsHelp METH
MethName MoveMethod RenameMethod ←SuperFringe FindLocalMethod
FindSelectorIndex Fix@$ FlushMethodCache FullInstallMethod FetchMethod
FetchMethodOrHelp GetCallerClass GetNthMethod GetSuperMethod PrintMeths
PutMethodNth ← ←! ←Super ←← DCM))
(DEFINEQ
(AddMethod
[LAMBDA (class selector method) (* dgb: "28-Feb-84 17:19")
(* 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 (FlushMethodCache)
(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)))])
(ApplyMethod
[LAMBDA (object selector argList class) (* dgb: "29-Feb-84 08:49")
(* Apply the selected method to the already evaluated
args in argList.)
(PROG (classForMethod)
(RETURN (APPLY [OR (FetchMethod (OR class (fetch CLASS of object))
selector)
(ERROR selector (CONCAT "not a selector in "
(OR class (fetch CLASS of object]
(CONS object argList])
(ApplyMethodInTtyProcess
[LAMBDA (object selector argList class waitFlg) (* dgb: " 2-MAR-83 12:50")
(* Apply the selected method to the already evaluated
args in argList as a tty process.)
(EVAL.IN.TTY.PROCESS (BQUOTE (ApplyMethod , object (QUOTE , selector)
(QUOTE , argList)
, class))
waitFlg])
(DefMethObj
[LAMBDA (cName sel fn arg dcm methodProps otherIVs) (* dgb: "26-Jun-84 13:03")
(* Creates the method object and fills in its IVs)
(PROG (self (methName (MethName cName sel)))
[SETQ self (OR (GetObjectRec methName)
(NewObject ($ Method)
(COND
((AND otherIVs (EQ (CAAR otherIVs)
(QUOTE UID)))
(* Use UID for object and delete from otherIVs)
(CADR (pop otherIVs)))
(T (DB-PackUI]
(NameObject self (CONS methName))
(←@
className cName)
(←@
selector sel)
(←@
args arg)
(←@
doc dcm)
(←@
method fn)
(AND methodProps (for p on methodProps do (PutValue self (QUOTE method)
(CADR p)
(CAR p))
by (CDDR p)))
(* method is filled by fn. all the other IVs which the method can have are in oth, and will be filled into the
instance)
(AND otherIVs (FillInst otherIVs self))
(InstallMethod self])
(DefineMethod
[LAMBDA (class selector argsOrFn expr) (* dgb: " 2-JAN-84 17:24")
(* * Define a new method (or replace an old one). If expr is NIL then argsOrFn should be a function Name, else it
should be a list of arguments, and expr should be the function definition)
(COND
((NOT (LITATOM selector))
(ERROR selector "is not a LIATOM, so cannot be a selector")))
(PROG (fnName file editFlg methName methObj (className (ClassName class)))
(* methName is name of object for method)
(SETQ methName (PACK* className (QUOTE %.)
selector))
(SETQ methObj (GetMethodObj class selector T))
[COND
((SETQ editFlg (NOT (OR argsOrFn expr)))
(SETQ argsOrFn (LIST (QUOTE self)))
(SETQ expr (COPY (QUOTE ( (* New method template)
self]
[COND
((AND argsOrFn (LITATOM argsOrFn))
(SETQ fnName argsOrFn))
(T [COND
((NULL expr) (* Here if argsOrFn left out)
(SETQ expr argsOrFn)
(SETQ argsOrFn (LIST (QUOTE self]
[COND
([AND (LISTP expr)
(NOT (LISTP (CAR expr] (* This is a single expression, not an implicit PROGN)
(SETQ expr (LIST expr]
[SETQ expr (FIXEDITDATE (CONS (QUOTE LAMBDA)
(CONS argsOrFn expr]
(SETQ fnName methName)
(DEFINE (LIST (LIST fnName expr]
(AddMethod class selector fnName)
(←@
\methObj:method fnName)
[COND
([AND (NULL (WHEREIS methName (QUOTE METHODS)))
(SETQ file (CAR (WHEREIS className (QUOTE CLASSES]
(ADDTOFILE methName (QUOTE METHODS)
file))
(T (MARKASCHANGED methName (QUOTE METHODS]
(COND
(editFlg (← class EditMethod selector)))
(← class CommentMethods (LIST selector)
T)
(RETURN (SETQ LASTWORD fnName])
(DeleteMethod
[LAMBDA (class selector prop) (* dgb: "25-Jun-84 16:08")
(PROG (methObj (methName (MethName class selector))
index pl fn freePos sel (methName (MethName class selector)))
TRYAGAIN
(SETQ index (FindSelectorIndex (SETQ class (GetClassRec class))
selector))
(COND
((NULL index)
(SETQ selector (HELPCHECK class " does not contain the selector " selector
"Type
RETURN 'selectorName
to try again"))
(GO TRYAGAIN)))
[COND
((EQ prop T) (* T is special Flag for deleteing the function
definition too)
(SETQ prop NIL)
(CLEARW PROMPTWINDOW)
(printout PROMPTWINDOW (CHARACTER 7)
"Deleting function definition for "
(SETQ fn (GetMethod class selector))
T)
(\PUTD fn)
(DELFROMFILE (MethName class selector)
(QUOTE METHODS))
(MARKASCHANGED fn NIL (QUOTE DELETED]
(COND
[prop (SETQ methObj (GetMethodObj class selector))
(COND
((FMEMB prop (GetClassValue methObj (QUOTE ivProperties)))
(PutValueOnly methObj prop NotSetValue))
(T (DeleteIV methObj (QUOTE method)
prop]
(T (* \DeleteNthEntry requires knowing the freePos.
Must compute it from selectors because it checks for
occurrence of NIL in block to mark end)
(DELFROMFILE (MethName class selector)
(QUOTE METHODS))
(FlushMethodCache)
(AND ($! methName)
(← ($! methName)
Destroy))
(UNINTERRUPTABLY
[SETQ freePos (\FreeEntryIndex (SETQ sel (fetch selectors of class]
(\DeleteNthEntry sel index freePos)
(\DeleteNthEntry (fetch methods of class)
index freePos))])
(DoFringeMethods
[NLAMBDA obj% selector% ..args (* dgb: "29-Feb-84 08:49")
(* This calls all the methods of an object in the
immediate supers of the object.
selector is evaluated.)
(PROG [selector object objClass fn (argList (MAPCAR obj% selector% ..args (FUNCTION EVAL]
(DECLARE (LOCALVARS . T))
(SETQ object (CAR argList))
(SETQ selector (CADR argList))
(SETQ argList (CONS object (CDDR argList)))
(SETQ objClass (Class object))
(COND
((SETQ fn (FetchMethod objClass selector))
(APPLY fn argList))
(T (for cls in (fetch localSupers of objClass) do (COND
((SETQ fn (FetchMethod cls selector))
(APPLY fn argList])
(DoMethod
[NLAMBDA obj% selector% class% ..args (* dgb: "29-Feb-84 08:49")
(* Function for macro so that args are known)
(DECLARE (LOCALVARS . T)
(SPECVARS classForMethod))
(PROG (classForMethod allArgs oBj)
(SETQ allArgs (MAPCAR obj% selector% class% ..args (FUNCTION EVAL)))
(SETQ oBj (pop allArgs))
(RETURN (APPLY [OR (FetchMethod (OR (CADR allArgs)
(Class oBj))
(CAR allArgs))
(ERROR (CAR allArgs)
(CONCAT "not a selector for " (OR (CADR allArgs)
(Class oBj]
(CONS oBj (CDDR allArgs])
(IVFunction
[LAMBDA (obj ivName) (* dgb: "29-Feb-84 15:21")
(PROG ((fnName (GetValue obj ivName)))
(RETURN (COND
((DEFINEDP fnName)
fnName))
(T (LoopsHelp "No iv function" obj ivName fnName])
(InstallMethod
[LAMBDA (self) (* dgb: "19-Jun-84 21:43")
(* Used in kernel system to add methods.
Replaced by FullInstallMethod after LOOPSKERNEL is
loaded by LOADLOOPS)
(AddMethod (GetObjectRec (@ className))
(@ selector)
(@ method])
(LoopsHelp
[LAMBDA (mess1 mess2 mess3 mess4) (* dgb: "29-Feb-84 15:26")
(COND
((NULL LoopsDebugFlg)
(ERROR mess1 mess2)))
(AND mess1 (PRIN2 mess1)
(TERPRI))
(AND mess2 (PRIN2 mess2)
(TERPRI))
(AND mess3 (PRIN2 mess3)
(TERPRI))
(AND mess4 (PRIN2 mess4)
(TERPRI))
(HELP "Loops Help"])
(METH
[NLAMBDA methDescr (* dgb: " 7-DEC-83 14:46")
(* * Put out by the class method. Contains in order the (className selector methName (if different from
className.selector) args doc . other-properties))
(PROG (self cName sel fnName methName (descr methDescr))
(SETQ cName (pop descr))
(SETQ sel (pop descr))
(SETQ methName (MethName cName sel))
(COND
((AND (SETQ fnName (CAR descr))
(LITATOM fnName)) (* Method name which is not identical to methName)
(SETQ descr (CDR descr)))
(T (SETQ fnName methName)))
(DefMethObj cName sel fnName (CAR descr)
(CADR descr)
NIL
(CDDR descr])
(MethName
[LAMBDA (classOrName selector) (* dgb: " 5-Apr-84 08:14")
(* Make name of form className.selector)
(PACK* (COND
((type? class classOrName)
(ClassName classOrName))
(T classOrName))
"." selector])
(MoveMethod
[LAMBDA (oldClassName newClassName selector newSelector files)
(* edited: "25-Jun-84 12:49")
(* Move a method from oldClassName to newClassName,
renaming function if appropriate)
(SETQ oldClassName (GoodClassName oldClassName NIL T))
(OR newClassName (SETQ newClassName oldClassName))
(SETQ newClassName (GoodClassName newClassName NIL T))
(OR newSelector (SETQ newSelector selector))
(PROG (oldDef newLocalFn delFnFlg oldRuleSetName oldRuleSet newRuleSetName newRuleSet
(oldClass (GetClassRec oldClassName))
(newClass (GetClassRec newClassName))
(localFn (FindLocalMethod (GetClassRec oldClassName)
selector)))
(COND
((NULL localFn)
(printout T selector " not found in " oldClassName)
(RETURN NIL))
[(STRPOS oldClassName localFn)
(OR (SETQ oldDef (CDR (GETDEF localFn)))
(ERROR "No defintion found for " localFn))
(* Remember to delete fn def Dont use DELDEF since it
bitches.)
(SETQ delFnFlg T)
(COND
([NEQ NotSetValue (SETQ oldRuleSetName (GetMethod oldClass selector (QUOTE RuleSet]
(* Treat specially those that are implemented by
RuleSets.)
(SETQ oldRuleSet (GetObjectRec oldRuleSetName))
(SETQ newRuleSetName (MethName (ClassName newClass)
selector))
(SETQ newRuleSet (← oldRuleSet CopyRules newRuleSetName newClass))
(SETQ newFn (DefRSM newClass selector newRuleSetName)))
(T (* Define the method)
(SETQ newFn (DM (ClassName newClass)
newSelector
(COPY (CAR oldDef))
(COPY (CDDR oldDef]
(T (AddMethod newClass selector localFn)))
(for prop in (DREMOVE (QUOTE RuleSet)
(← oldClass List (QUOTE Method)
selector))
do (PutMethodOnly newClass newSelector (GetMethodOnly oldClass selector prop)
prop))
(DeleteMethod oldClass selector delFnFlg)
(RETURN (OR newLocalFn localFn])
(RenameMethod
[LAMBDA (classOrName oldSelector newSelector) (* dgb: " 9-Apr-84 08:30")
(* * Rename selector in class, and rename method also if it is composite. If oldClassName is given, then class has
been renamed, and not selector changed.)
(PROG (className class newLocalFn oldDef localFn newMethName)
[COND
((type? class classOrName)
(SETQ class classOrName)
(SETQ className (ClassName class)))
(T (SETQ className (GoodClassName classOrName NIL T))
(SETQ class (GetClassRec className]
(SETQ localFn (FindLocalMethod class oldSelector))
(COND
((NULL localFn)
(printout T oldSelector " not found in " className)
(RETURN))) (* Rename Method Object so that old one goes away)
[COND
((STRPOS className localFn)
(OR (SETQ oldDef (CDR (GETDEF localFn)))
(ERROR localFn " defn cannot be found for RenameMethod"]
(← (GetMethodObj class oldSelector T)
ChangeName
(MethName class oldSelector)
(SETQ newMethName (MethName className newSelector))
newSelector)
(COND
(oldDef (DeleteMethod class oldSelector)
(DM className newSelector (CAR oldDef)
(CDR oldDef)))
(T (DeleteMethod class oldSelector)
(DM className newSelector localFn)))
(RETURN newMethName])
(←SuperFringe
[NLAMBDA obj% selector% ..args (* dgb: "29-Feb-84 08:49")
(* This calls all the methods of an object in the
immediate supers of the object.
selector is not evaluated.)
(PROG (callerClass fn object selector argList)
(DECLARE (LOCALVARS . T))
(SETQ object (EVAL (CAR obj% selector% ..args)))
(SETQ selector (CADR obj% selector% ..args))
(SETQ argList (MAPCAR (CDDR obj% selector% ..args)
(FUNCTION EVAL)))
(SETQ argList (CONS object argList))
(SETQ callerClass (GetCallerClass object selector (QUOTE ←SuperFringe)))
(for cls in (fetch localSupers of callerClass) do (COND
((SETQ fn (FetchMethod cls selector))
(APPLY fn argList])
(FindLocalMethod
[LAMBDA (class selector) (* dgb: " 9-JUN-83 22:27")
(* Return function handling method in this class, or NIL
if there is none)
(PROG ((index (FindSelectorIndex class selector)))
(RETURN (AND index (GetNthMethod class index])
(FindSelectorIndex
[LAMBDA (class selector) (* dgb: " 9-JUN-83 22:27")
(PROG NIL (* Prog is only so one can bomb out in case of NIL
selectors of class)
(RETURN (\FindEntryIndex selector (OR (fetch selectors of class)
(RETURN])
(Fix@$
[LAMBDA (atom tail) (* dgb: " 3-JUN-83 15:01")
(PROG (FORM ATOM (FIRSTCHAR (NTHCHAR atom 1)))
(SELECTQ FIRSTCHAR
[($ @)
(COND
((SETQ ATOM (SUBATOM atom 2)) (* Used form $loopsName or @ivName)
(SETQ FORM (LIST FIRSTCHAR ATOM))
(AND (LISTP tail)
(RPLACA tail FORM)))
((AND (EQ FIRSTCHAR (QUOTE @))
(LISTP tail)
(LISTP (CAR tail))) (* Tried to use old form @ (FOO FIE). Put @ inside
parens)
(SETQ FORM (CONS FIRSTCHAR (CAR tail)))
(RPLACA tail FORM)
(RPLACD tail (CDDR tail]
NIL)
(RETURN FORM])
(FlushMethodCache
[LAMBDA NIL (* dgb: "29-Feb-84 11:55")
(AND UseMethodCacheFlg (TYPENAMEP ClassBlock (QUOTE VMEMPAGEP))
(\ZEROWORDS ClassBlock (\ADDBASE ClassBlock 255])
(FullInstallMethod
[LAMBDA (self) (* dgb: " 1-NOV-83 08:02")
(* Used after kernel is installed.
Calls a method to install a method)
(← self OldInstance])
(FetchMethod
[LAMBDA (classRec selector) (* dgb: "28-Feb-84 17:48")
(* Returns the function for selector or NIL)
(PROG (pos meth index supers (class classRec))
(OR (type? class classRec)
(RETURN))
(OR UseMethodCacheFlg (GO ON))
[SETQ pos (LOGAND 254 (LOGXOR (\LOLOC classRec)
(\LOLOC selector] (* pos is an even postion on the page, computed from the
xor of the selector and the classRec addresses)
[COND
((AND (EQ classRec (\GETBASEPTR ClassBlock pos))
(EQ selector (\GETBASEPTR SelectorBlock pos)))
(RETURN (\GETBASEPTR MethodBlock pos]
ON (SETQ supers (fetch supers of classRec))
LP (COND
((SETQ index (FindSelectorIndex class selector))
(GO OUT))
((SETQ class (pop supers))
(GO LP))
(T (RETURN NIL)))
OUT (SETQ meth (GetNthMethod class index))
(COND
(UseMethodCacheFlg (\PUTBASEPTR ClassBlock pos classRec)
(\PUTBASEPTR SelectorBlock pos selector)
(\PUTBASEPTR MethodBlock pos meth)))
(RETURN meth])
(FetchMethodOrHelp
[LAMBDA (self selector) (* dgb: "29-Feb-84 15:40")
(* Searches for an selector up the supers chain. If UseMethodCacheFlg=T then searches first in the method cache.
If none found, searches for the MessageNotUnderstood action. If that is not found, causes a LISP break.)
(PROG (class)
TOP (SETQ class (Class self))
LP (RETURN (OR (AND class (OR (FetchMethod class selector)
(AND (FetchMethod class (QUOTE MessageNotUnderstood))
(SETQ selector (← self MessageNotUnderstood selector))
(GO LP))
(LoopsHelp (LIST (QUOTE ←)
(COND
((EQ selector (QUOTE PrintOn))
(QUOTE ***))
(T self))
selector
(QUOTE --))
"not understood")))
(PROGN (* Here if Object not found. Invokes the NoObjectForMsg
message on the current value of the LISP global variable
DefaultObject. See Object.NoObjectForMsg.)
(SETQ LastDefaultValue (DoMethod self (QUOTE NoObjectForMsg)
DefaultObject selector))
(RETURN (QUOTE GetLastDefaultValue])
(GetCallerClass
[LAMBDA (object selector fromCaller) (* dgb: "29-Feb-84 15:42")
(* Get the class of the caller for use by ←Super)
(PROG (class fn index supersList stkPos (callerName fromCaller))
SETCALLER
(OR (SETQ stkPos (REALSTKNTH -1 (OR stkPos callerName)
NIL stkPos))
(LoopsHelp selector "No caller found in " (OR fromCaller "←Super")))
(SETQ callerName (STKNAME stkPos))
CALLERSET
(SETQ class (Class object))
(SETQ supersList (Supers class))
LP [COND
((SETQ index (FindSelectorIndex class selector))
(* There is a method in this class)
(COND
((EQ callerName (SETQ fn (GetNthMethod class index)))
(* Fn here is the same one I am in.
Return class as callerName of DoSuperMethods)
(RELSTK stkPos)
(RETURN class]
(COND
((SETQ class (pop supersList)) (* Try next superClass)
(GO LP))
(T (* Never found containing method -- Move Back one
callerName)
(GO SETCALLER])
(GetNthMethod
[LAMBDA (class n) (* dgb: "28-APR-83 18:37")
(PROG ((meths (fetch methods of class)))
(RETURN (COND
((LISTP meths)
(GetNth meths n))
(T (\GetNthEntry meths n])
(GetSuperMethod
[LAMBDA (object selector callerName) (* dgb: "29-Feb-84 15:42")
(* Searches for an selector up the supers chain.
If none found, calls LISP HELP.)
(PROG (index fn flg supersList class stkPos)
[COND
(callerName (* first time could be set by interpreted ←Super)
(GO CALLERSET))
(T (* Initialization for SETCALLER)
(SETQ callerName (QUOTE GetSuperMethod]
SETCALLER
(OR (SETQ stkPos (REALSTKNTH -1 (OR stkPos callerName)
NIL stkPos))
(PROGN (RELSTK stkPos)
(LoopsHelp "No caller found in ←Super for:
" selector)))
(SETQ callerName (STKNAME stkPos))
CALLERSET
(SETQ class (Class object))
(SETQ supersList (Supers class))
LP [COND
((SETQ index (FindSelectorIndex class selector))
(* There is a response in this class)
(COND
((EQ callerName (SETQ fn (GetNthMethod class index)))
(* Fn here is the same one I am in.
Mark caller as found by seting flg)
(SETQ flg T))
(flg (* found a response and have previously seen caller of
←Super)
(RELSTK stkPos)
(RETURN fn]
(COND
((SETQ class (pop supersList)) (* Try next superClass)
(GO LP))
(flg (* No super found, though method was found)
(LoopsHelp selector "not understood in ←Super"))
(T (* Never found containing method -- Move Back one
caller)
(GO SETCALLER])
(PrintMeths
[LAMBDA (methList file) (* dgb: "21-OCT-83 07:11")
(printout file .FONT DEFAULTFONT "[DefMeths")
(for name self in methList when (SETQ self (GetObjectRec name))
do (printout file T "(" .FONT LAMBDAFONT name , .FONT DEFAULTFONT .PPFTL
[NCONC [COND
((NEQ name (@ method))
(LIST (@ method]
(LIST (@ args)
(@ doc))
(CDR (FetchIVDescr self (QUOTE method]
")" T))
(printout file "]
")
methList])
(PutMethodNth
[LAMBDA (class n fn) (* edited: "31-MAY-83 15:45")
(PROG ((meths (fetch methods of class)))
(RETURN (COND
((NULL meths)
(ERROR class "no methods in class"))
((LISTP meths)
(PutNth meths n fn))
(T (\PutNthEntry meths n fn])
(←
[NLAMBDA object% selector% ..args (* dgb: "26-Apr-84 09:16")
(* This is the function version of the macro. This function does more error checking than the MACRO and converts
unbound atoms into names for classes and instances)
(PROG (objectFor←Function
(objFormIn←Function
(CAR object% selector% ..args)))
(DECLARE (LOCALVARS . T))
[COND
[[AND (LITATOM objFormIn←Function)
(EQ (QUOTE NOBIND)
(SETQ objectFor←Function
(EVALV objFormIn←Function]
(SETQ objectFor←Function
(OR (EVAL (Fix@$ objFormIn←Function
object% selector% ..args))
(PROGN
(* * This is a hack to help a user who has left off the $ from an atom)
(WRITE "Using $" objFormIn←Function)
(GetObjectRec objFormIn←Function]
(T (SETQ objectFor←Function
(EVAL objFormIn←Function]
(COND
((NULL objectFor←Function)
(ERROR objFormIn←Function
"is NIL.")))
(RETURN (APPLY (FetchMethodOrHelp objectFor←Function
(CADR object% selector% ..args))
(CONS objectFor←Function
(for X in (CDDR object% selector% ..args) collect (EVAL X])
(←!
[NLAMBDA object% selector% ..args (* dgb: "29-Feb-84 08:49")
(* This is the function version of the macro. This function does more error checking than the MACRO and converts
unbound atoms into names for classes and instances)
(PROG (object↑ (objForm (CAR object% selector% ..args)))
[COND
[(LITATOM objForm)
(* * This is a hack to help a user who has left off the $ from an atom)
(COND
((EQ (QUOTE NOBIND)
(SETQ object↑ (EVALV objForm)))
(WRITE "Using $" objForm)
(SETQ object↑ (GetObjectRec objForm]
(T (SETQ object↑ (EVAL objForm]
(COND
((NULL object↑)
(ERROR objForm "is NIL.")))
(RETURN (PROG (classForMethod) (* ClassForMethod is set by FetchMethod for use by
embedded ←Supers. It can not be set by ←! until the
object↑ has been determined.)
(RETURN (APPLY (FetchMethodOrHelp object↑ (EVAL (CADR
object% selector% ..args)))
(CONS object↑ (for X in (CDDR object% selector% ..args)
collect (EVAL X])
(←Super
[NLAMBDA FORM%@ (* dgb: " 1-JUN-83 11:58")
(* This is a form to do ←Super so that the macro
expander does not mark as changed the function
containing the ←Super)
(PROG [(stkPos (REALSTKNTH -1 (QUOTE ←Super)))
(obj% (EVAL (CAR FORM%@)))
(action (CADR FORM%@))
(args% (MAPCAR (CDDR FORM%@)
(FUNCTION EVAL]
(DECLARE (LOCALVARS . T))
(RETURN (APPLY (GetSuperMethod obj% action (PROG1 (STKNAME stkPos)
(RELSTK stkPos)))
(CONS obj% args% ])
(←←
[NLAMBDA SEND% FORM (* dgb: "15-JAN-83 23:14")
(* This is the EVALQUOTE version of the ← function.
←← quotes its arguments except for the object)
(PROG (classForMethod obj (objForm (CAR SEND% FORM)))
[COND
[(LITATOM objForm)
(* * This is a hack to help a user who has left off the %$ from an atom)
(COND
((EQ (QUOTE NOBIND)
(SETQ obj (EVALV objForm)))
(SETQ obj (GetObjectRec objForm]
(T (SETQ obj (EVAL objForm]
(RETURN (APPLY (FetchMethodOrHelp obj (CADR SEND% FORM))
(CONS obj (for % X in (CDDR SEND% FORM) collect % X])
(DCM
[LAMBDA (className selector) (* dgb: "10-JUN-83 11:55")
(* Combine methods from supers with ←SuperFringe)
(PROG [(argList (ARGLIST (GetMethod (OR (GetClassRec className)
(ERROR className "not a defined class"))
selector]
(RETURN (DM className selector argList (SUBST (CDR argList)
(QUOTE argL)
(BQUOTE (
(* Combined method for , selector)
(←SuperFringe
self , selector . argL])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS UseMethodCacheFlg ClassBlock SelectorBlock MethodBlock)
)
(RPAQQ LoopsDebugFlg T)
(RPAQQ UseMethodCacheFlg T)
(RPAQ ClassBlock (NCREATE (QUOTE VMEMPAGEP)))
(RPAQ SelectorBlock (NCREATE (QUOTE VMEMPAGEP)))
(RPAQ MethodBlock (NCREATE (QUOTE VMEMPAGEP)))
(MOVD (QUOTE ←)
(QUOTE SEND))
(ADDTOVAR NLAMA ←← ←Super ←! ← ←SuperFringe DoMethod DoFringeMethods)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA ←← ←Super ←! ← ←SuperFringe METH DoMethod DoFringeMethods)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS LOOPSMETHODS COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (9228 38084 (AddMethod 9238 . 10167) (ApplyMethod 10169 . 10697) (
ApplyMethodInTtyProcess 10699 . 11132) (DefMethObj 11134 . 12333) (DefineMethod 12335 . 14329) (
DeleteMethod 14331 . 16249) (DoFringeMethods 16251 . 17131) (DoMethod 17133 . 17825) (IVFunction 17827
. 18102) (InstallMethod 18104 . 18514) (LoopsHelp 18516 . 18872) (METH 18874 . 19669) (MethName 19671
. 20011) (MoveMethod 20013 . 22321) (RenameMethod 22323 . 23780) (←SuperFringe 23782 . 24690) (
FindLocalMethod 24692 . 25080) (FindSelectorIndex 25082 . 25448) (Fix@$ 25450 . 26146) (
FlushMethodCache 26148 . 26381) (FullInstallMethod 26383 . 26679) (FetchMethod 26681 . 27903) (
FetchMethodOrHelp 27905 . 29136) (GetCallerClass 29138 . 30489) (GetNthMethod 30491 . 30757) (
GetSuperMethod 30759 . 32736) (PrintMeths 32738 . 33284) (PutMethodNth 33286 . 33626) (← 33628 . 34868
) (←! 34870 . 36046) (←Super 36048 . 36712) (←← 36714 . 37462) (DCM 37464 . 38082)))))
STOP