summaryrefslogtreecommitdiff
path: root/ipl/mprocs
diff options
context:
space:
mode:
Diffstat (limited to 'ipl/mprocs')
-rw-r--r--ipl/mprocs/colormap.icn232
-rw-r--r--ipl/mprocs/colortyp.icn44
-rw-r--r--ipl/mprocs/em_setup.icn101
-rw-r--r--ipl/mprocs/emutils.icn508
-rw-r--r--ipl/mprocs/evaltree.icn106
-rw-r--r--ipl/mprocs/evinit.icn89
-rw-r--r--ipl/mprocs/evnames.icn174
-rw-r--r--ipl/mprocs/evsyms.icn160
-rw-r--r--ipl/mprocs/evtmap.icn181
-rw-r--r--ipl/mprocs/evutils.icn94
-rw-r--r--ipl/mprocs/hexlib.icn146
-rw-r--r--ipl/mprocs/loadfile.icn64
-rw-r--r--ipl/mprocs/opname.icn129
-rw-r--r--ipl/mprocs/typebind.icn56
-rw-r--r--ipl/mprocs/typesyms.icn71
-rw-r--r--ipl/mprocs/viewpack.icn329
16 files changed, 2484 insertions, 0 deletions
diff --git a/ipl/mprocs/colormap.icn b/ipl/mprocs/colormap.icn
new file mode 100644
index 0000000..2bfcd70
--- /dev/null
+++ b/ipl/mprocs/colormap.icn
@@ -0,0 +1,232 @@
+############################################################################
+#
+# File: colormap.icn
+#
+# Subject: Procedures to map type event to color
+#
+# Author: Ralph E. Griswold
+#
+# Date: July 1, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# colormap(palette) returns a table that maps event-monitoring codes
+# for allocation events into RGB specifications for Icon. The
+# argument is the name of a palette, as given in the MemMon
+# system. The default for palette is "standard".
+#
+############################################################################
+#
+# Includes: evdefs.icn
+#
+############################################################################
+
+$include "evdefs.icn"
+
+procedure colormap(palette)
+ static maps
+ local x
+
+ initial {
+ maps := table()
+
+# Color map for doc.clr
+
+ x := table()
+
+ x[E_Coexpr] := "18724,18724,18724"
+ x[E_String] := "65535,65535,65535"
+ x[E_Tvsubs] := "65535,65535,65535"
+ x[E_File] := "56172,56172,56172"
+ x[E_Refresh] := "18724,18724,18724"
+ x[E_Lrgint] := "65535,65535,65535"
+ x[E_Real] := "65535,65535,65535"
+ x[E_Record] := "28086,28086,28086"
+ x[E_Set] := "28086,28086,28086"
+ x[E_Selem] := "46810,46810,46810"
+ x[E_List] := "18724,18724,18724"
+ x[E_Lelem] := "37448,37448,37448"
+ x[E_Table] := "18724,18724,18724"
+ x[E_Telem] := "56172,56172,56172"
+ x[E_Tvtbl] := "37448,37448,37448"
+ x[E_Slots] := "28086,28086,28086"
+ x[E_Cset] := "46810,46810,46810"
+
+ maps["doc"] := x
+
+# Color map for lw.clr
+
+ x := table()
+
+ x[E_Coexpr] := "28086,28086,28086"
+ x[E_String] := "65535,65535,65535"
+ x[E_Tvsubs] := "65535,65535,56172"
+ x[E_File] := "09362,00000,00000"
+ x[E_Refresh] := "09362,00000,00000"
+ x[E_Lrgint] := "65535,65535,65535"
+ x[E_Real] := "65535,65535,65535"
+ x[E_Record] := "65535,65535,65535"
+ x[E_Set] := "09362,18724,18724"
+ x[E_Selem] := "09362,18724,18724"
+ x[E_List] := "37448,37448,37448"
+ x[E_Lelem] := "37448,37448,37448"
+ x[E_Table] := "65535,65535,56172"
+ x[E_Telem] := "65535,65535,56172"
+ x[E_Tvtbl] := "65535,65535,56172"
+ x[E_Slots] := "18724,18724,18724"
+ x[E_Cset] := "09362,09362,09362"
+
+ maps["lw"] := x
+
+# Color map for pastel.clr
+
+ x := table()
+
+ x[E_Coexpr] := "65535,46810,28086" # peach
+ x[E_String] := "56172,28086,09362" # reddish brown
+ x[E_Tvsubs] := "56172,28086,09362" # reddish brown
+ x[E_File] := "00000,00000,28086" # dark blue
+ x[E_Refresh] := "37448,00000,00000" # dark red
+ x[E_Lrgint] := "65535,65535,00000" # yellow
+ x[E_Real] := "65535,28086,28086" # salmon
+ x[E_Record] := "65535,46810,28086" # peach
+ x[E_Set] := "56172,46810,65535" # light purple
+ x[E_Selem] := "56172,28086,65535" # medium purple
+ x[E_List] := "18724,37448,56172" # medium blue
+ x[E_Lelem] := "18724,56172,65535" # pastel blue
+ x[E_Table] := "46810,65535,37448" # light yellow-green
+ x[E_Telem] := "18724,56172,18724" # light green
+ x[E_Tvtbl] := "09362,37448,09362" # dark green
+ x[E_Slots] := "37448,65535,65535" # light blue
+ x[E_Cset] := "65535,65535,46810" # ivory
+
+ maps["pastel"] := x
+
+# Color map for qms.clr
+
+ x := table()
+
+ x[E_Coexpr] := "37448,18724,00000" # brown
+ x[E_String] := "65535,65535,46810" # ivory
+ x[E_Tvsubs] := "65535,65535,46810" # ivory
+ x[E_File] := "56172,65535,00000" # light green
+ x[E_Refresh] := "37448,18724,00000" # brown
+ x[E_Lrgint] := "65535,46810,28086" # peach
+ x[E_Real] := "65535,65535,00000" # yellow
+ x[E_Record] := "56172,00000,65535" # magenta
+ x[E_Set] := "37448,00000,00000" # medium red
+ x[E_Selem] := "65535,00000,00000" # red
+ x[E_List] := "00000,46810,46810" # medium cyan
+ x[E_Lelem] := "00000,65535,65535" # cyan
+ x[E_Table] := "00000,37448,00000" # dark green
+ x[E_Telem] := "00000,65535,00000" # green
+ x[E_Tvtbl] := "28086,65535,00000" # light green
+ x[E_Slots] := "37448,00000,56172" # purple
+ x[E_Cset] := "65535,56172,00000" # yellow orange
+
+ maps["qms"] := x
+
+# Color map for qmscomb.clr
+
+ x := table()
+
+ x[E_Coexpr] := "37448,18724,00000" # brown
+ x[E_String] := "65535,65535,46810" # ivory
+ x[E_Tvsubs] := "65535,65535,46810" # ivory
+ x[E_File] := "56172,65535,00000" # light green
+ x[E_Refresh] := "37448,18724,00000" # brown
+ x[E_Lrgint] := "65535,46810,28086" # peach
+ x[E_Real] := "65535,65535,00000" # yellow
+ x[E_Record] := "56172,00000,65535" # magenta
+ x[E_Set] := "65535,00000,00000" # red
+ x[E_Selem] := "65535,00000,00000" # red
+ x[E_List] := "00000,65535,65535" # cyan
+ x[E_Lelem] := "00000,65535,65535" # cyan
+ x[E_Table] := "00000,65535,00000" # green
+ x[E_Telem] := "00000,65535,00000" # green
+ x[E_Tvtbl] := "00000,65535,00000" # green
+ x[E_Slots] := "37448,00000,56172" # purple
+ x[E_Cset] := "65535,56172,00000" # yellow orange
+
+ maps["qmscomb"] := x
+
+# Color map for rt.clr
+
+ x := table()
+
+ x[E_Coexpr] := "37448,28086,18724" # light brown
+ x[E_String] := "65535,65535,46810" # ivory
+ x[E_Tvsubs] := "65535,28086,56172" # pink
+ x[E_File] := "37448,00000,56172" # purple
+ x[E_Refresh] := "00000,00000,37448" # navy blue
+ x[E_Lrgint] := "65535,46810,28086" # peach
+ x[E_Real] := "65535,65535,00000" # yellow
+ x[E_Record] := "65535,37448,00000" # orange
+ x[E_Set] := "37448,00000,00000" # dark red
+ x[E_Selem] := "56172,00000,00000" # red
+ x[E_List] := "18724,46810,65535" # pastel blue
+ x[E_Lelem] := "09362,28086,46810" # medium blue
+ x[E_Table] := "00000,28086,00000" # dark green
+ x[E_Telem] := "00000,46810,00000" # medium green
+ x[E_Tvtbl] := "28086,65535,28086" # light green
+ x[E_Slots] := "37448,28086,18724" # light brown
+ x[E_Cset] := "46810,28086,00000" # reddish brown
+
+ maps["rt"] := x
+
+# Color map for sun.clr
+
+ x := table()
+
+ x[E_Coexpr] := "37448,28086,18724" # light brown
+ x[E_String] := "65535,65535,46810" # ivory
+ x[E_Tvsubs] := "65535,28086,56172" # pink
+ x[E_File] := "37448,00000,56172" # purple
+ x[E_Refresh] := "00000,00000,37448" # navy blue
+ x[E_Lrgint] := "65535,46810,28086" # peach
+ x[E_Real] := "65535,65535,00000" # yellow
+ x[E_Record] := "65535,37448,00000" # orange
+ x[E_Set] := "46810,00000,00000" # dark red
+ x[E_Selem] := "56172,00000,00000" # red
+ x[E_List] := "18724,46810,65535" # pastel blue
+ x[E_Lelem] := "09362,28086,46810" # medium blue
+ x[E_Table] := "00000,28086,00000" # dark green
+ x[E_Telem] := "00000,37448,00000" # medium green
+ x[E_Tvtbl] := "00000,65535,00000" # light green
+ x[E_Slots] := "37448,28086,18724" # light brown
+ x[E_Cset] := "46810,28086,00000" # reddish brown
+
+ maps["sun"] := x
+
+# Color map for standard colors
+
+ x := table()
+
+ x[E_Coexpr] := "deep gray"
+ x[E_String] := "pale yellow"
+ x[E_Tvsubs] := "yellow"
+ x[E_File] := "pale gray"
+ x[E_Refresh] := "deep gray"
+ x[E_Lrgint] := "pale brown"
+ x[E_Real] := "pale purple"
+ x[E_Record] := "magenta"
+ x[E_Set] := "dark red"
+ x[E_Selem] := "red"
+ x[E_List] := "dark blue green"
+ x[E_Lelem] := "blue green"
+ x[E_Table] := "dark green"
+ x[E_Telem] := "green"
+ x[E_Tvtbl] := "light green"
+ x[E_Slots] := "purple"
+ x[E_Cset] := "orange"
+
+ maps["standard"] := x
+ }
+
+ return \maps[\palette | "standard"]
+
+end
diff --git a/ipl/mprocs/colortyp.icn b/ipl/mprocs/colortyp.icn
new file mode 100644
index 0000000..2592e0f
--- /dev/null
+++ b/ipl/mprocs/colortyp.icn
@@ -0,0 +1,44 @@
+############################################################################
+#
+# File: colortyp.icn
+#
+# Subject: Procedure to produce table of colors for Icon types
+#
+# Author: Ralph E. Griswold
+#
+# Date: July 1, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# Links: typecode
+#
+############################################################################
+
+# Color table for Icon type codes
+
+procedure colortyp()
+ local x
+
+ x := table()
+
+ x["C"] := "deep gray"
+ x["s"] := "pale yellow"
+ x["r"] := "pale purple"
+ x["R"] := "magenta"
+ x["S"] := "dark red"
+ x["L"] := "dark blue green"
+ x["T"] := "dark green"
+ x["c"] := "orange"
+ x["f"] := "pink"
+ x["i"] := "white"
+ x["n"] := "gray"
+ x["p"] := "red viole"
+ x["w"] := "deep blue"
+
+ return x
+
+end
diff --git a/ipl/mprocs/em_setup.icn b/ipl/mprocs/em_setup.icn
new file mode 100644
index 0000000..c915fd8
--- /dev/null
+++ b/ipl/mprocs/em_setup.icn
@@ -0,0 +1,101 @@
+############################################################################
+#
+# File: em_setup.icn
+#
+# Subject: Procedures to set up execution monitors
+#
+# Author: Ralph E. Griswold
+#
+# Date: March 3, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# These procedures provide support for the routine parts of building
+# Icon execution monitors, including what's necessary for them to
+# run stand-alone as well as under the control of monitor coordinators
+# like eve and vc.
+#
+# vis_setup(args[]) opens a window with attributes given
+# by args[]
+#
+# em_setup(sp) loads sp as the program to be monitored
+#
+# context_setup(mask) returns table of graphics context for
+# mask
+#
+# prog_name() returns the name of the source program
+# for the SP set up by em_setup()
+#
+# em_end() hold visualization window open if (a)
+# there is one and (b) monitoring is
+# stand alone
+#
+############################################################################
+#
+# Requires: Version 9 MT Icon, instrumentation, and graphics
+#
+############################################################################
+#
+# Links: evinit, interact, typebind, graphics
+#
+############################################################################
+#
+# Includes: evdefs.icn
+#
+############################################################################
+
+link evinit
+link interact
+link typebind
+link graphics
+
+$include "evdefs.icn"
+
+global Coordination # if nonnull, vc is in charge
+global Visualization # visualization window
+global EventSource # vc's event source
+
+procedure vis_setup(args[]) #: set up visualization window
+
+ Visualization := (WOpen ! args) |
+ stop("*** cannot open window for visualization")
+
+ return Visualization
+
+end
+
+procedure em_setup(sp) #: set up program to be monitored
+ local trash
+
+ trash := open("/dev/null", "w") |
+ stop("*** cannot open /dev/null")
+
+ EvInit(sp, , trash, trash) | stop("*** cannot load SP")
+
+ return
+
+end
+
+procedure context_setup(mask) #: table of graphics contexts for mask
+
+ return typebind(Visualization, mask)
+
+end
+
+procedure prog_name() #: name of monitored source program
+
+ return variable("&progname", EventSource) || ".icn"
+
+end
+
+procedure em_end() #: hold event monitoring for event at end
+ local back
+
+ back := WOpen("canvas=hidden", "bg=light gray")
+ if /Coordination then ExitNotice(back, "Normal termination of SP")
+
+end
diff --git a/ipl/mprocs/emutils.icn b/ipl/mprocs/emutils.icn
new file mode 100644
index 0000000..322815f
--- /dev/null
+++ b/ipl/mprocs/emutils.icn
@@ -0,0 +1,508 @@
+############################################################################
+#
+# File: emutils.icn
+#
+# Subject: Procedures to support MT-Icon monitors
+#
+# Author: Ralph E. Griswold
+#
+# Date: April 16, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# evname(s) maps the event code to a standard descriptive phrases and vice
+# versa.
+#
+############################################################################
+#
+# Links: convert, tables
+#
+############################################################################
+#
+# Includes: evdefs.icn
+#
+############################################################################
+
+link convert
+link tables
+
+$include "evdefs.icn"
+
+procedure evname(s)
+ local result
+ static namemap
+
+ initial {
+ namemap := table()
+
+ namemap[E_Aconv] := "conversion attempt"
+ namemap[E_Argp] := "argument pointer"
+ namemap[E_Alien] := "alien allocation"
+ namemap[E_Assign] := "assignment"
+# namemap[E_Base] := "base address of storage region"
+ namemap[E_BlkDeAlc] := "block deallocation"
+ namemap[E_Bsusp] := "suspension from operation"
+ namemap[E_Coact] := "co-expression activation"
+ namemap[E_Cocreate] := "co-expression creation"
+ namemap[E_Coexpr] := "co-expression allocation"
+ namemap[E_Cofail] := "co-expression failure"
+ namemap[E_Collect] := "garbage collection"
+# namemap[E_Comment] := "comment"
+ namemap[E_Coret] := "co-expression return"
+ namemap[E_Cset] := "cset allocation"
+ namemap[E_Deref] := "variable dereference"
+ namemap[E_Ecall] := "call of operation"
+ namemap[E_Efail] := "failure from expression"
+ namemap[E_Efp] := "expression frame pointer"
+ namemap[E_EndCollect] := "end of garbage collection"
+ namemap[E_Erem] := "removal of a suspended generator"
+ namemap[E_Eresum] := "resumption of expression"
+# namemap[E_Eret] := "return from expression"
+ namemap[E_Error] := "run-time error"
+ namemap[E_Esusp] := "suspension from alternation"
+ namemap[E_Exit] := "program exit"
+ namemap[E_External] := "external allocation"
+ namemap[E_Fcall] := "function call"
+ namemap[E_Fclose] := "file close"
+ namemap[E_Fconv] := "conversion failure"
+ namemap[E_Ffail] := "function failure"
+ namemap[E_File] := "file allocation"
+ namemap[E_Floc] := "file location"
+ namemap[E_Fmode] := "file open mode"
+ namemap[E_Fopen] := "file open"
+ namemap[E_Fread] := "file read"
+ namemap[E_Freads] := "file reads"
+ namemap[E_Free] := "free region"
+ namemap[E_Frem] := "function suspension removal"
+ namemap[E_Fresum] := "function resumption"
+ namemap[E_Fret] := "function return"
+ namemap[E_Fseek] := "file seek"
+ namemap[E_Fstring] := "string read or written"
+ namemap[E_Fsusp] := "function suspension"
+ namemap[E_Fwhere] := "file location"
+ namemap[E_Fwrite] := "function write"
+ namemap["\223"] := "function writes"
+ namemap[E_Gfp] := "generator frame pointer"
+# namemap[E_Highlight] := "allocation highlight"
+ namemap[E_Ilevel] := "interpreter call level"
+ namemap[E_Intcall] := "interpreter call"
+ namemap[E_Integer] := "integer value pseudo-event"
+ namemap[E_Intret] := "interpreter return"
+ namemap[E_Ipc] := "interpreter program counter"
+ namemap[E_Kywdint] := "integer keyword value pseudo-event"
+ namemap[E_Kywdpos] := "position value pseudo-event"
+ namemap[E_Kywdsubj] := "subject value pseudo-event"
+ namemap[E_Lbang] := "list generation"
+ namemap[E_Lcreate] := "list creation"
+ namemap[E_Lelem] := "list element allocation"
+ namemap[E_Lget] := "list get"
+ namemap[E_Line] := "line change"
+ namemap[E_List] := "list allocation"
+ namemap[E_Loc] := "location change"
+ namemap[E_Lpop] := "list pop"
+ namemap[E_Lpull] := "list pull"
+ namemap[E_Lpush] := "list push"
+ namemap[E_Lput] := "list put"
+ namemap[E_Lrand] := "list random reference"
+# namemap[E_Lref] := "list reference"
+ namemap[E_Lrgint] := "large integer allocation"
+ namemap[E_Lsub] := "list subscript"
+ namemap[E_Lsusp] := "suspension from limitation"
+ namemap[E_MXevent] := "monitor input event"
+ namemap[E_Nconv] := "conversion not needed"
+ namemap[E_NewRegion] := "new storage region"
+ namemap[E_Null] := "null value value pseudo-event"
+ namemap[E_Ocall] := "operator call"
+ namemap[E_Ofail] := "operator failure"
+# namemap[E_Offset] := "address offset"
+# namemap[E_Op] := "interpreter operation"
+ namemap[E_Opcode] := "virtual-machine instruction"
+ namemap[E_Orem] := "operator suspension removal"
+ namemap[E_Oresum] := "operator resumption"
+ namemap[E_Oret] := "operator return"
+ namemap[E_Osusp] := "operator suspension"
+# namemap[E_Pause] := "memory monitoring comment"
+ namemap[E_Pcall] := "procedure call"
+ namemap[E_Pfail] := "procedure failure"
+ namemap[E_Pfp] := "procedure frame pointer"
+# namemap[E_Pid] := "symbol name"
+ namemap[E_Prem] := "suspended procedure removal"
+ namemap[E_Presum] := "procedure resumption"
+ namemap[E_Pret] := "procedure return"
+ namemap[E_Proc] := "procedure value pseudo-event"
+ namemap[E_Psusp] := "procedure suspension"
+ namemap[E_Rbang] := "record generation"
+ namemap[E_Rcreate] := "record creation"
+ namemap[E_Real] := "real allocation"
+ namemap[E_Record] := "record allocation"
+ namemap[E_Refresh] := "refresh allocation"
+# namemap[E_Region] := "region"
+ namemap[E_Rrand] := "record random reference"
+# namemap[E_Rref] := "record reference"
+ namemap[E_Rsub] := "record subscript"
+ namemap[E_Sbang] := "set generation"
+ namemap[E_Sconv] := "conversion success"
+ namemap[E_Screate] := "set creation"
+ namemap[E_Sdelete] := "set deletion"
+ namemap[E_Selem] := "set element allocation"
+ namemap[E_Set] := "set allocation"
+ namemap[E_Sfail] := "scanning failure"
+ namemap[E_Sinsert] := "set insertion"
+# namemap[E_Size] := "region size"
+ namemap[E_Slots] := "hash header allocation"
+ namemap[E_Smember] := "set membership"
+ namemap[E_Snew] := "scanning environment creation"
+ namemap[E_Spos] := "scanning position"
+ namemap[E_Srand] := "set random reference"
+ namemap[E_Srem] := "scanning environment removal"
+ namemap[E_Sresum] := "scanning resumption"
+ namemap[E_Ssasgn] := "substring assignment"
+ namemap[E_Ssusp] := "scanning suspension"
+ namemap[E_Stack] := "stack depth"
+ namemap[E_StrDeAlc] := "string deallocation"
+ namemap[E_String] := "string allocation"
+ namemap[E_Sval] := "set value"
+# namemap[E_Sym] := "symbol table entry"
+ namemap[E_Table] := "table allocation"
+ namemap[E_Tbang] := "table generation"
+ namemap[E_Tconv] := "conversion target"
+ namemap[E_Tcreate] := "table creation"
+ namemap[E_Tdelete] := "table deletion"
+ namemap[E_Telem] := "table element allocation"
+ namemap[E_TenureBlock] := "tenure a block region"
+ namemap[E_TenureString] := "tenure a string region"
+ namemap[E_Tick] := "clock tick"
+ namemap[E_Tinsert] := "table insertion"
+ namemap[E_Tkey] := "table key generation"
+ namemap[E_Tmember] := "table membership"
+ namemap[E_Trand] := "table random reference"
+# namemap[E_Tref] := "table reference"
+ namemap[E_Tsub] := "table subscript"
+# namemap[E_Tval] := "table value"
+ namemap[E_Tvsubs] := "substring trapped variable allocation"
+ namemap[E_Tvtbl] := "table-element trapped variable allocation"
+# namemap[E_Used] := "space used"
+ namemap[E_Value] := "value assigned"
+ namemap[E_Fterm] := "write terminator"
+
+# namemap := twt(namemap)
+ }
+
+ result := namemap[s]
+ /result := "E_\\" || exbase10(find(s, &cset) - 1, 8)
+
+ return result
+
+end
+
+############################################################################
+#
+# evsym() maps event codes to the symbolic names for the codes and vice
+# versa.
+#
+############################################################################
+
+procedure evsym(s)
+ local result
+ static symmap
+
+ initial {
+ symmap := table()
+
+ symmap[E_Aconv] := "E_Aconv"
+ symmap[E_Argp] := "E_Argp"
+ symmap[E_Alien] := "E_Alien"
+ symmap[E_Assign] := "E_Assign"
+ symmap[E_BlkDeAlc] := "E_BlkDeAlc"
+ symmap[E_Bsusp] := "E_Bsusp"
+ symmap[E_Coact] := "E_Coact"
+ symmap[E_Cocreate] := "E_Cocreate"
+ symmap[E_Coexpr] := "E_Coexpr"
+ symmap[E_Cofail] := "E_Cofail"
+ symmap[E_Cofree] := "E_Cofree"
+ symmap[E_Collect] := "E_Collect"
+ symmap[E_Coret] := "E_Coret"
+ symmap[E_Cset] := "E_Cset"
+ symmap[E_Deref] := "E_Deref"
+ symmap[E_Ecall] := "E_Ecall"
+ symmap[E_Efail] := "E_Efail"
+ symmap[E_Efp] := "E_Efp"
+ symmap[E_Eresum] := "E_Eresum"
+ symmap[E_Error] := "E_Error"
+ symmap[E_Esusp] := "E_Esusp"
+ symmap[E_Erem] := "E_Erem"
+ symmap[E_Exit] := "E_Exit"
+ symmap[E_External] := "E_External"
+ symmap[E_Fcall] := "E_Fcall"
+ symmap[E_Fclose] := "E_Fclose"
+ symmap[E_Fconv] := "E_Fconv"
+ symmap[E_Ffail] := "E_Ffail"
+ symmap[E_File] := "E_File"
+ symmap[E_Floc] := "E_Loc"
+ symmap[E_Fmode] := "E_Fmode"
+ symmap[E_Fopen] := "E_Fopen"
+ symmap[E_Fread] := "E_Fread"
+ symmap[E_Freads] := "E_Freads"
+ symmap[E_Free] := "E_Free"
+ symmap[E_Frem] := "E_Frem"
+ symmap[E_Fresum] := "E_Fresum"
+ symmap[E_Fret] := "E_Fret"
+ symmap[E_Fseek] := "E_Fseek"
+ symmap[E_Fstring] := "E_Fstring"
+ symmap[E_Fsusp] := "E_Fsusp"
+ symmap[E_Fwhere] := "E_Fwhere"
+ symmap[E_Fwrite] := "E_Fwrite"
+ symmap[E_Fterm] := "E_Fterm"
+ symmap[E_Gfp] := "E_Gfp"
+ symmap[E_Ilevel] := "E_Ilevel"
+ symmap[E_Intcall] := "E_Intcall"
+ symmap[E_Integer] := "E_Integer"
+ symmap[E_Intret] := "E_Intret"
+ symmap[E_Ipc] := "E_Ipc"
+ symmap[E_Kywdint] := "E_Kywdint"
+ symmap[E_Kywdpos] := "E_Kywdpos"
+ symmap[E_Kywdsubj] := "E_Kywdsubj"
+ symmap[E_Lbang] := "E_Lbang"
+ symmap[E_Lcreate] := "E_Lcreate"
+ symmap[E_Lelem] := "E_Lelem"
+ symmap[E_Line] := "E_Line"
+ symmap[E_List] := "E_List"
+ symmap[E_Loc] := "E_Loc"
+ symmap[E_Lpop] := "E_Lpop"
+ symmap[E_Lpull] := "E_Lpull"
+ symmap[E_Lpush] := "E_Lpush"
+ symmap[E_Lput] := "E_Lput"
+ symmap[E_Lrand] := "E_Lrand"
+ symmap[E_Lref] := "E_Lref"
+ symmap[E_Lrgint] := "E_Lrgint"
+ symmap[E_Lsub] := "E_Lsub"
+ symmap[E_Lsusp] := "E_Lsusp"
+ symmap[E_Nconv] := "E_Nconv"
+ symmap[E_NewRegion]:= "E_NewRegion"
+ symmap[E_Null] := "E_Null"
+ symmap[E_Ocall] := "E_Ocall"
+ symmap[E_Ofail] := "E_Ofail"
+ symmap[E_Op] := "E_Op"
+ symmap[E_Opcode] := "E_Opcode"
+ symmap[E_Oresum] := "E_Oresum"
+ symmap[E_Oret] := "E_Oret"
+ symmap[E_Osusp] := "E_Osusp"
+ symmap[E_Orem] := "E_Orem"
+ symmap[E_Pcall] := "E_Pcall"
+ symmap[E_Pfail] := "E_Pfail"
+ symmap[E_Pfp] := "E_Pfp"
+ symmap[E_Presum] := "E_Presum"
+ symmap[E_Pret] := "E_Pret"
+ symmap[E_Proc] := "E_Proc"
+ symmap[E_Psusp] := "E_Psusp"
+ symmap[E_Prem] := "E_Prem"
+ symmap[E_Rbang] := "E_Rbang"
+ symmap[E_Rcreate] := "E_Rcreate"
+ symmap[E_Real] := "E_Real"
+ symmap[E_Record] := "E_Record"
+ symmap[E_Refresh] := "E_Refresh"
+ symmap[E_Rrand] := "E_Rrand"
+ symmap[E_Rref] := "E_Rref"
+ symmap[E_Rsub] := "E_Rsub"
+ symmap[E_Sbang] := "E_Sbang"
+ symmap[E_Sconv] := "E_Sconv"
+ symmap[E_Screate] := "E_Screate"
+ symmap[E_Sdelete] := "E_Sdelete"
+ symmap[E_Selem] := "E_Selem"
+ symmap[E_Set] := "E_Set"
+ symmap[E_Sfail] := "E_Sfail"
+ symmap[E_Sinsert] := "E_Sinsert"
+ symmap[E_Slots] := "E_Slots"
+ symmap[E_Smember] := "E_Smember"
+ symmap[E_Snew] := "E_Snew"
+ symmap[E_Spos] := "E_Spos"
+ symmap[E_Srand] := "E_Srand"
+ symmap[E_Sresum] := "E_Sresum"
+ symmap[E_Ssasgn] := "E_Ssasgn"
+ symmap[E_Ssusp] := "E_Ssusp"
+ symmap[E_Stack] := "E_Stack"
+ symmap[E_StrDeAlc] := "E_StrDeAlc"
+ symmap[E_String] := "E_String"
+ symmap[E_Sval] := "E_Sval"
+ symmap[E_Srem] := "E_Srem"
+ symmap[E_Table] := "E_Table"
+ symmap[E_Tbang] := "E_Tbang"
+ symmap[E_Tconv] := "E_Tconv"
+ symmap[E_Tcreate] := "E_Tcreate"
+ symmap[E_Tdelete] := "E_Tdelete"
+ symmap[E_Telem] := "E_Telem"
+ symmap[E_Tick] := "E_Tick"
+ symmap[E_Tinsert] := "E_Tinsert"
+ symmap[E_Tkey] := "E_Tkey"
+ symmap[E_Tmember] := "E_Tmember"
+ symmap[E_Trand] := "E_Trand"
+ symmap[E_Tref] := "E_Tref"
+ symmap[E_Tsub] := "E_Tsub"
+ symmap[E_Tval] := "E_Tval"
+ symmap[E_Tvsubs] := "E_Tvsubs"
+ symmap[E_Tvtbl] := "E_Tvtbl"
+ symmap[E_Value] := "E_Value"
+
+ twt(symmap)
+ }
+
+ result := symmap[s]
+ /result := "E_\\" || exbase10(find(s, &cset), 8)
+
+ return result
+
+end
+
+procedure allocode(s)
+ static allocmap
+
+ initial {
+ allocmap := table("unknown code")
+
+ allocmap[E_Coexpr] := "co-expression"
+ allocmap[E_Cset] := "cset"
+ allocmap[E_File] := "file"
+ allocmap[E_List] := "list"
+ allocmap[E_Real] := "real"
+ allocmap[E_Record] := "record"
+ allocmap[E_Set] := "set"
+ allocmap[E_String] := "string"
+ allocmap[E_Table] := "table"
+
+ twt(allocmap)
+ }
+
+ return allocmap[s]
+
+end
+
+# Turn off output in SP.
+
+procedure kill_output()
+
+ variable("write", EventSource) := -1
+ variable("writes", EventSource) := -1
+
+ return
+
+end
+
+############################################################################
+#
+# opname() maps a virtual-machine instruction number to a symbolic name.
+#
+############################################################################
+
+procedure opname(i) #: map virtual-machine code to name
+ static opmap
+
+ initial {
+ opmap := table("")
+
+ opmap[1] := "Asgn"
+ opmap[2] := "Bang"
+ opmap[3] := "Cat"
+ opmap[4] := "Compl"
+ opmap[5] := "Diff"
+ opmap[6] := "Div"
+ opmap[7] := "Eqv"
+ opmap[8] := "Inter"
+ opmap[9] := "Lconcat"
+ opmap[10] := "Lexeq"
+ opmap[11] := "Lexge"
+ opmap[12] := "Lexgt"
+ opmap[13] := "Lexle"
+ opmap[14] := "Lexlt"
+ opmap[15] := "Lexne"
+ opmap[16] := "Minus"
+ opmap[17] := "Mod"
+ opmap[18] := "Mult"
+ opmap[19] := "Neg"
+ opmap[20] := "Neqv"
+ opmap[21] := "Nonnull"
+ opmap[22] := "Null"
+ opmap[23] := "Number"
+ opmap[24] := "Numeq"
+ opmap[25] := "Numge"
+ opmap[26] := "Numgt"
+ opmap[27] := "Numle"
+ opmap[28] := "Numlt"
+ opmap[29] := "Numne"
+ opmap[30] := "Plus"
+ opmap[31] := "Power"
+ opmap[32] := "Random"
+ opmap[33] := "Rasgn"
+ opmap[34] := "Refresh"
+ opmap[35] := "Rswap"
+ opmap[36] := "Sect"
+ opmap[37] := "Size"
+ opmap[38] := "Subsc"
+ opmap[39] := "Swap"
+ opmap[40] := "Tabmat"
+ opmap[41] := "Toby"
+ opmap[42] := "Unions"
+ opmap[43] := "Value"
+ opmap[44] := "Bscan"
+ opmap[45] := "Ccase"
+ opmap[46] := "Chfail"
+ opmap[47] := "Coact"
+ opmap[48] := "Cofail"
+ opmap[49] := "Coret"
+ opmap[50] := "Create"
+ opmap[51] := "Cset"
+ opmap[52] := "Dup"
+ opmap[53] := "Efail"
+ opmap[54] := "Eret"
+ opmap[55] := "Escan"
+ opmap[56] := "Esusp"
+ opmap[57] := "Field"
+ opmap[58] := "Goto"
+ opmap[59] := "Init"
+ opmap[60] := "Int"
+ opmap[61] := "Invoke"
+ opmap[62] := "Keywd"
+ opmap[63] := "Limit"
+ opmap[64] := "Line"
+ opmap[65] := "Llist"
+ opmap[66] := "Lsusp"
+ opmap[67] := "Mark"
+ opmap[68] := "Pfail"
+ opmap[69] := "Pnull"
+ opmap[70] := "Pop"
+ opmap[71] := "Pret"
+ opmap[72] := "Psusp"
+ opmap[73] := "Push1"
+ opmap[74] := "Pushn1"
+ opmap[75] := "Real"
+ opmap[76] := "Sdup"
+ opmap[77] := "Str"
+ opmap[78] := "Unmark"
+ opmap[80] := "Var"
+ opmap[81] := "Arg"
+ opmap[82] := "Static"
+ opmap[83] := "Local"
+ opmap[84] := "Global"
+ opmap[85] := "Mark0"
+ opmap[86] := "Quit"
+ opmap[87] := "FQuit"
+ opmap[88] := "Tally"
+ opmap[89] := "Apply"
+ opmap[90] := "Acset"
+ opmap[91] := "Areal"
+ opmap[92] := "Astr"
+ opmap[93] := "Aglobal"
+ opmap[94] := "Astatic"
+ opmap[95] := "Agoto"
+ opmap[96] := "Amark"
+ opmap[98] := "Noop"
+ opmap[100] := "SymEvents"
+ opmap[108] := "Colm"
+ }
+
+ return opmap[i]
+
+end
diff --git a/ipl/mprocs/evaltree.icn b/ipl/mprocs/evaltree.icn
new file mode 100644
index 0000000..c007dca
--- /dev/null
+++ b/ipl/mprocs/evaltree.icn
@@ -0,0 +1,106 @@
+############################################################################
+#
+# File: evaltree.icn
+#
+# Subject: Procedures to maintain activation tree
+#
+# Author: Clinton Jeffery
+#
+# Date: June 19, 1994
+#
+###########################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# Usage: evaltree(cset, procedure, record constructor)
+#
+# The record type must have fields node, parent, children
+#
+# See "A Framework for Monitoring Program Execution", Clinton L. Jeffery,
+# TR 93-21, Department of Computer Science, The University of Arizona,
+# July 30, 1993.
+#
+############################################################################
+#
+# Requires: MT Icon and event monitoring
+#
+############################################################################
+
+$include "evdefs.icn"
+
+record __evaltree_node(node,parent,children)
+
+global CallCodes,
+ SuspendCodes,
+ ResumeCodes,
+ ReturnCodes,
+ FailCodes,
+ RemoveCodes
+
+procedure evaltree(mask, callback, activation_record)
+ local c, current, p, child
+
+
+ /activation_record := __evaltree_node
+ CallCodes := string(mask ** cset(E_Pcall || E_Fcall || E_Ocall || E_Snew))
+ SuspendCodes := string(mask ** cset(E_Psusp || E_Fsusp ||
+ E_Osusp || E_Ssusp))
+ ResumeCodes := string(mask ** cset(E_Presum || E_Fresum || E_Oresum ||
+ E_Sresum))
+ ReturnCodes := string(mask ** cset(E_Pret || E_Fret || E_Oret))
+ FailCodes := string(mask ** cset(E_Pfail || E_Ffail || E_Ofail || E_Sfail))
+ RemoveCodes := string(mask ** cset(E_Prem || E_Frem || E_Orem || E_Srem))
+
+ current := activation_record()
+ current.parent := activation_record()
+ current.children := []
+ current.parent.children := []
+
+ while EvGet(mask) do {
+ case &eventcode of {
+ !CallCodes: {
+ c := activation_record()
+ c.node := &eventvalue
+ c.parent := current
+ c.children := []
+ put(current.children, c)
+ current := c
+ callback(current, current.parent)
+ }
+ !ReturnCodes | !FailCodes: {
+ p := pull(current.parent.children)
+ current := current.parent
+ callback(current, p)
+ }
+ !SuspendCodes: {
+ current := current.parent
+ callback(current, current.children[-1])
+ }
+ !ResumeCodes: {
+ current := current.children[-1]
+ callback(current, current.parent)
+ }
+ !RemoveCodes: {
+ if child := pull(current.children) then {
+ while put(current.children, pop(child.children))
+ callback(current, child)
+ }
+ else {
+ if current === current.parent.children[-1] then {
+ p := pull(current.parent.children)
+ current := current.parent
+ callback(current, p)
+ next
+ }
+ else stop("evaltree: unknown removal")
+ }
+ }
+ default: {
+ callback(current, current)
+ }
+ }
+ }
+end
+
diff --git a/ipl/mprocs/evinit.icn b/ipl/mprocs/evinit.icn
new file mode 100644
index 0000000..09a2ee6
--- /dev/null
+++ b/ipl/mprocs/evinit.icn
@@ -0,0 +1,89 @@
+############################################################################
+#
+# File: evinit.icn
+#
+# Subject: Procedures for event monitoring
+#
+# Author: Ralph E. Griswold
+#
+# Date: November 5, 1995
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# This file provides initialization for event monitors.
+#
+# This file is intended for use with event monitors running under
+# MT Icon.
+#
+############################################################################
+
+$include "evdefs.icn"
+
+procedure EvInit(f,input,output,error)
+ if not MTEvInit(f,input,output,error) then fail
+ return
+end
+
+procedure EvTerm(win)
+ if &eventsource === (Monitored | EventSource) then {
+ if type(win) == "window" then
+ Event(win)
+ }
+end
+#
+# MultiThread EventMon support, from file mtsupport.icn
+#
+
+global Monitored, EventSource, MTEventMask
+
+#
+# If EvInit is called with a string or a list, run as a standalone MT-based
+# event monitor -- load the icode file and overload certain EvMon symbols.
+#
+# This operation is skipped if &eventsource has already been initialized,
+# presumably by some event broker such as Eve.
+#
+procedure MTEvInit(f,input,output,error)
+
+ if \&eventsource then return
+
+ if type(f) == "string" then {
+ &eventsource := EventSource := Monitored := load(f,,input,output,error) | fail
+ EvGet :=: MTEvGet
+ }
+ else if type(f) == "list" then {
+ &eventsource := EventSource := Monitored := load(f[1],f[2:0],input,output,error) | fail
+ EvGet :=: MTEvGet
+ }
+ return &eventsource
+end
+
+procedure MTEvGet(c,flag)
+ static lastcset
+ initial {
+ lastcset := ''
+ }
+
+ if c ~=== lastcset then {
+ lastcset := c
+ eventmask(\(Monitored | EventSource) ,\c | &cset,&main)
+ }
+ return MTEvGet(c,flag)
+end
+
+#
+# Eve-specific extensions to the general model
+#
+procedure EvQuit()
+ EvSignal("quit")
+end
+
+procedure EvSignal(x)
+ if type(x) == "cset" then
+ write(&errout, "EvSignal(", image(x), ") is ambiguous.")
+ return x @ &eventsource
+end
diff --git a/ipl/mprocs/evnames.icn b/ipl/mprocs/evnames.icn
new file mode 100644
index 0000000..046b4a3
--- /dev/null
+++ b/ipl/mprocs/evnames.icn
@@ -0,0 +1,174 @@
+############################################################################
+#
+# File: evnames.icn
+#
+# Subject: Procedures to map between event codes and names
+#
+# Author: Ralph E. Griswold
+#
+# Date: December 26, 1995
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# evnames(x) creates a two-way table. Indexed by an event code, it
+# produces a descriptive phrase for the code. Indexed by the descriptive
+# phrase it produces the event code. It returns the value for key x.
+#
+############################################################################
+#
+# Links: tables
+#
+############################################################################
+#
+# Includes: evdefs.icn
+#
+############################################################################
+
+link tables
+
+$include "evdefs.icn"
+
+procedure evnames(e)
+ static namemap
+
+ initial {
+ namemap := table("unknown event")
+
+ namemap[E_Aconv] := "conversion attempt"
+ namemap[E_Alien] := "alien allocation"
+ namemap[E_Assign] := "assignment"
+ namemap[E_Base] := "base address of storage region"
+ namemap[E_BlkDeAlc] := "block deallocation"
+ namemap[E_Bsusp] := "suspension from operation"
+ namemap[E_Coact] := "co-expression activation"
+ namemap[E_Coexpr] := "co-expression allocation"
+ namemap[E_Cofail] := "co-expression failure"
+ namemap[E_Collect] := "garbage collection"
+ namemap[E_Comment] := "comment"
+ namemap[E_Coret] := "co-expression return"
+ namemap[E_Cset] := "cset allocation"
+ namemap[E_Ecall] := "call of operation"
+ namemap[E_Efail] := "failure from expression"
+ namemap[E_EndCollect] := "end of garbage collection"
+ namemap[E_Erem] := "removal of a suspended generator"
+ namemap[E_Eresum] := "resumption of expression"
+ namemap[E_Eret] := "return from expression"
+ namemap[E_Error] := "run-time error"
+ namemap[E_Esusp] := "suspension from alternation"
+ namemap[E_Exit] := "program exit"
+ namemap[E_External] := "external allocation"
+ namemap[E_Fcall] := "function call"
+ namemap[E_Fconv] := "conversion failure"
+ namemap[E_Ffail] := "function failure"
+ namemap[E_File] := "file allocation"
+ namemap[E_Free] := "free region"
+ namemap[E_Frem] := "function suspension removal"
+ namemap[E_Fresum] := "function resumption"
+ namemap[E_Fret] := "function return"
+ namemap[E_Fsusp] := "function suspension"
+ namemap[E_Highlight] := "allocation highlight"
+ namemap[E_Intcall] := "interpreter call"
+ namemap[E_Integer] := "integer value pseudo-event"
+ namemap[E_Intret] := "interpreter return"
+ namemap[E_Kywdint] := "integer keyword value pseudo-event"
+ namemap[E_Kywdpos] := "position value pseudo-event"
+ namemap[E_Kywdsubj] := "subject value pseudo-event"
+ namemap[E_Lbang] := "list generation"
+ namemap[E_Lcreate] := "list creation"
+ namemap[E_Lelem] := "list element allocation"
+ namemap[E_Lget] := "list get"
+ namemap[E_Line] := "line change"
+ namemap[E_List] := "list allocation"
+ namemap[E_Loc] := "location change"
+ namemap[E_Lpop] := "list pop"
+ namemap[E_Lpull] := "list pull"
+ namemap[E_Lpush] := "list push"
+ namemap[E_Lput] := "list put"
+ namemap[E_Lrand] := "list random reference"
+ namemap[E_Lref] := "list reference"
+ namemap[E_Lrgint] := "large integer allocation"
+ namemap[E_Lsub] := "list subscript"
+ namemap[E_Lsusp] := "suspension from limitation"
+ namemap[E_MXevent] := "monitor input event"
+ namemap[E_Nconv] := "conversion not needed"
+ namemap[E_Null] := "null value value pseudo-event"
+ namemap[E_Ocall] := "operator call"
+ namemap[E_Ofail] := "operator failure"
+ namemap[E_Offset] := "address offset"
+ namemap[E_Opcode] := "virtual-machine instruction"
+ namemap[E_Orem] := "operator suspension removal"
+ namemap[E_Oresum] := "operator resumption"
+ namemap[E_Oret] := "operator return"
+ namemap[E_Osusp] := "operator suspension"
+ namemap[E_Pause] := "memory monitoring comment"
+ namemap[E_Pcall] := "procedure call"
+ namemap[E_Pfail] := "procedure failure"
+ namemap[E_Pid] := "symbol name"
+ namemap[E_Prem] := "suspended procedure removal"
+ namemap[E_Presum] := "procedure resumption"
+ namemap[E_Pret] := "procedure return"
+ namemap[E_Proc] := "procedure value pseudo-event"
+ namemap[E_Psusp] := "procedure suspension"
+ namemap[E_Rbang] := "record generation"
+ namemap[E_Rcreate] := "record creation"
+ namemap[E_Real] := "real allocation"
+ namemap[E_Record] := "record allocation"
+ namemap[E_Refresh] := "refresh allocation"
+ namemap[E_Region] := "region"
+ namemap[E_Rrand] := "record random reference"
+ namemap[E_Rref] := "record reference"
+ namemap[E_Rsub] := "record subscript"
+ namemap[E_Sbang] := "set generation"
+ namemap[E_Sconv] := "conversion success"
+ namemap[E_Screate] := "set creation"
+ namemap[E_Sdelete] := "set deletion"
+ namemap[E_Selem] := "set element allocation"
+ namemap[E_Set] := "set allocation"
+ namemap[E_Sfail] := "scanning failure"
+ namemap[E_Sinsert] := "set insertion"
+ namemap[E_Size] := "region size"
+ namemap[E_Slots] := "hash header allocation"
+ namemap[E_Smember] := "set membership"
+ namemap[E_Snew] := "scanning environment creation"
+ namemap[E_Spos] := "scanning position"
+ namemap[E_Srand] := "set random reference"
+ namemap[E_Srem] := "scanning environment removal"
+ namemap[E_Sresum] := "scanning resumption"
+ namemap[E_Ssasgn] := "substring assignment"
+ namemap[E_Ssusp] := "scanning suspension"
+ namemap[E_Stack] := "stack depth"
+ namemap[E_StrDeAlc] := "string deallocation"
+ namemap[E_String] := "string allocation"
+ namemap[E_Sval] := "set value"
+ namemap[E_Sym] := "symbol table entry"
+ namemap[E_Table] := "table allocation"
+ namemap[E_Tbang] := "table generation"
+ namemap[E_Tconv] := "conversion target"
+ namemap[E_Tcreate] := "table creation"
+ namemap[E_Tdelete] := "table deletion"
+ namemap[E_Telem] := "table element allocation"
+ namemap[E_TenureBlock] := "tenure a block region"
+ namemap[E_TenureString] := "tenure a string region"
+ namemap[E_Tick] := "clock tick"
+ namemap[E_Tinsert] := "table insertion"
+ namemap[E_Tkey] := "table key generation"
+ namemap[E_Tmember] := "table membership"
+ namemap[E_Trand] := "table random reference"
+ namemap[E_Tref] := "table reference"
+ namemap[E_Tsub] := "table subscript"
+ namemap[E_Tval] := "table value"
+ namemap[E_Tvsubs] := "substring trapped variable allocation"
+ namemap[E_Tvtbl] := "table-element trapped variable allocation"
+ namemap[E_Used] := "space used"
+ namemap[E_Value] := "value assigned"
+
+ twt(namemap)
+ }
+
+ return namemap[e]
+
+end
diff --git a/ipl/mprocs/evsyms.icn b/ipl/mprocs/evsyms.icn
new file mode 100644
index 0000000..8ccc705
--- /dev/null
+++ b/ipl/mprocs/evsyms.icn
@@ -0,0 +1,160 @@
+############################################################################
+#
+# File: evsyms.icn
+#
+# Subject: Procedures to produce table of event codes and symbols
+#
+# Author: Ralph E. Griswold
+#
+# Date: October 3, 1996
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# evsyms() returns returns a two-way table. Indexed by an event code, it
+# produces the symbol (global identifier name) for the code. Indexed by the
+# symbol of the code, it produces the event code.
+#
+# This procedure is intended for use in event monitors under MT Icon.
+#
+############################################################################
+#
+# Links: tables
+#
+############################################################################
+#
+# Includes: "evdefs.icn"
+#
+############################################################################
+
+link tables
+
+$include "evdefs.icn"
+
+procedure evsyms()
+ static symmap
+
+ initial {
+ symmap := table("E_????")
+
+ symmap[E_Aconv] := "E_Aconv"
+ symmap[E_Alien] := "E_Alien"
+ symmap[E_Assign] := "E_Assign"
+ symmap[E_BlkDeAlc] := "E_BlkDeAlc"
+ symmap[E_Bsusp] := "E_Bsusp"
+ symmap[E_Coact] := "E_Coact"
+ symmap[E_Coexpr] := "E_Coexpr"
+ symmap[E_Cofail] := "E_Cofail"
+ symmap[E_Collect] := "E_Collect"
+ symmap[E_Coret] := "E_Coret"
+ symmap[E_Cset] := "E_Cset"
+ symmap[E_Ecall] := "E_Ecall"
+ symmap[E_Efail] := "E_Efail"
+ symmap[E_Eresum] := "E_Eresum"
+ symmap[E_Error] := "E_Error"
+ symmap[E_Esusp] := "E_Esusp"
+ symmap[E_Erem] := "E_Erem"
+ symmap[E_Exit] := "E_Exit"
+ symmap[E_External] := "E_External"
+ symmap[E_Fcall] := "E_Fcall"
+ symmap[E_Fconv] := "E_Fconv"
+ symmap[E_Ffail] := "E_Ffail"
+ symmap[E_File] := "E_File"
+ symmap[E_Free] := "E_Free"
+ symmap[E_Fresum] := "E_Fresum"
+ symmap[E_Fret] := "E_Fret"
+ symmap[E_Fsusp] := "E_Fsusp"
+ symmap[E_Frem] := "E_Frem"
+ symmap[E_Intcall] := "E_Intcall"
+ symmap[E_Integer] := "E_Integer"
+ symmap[E_Intret] := "E_Intret"
+ symmap[E_Kywdint] := "E_Kywdint"
+ symmap[E_Kywdpos] := "E_Kywdpos"
+ symmap[E_Kywdsubj] := "E_Kywdsubj"
+ symmap[E_Lbang] := "E_Lbang"
+ symmap[E_Lcreate] := "E_Lcreate"
+ symmap[E_Lelem] := "E_Lelem"
+ symmap[E_Line] := "E_Line"
+ symmap[E_List] := "E_List"
+ symmap[E_Loc] := "E_Loc"
+ symmap[E_Lpop] := "E_Lpop"
+ symmap[E_Lpull] := "E_Lpull"
+ symmap[E_Lpush] := "E_Lpush"
+ symmap[E_Lput] := "E_Lput"
+ symmap[E_Lrand] := "E_Lrand"
+ symmap[E_Lref] := "E_Lref"
+ symmap[E_Lrgint] := "E_Lrgint"
+ symmap[E_Lsub] := "E_Lsub"
+ symmap[E_Lsusp] := "E_Lsusp"
+ symmap[E_Nconv] := "E_Nconv"
+ symmap[E_Null] := "E_Null"
+ symmap[E_Ocall] := "E_Ocall"
+ symmap[E_Ofail] := "E_Ofail"
+ symmap[E_Opcode] := "E_Opcode"
+ symmap[E_Oresum] := "E_Oresum"
+ symmap[E_Oret] := "E_Oret"
+ symmap[E_Osusp] := "E_Osusp"
+ symmap[E_Orem] := "E_Orem"
+ symmap[E_Pcall] := "E_Pcall"
+ symmap[E_Pfail] := "E_Pfail"
+ symmap[E_Presum] := "E_Presum"
+ symmap[E_Pret] := "E_Pret"
+ symmap[E_Proc] := "E_Proc"
+ symmap[E_Psusp] := "E_Psusp"
+ symmap[E_Prem] := "E_Prem"
+ symmap[E_Rbang] := "E_Rbang"
+ symmap[E_Rcreate] := "E_Rcreate"
+ symmap[E_Real] := "E_Real"
+ symmap[E_Record] := "E_Record"
+ symmap[E_Refresh] := "E_Refresh"
+ symmap[E_Rrand] := "E_Rrand"
+ symmap[E_Rref] := "E_Rref"
+ symmap[E_Rsub] := "E_Rsub"
+ symmap[E_Sbang] := "E_Sbang"
+ symmap[E_Sconv] := "E_Sconv"
+ symmap[E_Screate] := "E_Screate"
+ symmap[E_Sdelete] := "E_Sdelete"
+ symmap[E_Selem] := "E_Selem"
+ symmap[E_Set] := "E_Set"
+ symmap[E_Sfail] := "E_Sfail"
+ symmap[E_Sinsert] := "E_Sinsert"
+ symmap[E_Slots] := "E_Slots"
+ symmap[E_Smember] := "E_Smember"
+ symmap[E_Snew] := "E_Snew"
+ symmap[E_Spos] := "E_Spos"
+ symmap[E_Srand] := "E_Srand"
+ symmap[E_Sresum] := "E_Sresum"
+ symmap[E_Ssasgn] := "E_Ssasgn"
+ symmap[E_Ssusp] := "E_Ssusp"
+ symmap[E_Stack] := "E_Stack"
+ symmap[E_StrDeAlc] := "E_StrDeAlc"
+ symmap[E_String] := "E_String"
+ symmap[E_Sval] := "E_Sval"
+ symmap[E_Srem] := "E_Srem"
+ symmap[E_Table] := "E_Table"
+ symmap[E_Tbang] := "E_Tbang"
+ symmap[E_Tconv] := "E_Tconv"
+ symmap[E_Tcreate] := "E_Tcreate"
+ symmap[E_Tdelete] := "E_Tdelete"
+ symmap[E_Telem] := "E_Telem"
+ symmap[E_Tick] := "E_Tick"
+ symmap[E_Tinsert] := "E_Tinsert"
+ symmap[E_Tkey] := "E_Tkey"
+ symmap[E_Tmember] := "E_Tmember"
+ symmap[E_Trand] := "E_Trand"
+ symmap[E_Tref] := "E_Tref"
+ symmap[E_Tsub] := "E_Tsub"
+ symmap[E_Tval] := "E_Tval"
+ symmap[E_Tvsubs] := "E_Tvsubs"
+ symmap[E_Tvtbl] := "E_Tvtbl"
+ symmap[E_Value] := "E_Value"
+
+ symmap := twt(symmap)
+ }
+
+ return symmap
+
+end
diff --git a/ipl/mprocs/evtmap.icn b/ipl/mprocs/evtmap.icn
new file mode 100644
index 0000000..255adae
--- /dev/null
+++ b/ipl/mprocs/evtmap.icn
@@ -0,0 +1,181 @@
+############################################################################
+#
+# File: evtmap.icn
+#
+# Subject: Procedure to map event code names to values
+#
+# Author: Ralph E. Griswold
+#
+# Date: July 15, 1995
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# evtmap(s) returns the event-code value for the event string name s. It
+# fails is s is not the name of an event value.
+#
+############################################################################
+#
+# Includes: evdefs.icn, etdefs.icn
+#
+############################################################################
+
+$include "evdefs.icn"
+$include "etdefs.icn"
+
+procedure evtmap(s) #: map event code name to event value
+ static maptbl
+
+ initial {
+ maptbl:= table()
+
+ maptbl["E_Aconv"] := "I"
+ maptbl["E_Alien"] := "z"
+ maptbl["E_Assign"] := "\347"
+ maptbl["E_Base"] := "<"
+ maptbl["E_BlkDeAlc"] := "-"
+ maptbl["E_Bsusp"] := "b"
+ maptbl["E_Coact"] := "A"
+ maptbl["E_Coexpr"] := "x"
+ maptbl["E_Cofail"] := "D"
+ maptbl["E_Collect"] := "G"
+ maptbl["E_Comment"] := "#"
+ maptbl["E_Coret"] := "B"
+ maptbl["E_Cset"] := "e"
+ maptbl["E_Ecall"] := "c"
+ maptbl["E_Efail"] := "f"
+ maptbl["E_EndCollect"] := "\360"
+ maptbl["E_Erem"] := "v"
+ maptbl["E_Eresum"] := "u"
+ maptbl["E_Eret"] := "r"
+ maptbl["E_Error"] := "E"
+ maptbl["E_Esusp"] := "a"
+ maptbl["E_Exit"] := "X"
+ maptbl["E_External"] := "j"
+ maptbl["E_Fcall"] := ":"
+ maptbl["E_Fconv"] := "J"
+ maptbl["E_Ffail"] := "M"
+ maptbl["E_File"] := "g"
+ maptbl["E_Free"] := "Z"
+ maptbl["E_Frem"] := "["
+ maptbl["E_Fresum"] := "Y"
+ maptbl["E_Fret"] := "P"
+ maptbl["E_Fsusp"] := "W"
+ maptbl["E_Highlight"] := "H"
+ maptbl["E_Intcall"] := "\351"
+ maptbl["E_Integer"] := "@"
+ maptbl["E_Intret"] := "\352"
+ maptbl["E_Kywdint"] := "^"
+ maptbl["E_Kywdpos"] := "&"
+ maptbl["E_Kywdsubj"] := "*"
+ maptbl["E_Lbang"] := "\301"
+ maptbl["E_Lcreate"] := "\302"
+ maptbl["E_Lelem"] := "m"
+ maptbl["E_List"] := "k"
+ maptbl["E_Loc"] := "|"
+ maptbl["E_Lpop"] := "\303"
+ maptbl["E_Lpull"] := "\304"
+ maptbl["E_Lpush"] := "\305"
+ maptbl["E_Lput"] := "\306"
+ maptbl["E_Lrand"] := "\307"
+ maptbl["E_Lref"] := "\310"
+ maptbl["E_Lrgint"] := "L"
+ maptbl["E_Lsub"] := "\311"
+ maptbl["E_Lsusp"] := "l"
+ maptbl["E_MXevent"] := "\370"
+ maptbl["E_Nconv"] := "N"
+ maptbl["E_Null"] := "$"
+ maptbl["E_Ocall"] := "\\"
+ maptbl["E_Ofail"] := "]"
+ maptbl["E_Offset"] := "+"
+ maptbl["E_Opcode"] := "O"
+ maptbl["E_Orem"] := "\177"
+ maptbl["E_Oresum"] := "}"
+ maptbl["E_Oret"] := "`"
+ maptbl["E_Osusp"] := "{"
+ maptbl["E_Pause"] := ";"
+ maptbl["E_Pcall"] := "C"
+ maptbl["E_Pfail"] := "F"
+ maptbl["E_Pid"] := "."
+ maptbl["E_Prem"] := "V"
+ maptbl["E_Presum"] := "U"
+ maptbl["E_Pret"] := "R"
+ maptbl["E_Proc"] := "%"
+ maptbl["E_Psusp"] := "S"
+ maptbl["E_Rbang"] := "\312"
+ maptbl["E_Rcreate"] := "\313"
+ maptbl["E_Real"] := "d"
+ maptbl["E_Record"] := "h"
+ maptbl["E_Refresh"] := "y"
+ maptbl["E_Region"] := "?"
+ maptbl["E_Rrand"] := "\314"
+ maptbl["E_Rref"] := "\315"
+ maptbl["E_Rsub"] := "\316"
+ maptbl["E_Ssasgn"] := "\354"
+ maptbl["E_Sbang"] := "\317"
+ maptbl["E_Sconv"] := "Q"
+ maptbl["E_Screate"] := "\320"
+ maptbl["E_Sdelete"] := "\321"
+ maptbl["E_Selem"] := "t"
+ maptbl["E_Set"] := "q"
+ maptbl["E_Sfail"] := "\341"
+ maptbl["E_Sinsert"] := "\322"
+ maptbl["E_Size"] := ">"
+ maptbl["E_Slots"] := "w"
+ maptbl["E_Smember"] := "\323"
+ maptbl["E_Snew"] := "\340"
+ maptbl["E_Spos"] := "\346"
+ maptbl["E_Srand"] := "\336"
+ maptbl["E_Srem"] := "\344"
+ maptbl["E_Sresum"] := "\343"
+ maptbl["E_Ssusp"] := "\342"
+ maptbl["E_Stack"] := "\353"
+ maptbl["E_StrDeAlc"] := "~"
+ maptbl["E_String"] := "s"
+ maptbl["E_Sval"] := "\324"
+ maptbl["E_Sym"] := "T"
+ maptbl["E_Table"] := "n"
+ maptbl["E_Tbang"] := "\325"
+ maptbl["E_Tconv"] := "K"
+ maptbl["E_Tcreate"] := "\326"
+ maptbl["E_Tdelete"] := "\327"
+ maptbl["E_Telem"] := "o"
+ maptbl["E_TenureBlock"] := "\362"
+ maptbl["E_TenureString"] := "\361"
+ maptbl["E_Tick"] := "."
+ maptbl["E_Tinsert"] := "\330"
+ maptbl["E_Tkey"] := "\331"
+ maptbl["E_Tmember"] := "\332"
+ maptbl["E_Trand"] := "\337"
+ maptbl["E_Tref"] := "\333"
+ maptbl["E_Tsub"] := "\334"
+ maptbl["E_Tval"] := "\335"
+ maptbl["E_Tvsubs"] := "i"
+ maptbl["E_Tvtbl"] := "p"
+ maptbl["E_Used"] := "="
+ maptbl["E_Value"] := "\350"
+
+ maptbl["T_01"] := "A"
+ maptbl["T_02"] := "B"
+ maptbl["T_03"] := "C"
+ maptbl["T_04"] := "D"
+ maptbl["T_05"] := "E"
+ maptbl["T_06"] := "F"
+ maptbl["T_07"] := "G"
+ maptbl["T_08"] := "H"
+ maptbl["T_09"] := "I"
+ maptbl["T_10"] := "J"
+ maptbl["T_11"] := "K"
+ maptbl["T_12"] := "L"
+ maptbl["T_13"] := "M"
+ maptbl["T_14"] := "N"
+
+$define T_Mask1 cset("ABCDEFGHIJKLM")
+ }
+
+ return \maptbl[s]
+
+end
diff --git a/ipl/mprocs/evutils.icn b/ipl/mprocs/evutils.icn
new file mode 100644
index 0000000..c1c847e
--- /dev/null
+++ b/ipl/mprocs/evutils.icn
@@ -0,0 +1,94 @@
+############################################################################
+#
+# File: evutils.icn
+#
+# Subject: Procedures to support event monitoring
+#
+# Author: Clinton L. Jeffery
+#
+# Date: November 23, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# This may not be the latest version of this file, despite the date.
+#
+############################################################################
+#
+# Requires: Version 9 graphics
+#
+############################################################################
+
+#
+# location() - encodes a two-dimensional location in an integer
+#
+procedure location(x, y)
+ return ishift(x, 16) + y
+end
+
+#
+# vertical() - returns the y/line/row component of a location
+#
+procedure vertical(Loc)
+ return iand(Loc, 65535) # 16 least-significant bits
+end
+
+#
+# horizontal - returns the x/column component of a location
+#
+procedure horizontal(Loc)
+ return ishift(Loc, -16) # 16 most-significant bits
+end
+
+#
+# prog_len() return the number of lines in TP
+# Don't call until EvInit() has been called.
+#
+procedure prog_len()
+ local basename, fname, f, count
+ #
+ # Extract TP's &file keyword
+ #
+ basename := fname := keyword("file", EventSource)
+ if (not (f := open(fname))) & lpath := getenv("LPATH") || " " then {
+ #
+ # Search LPATH for the file if it wasn't in the current directory.
+ #
+ lpath ? {
+ while dir := tab(find(" ")) do {
+ if fname := dir || "/" || basename & (f := open(fname)) then break
+ }
+ if /f then fail
+ }
+ }
+ count := 0
+ every !f do count +:= 1
+ close(f)
+ return count
+end
+
+#
+# procedure_name() - return the name of a procedure
+#
+procedure procedure_name(p)
+ return image(p)[10:0] # strip off "procedure " prefix of image
+end
+
+#
+# XHeight(w) - return window height in pixels
+#
+procedure XHeight(w)
+ /w := &window
+ return WAttrib(w, "height")
+end
+
+#
+# XWidth(w) - return window width in pixels
+#
+procedure XWidth(w)
+ /w := &window
+ return WAttrib(w, "width")
+end
diff --git a/ipl/mprocs/hexlib.icn b/ipl/mprocs/hexlib.icn
new file mode 100644
index 0000000..4b7d5b9
--- /dev/null
+++ b/ipl/mprocs/hexlib.icn
@@ -0,0 +1,146 @@
+############################################################################
+#
+# File: hexlib.icn
+#
+# Subject: Procedures for hexagons
+#
+# Author: Clinton Jeffery
+#
+# Date: August 12, 1994
+#
+#########################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# This file is used by algae but is not finished or supported.
+#
+############################################################################
+#
+# Requires: Version 9 graphics
+#
+############################################################################
+
+global scale,scale2,scale4,scale5,numrows,numcols,drawsegs,drawlefts,drawrights
+global drawesegs, q, qq, wHexOutline
+
+procedure starthex(w)
+ /scale := 10
+ /numrows := 10
+ /numcols := 10
+ scale2 := 2*scale
+ scale4 := 4*scale
+ scale5 := 5*scale
+ if (numcols % 2) = 0 then numcols +:= 1
+ every col := 0 to numcols-1 by 2 do oddcol(w,col*scale4)
+ every col := 1 to numcols-1 by 2 do evencol(w,col*scale4)
+# DrawSegment ! drawsegs
+end
+
+procedure oddcol(w,x)
+ initial {
+ i := numrows+1
+ i6 := i * 6
+ drawlefts := list(i6+1)
+ drawrights := list(i6+1)
+ drawsegs := list(i*8+1)
+ drawlefts[1] := drawrights[1] := drawsegs[1] := w
+ q := qq := 2
+ every i := 0 to numrows do hex(x,i*scale4)
+ DrawLine ! drawlefts
+ DrawLine ! drawrights
+ DrawSegment ! drawsegs
+ return
+ }
+ q := 2
+ qq := 2
+ every i := 0 to numrows do rehex(x,i*scale4)
+ DrawLine ! drawlefts
+ DrawLine ! drawrights
+ DrawSegment ! drawsegs
+end
+
+procedure evencol(w,x)
+ initial {
+ drawesegs := list(numrows*8+1)
+ drawesegs[1] := w
+ q := 2
+ every i := 0 to numrows-1 do parthex(x,i*scale4+scale2)
+ DrawSegment ! drawesegs
+ return
+ }
+ q := 2
+ every i := 0 to numrows-1 do reparthex(x,i*scale4+scale2)
+ DrawSegment ! drawesegs
+end
+
+procedure parthex(x,y)
+ y4 := y + scale4
+ drawesegs[q+1] := y4
+ drawesegs[q+3] := y4
+ drawesegs[q+5] := y
+ drawesegs[q+7] := y
+ reparthex(x,y)
+end
+procedure reparthex(x,y)
+ x1 := x + scale
+ x4 := x + scale4
+ drawesegs[q ] := x1
+ drawesegs[q+2] := x4
+ drawesegs[q+4] := x1
+ drawesegs[q+6] := x4
+ q +:= 8
+end
+procedure hex(x,y)
+ y2 := y + scale2
+ y4 := y + scale4
+ drawlefts[qq+1] := y
+ drawlefts[qq+3] := y2
+ drawlefts[qq+5] := y4
+ drawrights[qq+1] := y
+ drawrights[qq+3] := y2
+ drawrights[qq+5] := y4
+ drawsegs[q+1] := y4
+ drawsegs[q+3] := y4
+ drawsegs[q+5] := y
+ drawsegs[q+7] := y
+ rehex(x,y)
+end
+procedure rehex(x,y)
+ x1 := x + scale
+ x4 := x + scale4
+ drawlefts[qq] := x1
+ drawlefts[qq+2] := x
+ drawlefts[qq+4] := x1
+ drawrights[qq] := x4
+ drawrights[qq+2] := x+scale5
+ drawrights[qq+4] := x4
+ drawsegs[q] := x1
+ drawsegs[q+2] := x4
+ drawsegs[q+4] := x1
+ drawsegs[q+6] := x4
+ q +:= 8
+ qq +:= 6
+end
+
+procedure hex_spot(w, row, col)
+ x := (col-1)*scale4
+ y := (row-1)*scale4
+ if col % 2 = 0 then y +:= scale2
+ x1 := x + scale
+ x4 := x + scale4
+ x5 := x + scale5
+ y2 := y + scale2
+ y4 := y + scale4
+ FillPolygon(w, x1, y, x, y2, x1, y4, x4, y4, x5, y2, x4, y)
+ DrawLine(wHexOutline, x1, y, x, y2, x1, y4, x4, y4, x5, y2, x4, y, x1, y)
+end
+
+procedure hex_mouse(y,x)
+ if x % scale4 = 0 then fail
+ col := x / scale4 + 1
+ if col % 2 = 0 then row := (y - scale2) / scale4 + 1
+ else row := y / scale4 + 1
+ return ishift(col, 16) + row
+end
diff --git a/ipl/mprocs/loadfile.icn b/ipl/mprocs/loadfile.icn
new file mode 100644
index 0000000..28cd0b2
--- /dev/null
+++ b/ipl/mprocs/loadfile.icn
@@ -0,0 +1,64 @@
+############################################################################
+#
+# File: loadfile.icn
+#
+# Subject: Procedure to produce and load program on the fly
+#
+# Author: Ralph E. Griswold
+#
+# Date: November 21, 1996
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# loadfile(exp, link, ...) produces and loads a program that generates
+# the results of exp. The trailing arguments name link
+# files needed for the expression. loadfile() returns a procedure
+# that generates the results.
+#
+############################################################################
+#
+# Requires: MT-Icon, system(), pipes, /tmp
+#
+############################################################################
+#
+# Links: io
+#
+############################################################################
+
+link io
+
+procedure loadfile(exp, links[]) #: produce and load program
+ local output, prog
+ static name
+
+ output := tempfile("load", ".icn", "/tmp")
+
+ image(output) ? {
+ ="file("
+ name := tab(find(".icn"))
+ }
+
+ write(output, "invocable all")
+ every write(output, "link ", image(!links))
+ write(output, "procedure main(args)")
+ write(output, " suspend ", exp)
+ write(output, "end")
+
+ close(output)
+
+ if system("mticont -o " || name || " -s " || name ||
+ " >/dev/null 2>/dev/null") ~= 0 then fail
+
+ remove(name || ".icn") # remove source code file
+
+ # Load the program
+
+ prog := load(name) | stop("*** load failure in loadfile")
+
+ return variable("main", prog)
+
+end
diff --git a/ipl/mprocs/opname.icn b/ipl/mprocs/opname.icn
new file mode 100644
index 0000000..9c87667
--- /dev/null
+++ b/ipl/mprocs/opname.icn
@@ -0,0 +1,129 @@
+############################################################################
+#
+# File: opname.icn
+#
+# Subject: Procedure to map VM opcodes to their names
+#
+# Author: Ralph E. Griswold
+#
+# Date: August 8, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# opnames() maps the virtual-machine instruction numbers to symbolic names.
+#
+############################################################################
+
+procedure opname(i) #: map virtual-machine code to name
+ static opmap
+
+ initial {
+ opmap := table("")
+
+ opmap[1] := "Asgn"
+ opmap[2] := "Bang"
+ opmap[3] := "Cat"
+ opmap[4] := "Compl"
+ opmap[5] := "Diff"
+ opmap[6] := "Div"
+ opmap[7] := "Eqv"
+ opmap[8] := "Inter"
+ opmap[9] := "Lconcat"
+ opmap[10] := "Lexeq"
+ opmap[11] := "Lexge"
+ opmap[12] := "Lexgt"
+ opmap[13] := "Lexle"
+ opmap[14] := "Lexlt"
+ opmap[15] := "Lexne"
+ opmap[16] := "Minus"
+ opmap[17] := "Mod"
+ opmap[18] := "Mult"
+ opmap[19] := "Neg"
+ opmap[20] := "Neqv"
+ opmap[21] := "Nonnull"
+ opmap[22] := "Null"
+ opmap[23] := "Number"
+ opmap[24] := "Numeq"
+ opmap[25] := "Numge"
+ opmap[26] := "Numgt"
+ opmap[27] := "Numle"
+ opmap[28] := "Numlt"
+ opmap[29] := "Numne"
+ opmap[30] := "Plus"
+ opmap[31] := "Power"
+ opmap[32] := "Random"
+ opmap[33] := "Rasgn"
+ opmap[34] := "Refresh"
+ opmap[35] := "Rswap"
+ opmap[36] := "Sect"
+ opmap[37] := "Size"
+ opmap[38] := "Subsc"
+ opmap[39] := "Swap"
+ opmap[40] := "Tabmat"
+ opmap[41] := "Toby"
+ opmap[42] := "Unions"
+ opmap[43] := "Value"
+ opmap[44] := "Bscan"
+ opmap[45] := "Ccase"
+ opmap[46] := "Chfail"
+ opmap[47] := "Coact"
+ opmap[48] := "Cofail"
+ opmap[49] := "Coret"
+ opmap[50] := "Create"
+ opmap[51] := "Cset"
+ opmap[52] := "Dup"
+ opmap[53] := "Efail"
+ opmap[54] := "Eret"
+ opmap[55] := "Escan"
+ opmap[56] := "Esusp"
+ opmap[57] := "Field"
+ opmap[58] := "Goto"
+ opmap[59] := "Init"
+ opmap[60] := "Int"
+ opmap[61] := "Invoke"
+ opmap[62] := "Keywd"
+ opmap[63] := "Limit"
+ opmap[64] := "Line"
+ opmap[65] := "Llist"
+ opmap[66] := "Lsusp"
+ opmap[67] := "Mark"
+ opmap[68] := "Pfail"
+ opmap[69] := "Pnull"
+ opmap[70] := "Pop"
+ opmap[71] := "Pret"
+ opmap[72] := "Psusp"
+ opmap[73] := "Push1"
+ opmap[74] := "Pushn1"
+ opmap[75] := "Real"
+ opmap[76] := "Sdup"
+ opmap[77] := "Str"
+ opmap[78] := "Unmark"
+ opmap[80] := "Var"
+ opmap[81] := "Arg"
+ opmap[82] := "Static"
+ opmap[83] := "Local"
+ opmap[84] := "Global"
+ opmap[85] := "Mark0"
+ opmap[86] := "Quit"
+ opmap[87] := "FQuit"
+ opmap[88] := "Tally"
+ opmap[89] := "Apply"
+ opmap[90] := "Acset"
+ opmap[91] := "Areal"
+ opmap[92] := "Astr"
+ opmap[93] := "Aglobal"
+ opmap[94] := "Astatic"
+ opmap[95] := "Agoto"
+ opmap[96] := "Amark"
+ opmap[98] := "Noop"
+ opmap[100] := "SymEvents"
+ opmap[108] := "Colm"
+ }
+
+ return opmap[i]
+
+end
diff --git a/ipl/mprocs/typebind.icn b/ipl/mprocs/typebind.icn
new file mode 100644
index 0000000..84bf9ec
--- /dev/null
+++ b/ipl/mprocs/typebind.icn
@@ -0,0 +1,56 @@
+############################################################################
+#
+# File: typebind.icn
+#
+# Subject: Procedures to produce table of graphic contexts for type
+#
+# Author: Ralph E. Griswold and Clinton L. Jeffery
+#
+# Date: March 4, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# typebind(window, codes, opts) returns a table of graphic contexts bound to
+# window with foreground colors keyed by type in the string of event codes.
+#
+# Codes for which there is no corresponding color are ignored.
+#
+# Note: Event monitoring global identifiers must be linked by the program
+# that uses this procedure.
+#
+############################################################################
+#
+# Links: colormap
+#
+############################################################################
+#
+# Requires: Version 9 graphics
+#
+############################################################################
+
+link colormap
+
+procedure typebind(window, codes, opts)
+ local code, context
+ static contexts, color
+
+ initial {
+ contexts := table()
+ if /opts then color := colormap("standard")
+ else color := colormap(opts["p"])
+ }
+
+ if /contexts[window] := table() then {
+ context := contexts[window]
+ every code := !codes do
+ context[code] := Clone(window, , "fg=" || \color[code])
+ }
+ contexts[window]["bg"] := Clone(window, "fg=" || WAttrib(window,"bg"))
+ return contexts[window]
+
+end
+
diff --git a/ipl/mprocs/typesyms.icn b/ipl/mprocs/typesyms.icn
new file mode 100644
index 0000000..04dee72
--- /dev/null
+++ b/ipl/mprocs/typesyms.icn
@@ -0,0 +1,71 @@
+############################################################################
+#
+# File: typesyms.icn
+#
+# Subject: Procedure to map type codes to event codes
+#
+# Author: Ralph E. Griswold
+#
+# Date: June 8, 1994
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# typesyms() returns a table that maps type codes to event codes. The
+# table can be subscripted either by one-character strings in the style
+# of typecode() or by the integer values given by T_type globals.
+#
+# This procedure is intended for use with event monitors running under
+# MT Icon.
+#
+############################################################################
+#
+# See also: typecode.icn
+#
+############################################################################
+#
+# Includes: evdefs.icn
+#
+############################################################################
+
+$include "evdefs.icn"
+
+procedure typesyms()
+ static typetable
+
+ initial {
+ typetable := table()
+
+ typetable["L"] := E_List
+ typetable["S"] := E_Set
+ typetable["T"] := E_Table
+ typetable["R"] := E_Record
+ typetable["s"] := E_String
+ typetable["c"] := E_Cset
+ typetable["i"] := E_Integer
+ typetable["r"] := E_Real
+ typetable["f"] := E_File
+ typetable["n"] := E_Null
+ typetable["p"] := E_Proc
+ typetable["C"] := E_Coexpr
+
+ typetable[T_List] := E_List
+ typetable[T_Set] := E_Set
+ typetable[T_Table] := E_Table
+ typetable[T_Record] := E_Record
+ typetable[T_String] := E_String
+ typetable[T_Cset] := E_Cset
+ typetable[T_Integer] := E_Integer
+ typetable[T_Real] := E_Real
+ typetable[T_File] := E_File
+ typetable[T_Null] := E_Null
+ typetable[T_Proc] := E_Proc
+ typetable[T_Coexpr] := E_Coexpr
+ }
+
+ return typetable
+
+end
diff --git a/ipl/mprocs/viewpack.icn b/ipl/mprocs/viewpack.icn
new file mode 100644
index 0000000..1797fd1
--- /dev/null
+++ b/ipl/mprocs/viewpack.icn
@@ -0,0 +1,329 @@
+############################################################################
+#
+# File: viewpack.icn
+#
+# Subject: Procedures to visualize color streams
+#
+# Author: Ralph E. Griswold
+#
+# Date: May 2, 2001
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# These procedures provide various ways of visualizing a stream of colors.
+#
+############################################################################
+#
+# Requires: Version 9 graphics
+#
+############################################################################
+
+$define Hold 300
+
+# blinking light
+
+procedure beacon(win, color, value) #: 1C visualization as blinking light
+
+ Fg(win, color)
+ FillCircle(win, width / 2, height / 2, width / 2)
+ WDelay(win, Hold)
+
+end
+
+# random curves
+
+procedure curves(win, color, value) #: 1C visualization as random curves
+ local x0, y0
+
+ Fg(win, color)
+ DrawCurve ! [
+ win,
+ x0 := ?width, y0 := ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ .x0, .y0
+ ]
+
+ WDelay(win, Hold)
+
+ return
+
+end
+
+# "haystack"
+
+procedure haystack(win, color, value) #: 2CS visualization as "haystack"
+ static angle, xcenter, ycenter, xorg, yorg, fullcircle
+
+ initial {
+ fullcircle := 2 * &pi
+ ycenter := height / 2
+ xcenter := width / 2
+ }
+
+ Fg(win, color)
+ angle := ?0 * fullcircle # angle for locating starting point
+ xorg := xcenter + ?xcenter * cos(angle)
+ yorg := ycenter + ?ycenter * sin(angle)
+ angle := ?0 * fullcircle # angle for locating end point
+ DrawLine(win, xorg, yorg, value * cos(angle) +
+ xorg, value * sin(angle) + yorg)
+
+ return
+
+end
+
+# "nova"
+
+$define Scale 1.5
+$define Rays 360
+
+procedure nova(win, color, value) #: 1C visualization as exploding star
+ local clear, xorg, yorg, radius, arc, oldlength, length
+ static fullcircle, radians, advance, erase
+
+ initial {
+ fullcircle := 2 * &pi
+ radians := 0
+ advance := fullcircle / Rays # amount to advance
+ erase := list(Rays)
+ }
+
+ Fg(win, color)
+ xorg := width / 2
+ yorg := height / 2
+ radius := ((height < width) | height) / 2.0
+
+ length := value * Scale
+ put(erase, length)
+ oldlength := get(erase)
+
+# The following are to erase old ray at that angle
+
+# DrawLine(Background, xorg, yorg, \oldlength * cos(radians) + xorg,
+# oldlength * sin(radians) + yorg)
+
+ DrawLine(win, xorg, yorg, length * cos(radians) +
+ xorg, length * sin(radians) + yorg)
+
+ radians +:= advance
+ radians %:= fullcircle
+
+ return
+
+end
+
+# "pinwheel"
+
+$define Sectors 240
+
+procedure pinwheel(win, color, value) #: 1C visualization as radar sweep
+ static clear, xorg, yorg, radius, offset
+ static arc, advance, blank, max, xratio, yratio
+ static fullcircle, background
+
+ initial {
+ fullcircle := 2 * &pi
+ max := real((width < height) | width)
+ xratio := width / max
+ yratio := height / max
+ offset := 0
+ advance := fullcircle / Sectors
+ blank := 2 * advance
+ xorg := width / 2
+ yorg := height / 2
+ radius := max / 2
+
+ # This belongs elsewhere
+
+ background := Clone(win, "bg=" || default_color)
+
+ }
+
+ Fg(win, color)
+ FillArc(background, 0, 0, width, height, offset + advance, blank)
+ FillArc(win, 0, 0, width, height, offset, advance)
+ DrawLine(background, xorg, yorg, xratio * radius * cos(offset) +
+ xorg, yratio * radius * sin(offset) + yorg)
+
+ offset +:= advance
+ offset %:= fullcircle
+
+ return
+
+end
+
+# random polygons
+
+procedure polygons(win, color, value) #: 1C visualization as random polygons
+ local x0, y0
+
+ Fg(win, color)
+ FillPolygon ! [
+ win,
+ x0 := ?width, y0 := ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ ?width, ?height,
+ .x0, .y0
+ ]
+
+ WDelay(win, Hold)
+
+ return
+
+end
+
+# random dots
+
+procedure splatter(win, color, value) #: 2CS visualization as random dots
+ local radius, xplace, yplace
+
+ Fg(win, color)
+ radius := sqrt(value)
+ xplace := ?width - 1 - (radius / 2)
+ yplace := ?height - 1 - (radius / 2)
+ FillCircle(win, xplace, yplace, radius)
+
+ return
+
+end
+
+# scrolling strip
+
+procedure strip(win, color, value) #: 2CS visualization as scrolling lines
+ local count
+
+ Fg(win, color) | "black"
+ if /value | (value = 0) then return
+ count := log(value, 10) + 1
+ every 1 to count do {
+ CopyArea(win, 1, 0, width - 1, height, 0, 0)
+ EraseArea(win, width - 1, 0, width - 1, height)
+ FillRectangle(win, width - 1, 0, 1, height)
+ }
+
+ return
+
+end
+
+procedure symdraw(W, mid, x, y, r)
+
+ FillCircle(W, mid + x, mid + y, r)
+ FillCircle(W, mid + x, mid - y, r)
+ FillCircle(W, mid - x, mid + y, r)
+ FillCircle(W, mid - x, mid - y, r)
+
+ FillCircle(W, mid + y, mid + x, r)
+ FillCircle(W, mid + y, mid - x, r)
+ FillCircle(W, mid - y, mid + x, r)
+ FillCircle(W, mid - y, mid - x, r)
+
+ return
+
+end
+
+# symmetric random dots
+
+procedure symsplat(win, color, value) #: 2CS visualization as symmetric random dots
+ local radius
+ static xplace, yplace, oscale
+
+ Fg(win, color)
+ radius := sqrt(value)
+ xplace := ?width - 1
+ yplace := ?height - 1
+ symdraw(win, width / 2, xplace, yplace, radius)
+
+ return
+
+end
+
+# evolving vortex
+
+procedure vortex(win, color, value) #: 1C visualization as an aspirating vortex
+ local count
+ static x1, x2, y1, y2
+
+ initial {
+ x1 := y1 := 0
+ x2 := width
+ y2 := height
+ }
+
+ Fg(win, color)
+ if value = 0 then return
+ count := log(value, 10) + 1
+ every 1 to count do {
+ if (x2 | y2) < 0 then {
+ x1 := y1 := 0
+ x2 := width
+ y2 := height
+ }
+ DrawRectangle(win, x1, y1, x2 - x1, y2 - y1)
+ x1 +:= 1
+ x2 -:= 1
+ y1 +:= 1
+ y2 -:= 1
+ }
+
+ return
+
+end
+
+# random walk
+#
+# This procedure is suspect -- it seems to wander off the display area.
+
+$define Delta 30
+
+procedure web(win, color, value) #: 2CS visualization as a random walk
+ static xorg, yorg, x, y, angle, degrees, radians, resid
+
+ initial {
+ resid := 0
+ xorg := ?(width - 1) # starting point
+ yorg := ?(height - 1)
+ }
+
+ Fg(win, color)
+ if resid <= 1 then {
+ angle := ?0 * 2 * &pi # initial direction for new walk
+ resid := value
+ }
+
+ x := xorg + resid * cos(angle)
+ y := yorg + resid * sin(angle)
+
+ if x > width then {
+ x := width
+ }
+ if y > height then {
+ y := height
+ }
+ if x < 0 then {
+ x := 0
+ }
+ if y < 0 then {
+ y := 0
+ }
+ DrawLine(win, xorg, yorg, x, y)
+ resid -:= sqrt((x - xorg) ^ 2 + (y - yorg) ^ 2)
+ xorg := x # move to new point
+ yorg := y
+ angle := -angle # reflect
+
+ return
+
+end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-17 21:10:36 +0000