diff options
Diffstat (limited to 'ipl/packs/itweak/itweak.icn')
| -rw-r--r-- | ipl/packs/itweak/itweak.icn | 830 |
1 files changed, 830 insertions, 0 deletions
diff --git a/ipl/packs/itweak/itweak.icn b/ipl/packs/itweak/itweak.icn new file mode 100644 index 0000000..47324ef --- /dev/null +++ b/ipl/packs/itweak/itweak.icn @@ -0,0 +1,830 @@ +############################################################################ +# +# File: itweak.icn +# +# Subject: Icon interactive debugging. +# Tweaks a ucode file ('.u1') to invoke a debugging procedure. +# +# Author: Hakan Soderstrom +# +# Revision: $Revision: 2.21 $ +# +########################################################################### +# +# Copyright (c) 1994 Hakan Soderstrom and +# Soderstrom Programvaruverkstad AB, Sweden +# +# Permission to use, copy, modify, distribute, and sell this software +# and its documentation for any purpose is hereby granted without fee, +# provided that the above copyright notice and this permission notice +# appear in all copies of the software and related documentation. +# +# THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND, +# EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY +# WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. +# +# IN NO EVENT SHALL HAKAN SODERSTROM OR SODERSTROM PROGRAMVARUVERKSTAD +# AB BE LIABLE FOR ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL +# DAMAGES OF ANY KIND, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +# OF USE, DATA OR PROFITS, WHETHER OR NOT ADVISED OF THE POSSIBILITY +# OF DAMAGE, AND ON ANY THEORY OF LIABILITY, ARISING OUT OF OR IN +# CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +# +########################################################################### + +# +#-------- Record types -------- +# + +record l_decl (d_type, d_serial, d_code, d_name, d_displ, ld_cserial, ld_dbg) +# Holds a 'local' declaration. +# 'd_type' must be the declaration type (integer), in this case, +$define D_LOCAL 1 +# 'd_serial' must be the serial number of the declaration (integer). +# 'd_code' must be the bitfield that further characterizes the declaration. +# It is stored as the integer obtained by interpreting the octal coded +# bitfield as a decimal number. +# 'd_name' must be the source name of the declared entity. +# 'd_displ' must be non-null to indicate that this declaration is to be +# passed to the debug procedure. +# 'ld_cserial' may be a constant serial number (integer), or null. +# If integer then the name of this local exists as a constant in the current +# procedure, which means we include it among the visible variables. +# 'ld_dbg' is non-null if the declaration has been added by this program. + +record c_decl (d_type, d_serial, d_code, d_name, d_displ) +# Holds a constant declaration added by the program. +# Like 'l_decl', except 'd_type' must be +$define D_CONST 2 + +record fmap (fm_ucode, fm_source) +# Holds the mapping between an ucode file name and a source file name. +# 'fm_ucode' must be the root of an ucode file name (string). +# I.e. the file name without the trailing '.u?'. +# 'fm_source' must be the name of the source file from which the ucode +# file originates (string). + +global file_map +# Set containing mapping between ucode and source files (set of record fmap). + +global file_root, uin, uout, ulno +# The current root file name (i.e. file name without '.u?'). +# The current ucode input file. +# The current ucode output file. +# The current line number in the current ucode input file. + +global init_file +# Output file name: init file. + +global msgout +# Message output file. + +global proc_hil +# Table containing the "high label" of each procedure in a ucode file. +# Entry key is a procedure name (string). +# Entry value is the numeric part of the highest existing label before +# debugification (integer). + +global white +# This program's definition of white space. + +# +#-------- Constants -------- +# + +# Version of this program, variable for holding it. +$define PROGRAM_VERSION "$Revision: 2.21 $" +$define PROG_VERSION_VAR "__dbg_itweak_ver" + +# DEBUGGING IDENTIFIERS. +# List holding breakpoints for one source file; two parts. +# The root file name should be spliced in between. +$define DBG_BRKP1 "__dbg_file_" +$define DBG_BRKP2 "_brkp" +# Global variable holding source/ucode file map. +# Note: any change affects 'dbg.icn' as well. +$define DBG_FILE_MAP "__dbg_file_map" +# Procedure for initializing debugging globals. +$define DBG_INIT "__dbg_init" +# Local variable: trapped line number. +$define DBG_LINE "__dbg_line" +# List containing names of interesting local variables. +$define DBG_NAME "__dbg_name" +# Procedure to call on break. +$define DBG_PROC "__dbg_proc" +# Procedure deciding on break. +$define DBG_TEST "__dbg_test" + +# Name of variable whose presence is taken as assurance that an ucode +# file has been tweaked. +$define DBG_SENTINEL DBG_LINE + +# Default file name for writing the debug initialization code. +$define DBG_INIT_FILE "dbg_init.icn" + +# File name for the debugging run-time. +$define DBG_RUN_TIME "dbg_run.u1" + +# Ucode 'codes' (bitfields) for local declarations. +# The values are the octal coded bitfield interpreted as decimal. +$define LD_GLOBAL 0 +$define LD_LOCAL 20 +$define LD_PARM 1000 +$define LD_STATIC 40 + +# Ucode 'codes' (bitfields) for constant declarations. +$define CD_INT 2000 +$define CD_STRING 10000 + +# Various ucode op-codes. +$define OP_CONST "con" +$define OP_DEND "declend" +$define OP_END "end" +$define OP_FILEN "filen" +$define OP_LABEL "lab" +$define OP_LINE "line" +$define OP_LOCAL "local" +$define OP_PROC "proc" + +# Op-codes in the '.u2' file. +$define OP_VERSION "version" +$define OP_LINK "link" +$define OP_GLOBAL "global" + +# Icon versions for which the program has been tested. +$define ICON_VER_LO "U8.10.00" +$define ICON_VER_HI "U9.0.00" + +# Prefix used for labels. +$define ULAB_PREF "L" + +$define NALN -1 +# Not A Line Number. + +$define PROGNAME "itweak" +# The name by which the user knows this program. + +$define U1 ".u1" +$define U2 ".u2" +# Standard ucode file name suffix. + +$define U1TMP ".uA" +$define U2TMP ".uB" +# Suffix of temporary ucode file. + +$define U1OLD ".u1~" +$define U2OLD ".u2~" +# Suffix of renamed, original ucode file. + +# +#-------- Main -------- +# + +procedure main (argv) +local file_names, iout, u2count + # Initialize globals. + file_map := set () + msgout := &errout + white := '\t ' + # Process command line options; leave a list of file names. + if argv[1] == "-o" then { + get (argv) + (init_file := get (argv)) | + confl ("'-o' requires a file name") + } + else + init_file := DBG_INIT_FILE + file_names := copy (argv) + # The number of tweaked '.u2' files. + u2count := 0 + # Do two passes on each file. + every file_root := !file_names do { + # Allow for 'file.u1' and 'file.u'. + file_root := if file_root[-3:0] == ".u1" then + file_root[1:-3] else if file_root[-2:0] == ".u" then + file_root[1:-2] + # Pass 1. + (uin := open (file_root || U1, "r")) | + confl ("Cannot open '%1%2' for input.", file_root, U1) + uout := &null + if pass1 () then { + close (uin) + # Tweak at most one '.u2' file. + if u2count = 0 then { + (uin := open (file_root || U2, "r")) | + confl ("Cannot open '%1%2' for input.", file_root, U2) + (uout := open (file_root || U2TMP, "w")) | + confl ("Cannot open '%1%2' for output.", file_root, + U2TMP) + u2tweak () + close (uin) + close (uout) + u2count +:= 1 + # Make way for the following rename. + remove (file_root || U2OLD) + rename (file_root || U2, file_root || U2OLD) | + confl ("Cannot rename '%1%2' to '%1%3'.", file_root, + U2, U2OLD) + rename (file_root || U2TMP, file_root || U2) | + confl ("Cannot rename '%1%2' to '%1%3'.", file_root, + U2TMP, U2) + } + # Pass 2. + (uin := open (file_root || U1, "r")) | + confl ("Cannot open '%1%2' for input.", file_root, U1) + (uout := open (file_root || U1TMP, "w")) | + confl ("Cannot open '%1%2' for output.", file_root, U1TMP) + pass2 () + close (uin) + close (uout) + # Make way for the following rename. + remove (file_root || U1OLD) + rename (file_root || U1, file_root || U1OLD) | + confl ("Cannot rename '%1%2' to '%1%3'.", file_root, U1, U1OLD) + rename (file_root || U1TMP, file_root || U1) | + confl ("Cannot rename '%1%2' to '%1%3'.", file_root, U1TMP, U1) + } + else { + close (uin) + note ("'%1%2' seems to be tweaked already; left untouched.", + file_root, U1) + } + } + # Write initialization code. + (iout := open (init_file, "w")) | + confl ("Cannot open '%1' for output.", init_file) + cre_init (iout) + note ("Initialization code written to '%1'.", init_file) +end + +# +#-------- Pass 1 procedures -------- +# + +procedure pass1 () +# Performs a first pass over a ucode file, collecting label statistics. +# RETURNS null normally. +# FAILS if the first procedure has a local declaration containing the sentinel +# variable. +# This is taken to imply that the ucode file is already tweaked. +# SIDE EFFECT: Updates glocal 'proc_hil' (max labels per proc). +# Updates 'file_map' (source file name ~ ucode file name). +local cur_high, cur_proc, labint, line, loc, op, proc_no +static fn_instr, lc_decl +initial { + fn_instr := [OP_FILEN, OP_LINE, OP_LABEL] + lc_decl := [OP_LOCAL, OP_CONST, OP_DEND] + } + proc_hil := table () + loc := table () + proc_no := 0 + while op := p1_proclab () do if op[1] == "proc" then { + if \cur_proc then { + (/proc_hil[cur_proc] := cur_high) | + confl ("%1: occurs twice; confusing.", cur_proc) + } + cur_proc := op[2] + cur_high := -1 + + # Special treatment of the first procedure in every file. + if (proc_no +:= 1) = 1 then { + # Borrow some pass 2 code to collect the local declarations. + while (op := p2_upto (lc_decl))[1] == OP_LOCAL do + p2_getlocal (loc, op[2]) + # Look for source file name. + repeat if (op := p2_upto (fn_instr))[1] == OP_FILEN then { + insert (file_map, fmap (file_root, op[2])) + break + } + else if op[1] == OP_LABEL then + cur_high <:= integer (op[2][2:0]) + # Flush buffers. + p2_upto () + # Fail if the sentinel is present. + if \loc[DBG_SENTINEL] then + fail + } + } + else if op[1] == "lab" then { + # ASSUME the label consists of one character followed by an integer. + (labint := integer (op[2][2:0])) | + intern ("pass1: Problem parsing label %1.", image (op[2])) + cur_high <:= labint + } + if \cur_proc then { + (/proc_hil[cur_proc] := cur_high) | + confl ("%1: occurs twice; confusing.", cur_proc) + } + else + intern ("pass1: No proc found.") + return &null +end + +procedure p1_proclab () +# Returns the next ucode line containing a "proc" or "lab" instruction. +# If a matching line is found, RETURNS a two-component list. +# The first element contains the instruction found (string). +# The second element contains the second word on the line. +# FAILS on end-of-file. +local line, opcode, tail +static opchar +initial opchar := &lcase + while line := read (uin) do line ? { + if (opcode := tab (many (opchar))) == ("proc" | "lab") then { + tab (many (white)) + tail := tab (upto (white) | 0) + break + } + } + return [opcode, \tail] +end + +# +#-------- Pass 2 procedures -------- +# + +procedure pass2 () +# Performs a second pass over the ucode file, doing the actual tweaking. +# Writes the new ucode to 'uout'. +local counter, op + counter := 0 + while op := p2_upto ([OP_PROC]) do + p2_proc (trim (op[2]), counter +:= 1) +end + +procedure p2_addbrkp (line, last_lab, dbg_brkp, dbg_label, dbg_line, dbg_test) +# Adds code for breakpoint testing. +# 'line' should be the line number associated with the current ucode 'line' +# instruction. +# 'ltab' must be a table containing declarations of the current procedure. +# 'last_lab' must be the previous highest label serial (integer). +# RETURNS the new highest label serial. + write (uout, + "\tmark\t", ULAB_PREF, last_lab +:= 1, + "\n\tpnull", + "\n\tvar\t", dbg_line, + "\n\tvar\t", dbg_test, + "\n\tvar\t", dbg_brkp, + "\n\tkeywd\tline\n\tinvoke\t2\n\tasgn\n\tgoto\t", dbg_label, + "\n\tunmark\nlab ", ULAB_PREF, last_lab) + return last_lab +end + +procedure p2_addcall (ltab, dbg_label, init_label, end_label, dbg_line, dbg_name, + dbg_proc, pname_decl) +# Adds code for invoking the debug procedure. +local decl, pname_var, vlist + # Make vlist an alphabetically sorted list of identifiers: the names of + # the variables which should be passed to the debugging procedure. + vlist := [] + every \(decl := !ltab).d_displ do + put (vlist, decl.d_name) + vlist := sort (vlist) + # Begin writing the code. + write (uout, + "\tgoto\t", end_label, + "\nlab ", dbg_label, + "\n\tinit\t", init_label, + "\n\tmark\t", init_label, + "\n\tpnull\n\tvar\t", dbg_name, + "\n\tpnull") + every write (uout, "\tstr\t", (ltab[!vlist]).ld_cserial) + pname_var := if pname_decl.d_type = D_LOCAL then + pname_decl.ld_cserial else pname_decl.d_serial + write (uout, + "\tllist\t", *vlist, + "\n\tasgn\n\tunmark\nlab ", init_label, + "\n\tmark0\n\tvar\t", dbg_proc, + "\n\tkeywd\tfile\n\tvar\t", dbg_line, + "\n\tstr\t", pname_var, + "\n\tvar\t", dbg_name) + every write (uout, "\tvar\t", (ltab[!vlist]).d_serial) + write (uout, + "\tinvoke\t", 4 + *vlist, + "\n\tunmark\nlab ", end_label, + "\n\tpfail") +end + +procedure p2_addconst (decl, last_ser) +# Adds a string constant declaration containing the name of a local or constant +# declaration. +# 'decl' must be the declaration (record l_decl or c_decl). +# 'last_ser' must be the previous highest constant serial in this procedure. +# RETURNS the serial of the new constant. +# SIDE EFFECT: Updates 'decl'. +# Writes the new constant to the ucode output file. +# NOTE: This version does not add the name if the declaration is a global and +# is known to be a procedure. +local serial + # Omit variables which have been added by this program. + (decl.d_type = D_CONST) | (/decl.ld_dbg & decl.d_code ~= LD_GLOBAL) | + fail + (decl.d_type = D_CONST) | (decl.d_displ := 1) + serial := last_ser + 1 + if decl.d_type = D_LOCAL then + decl.ld_cserial := serial + else + decl.d_serial := serial + writes (uout, "\tcon\t", serial, ",", + right (CD_STRING, 6, "0"), ",", *decl.d_name) + every writes (uout, ",", octal (ord (!decl.d_name))) + write (uout) + return serial +end + +procedure p2_addinit (ltab, init_label) + write (uout, + "\tinit\t", init_label, + "\n\tmark\t", init_label, + "\n\tvar\t", ltab[DBG_INIT].d_serial, + "\n\tinvoke\t0\n\tunmark\nlab ", init_label) +end + +procedure p2_addlocal (pname, ltab, serial, code, name, dbg) +# Adds a local declaration to a table. +# 'pname' must be the current procedure name. +# 'ltab' must be the table where the new declaration is stored. +# See 'p2_getlocal' for details. +# 'serial' must be the serial to assign to the new declaration. +# 'code' must be the code, +# 'name' must be the name of the new declaration. +# 'dbg' may be non-null to indicate something different from a normal variable +# declaration. +# RETURNS the new declaration (record l_decl). +# SIDE EFFECT: Writes code for the new declaration to the ucode output file. +# Creates a new entry in 'ltab'. +local decl, old_d + # Check if the declaration already is there. + if old_d := \ltab[name] then { + # Check that the existing declaration is equivalent to the new. + (old_d.d_code = code) | + confl ("%1: conflicting declarations in procedure %2.", name, pname) + return old_d + } + decl := l_decl (D_LOCAL) + decl.d_serial := serial + decl.d_code := code + decl.ld_dbg := 1 + ltab[decl.d_name := name] := decl + write (uout, "\tlocal\t", serial, ",", right (code, 6, "0"), ",", name) + return decl +end + +procedure p2_brkp () +# Scans the ucode input file for the next breakpoint location. +# Ucode 'line' instructions are considered suitable breakpoint locations. +# If there are several 'line' instructions with the same line number only the +# last one is considered suitable. +# If a location is found, RETURNS the line number of the current location. +# FAILS if no suitable location is found. +# This means that an 'end' instruction has been reached +# When the procedure returns the 'line' instruction has been copied to the ucode +# output file. +# When the procedure encounters an 'end' instruction this instruction is not +# copied to the ucode output file. +local last_lno, line, opcode +static cur_lno, opchar +initial { + cur_lno := NALN + opchar := &lcase ++ '01' + } + repeat { + # Read and copy until the next 'line' or 'end' instruction is found. + repeat { + (line := read (uin)) | + intern ("p2_brkp: unexpected end of file.") + line ? if tab (many (white)) & + (opcode := tab (many (opchar))) then { + (opcode ~== OP_END) | { + last_lno := NALN + break + } + write (uout, line) + (opcode ~== OP_LINE) | { + last_lno := integer (tab (0)) + break + } + } + else + write (uout, line) + } + if last_lno = NALN then + break + else case cur_lno of { + # Still the same line, try another one. + last_lno: next # a little unstructured ... + # First line found. + NALN: cur_lno := last_lno + # OK, this is it, stop here. + default: break + } + } + if last_lno = NALN then + fail + else + return cur_lno :=: last_lno +end + +procedure p2_getlocal (ltab, dstring) +# Gets a local declaration from ucode representation; adds it to a table. +# 'ltab' must be a table storing declarations. +# Entry key is the variable name. +# Entry value is an 'l_decl' record. +# 'dstring' must be the ucode string defining the local. +# RETURNS the serial number of the new declaration. +# SIDE EFFECT: Adds an entry to 'ltab'. +local decl + decl := l_decl (D_LOCAL) + dstring ? { + decl.d_serial := integer (tab (many (&digits))) + ="," + decl.d_code := integer (tab (many (&digits))) + ="," + decl.d_name := tab (upto (white) | 0) + } + ltab[decl.d_name] := decl + return decl.d_serial +end + +procedure p2_newlocals (pname, ltab, last_ser, main_flag) +# Adds debugging local declarations to a procedure. +# 'pname' must be the procedure name (string). +# 'ltab' must be a table holding local declarations; see 'p2_getlocal'. +# 'last_ser' must be the last (highest) serial previously assigned. +# 'main_flag' must be non-null if the current procedure is 'main'. +# This will add the DBG_INIT procedure. +# RETURNS the last local declaration serial. +# SIDE EFFECT: Writes the new declarations to the ucode output file. +# Adds the new declarations to 'ltab'. + # Add the debugging init procedure if this is 'main'. + /main_flag | + p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL, DBG_INIT) + p2_addlocal (pname, ltab, last_ser +:= 1, LD_LOCAL, DBG_LINE) + p2_addlocal (pname, ltab, last_ser +:= 1, LD_STATIC, DBG_NAME) + p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL, DBG_PROC) + p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL, DBG_TEST) + p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL, + make_brkp_idf (file_root)) + return last_ser +end + +procedure p2_proc (pname) +# Tweaks the ucode of a single procedure. +# 'pname' must be the name of the procedure. +# SIDE EFFECT: Writes tweaked ucode to the ucode output file. +local dbg_brkp, dbg_label, dbg_line, dbg_name, dbg_proc, dbg_test +local init_label, end_label, pname_decl +local loc, first_new_const, last_conser, last_label, last_locser, line +local main_flag, op +static con_decl, lc_decl +initial { + # This is just a piece of hand optimization. + con_decl := [OP_CONST, OP_DEND] + lc_decl := [OP_LOCAL, OP_CONST, OP_DEND] + } + main_flag := pname == "main" + # Go through local declarations; add some new. + # See 'p2_getlocal' for documentation of the 'loc' table. + loc := table () + last_locser := -1 + while (op := p2_upto (lc_decl))[1] == OP_LOCAL do { + last_locser <:= p2_getlocal (loc, op[2]) + } + # Add our own locals, write them to the ucode output file. + last_locser := p2_newlocals (pname, loc, last_locser, main_flag) + # Go through constant declarations in order to find the maximum serial. + last_conser := -1 + repeat { + if op[1] == OP_CONST then + last_conser <:= (op[2] ? integer (tab (many (&digits)))) + else + break + (op := p2_upto (con_decl)) | break + } + # Declare a constant for the procedure name. + # Note that the procedure name may be hidden by a local! + /loc[pname] := c_decl (D_CONST, , CD_STRING, pname) + # Add new constant declarations to the ucode file. + first_new_const := last_conser + 1 + every last_conser := p2_addconst (!loc, last_conser) + # We will soon need a new label. + last_label := proc_hil[pname] + # Flush the 'p2_upto' buffer, normally the 'declend' instruction. + p2_upto () + # If this is the 'main' procedure insert code for invoking the + # initialization procedure. + if \main_flag then + p2_addinit (loc, ULAB_PREF || (last_label +:= 1)) + # Insert breakpoint testing code. + dbg_brkp := loc[make_brkp_idf (file_root)].d_serial + dbg_label := ULAB_PREF || (last_label +:= 1) + dbg_line := loc[DBG_LINE].d_serial + dbg_test := loc[DBG_TEST].d_serial + while last_label := p2_addbrkp (p2_brkp (), last_label, + dbg_brkp, dbg_label, dbg_line, dbg_test) + # Write the debug invocation code. + init_label := ULAB_PREF || (last_label +:= 1) + end_label := ULAB_PREF || (last_label +:= 1) + dbg_name := loc[DBG_NAME].d_serial + dbg_proc := loc[DBG_PROC].d_serial + pname_decl := loc[pname] + p2_addcall (loc, dbg_label, init_label, end_label, dbg_line, dbg_name, + dbg_proc, pname_decl) + # Add an 'end' instruction swallowed by 'p2_brkp'. + write (uout, "\t", OP_END) +end + +procedure p2_upto (op) +# Scans the ucode file, looking for the next line containing an interesting +# op-code. +# Copies non-matching lines to the new ucode file (if non-null) +# 'op' must be a list of the interesting op-code(s), or null. +# If a matching line is found, RETURNS a list of two elements. +# The first element contains the op-code, the second element the tail of the +# instruction (excluding any leading white space). +# FAILS on end-of-file. +# FLUSHING THE BUFFER: +# If the procedure is invoked with null 'op' any uncopied lines are written to +# the ucode output file; the procedure fails. +# NOTE: The procedure is used occasionally in pass 1, where there is no 'uout' +# file. +# This is the reason 'uout' is checked for existence (otherwise ucode will +# appear on standard output). +local opcode, tail +static new_line, opchar, old_line +initial opchar := &lcase ++ '01' + write (\uout, \new_line) + new_line := &null + \op | fail + repeat { + old_line := new_line + (new_line := read (uin)) | fail + new_line ? { + tab (many (white)) + if (opcode := tab (many (opchar))) == !op then { + tab (many (white)) + tail := tab (0) + break + } + else + write (\uout, new_line) + } + } + return [opcode, tail] +end + +# +#-------- '.u2' tweaking ----------- +# + +procedure u2tweak () +# Tweaks a '.u2' file, which means: +# Check the Icon version number; +# insert 'link' commands to the debugging run-time and to the init procedure. +local hitcount, op + (op := p2_upto ([OP_VERSION])) | { + note ("Surprising absence of 'version' in .u2 file...") + fail + } + (ICON_VER_LO <<= op[2] <<= ICON_VER_HI) | + note ("WARNING: %1 is tested only for Icon versions '%2'-'%3', found '%4'.", + PROGNAME, ICON_VER_LO, ICON_VER_HI, op[2]) + hitcount := 0 + while (op := p2_upto ([OP_LINK, OP_GLOBAL]))[1] == OP_LINK do + if op[2] == DBG_RUN_TIME then + hitcount +:= 1 + if hitcount = 0 then { + write (uout, OP_LINK, "\t", DBG_RUN_TIME) + write (uout, OP_LINK, "\t", init_file) + } + p2_upto () + while write (uout, read (uin)) +end + +# +#-------- General message handling and other utilities -------- +# + +procedure confl (msg, parm[]) +# Writes a conflict message and stops the program with nonzero exit code. + message ("[CONFLICT] ", subst (msg, parm)) + message ("*** ", PROGNAME, " stops with failure.") + stop () +end + +procedure cre_init (f) +# Creates initialization code. +# 'f' must be a file open for output. +local map, version + version := (PROGRAM_VERSION ? (tab (upto (&digits)), + tab (many (&digits++'.')))) + every write (f, "global ", (PROG_VERSION_VAR | DBG_TEST | DBG_FILE_MAP)) + every write (f, "global ", make_brkp_idf ((!file_map).fm_ucode)) + write (f, + "\nprocedure ", DBG_INIT, " ()\n\t", + PROG_VERSION_VAR, " := \"", version, "\"\n\t", + DBG_TEST, " := member") + every write (f, + "\t", make_brkp_idf ((!file_map).fm_ucode), " := set ()") + write (f, "\t", DBG_FILE_MAP, " := table ()") + every map := !file_map do + write (f, "\t", + DBG_FILE_MAP, "[\"", map.fm_source, "\"] := ", + make_brkp_idf (map.fm_ucode)) + write (f, "\t", DBG_PROC, " ()\nend") +end + +procedure fld_adj (str) +# Part of 'subst' format string parsing. +# 'str' must be a parameter string identified by the beginning part of a +# placeholder ('%n'). +# This procedure checks if the placeholder contains a fixed field width +# specifier. +# A fixed field specifier begins with '<' or '<' and continues with the field +# width expressed as a decimal literal. +# RETURNS 'str' possibly inserted in a fixed width field. +local just, init_p, res, wid +static fwf +initial fwf := '<>' + init_p := &pos + if (just := if ="<" then left else if =">" then right) & + (wid := integer (tab (many (&digits)))) then + res := just (str, wid) + else { + res := str + &pos := init_p + } + return res +end + +procedure intern (msg, parm[]) +# Writes an internal conflict message and stops the program with nonzero exit +# code. + message ("*** INTERNAL: ", subst (msg, parm)) + message ("*** ", PROGNAME, " stops with failure.") + stop () +end + +procedure make_brkp_idf (ucode_root) +# RETURNS an identifier which should be used to hold the breakpoints of an +# ucode file whose root name is 'ucode_root'. + return DBG_BRKP1 || ucode_root || DBG_BRKP2 +end + +procedure message (parm[]) +# Writes any number of strings to the message file. + every writes (msgout, !parm) + write (msgout) +end + +procedure note (msg, parm[]) +# Writes a note message. + message ("[NOTE] ", subst (msg, parm)) +end + +procedure octal (i) +# RETURNS the 'i' integer in the form of an octal literal. + static digits + local s, d + initial digits := string (&digits) + if i = 0 then return "0" + s := "" + while i > 0 do { + d := i % 8 + if d > 9 then d := digits[d + 1] + s := d || s + i /:= 8 + } + return s +end + +procedure subst (msg, parm) +# Substitutes parameters in a message template. +# 'msg' must be a message template (string). +# 'parm' must be a list of parameters (list of string-convertible), or null. +# It may also be a string. +local esc, res, sub +static p_digit +initial p_digit := '123456789' + \parm | return msg + parm := [string (parm)] + res := "" + msg ? until pos (0) do { + res ||:= tab (upto ('%\\') | 0) + if ="%" then res ||:= { + if any (p_digit) then { + sub := (\parm[integer (move (1))] | "") + fld_adj (sub) + } + else if any ('%') then + move (1) + else "" + } + else if ="\\" then res ||:= case esc := move (1) of { + "n": "\n" + "t": "\t" + default: esc + } + } + return res +end |