############################################################################
#
#	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