home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.cs.arizona.edu
/
ftp.cs.arizona.edu.tar
/
ftp.cs.arizona.edu
/
icon
/
historic
/
v941.tgz
/
icon.v941src.tar
/
icon.v941src
/
ipl
/
packs
/
itweak
/
itweak.icn
< prev
next >
Wrap
Text File
|
2000-07-29
|
26KB
|
831 lines
############################################################################
#
# 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