(FILECREATED "11-Mar-86 09:19:08" {SUMEX-AIM}PS:<LANE>GRAPHCALLS.LSP;51 39437
changes to: (PROPS (CALLSMENU MENU))
previous date: "18-Feb-86 10:52:09" {SUMEX-AIM}PS:<LANE>GRAPHCALLS.LSP;50)
(* Copyright (c) 1984, 1985, 1986 by Stanford University. All rights reserved.)
(PRETTYCOMPRINT GRAPHCALLSCOMS)
(RPAQQ GRAPHCALLSCOMS [(* * GRAPHCALLS Dynamic Function Graphing)
(LOCALVARS . T)
(FNS GRAPHCALLS GRAPHCALLS1 DEFAULTGRAPHCALLSFN ADVISECALLS BREAKINCALLS CALLSLEFTFN
CALLSMIDDLEFN COLLECTCALLS INSPECTFRAME INSPECTCALLS $INVERTID$ CALLSFETCH CALLSSTORE
CALLSPRINT CALLSCLOSEFN GRAPHWCLOSEFN NO\)
(INITVARS (CALLSDELAY 250)
[GRAPHCALLSFONT (FONTCLASS 'GRAPHCALLSFONT
'(13 (GACHA 8)
(GACHA 8)
(MODERN 8))
'(DISPLAY INTERPRESS)]
(CALLSINSPECTWIDTH 250)
(GRAPHCALLSDEPTH 2)
(INSPECTCODEWIDTH 400)
(GRAPHCALLSDEFAULTFORMAT '(HORIZONTAL COMPACT REVERSE/DAUGHTERS))
(DEFAULTGRAPHCALLSFN (FUNCTION DEFAULTGRAPHCALLSFN))
(GRAPHCALLSSUBFNDEFFLG T)
GRAPHCALLSINSPECTCODEW)
(VARS NOADVISEFNS)
(PROP MENU * GRAPHCALLSMENUS)
(INITVARS * GRAPHCALLSMENUS)
(GLOBALVARS * GRAPHCALLSMENUS)
(GLOBALVARS CALLSDELAY GRAPHCALLSFONT CALLSINSPECTWIDTH GRAPHCALLSDEPTH NOADVISEFNS
INSPECTCODEWIDTH GRAPHCALLSDEFAULTFORMAT DEFAULTGRAPHCALLSFN
GRAPHCALLSSUBFNDEFFLG GRAPHCALLSINSPECTCODEW)
(DECLARE: DONTCOPY (RECORDS CALLSRECORD))
(GLOBALVARS DEFAULT.GRAPH.NODEBORDER DEFAULT.GRAPH.NODEFONT DEFAULT.GRAPH.NODELABELSHADE)
(BLOCKS (GRAPHCALLS (SPECVARS GRAPHCALLSEEN)
(GLOBALVARS GRAPHCALLSFONT GRAPHCALLSDEPTH NOADVISEFNS)
(ENTRIES GRAPHCALLS)
GRAPHCALLS GRAPHCALLS1 ADVISECALLS)
(INSPECTFRAME (SPECVARS COLLECTCALLSEEN)
(GLOBALVARS CALLSINSPECTWIDTH)
(ENTRIES INSPECTFRAME)
INSPECTFRAME INSPECTCALLS COLLECTCALLS))
(FILES (SYSLOAD FROM LISPUSERS)
GRAPHER)
[P (for MENU in GRAPHCALLSMENUS do (SET MENU (EVAL (GETPROP MENU 'MENU]
(* * GRAPHCALLS Command Window)
(FNS GRAPHCALLSW CLEARCOMMANDMENU DOGRAPHCALL GRAPHFILTER INCLUDEFNS PRINTGRAPHFN)
(INITVARS GRAPHCOMMANDW (SCRATCHMENU (create MENU)))
(VARS GRAPHMENUS)
(PROP MENU * (PROGN GRAPHMENUS))
(GLOBALVARS GRAPHCOMMANDW SCRATCHMENU GRAPHMENUS)
(DECLARE: DONTCOPY (RECORDS GRAPHMENUREC)
(CONSTANTS WHITESHADE BLACKSHADE null))
(ADDVARS (BackgroundMenuCommands ("GraphCalls" '(GRAPHCALLSW)
"Puts up a GraphCalls Command Window")))
(P (SETQ BackgroundMenu NIL))
(* * Multiple Selection Menus)
(FNS MMENU MMENUSELECTEDFN MARKMENUITEM SUBITEMSELECTFN MAKEBOLDMENUITEM)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML $INVERTID$)
(LAMA])
(* * GRAPHCALLS Dynamic Function Graphing)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DEFINEQ
(GRAPHCALLS
[LAMBDA (FN FILTER DEPTH FLAGS FORMAT STREAM SEARCHFN NAMEFN)
(* cdl "15-Oct-85 14:34")
(PROG (GRAPHNODES GRAPH GRAPHCALLSEEN (FONT GRAPHCALLSFONT))
(DECLARE (SPECVARS GRAPHCALLSEEN))
(if (NULL SEARCHFN)
then (SETQ SEARCHFN DEFAULTGRAPHCALLSFN))
(if (NULL (APPLY* SEARCHFN FN))
then (RETURN))
(if STREAM
then (SETQ FONT (DSPFONT NIL STREAM)))
(if (NULL FORMAT)
then (SETQ FORMAT GRAPHCALLSDEFAULTFORMAT))
(SETQ GRAPHNODES (GRAPHCALLS1 FN FILTER (OR DEPTH GRAPHCALLSDEPTH)
(FONTCOPY (FONTCLASSCOMPONENT FONT STREAM)
'WEIGHT
'BOLD)
SEARCHFN NAMEFN))
(SETQ GRAPH (LAYOUTGRAPH GRAPHNODES (LIST FN)
FORMAT FONT))
(SETQ FLAGS (MKLIST FLAGS))
(if (OR (NULL STREAM)
(WINDOWP STREAM))
then [if (OR (MEMB 'SHAPE
FLAGS)
(MEMB 'COUNT
FLAGS))
then (LET (GRAPHWIDTH GRAPHHEIGHT)
[with REGION (GRAPHREGION GRAPH)
(SETQ GRAPHWIDTH
(WIDTHIFWINDOW (if (MEMB 'COUNT
FLAGS)
then (PLUS WIDTH
(STRINGWIDTH
"00000"
GRAPHCALLSFONT))
else WIDTH)))
(SETQ GRAPHHEIGHT (HEIGHTIFWINDOW
HEIGHT
(MEMB 'EDIT
FLAGS]
(if (WINDOWP STREAM)
then (with REGION (WINDOWPROP STREAM 'REGION)
(SHAPEW STREAM
(CREATEREGION LEFT BOTTOM
GRAPHWIDTH
GRAPHHEIGHT)))
else (SETQ STREAM (CREATEW (GETBOXREGION GRAPHWIDTH
GRAPHHEIGHT]
(SETQ STREAM (SHOWGRAPH GRAPH STREAM (FUNCTION CALLSLEFTFN)
(FUNCTION CALLSMIDDLEFN)
(MEMB 'TOP
FLAGS)
(MEMB 'EDIT
FLAGS)))
(WINDOWPROP STREAM 'CLOSEFN
(FUNCTION GRAPHWCLOSEFN))
(SETQ STREAM (WINDOWPROP STREAM 'DSP))
else (DISPLAYGRAPH GRAPH STREAM))
(if (OR (MEMB 'INVERT
FLAGS)
(MEMB 'COUNT
FLAGS))
then (STREAMPROP STREAM 'ADVISEDFNS
(ADVISECALLS GRAPHNODES FN FLAGS STREAM)))
(STREAMPROP STREAM 'FILTER
FILTER)
(STREAMPROP STREAM 'FLAGS
FLAGS)
(STREAMPROP STREAM 'FORMAT
FORMAT)
(STREAMPROP STREAM 'SEARCHFN
SEARCHFN)
(STREAMPROP STREAM 'NAMEFN
NAMEFN)
(RETURN STREAM])
(GRAPHCALLS1
[LAMBDA (FN FILTER DEPTH FONT SEARCHFN NAMEFN) (* cdl "15-Oct-85 09:54")
(PROG (GRAPHNODES GRAPHNODE)
(push GRAPHCALLSEEN FN)
[with GRAPHNODE (SETQ GRAPHNODE (create GRAPHNODE
NODEID ← FN
NODELABEL ←(if NAMEFN
then (APPLY* NAMEFN FN)
else FN)))
(if (NULL (SETQ TONODES (for SUBFN in (CAR (APPLY* SEARCHFN FN))
when (OR (NULL FILTER)
(APPLY* FILTER SUBFN))
collect SUBFN)))
then (SETQ NODEFONT FONT)
(RETURN (CONS GRAPHNODE)))
(if (ZEROP DEPTH)
then (SETQ TONODES NIL)
else (SETQ GRAPHNODES (for SUBFN in TONODES unless (FMEMB SUBFN
GRAPHCALLSEEN)
join (GRAPHCALLS1 SUBFN FILTER (SUB1 DEPTH)
FONT SEARCHFN NAMEFN]
(RETURN (CONS GRAPHNODE GRAPHNODES])
(DEFAULTGRAPHCALLSFN
[LAMBDA (FN) (* cdl "18-Feb-86 10:39")
(if (FGETD FN)
then (if GRAPHCALLSSUBFNDEFFLG
then (RESETLST [RESETSAVE NIL (BQUOTE (PUTD \SUBFNDEF ,
(PROG1
(GETD '\SUBFNDEF)
(MOVD 'NILL
'\SUBFNDEF]
(CALLS FN))
else (CALLS FN])
(ADVISECALLS
[LAMBDA (GRAPHNODES ROOTID FLAGS STREAM) (* cdl "15-Oct-85 10:25")
(PROG (ADVISEDFNS FN)
[for GRAPHNODE in GRAPHNODES
do (for TONODE in (with GRAPHNODE GRAPHNODE TONODES)
when (AND (SETQ FN (if (LISTP TONODE)
then (CAR TONODE)
else TONODE))
(FGETD FN)
(NOT (MEMB FN NOADVISEFNS)))
do (push ADVISEDFNS (UNMARKASCHANGED
(ADVISE (LIST FN 'IN
(with GRAPHNODE GRAPHNODE
(if (LISTP NODEID)
then (CAR NODEID)
else NODEID)))
'AROUND
(BQUOTE ($INVERTID$ , (GETNODEFROMID FN
GRAPHNODES)
, STREAM * , FLAGS)))
'ADVICE]
(UNMARKASCHANGED (ADVISE ROOTID 'AROUND
(BQUOTE ($INVERTID$ , (GETNODEFROMID ROOTID GRAPHNODES)
, STREAM * , FLAGS)))
'ADVICE)
(push ADVISEDFNS ROOTID)
(RETURN ADVISEDFNS])
(BREAKINCALLS
[LAMBDA (NODE WINDOW FN) (* cdl " 9-Sep-85 08:45")
(PROG [PARENT NODELST (GRAPHNODES (fetch GRAPHNODES of (WINDOWPROP WINDOW 'GRAPH]
(with GRAPHNODE NODE (if (NULL FROMNODES)
then (RETURN))
(SETQ NODELST (for FROMNODE in FROMNODES collect (GETNODEFROMID
FROMNODE
GRAPHNODES)))
(if (CDR NODELST)
then (for N in NODELST do (FLIPNODE N WINDOW))
(CALLSPRINT "In the context of which node?")
(SETQ PARENT (READ/NODE NODELST WINDOW))
(for N in NODELST do (FLIPNODE N WINDOW))
else (SETQ PARENT (CAR NODELST)))
(if PARENT
then (CALLSPRINT (APPLY* FN (LIST NODELABEL 'IN
(fetch NODELABEL of PARENT])
(CALLSLEFTFN
[LAMBDA (GRAPHNODE WINDOW)
(DECLARE (SPECVARS GRAPHNODE WINDOW)) (* cdl "15-Oct-85 10:06")
(LET [FN (STREAM (WINDOWPROP WINDOW 'DSP]
(DECLARE (SPECVARS FN STREAM))
(if GRAPHNODE
then (if (LISTP (SETQ FN (fetch (GRAPHNODE NODEID) of GRAPHNODE)))
then (SETQ FN (CAR FN)))
(MENU CALLSMENU)
else (MENU GRAPHCALLSMENU])
(CALLSMIDDLEFN
[LAMBDA (GRAPHNODE WINDOW)
(DECLARE (SPECVARS GRAPHNODE)) (* cdl "15-Oct-85 10:07")
(LET (FN)
(DECLARE (SPECVARS FN))
(if (AND GRAPHNODE GRAPHCOMMANDW)
then (if (LISTP (SETQ FN (fetch (GRAPHNODE NODEID) of GRAPHNODE)))
then (SETQ FN (CAR FN)))
(MENU CALLSMIDDLEMENU])
(COLLECTCALLS
[LAMBDA (FN GRAPHNODES BACKFLG) (* cdl "10-Oct-85 17:43")
(PROG [EXPANDCALLS CALLS (VARS (AND (FGETD FN)
(VARS FN]
[with GRAPHNODE (GETNODEFROMID FN GRAPHNODES)
(SETQ EXPANDCALLS (for ID in (if BACKFLG
then FROMNODES
else TONODES)
unless (FMEMB ID COLLECTCALLSEEN)
collect (PROGN (push COLLECTCALLSEEN ID)
ID]
(while [ILESSP (LENGTH VARS)
(CONSTANT (LENGTH (RECORDFIELDNAMES 'CALLSRECORD]
do (SETQ VARS (NCONC1 VARS NIL)))
[if EXPANDCALLS
then (for ID in EXPANDCALLS when (FGETD ID)
do (SETQ CALLS (COLLECTCALLS ID GRAPHNODES BACKFLG))
(with CALLSRECORD VARS (SETQ FREEVARS (UNION
FREEVARS
(fetch (CALLSRECORD FREEVARS) of CALLS)))
(SETQ GLOBALVARS (UNION GLOBALVARS (fetch (CALLSRECORD
GLOBALVARS)
of CALLS]
(replace (CALLSRECORD LOCALVARS) of VARS with NIL)
(RETURN VARS])
(INSPECTFRAME
[LAMBDA (FN WINDOW TREEFLG BACKFLG) (* cdl "10-Oct-85 17:41")
(PROG (RECORD COLLECTCALLSEEN VARS)
(DECLARE (SPECVARS COLLECTCALLSEEN))
(if (AND TREEFLG (OR BACKFLG (FGETD FN))
(SETQ RECORD (COLLECTCALLS FN (fetch GRAPHNODES
of (WINDOWPROP WINDOW 'GRAPH))
BACKFLG))
(in RECORD thereis LISTP))
then (INSPECTCALLS RECORD WINDOW (CONCAT FN "'s "
(if BACKFLG
then "scope"
else "tree")))
elseif (AND (NOT TREEFLG)
(FGETD FN)
(in (SETQ VARS (VARS FN)) thereis LISTP))
then (INSPECTCALLS VARS WINDOW FN)
else (CALLSPRINT NIL "Nothing to INSPECT!"])
(INSPECTCALLS
[LAMBDA (RECORD WINDOW LABEL) (* cdl "27-Jun-85 16:04")
(PROG [INSPECTW INSPECTWS REGION (LINEHEIGHT (FONTPROP DEFAULTFONT 'HEIGHT]
(SETQ REGION (CREATEREGION NIL NIL (WIDTHIFWINDOW CALLSINSPECTWIDTH)
(HEIGHTIFWINDOW (ITIMES (LENGTH (in RECORD
thereis LISTP))
LINEHEIGHT)
T)))
(with REGION (with REGION REGION (GETBOXREGION WIDTH HEIGHT))
(replace (REGION LEFT) of REGION with LEFT)
(replace (REGION BOTTOM) of REGION with BOTTOM))
[SETQ INSPECTWS (for FIELD in [CONSTANT (REVERSE (RECORDFIELDNAMES
'CALLSRECORD]
as VALUE in RECORD when VALUE
collect (PROG1
(SETQ INSPECTW
(INSPECTW.CREATE
VALUE VALUE (FUNCTION CALLSFETCH)
(FUNCTION CALLSSTORE)
NIL NIL NIL (if LABEL
then (CONCAT FIELD " in " LABEL))
NIL
(create REGION
HEIGHT ←(HEIGHTIFWINDOW
(ITIMES (LENGTH VALUE)
LINEHEIGHT)
T)
BOTTOM ←(if INSPECTW
then
(fetch (REGION TOP)
of (WINDOWPROP
INSPECTW
'REGION))
else (fetch BOTTOM
of REGION))
using REGION)))
(WINDOWPROP INSPECTW 'CLOSEFN
(FUNCTION CALLSCLOSEFN))
(WINDOWPROP INSPECTW 'GRAPHW
WINDOW]
(if INSPECTWS
then (WINDOWADDPROP WINDOW 'INSPECTWS
INSPECTWS])
($INVERTID$
[NLAMBDA ($NODE$ $STREAM$ $FORM$ $FLAGS$) (* cdl "27-Jun-85 15:11")
(if (MEMB 'INVERT
$FLAGS$)
then (FLIPNODE $NODE$ $STREAM$))
(BLOCK CALLSDELAY)
(SETQ $FORM$ (EVAL $FORM$))
(if (MEMB 'INVERT
$FLAGS$)
then (FLIPNODE $NODE$ $STREAM$))
[if (MEMB 'COUNT
$FLAGS$)
then (with GRAPHNODE $NODE$ (MOVETO (PLUS (fetch XCOORD of NODEPOSITION)
(QUOTIENT NODEWIDTH 2))
(DIFFERENCE (PLUS (fetch YCOORD of
NODEPOSITION)
(FONTPROP NODEFONT
'DESCENT)
1)
(QUOTIENT NODEHEIGHT 2))
$STREAM$)
(DSPFONT NODEFONT $STREAM$)
(printout $STREAM$ , (if (FIXP NODEBORDER)
then (add NODEBORDER 1)
else (SETQ NODEBORDER 1]
$FORM$])
(CALLSFETCH
[LAMBDA (OBJECT PROPERTY) (* cdl "21-Feb-84 14:17")
(EVALV PROPERTY])
(CALLSSTORE
[LAMBDA (OBJECT PROPERTY NEWVALUE) (* cdl "28-Feb-84 10:09")
(SET PROPERTY NEWVALUE])
(CALLSPRINT
[LAMBDA (X ERROR) (* cdl "27-Jun-85 08:26")
(CLRPROMPT)
(if X
then (CENTERPRINTINREGION X NIL PROMPTWINDOW)
elseif ERROR
then (RINGBELLS)
(CENTERPRINTINREGION ERROR NIL PROMPTWINDOW])
(CALLSCLOSEFN
[LAMBDA (WINDOW) (* cdl "27-Jun-85 16:02")
(PROG (INSPECTWS (GRAPHW (WINDOWPROP WINDOW 'GRAPHW
NIL)))
(SETQ INSPECTWS (for WINDOWLST in (WINDOWPROP GRAPHW 'INSPECTWS)
thereis (FMEMB WINDOW WINDOWLST)))
(for INSPECTW in INSPECTWS when (AND (OPENWP INSPECTW)
(NEQ INSPECTW WINDOW))
do (WINDOWPROP INSPECTW 'CLOSEFN
NIL)
(WINDOWPROP INSPECTW 'GRAPHW
NIL)
(CLOSEW INSPECTW))
(WINDOWDELPROP GRAPHW 'INSPECTWS
INSPECTWS])
(GRAPHWCLOSEFN
[LAMBDA (WINDOW) (* cdl "27-Jun-85 15:13")
(for INSPECTWS in (WINDOWPROP WINDOW 'INSPECTWS
NIL)
do (for INSPECTW in INSPECTWS when (OPENWP INSPECTW)
do (WINDOWPROP INSPECTW 'CLOSEFN
NIL)
(WINDOWPROP INSPECTW 'GRAPHW
NIL)
(CLOSEW INSPECTW)))
(LET ((FNS (STREAMPROP (WINDOWPROP WINDOW 'DSP)
'ADVISEDFNS
NIL)))
(if FNS
then (APPLY (FUNCTION UNADVISE)
FNS])
(NO\
[LAMBDA (FN) (* cdl " 6-Mar-84 14:47")
(NEQ (NTHCHARCODE FN 1)
(CHARCODE \])
)
(RPAQ? CALLSDELAY 250)
(RPAQ? GRAPHCALLSFONT (FONTCLASS 'GRAPHCALLSFONT
'(13 (GACHA 8)
(GACHA 8)
(MODERN 8))
'(DISPLAY INTERPRESS)))
(RPAQ? CALLSINSPECTWIDTH 250)
(RPAQ? GRAPHCALLSDEPTH 2)
(RPAQ? INSPECTCODEWIDTH 400)
(RPAQ? GRAPHCALLSDEFAULTFORMAT '(HORIZONTAL COMPACT REVERSE/DAUGHTERS))
(RPAQ? DEFAULTGRAPHCALLSFN (FUNCTION DEFAULTGRAPHCALLSFN))
(RPAQ? GRAPHCALLSSUBFNDEFFLG T)
(RPAQ? GRAPHCALLSINSPECTCODEW NIL)
(RPAQQ NOADVISEFNS (ALLOCSTRING BLOCK ERROR ERRORX HELP RAID RECLAIM \ALLOCBLOCK \MOVEBYTES
\MP.ERROR \STOP.DRIBBLE?))
(RPAQQ GRAPHCALLSMENUS (GRAPHCALLSMENU CALLSMENU CALLSMIDDLEMENU FNS/FILESMENU))
(PUTPROPS GRAPHCALLSMENU MENU [create MENU ITEMS ←
'[("UNBREAK" (UNBREAK)
"UnBreak everything.")
("RESET" (for GRAPHNODE in (fetch (GRAPH GRAPHNODES)
of
(WINDOWPROP WINDOW
'GRAPH))
do
(with GRAPHNODE GRAPHNODE
(if (FIXP NODEBORDER)
then
(SETQ NODEBORDER NIL)))
finally
(REDISPLAYW WINDOW]])
(PUTPROPS CALLSMENU MENU (create
MENU ITEMS ← '[("?=" (PROG (ARGS)
(CALLSPRINT (if (SETQ ARGS (NLSETQ (ARGLIST FN)))
then
(CONS FN (CAR ARGS)))
"Args not availiable!"))
"The function's argument list")
("HELP" (CALLSPRINT (NLSETQ (PROGN (IRM.LOOKUP FN)
FN))
"Help not available!")
"HelpSys information")
("FNTYP" (CALLSPRINT (FNTYP FN)
"Fn's type not found")
"Get the FNTYP of the function")
("WHERE" (CALLSPRINT (WHEREIS FN NIL T)
"File not found!")
"Do a WHEREIS on function")
("EDIT" (if (NLSETQ (PROGN (EDITDEF (fetch (GRAPHNODE NODELABEL)
of GRAPHNODE)
'FNS)
(TOTOPW WINDOW)))
else
(CALLSPRINT NIL "Nothing to EDIT!"))
"Edit the function")
("TYPEIN" (BKSYSBUF FN)
"BKSYSBUF the function name")
("BREAK" (CALLSPRINT (APPLY* (FUNCTION BREAK)
FN))
"Break this function"
(SUBITEMS ("BREAKIN" (BREAKINCALLS GRAPHNODE WINDOW
(FUNCTION BREAK))
"Break this fn in another fn")
("UNBREAKIN" (BREAKINCALLS GRAPHNODE WINDOW
(FUNCTION UNBREAK))
"UnBreak this fn in another fn")
("UNBREAK" (CALLSPRINT (APPLY* (FUNCTION UNBREAK)
FN))
"UnBreak this function")
("TRACE" (CALLSPRINT (APPLY* (FUNCTION TRACE)
FN))
"Trace this function")
("TRACEIN" (BREAKINCALLS GRAPHNODE WINDOW
(FUNCTION TRACE))
"Trace this fn in another fn")))
("CCODE" (if (CCODEP FN)
then
(if (NOT (WINDOWP GRAPHCALLSINSPECTCODEW))
then
(SETQ GRAPHCALLSINSPECTCODEW
(CREATEW (GETBOXREGION INSPECTCODEWIDTH
(DIFFERENCE SCREENHEIGHT
SCROLLBARWIDTH))
null)))
(WINDOWPROP GRAPHCALLSINSPECTCODEW 'TITLE
(CONCAT FN " Code Window"))
(DSPRESET GRAPHCALLSINSPECTCODEW)
(CLEARW GRAPHCALLSINSPECTCODEW)
(INSPECTCODE FN GRAPHCALLSINSPECTCODEW)
else
(CALLSPRINT NIL "Not compiled code!"))
"Inspect this function's ccode")
("GRAPH" (if (GRAPHCALLS FN (STREAMPROP STREAM 'FILTER)
GRAPHCALLSDEPTH
(STREAMPROP STREAM 'FLAGS)
(STREAMPROP STREAM 'FORMAT)
NIL
(STREAMPROP STREAM 'SEARCHFN)
(STREAMPROP STREAM 'NAMEFN))
else
(CALLSPRINT NIL "Nothing to graph!"))
"Graph this function's calls")
("FRAME" (INSPECTFRAME FN WINDOW)
"Inspect this function's vars"
(SUBITEMS (">FRAME" (INSPECTFRAME FN WINDOW T)
"Inspect this sub-graph's freevars")
("<FRAME" (INSPECTFRAME FN WINDOW T T)
"Inspect this fn's scope"]
CENTERFLG ← T WHENSELECTEDFN ← (FUNCTION SUBITEMSELECTFN)))
(PUTPROPS CALLSMIDDLEMENU MENU (create
MENU ITEMS ← '(("EXCLUDE" [PROG [(ALIST (WINDOWPROP GRAPHCOMMANDW 'EXCLUDEFNS))
(FILE (OR (CAR (WHEREIS FN 'FNS
FILELST))
'SYSTEM]
(if ALIST then (PUTASSOC FILE
(CONS FN
(CDR (ASSOC FILE ALIST)))
ALIST)
else
(WINDOWADDPROP GRAPHCOMMANDW 'EXCLUDEFNS
(LIST FILE FN]
"Exclude this function from future graphs"))
CENTERFLG ← T))
(PUTPROPS FNS/FILESMENU MENU (create MENU ITEMS ← '(FILES FNS)
CENTERFLG ← T))
(RPAQQ GRAPHCALLSMENUS (GRAPHCALLSMENU CALLSMENU CALLSMIDDLEMENU FNS/FILESMENU))
(RPAQ? GRAPHCALLSMENU NIL)
(RPAQ? CALLSMENU NIL)
(RPAQ? CALLSMIDDLEMENU NIL)
(RPAQ? FNS/FILESMENU NIL)
(RPAQQ GRAPHCALLSMENUS (GRAPHCALLSMENU CALLSMENU CALLSMIDDLEMENU FNS/FILESMENU))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GRAPHCALLSMENU CALLSMENU CALLSMIDDLEMENU FNS/FILESMENU)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CALLSDELAY GRAPHCALLSFONT CALLSINSPECTWIDTH GRAPHCALLSDEPTH NOADVISEFNS INSPECTCODEWIDTH
GRAPHCALLSDEFAULTFORMAT DEFAULTGRAPHCALLSFN GRAPHCALLSSUBFNDEFFLG GRAPHCALLSINSPECTCODEW)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD CALLSRECORD (LOCALVARS FREEVARS GLOBALVARS))
]
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DEFAULT.GRAPH.NODEBORDER DEFAULT.GRAPH.NODEFONT DEFAULT.GRAPH.NODELABELSHADE)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: GRAPHCALLS (SPECVARS GRAPHCALLSEEN)
(GLOBALVARS GRAPHCALLSFONT GRAPHCALLSDEPTH NOADVISEFNS)
(ENTRIES GRAPHCALLS)
GRAPHCALLS GRAPHCALLS1 ADVISECALLS)
(BLOCK: INSPECTFRAME (SPECVARS COLLECTCALLSEEN)
(GLOBALVARS CALLSINSPECTWIDTH)
(ENTRIES INSPECTFRAME)
INSPECTFRAME INSPECTCALLS COLLECTCALLS)
]
(FILESLOAD (SYSLOAD FROM LISPUSERS)
GRAPHER)
[for MENU in GRAPHCALLSMENUS do (SET MENU (EVAL (GETPROP MENU 'MENU]
(* * GRAPHCALLS Command Window)
(DEFINEQ
(GRAPHCALLSW
[LAMBDA (REBUILD?) (* cdl "15-Oct-85 17:22")
(PROG (MENULST DEFAULT PROMPTW)
(if (AND (WINDOWP GRAPHCOMMANDW)
(NOT REBUILD?))
then (with REGION (with REGION (WINDOWPROP GRAPHCOMMANDW 'REGION)
(GETBOXREGION WIDTH HEIGHT))
(MOVEW GRAPHCOMMANDW LEFT BOTTOM))
(RETURN (TOTOPW GRAPHCOMMANDW))
elseif (OPENWP GRAPHCOMMANDW)
then (CLOSEW GRAPHCOMMANDW))
[SETQ MENULST (for MENU in GRAPHMENUS collect (EVAL (GETPROP MENU
'MENU]
(SETQ GRAPHCOMMANDW (CREATEW (GETBOXREGION
[WIDTHIFWINDOW (ADD1 (for MENU in MENULST
sum (SUB1
(fetch
IMAGEWIDTH
of MENU]
(HEIGHTIFWINDOW (for MENU in MENULST
maximize (fetch IMAGEHEIGHT
of MENU))
T))
"GraphCalls Command Window"))
[bind (HEIGHT ←(WINDOWPROP GRAPHCOMMANDW 'HEIGHT))
(POSITION ←(create POSITION
XCOORD ← 0))
for MENU in MENULST do (with MENU MENU (with POSITION POSITION
(SETQ YCOORD
(IDIFFERENCE HEIGHT
IMAGEHEIGHT))
(ADDMENU MENU GRAPHCOMMANDW
POSITION)
(if (SETQ DEFAULT
(GETMENUPROP
MENU
'VALUE))
then (DOSELECTEDITEM
MENU DEFAULT))
(add XCOORD (SUB1
IMAGEWIDTH]
[WINDOWPROP GRAPHCOMMANDW 'REPAINTFN
(FUNCTION (LAMBDA (WINDOW)
(MENUREPAINTFN GRAPHCOMMANDW)
(CLEARCOMMANDMENU)
(PRINTGRAPHFN (WINDOWPROP GRAPHCOMMANDW 'FUNCTION]
[WINDOWPROP GRAPHCOMMANDW 'AFTERMOVEFN
(FUNCTION (LAMBDA (WINDOW)
(with REGION (WINDOWPROP WINDOW 'REGION)
(MOVEW (WINDOWPROP WINDOW 'PROMPTWINDOW)
LEFT PTOP]
(WINDOWPROP GRAPHCOMMANDW 'PROMPTWINDOW
(SETQ PROMPTW (CREATEW [with REGION (WINDOWPROP GRAPHCOMMANDW
'REGION)
(CREATEREGION
LEFT PTOP WIDTH
(HEIGHTIFWINDOW (FONTPROP
(DSPFONT NIL
GRAPHCOMMANDW)
'HEIGHT]
NIL NIL T)))
(WINDOWPROP PROMPTW 'PAGEFULLFN
(FUNCTION NILL))
(RETURN GRAPHCOMMANDW])
(CLEARCOMMANDMENU
[LAMBDA NIL (* cdl "15-Oct-85 14:52")
(LET [(MENUS (WINDOWPROP GRAPHCOMMANDW 'MENU]
(for I to (CONSTANT (LENGTH GRAPHMENUS)) as MENU in MENUS
do (with MENU MENU (for ITEM in SHADEDITEMS do (RPLACD ITEM 0)))
(PUTMENUPROP MENU 'VALUE
NIL))
(MENUREPAINTFN GRAPHCOMMANDW)
(with GRAPHMENUREC MENUS (DOSELECTEDITEM DELAYMENU 5)
(DOSELECTEDITEM DEPTHMENU GRAPHCALLSDEPTH))
(for PROP in '(INCLUDESET INCLUDEFNS INCLUDEFILES EXCLUDESET EXCLUDEFNS EXCLUDEFILES)
do (WINDOWPROP GRAPHCOMMANDW PROP NIL])
(DOGRAPHCALL
[LAMBDA NIL (* cdl "16-Oct-85 13:53")
(PROG [FLAGS FORMAT (FN (WINDOWPROP GRAPHCOMMANDW 'FUNCTION]
(WINDOWPROP GRAPHCOMMANDW 'INCLUDESET
(in (WINDOWPROP GRAPHCOMMANDW 'INCLUDEFNS) join CDR))
(WINDOWPROP GRAPHCOMMANDW 'EXCLUDESET
(in (WINDOWPROP GRAPHCOMMANDW 'EXCLUDEFNS) join CDR))
[if FN
then (with GRAPHMENUREC (WINDOWPROP GRAPHCOMMANDW 'MENU)
(SETQ FLAGS (in (GETMENUPROP FLAGSMENU 'VALUE) collect CADR))
(SETQ FORMAT (CONS 'REVERSE/DAUGHTERS
(in (GETMENUPROP FORMATMENU 'VALUE)
collect CADR)))
(if (AND (OR (FMEMB 'INVERT
FLAGS)
(FMEMB 'COUNT
FLAGS))
(for ITEM in (GETMENUPROP FILTERMENU 'VALUE)
never (EQ (CADR ITEM)
'WHEREIS))
(NOT (MOUSECONFIRM
"Advising without a WHEREIS filter advises system code, confirm to continue."
null)))
then (RETURN))
(if [GRAPHCALLS FN (FUNCTION GRAPHFILTER)
(GETMENUPROP DEPTHMENU 'VALUE)
FLAGS FORMAT NIL NIL
(if (FMEMB 'ARGLIST
FORMAT)
then (FUNCTION [LAMBDA (FN)
(if (FGETD FN)
then (CONS FN (
SMARTARGLIST
FN))
else FN])
elseif (FMEMB 'WHEREIS
FORMAT)
then (FUNCTION (LAMBDA (FN)
(LET ((FILES (WHEREIS
FN
'FNS
T)))
(if FILES
then (CONS FN FILES)
else FN]
then (RETURN]
(CALLSPRINT NIL "Can't graph function"])
(GRAPHFILTER
[LAMBDA (FN) (* cdl "15-Oct-85 14:54")
(PROG [(INCLUDESET (WINDOWPROP GRAPHCOMMANDW 'INCLUDESET))
(EXCLUDESET (WINDOWPROP GRAPHCOMMANDW 'EXCLUDESET))
(EXCLUDEFILES (WINDOWPROP GRAPHCOMMANDW 'EXCLUDEFILES))
(INCLUDEFILES (WINDOWPROP GRAPHCOMMANDW 'INCLUDEFILES]
(if (NULL (for FILTER in (GETMENUPROP (with GRAPHMENUREC (WINDOWPROP
GRAPHCOMMANDW
'MENU)
FILTERMENU)
'VALUE)
always (APPLY* (CADR FILTER)
FN)))
then (RETURN)
elseif (AND EXCLUDESET (FMEMB FN EXCLUDESET))
then (RETURN)
elseif (AND INCLUDESET (FMEMB FN INCLUDESET))
then (RETURN FN)
elseif (AND EXCLUDEFILES (WHEREIS FN 'FNS
EXCLUDEFILES))
then (RETURN)
elseif INCLUDEFILES
then (RETURN (WHEREIS FN 'FNS
INCLUDEFILES))
else (RETURN FN])
(INCLUDEFNS
[LAMBDA (INFLG) (* cdl "10-Oct-85 08:18")
(DECLARE (GLOBALVARS FILELST))
(PROG (FILES FNS FNS/FILES ALIST LABEL)
(SETQ LABEL (if INFLG
then "Include "
else "Exclude "))
(if (NULL (SETQ FNS/FILES (MENU FNS/FILESMENU)))
then (RETURN)
elseif (EQ FNS/FILES 'FILES)
then [SETQ FILES (WINDOWPROP GRAPHCOMMANDW (if INFLG
then 'INCLUDEFILES
else 'EXCLUDEFILES]
(SETQ FILES (MMENU (create MENU
ITEMS ←(APPEND FILELST '(DONE))
TITLE ←(CONCAT LABEL "Files") smashing
SCRATCHMENU)
FILES))
(WINDOWPROP GRAPHCOMMANDW (if INFLG
then 'INCLUDEFILES
else 'EXCLUDEFILES)
FILES)
elseif (AND (SETQ FILES (MENU (create MENU
ITEMS ← FILELST
TITLE ← 'FILELST smashing SCRATCHMENU)
))
(SETQ FNS (FILEFNSLST FILES)))
then [SETQ ALIST (WINDOWPROP GRAPHCOMMANDW (if INFLG
then 'INCLUDEFNS
else 'EXCLUDEFNS]
[SETQ FNS (MMENU (create MENU
ITEMS ←(APPEND (FILEFNSLST FILES)
'(DONE))
TITLE ←(CONCAT LABEL "from " FILES)
smashing SCRATCHMENU)
(CDR (ASSOC FILES ALIST]
(if ALIST
then (PUTASSOC FILES FNS ALIST)
else (WINDOWPROP GRAPHCOMMANDW (if INFLG
then 'INCLUDEFNS
else 'EXCLUDEFNS)
(LIST (CONS FILES FNS])
(PRINTGRAPHFN
[LAMBDA (FN) (* cdl "15-Oct-85 14:25")
(if FN
then (WINDOWPROP GRAPHCOMMANDW 'FUNCTION
FN)
(with GRAPHMENUREC (WINDOWPROP GRAPHCOMMANDW 'MENU)
(LET ((WIDTH (with MENU DEPTHMENU MENUREGIONLEFT))
(HEIGHT (with MENU FILTERMENU MENUREGIONBOTTOM)))
(BLTSHADE WHITESHADE GRAPHCOMMANDW 0 0 WIDTH HEIGHT)
(CENTERPRINTINAREA FN 0 0 WIDTH HEIGHT GRAPHCOMMANDW])
)
(RPAQ? GRAPHCOMMANDW NIL)
(RPAQ? SCRATCHMENU (create MENU))
(RPAQQ GRAPHMENUS (COMMANDMENU FILTERMENU FLAGSMENU FORMATMENU DEPTHMENU DELAYMENU))
(PUTPROPS COMMANDMENU MENU (create MENU ITEMS ←
(BQUOTE ((, (MAKEBOLDMENUITEM "Function" MENUFONT)
(PROG [(WINDOW (WINDOWPROP GRAPHCOMMANDW
'PROMPTWINDOW]
(PRINTGRAPHFN (CAR (PROCESS.READ WINDOW "> " T)
))
(CLOSEW WINDOW))
"Enter a new function to be graphed, prompts for input.")
(Include (INCLUDEFNS T)
"Specify which functions (by file or function) to include (overide EXCLUDE).")
(Exclude (INCLUDEFNS NIL)
"Specify which functions (by file or function) to exclude from the graph.")
(Clear (CLEARCOMMANDMENU)
"Clear the current settings on the command window to the defaults.")
(, (MAKEBOLDMENUITEM "Graph" MENUFONT)
(DOGRAPHCALL)
"Graph the function with the selected settings.")))
TITLE ← "Command" CENTERFLG ← T))
(PUTPROPS FILTERMENU MENU (create MENU ITEMS ← '((WhereIs WHEREIS
"Only graph functions that WHEREIS can locate.")
(FGetD FGETD
"Only graph functions that are defined.")
(ExprP EXPRP
"Only graph functions that are not compiled.")
(CCodeP CCODEP
"Only graph functions that are compiled.")
(No\ NO\
"Only graph functions that do not have an initial \ in their name."))
TITLE ← "Filters" CENTERFLG ← T WHENSELECTEDFN ←
(FUNCTION MMENUSELECTEDFN)))
(PUTPROPS FLAGSMENU MENU (create MENU ITEMS ← '((Invert INVERT
"ADVISE the graphed functions to invert their node when called.")
(Count COUNT
"ADVISE the graphed functions to keep a count of calls after their node.")
(Shape SHAPE
"Shape the graph window to fit the graph.")
(Top TOP "Pass the TOPJUSTIFYFLG to SHOWGRAPH.")
(Edit EDIT
"Make the graph editable by passing the ALLOWEDITFLG to SHOWGRAPH."))
TITLE ← "Flags" CENTERFLG ← T WHENSELECTEDFN ←
(FUNCTION MMENUSELECTEDFN)))
(PUTPROPS FORMATMENU MENU (create MENU ITEMS ← '((Lattice LATTICE
"Specify the LATTICE format in LAYOUTGRAPH.")
(Reverse REVERSE
"Specify the REVERSE format in LAYOUTGRAPH.")
(Vertical VERTICAL
"Specify the VERTICAL format in LAYOUTGRAPH.")
(ArgList ARGLIST
"Use the function and its arguments as the node label.")
(WhereIs WHEREIS
"Use the function and the file(s) where it is found as the node label."))
TITLE ← "Format" CENTERFLG ← T WHENSELECTEDFN ←
(FUNCTION MMENUSELECTEDFN)))
(PUTPROPS DEPTHMENU MENU (create MENU ITEMS ←
'(0 1 2 3 4 5 6 7 8 9 10)
TITLE ← "Depth" WHENSELECTEDFN ← (FUNCTION MARKMENUITEM)
MENUUSERDATA ← (LIST 'VALUE
GRAPHCALLSDEPTH)
CENTERFLG ← T))
(PUTPROPS DELAYMENU MENU (create MENU ITEMS ←
'(0 1 2 3 4 5 6 7 8 9 10)
TITLE ← "Delay" WHENSELECTEDFN ← [FUNCTION (LAMBDA (ITEM MENU KEY)
(MARKMENUITEM
ITEM MENU KEY)
(SETQ
CALLSDELAY
(TIMES 100
ITEM]
MENUUSERDATA ← '(VALUE 5)
CENTERFLG ← T))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GRAPHCOMMANDW SCRATCHMENU GRAPHMENUS)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD GRAPHMENUREC (COMMANDMENU FILTERMENU FLAGSMENU FORMATMENU DEPTHMENU DELAYMENU))
]
(DECLARE: EVAL@COMPILE
(RPAQQ WHITESHADE 0)
(RPAQQ BLACKSHADE 65535)
(RPAQQ null "")
(CONSTANTS WHITESHADE BLACKSHADE null)
)
)
(ADDTOVAR BackgroundMenuCommands ("GraphCalls" '(GRAPHCALLSW)
"Puts up a GraphCalls Command Window"))
(SETQ BackgroundMenu NIL)
(* * Multiple Selection Menus)
(DEFINEQ
(MMENU
[LAMBDA (MENU PRESELECT) (* cdl " 9-Oct-85 14:39")
(LET (EVENT)
[if [NULL (SETQ EVENT (GETMENUPROP MENU 'EVENT]
then (PUTMENUPROP MENU 'EVENT
(SETQ EVENT (CREATE.EVENT 'MULTIMENU]
(with MENU MENU (SETQ WHENSELECTEDFN (FUNCTION MMENUSELECTEDFN)))
(ADDMENU MENU)
(for ITEM in PRESELECT do (DOSELECTEDITEM MENU ITEM))
(AWAIT.EVENT EVENT)
(PROG1 (GETMENUPROP MENU 'VALUE)
(PUTMENUPROP MENU 'VALUE
NIL])
(MMENUSELECTEDFN
[LAMBDA (ITEM MENU KEY) (* cdl "12-Sep-85 08:09")
(LET [(VALUE (GETMENUPROP MENU 'VALUE]
(SELECTQ ITEM
[DONE (CLRPROMPT)
(SETQ VALUE (for ITEM in VALUE collect (DEFAULTWHENSELECTEDFN
ITEM MENU)))
(DELETEMENU MENU T)
(NOTIFY.EVENT (GETMENUPROP MENU 'EVENT]
(CLEAR (for ITEM in VALUE do (SHADEITEM ITEM MENU WHITESHADE))
(SETQ VALUE NIL))
(if (MEMB ITEM VALUE)
then (SHADEITEM ITEM MENU WHITESHADE)
(SETQ VALUE (DREMOVE ITEM VALUE))
else (SHADEITEM ITEM MENU BLACKSHADE)
(push VALUE ITEM)))
(PUTMENUPROP MENU 'VALUE
VALUE])
(MARKMENUITEM
[LAMBDA (ITEM MENU KEY) (* cdl "12-Sep-85 08:18")
(LET [(VALUE (GETMENUPROP MENU 'VALUE]
(if VALUE
then (SHADEITEM VALUE MENU WHITESHADE)))
(PUTMENUPROP MENU 'VALUE
ITEM)
(SHADEITEM ITEM MENU BLACKSHADE])
(SUBITEMSELECTFN
[LAMBDA (ITEM MENU KEY) (* cdl "27-Jun-85 08:30")
(PROG [SUBMENU SUBITEMS (SUBMENUS (GETMENUPROP MENU 'SUBMENUS]
(* Function to emulate CAROL subitems in FUGUE)
(if [AND (EQ KEY 'MIDDLE)
(LISTP ITEM)
(SETQ SUBITEMS (CDR (ASSOC 'SUBITEMS
(CDDDR ITEM]
then (if (SETQ SUBMENU (CDR (SASSOC SUBITEMS SUBMENUS)))
else (SETQ SUBMENU (create MENU
ITEMS ← SUBITEMS))
(PUTMENUPROP MENU 'SUBMENUS
(CONS (CONS SUBITEMS SUBMENU)
SUBMENUS)))
(RETURN (MENU SUBMENU))
else (RETURN (DEFAULTWHENSELECTEDFN ITEM MENU KEY])
(MAKEBOLDMENUITEM
[LAMBDA (STRING FONT) (* cdl "16-Oct-85 08:56")
(LET [BITMAP STREAM (BOLDERFONT (FONTCOPY FONT 'WEIGHT
'BOLD]
[SETQ STREAM (DSPCREATE (SETQ BITMAP (BITMAPCREATE (STRINGWIDTH STRING BOLDERFONT)
(FONTPROP FONT 'HEIGHT]
(DSPFONT BOLDERFONT STREAM)
(DSPYPOSITION (FONTPROP FONT 'DESCENT)
STREAM)
(PRIN1 STRING STREAM)
BITMAP])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML $INVERTID$)
(ADDTOVAR LAMA )
)
(PUTPROPS GRAPHCALLS.LSP COPYRIGHT ("Stanford University" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2927 17029 (GRAPHCALLS 2939 . 5762) (GRAPHCALLS1 5766 . 6795) (DEFAULTGRAPHCALLSFN 6799
. 7234) (ADVISECALLS 7238 . 8348) (BREAKINCALLS 8352 . 9292) (CALLSLEFTFN 9296 . 9774) (CALLSMIDDLEFN
9778 . 10205) (COLLECTCALLS 10209 . 11432) (INSPECTFRAME 11436 . 12284) (INSPECTCALLS 12288 . 14050)
($INVERTID$ 14054 . 15007) (CALLSFETCH 15011 . 15145) (CALLSSTORE 15149 . 15290) (CALLSPRINT 15294 .
15603) (CALLSCLOSEFN 15607 . 16260) (GRAPHWCLOSEFN 16264 . 16862) (NO\ 16866 . 17026)) (23189 32003 (
GRAPHCALLSW 23201 . 25883) (CLEARCOMMANDMENU 25887 . 26612) (DOGRAPHCALL 26616 . 28578) (GRAPHFILTER
28582 . 29681) (INCLUDEFNS 29685 . 31478) (PRINTGRAPHFN 31482 . 32000)) (36055 39187 (MMENU 36067 .
36690) (MMENUSELECTEDFN 36694 . 37503) (MARKMENUITEM 37507 . 37833) (SUBITEMSELECTFN 37837 . 38672) (
MAKEBOLDMENUITEM 38676 . 39184)))))
STOP