(FILECREATED "20-SEP-83 12:07:02" {INDIGO}<LOOPS>SOURCES>LOOPSMETHODS.;8 22377
changes to: (MACROS MenuGetOrCreate)
previous date: "10-JUN-83 14:44:15" {INDIGO}<LOOPS>SOURCES>LOOPSMETHODS.;7)
(PRETTYCOMPRINT LOOPSMETHODSCOMS)
(RPAQQ LOOPSMETHODSCOMS [(* Copyright (c)
1983 by Xerox Corporation)
(MACROS * METHODMACROS)
(MACROS * OTHERLOOPSMACROS)
(FNS * METHODSFNS)
(P (MOVD (QUOTE ←)
(QUOTE SEND)))
(P (ADDTOVAR NLAMA ←← ←Super ←! ← ←SuperFringe DoMethod DoFringeMethods))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA ←← ←Super ←! ← ←SuperFringe DoMethod
DoFringeMethods)
(NLAML)
(LAMA])
(* Copyright (c) 1983 by Xerox Corporation)
(RPAQQ METHODMACROS (AVApply* DOAPPLY* DoMethod FetchMethod FindSelectorIndex MapSupersForm? SEND
SENDSUPER ← ←! ←New ←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 (index supers (class classRec))
(OR (type? class classRec)
(RETURN))
(SETQ supers (fetch supers of classRec))
LP (COND
((SETQ index (FindSelectorIndex class selector))
(RETURN (GetNthMethod class index)))
((SETQ class (pop supers))
(GO LP))
(T (RETURN NIL])
(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 [(obj action . args)
(PROG ((oBj obj))
(DECLARE (LOCALVARS oBj))
(RETURN (DOAPPLY*(FetchMethodOrHelp oBj (QUOTE action))
oBj . args])
(PUTPROPS ←! MACRO [(obj action . args)
(PROG ((oBj obj))
(RETURN (PROG (classForMethod)
(RETURN (DOAPPLY*(FetchMethodOrHelp oBj action)
oBj . args])
(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 ←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 (ApplyMethod ApplyMethodInTtyProcess DoFringeMethods DoMethod ←SuperFringe
FindLocalMethod FindSelectorIndex Fix@$ FetchMethod FetchMethodOrHelp
GetCallerClass GetNthMethod GetSuperMethod PutMethodNth ← ←! ←Super ←←
DCM))
(DEFINEQ
(ApplyMethod
[LAMBDA (object selector argList class) (* dgb: "28-APR-83 18:40")
(* 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])
(DoFringeMethods
[NLAMBDA obj% selector% ..args (* sm: " 9-JUN-83 11:06")
(* 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: "28-APR-83 18:40")
(* 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])
(←SuperFringe
[NLAMBDA obj% selector% ..args (* dgb: "10-JUN-83 14:33")
(* 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])
(FetchMethod
[LAMBDA (classRec selector) (* dgb: " 9-JUN-83 22:27")
(* Returns the function for selector or NIL)
(PROG (index supers (class classRec))
(OR (type? class classRec)
(RETURN))
(SETQ supers (fetch supers of classRec))
LP (COND
((SETQ index (FindSelectorIndex class selector))
(RETURN (GetNthMethod class index)))
((SETQ class (pop supers))
(GO LP))
(T (RETURN NIL])
(FetchMethodOrHelp
[LAMBDA (self selector) (* dgb: "28-APR-83 18:40")
(* Searches for an selector up the supers chain. 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))
(HELP (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) (* sm: " 9-JUN-83 11:02")
(PROG (class fn index supersList stkPos (callerName fromCaller))
SETCALLER
[OR (SETQ stkPos (REALSTKNTH -1 (OR stkPos callerName)
NIL stkPos))
(HELP selector (CONCAT "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: " 9-JUN-83 22:27")
(* 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)
(HELP "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)
(HELP selector "not understood in ←Super"))
(T (* Never found containing method -- Move Back one
caller)
(GO SETCALLER])
(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: " 3-JUN-83 15:05")
(* 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)))
(DECLARE (LOCALVARS . T))
[COND
[[AND (LITATOM objForm)
(EQ (QUOTE NOBIND)
(SETQ object↑ (EVALV objForm]
(SETQ object↑ (OR (EVAL (Fix@$ objForm object% selector% ..args))
(PROGN
(* * This is a hack to help a user who has left off the $ from an atom)
(WRITE "Using $" objForm)
(GetObjectRec objForm]
(T (SETQ object↑ (EVAL objForm]
(COND
((NULL object↑)
(ERROR objForm "is NIL.")))
(RETURN (APPLY (FetchMethodOrHelp object↑ (CADR object% selector% ..args))
(CONS object↑ (for X in (CDDR object% selector% ..args) collect
(EVAL X])
(←!
[NLAMBDA object% selector% ..args (* dgb: "10-FEB-83 21:37")
(* 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])
)
(MOVD (QUOTE ←)
(QUOTE SEND))
(ADDTOVAR NLAMA ←← ←Super ←! ← ←SuperFringe DoMethod DoFringeMethods)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA ←← ←Super ←! ← ←SuperFringe DoMethod DoFringeMethods)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (7355 22065 (ApplyMethod 7365 . 7893) (ApplyMethodInTtyProcess 7895 . 8328) (
DoFringeMethods 8330 . 9209) (DoMethod 9211 . 9903) (←SuperFringe 9905 . 10813) (FindLocalMethod 10815
. 11203) (FindSelectorIndex 11205 . 11571) (Fix@$ 11573 . 12269) (FetchMethod 12271 . 12844) (
FetchMethodOrHelp 12846 . 13997) (GetCallerClass 13999 . 15231) (GetNthMethod 15233 . 15499) (
GetSuperMethod 15501 . 17460) (PutMethodNth 17462 . 17802) (← 17804 . 18848) (←! 18850 . 20027) (
←Super 20029 . 20693) (←← 20695 . 21443) (DCM 21445 . 22063)))))
STOP