path: root/ipl/packs/itweak/dbg_run.icn

############################################################################
#
#	File:     dbg_run.icn
#
#	Subject:  Icon interactive debugging.
#		  Contains an interactive debugging run-time system.
#
#	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.
#
###########################################################################
#
# General note: all names are prefixed in an elaborate way in order to
# avoid name collisions with the debugged program.
# The default prefix for all globally visible names is '__dbg_'.
#
# This is the reason why lists are frequently used instead of records
# (whose field names clutter the global name space).
#
###########################################################################

#
#-------- Constants --------
#

# Versions (this program and 'itweak').
$define PROGRAM_VERSION	"$Revision: 2.21 $"

# Components of a breakpoint descriptor (list).
# Breakpoint id (integer).
$define BRKP_ID		1
# Source file (string).
$define BRKP_FILE	2
# File index.
$define BRKP_FIDX	3
# First line number.
$define BRKP_LINE1	4
# Second line number.
$define BRKP_LINE2	5
# Ignore counter (integer).
$define BRKP_IGNORE	6
# Condition for breaking.
$define BRKP_COND	7
# Commands to perform on break.
$define BRKP_DO		8

# Constants for 'the current breakpoint' and 'the last breakpoint'.
$define BRKP_CURRENT	-1
$define BRKP_LAST	-2

# Keywords for the 'clear' command.
# Definitions must match list in compilation procedure.
$define CLEAR_BREAKPOINT	1
$define CLEAR_COND		2
$define CLEAR_DO		3
$define CLEAR_ECHO		4
$define CLEAR_MACRO		5

# Keywords for the 'info' command.
# Definitions must match list in compilation procedure.
$define INFO_BREAKPOINT		1
$define INFO_ECHO		2
$define INFO_FILES		3
$define INFO_GLOBALS		4
$define INFO_LOCALS		5
$define INFO_MACROS		6
$define INFO_TRACE		7
$define INFO_VERSION		8

# Keywords for the 'set' command.
# Definitions must match list in compilation procedure.
$define SET_ECHO		1
$define SET_PRELUDE		2
$define SET_POSTLUDE		3

# Components of a command definition (list).
# Used for built-in commands as well as user-defined macros.
# Unabbreviated command/macro name (string).
$define CMD_NAME	1
# Command code (an integer corresponding to the name).
$define CMD_CODE	2
# Help text (list of string).
$define CMD_HELP	3
# Compilation procedure; null if macro.
$define CMD_COMPILE	4
# Macro definition (list of command instances, list of list).
# Null if built-in command.
$define CMD_MACRO	5
# Executing procedure, if built-in. Null otherwise.
$define CMD_EXEC	6

# Command codes.
$define BREAK_CMD	1
$define CLEAR_CMD	2
$define COMMENT_CMD	3
$define CONDITION_CMD	4
$define DO_CMD		5
$define END_CMD		6
$define EPRINT_CMD	7
$define FAIL_CMD	8
$define FPRINT_CMD	9
$define FRAME_CMD	10
$define GOON_CMD	11
$define HELP_CMD	12
$define INFO_CMD	13
$define IGNORE_CMD	14
$define MACRO_CMD	15
$define NEXT_CMD	16
$define PRINT_CMD	17
$define SET_CMD		18
$define SOURCE_CMD	19
$define STOP_CMD	20
$define TRACE_CMD	21
$define WHERE_CMD	22
$define USERDEF_CMD	23

# Environment variable for defining the input file (must be a string value).
$define DBG_INPUT_ENV	"DBG_INPUT"

# Environment variable for defining the primary output file
# (must be a string value).
$define DBG_OUTPUT_ENV	"DBG_OUTPUT"

# Prefix for debugging run-time global names.
$define DBG_PREFIX	"__dbg_"

# Maximum source nesting levels.
$define MAX_SOURCE_NESTING	12

# File index is obtained by shifting a small integer left a number of
# positions.
$define FIDX_SHIFT	10

# Prompt string to use in initialization mode.
$define INIT_PROMPT	"debug init $ "

# Execution return status.
# Normal return.
$define OK_STATUS	0
# Break the command loop, resume execution.
$define RESUME_STATUS	1
# Break the command loop, terminate the session.
$define STOP_STATUS	2
# Break the command loop, make the current procedure fail.
$define FAIL_STATUS	3

# Index into '__dbg_g_where'.
$define WHERE_FILE	1
$define WHERE_LINE	2
$define WHERE_PROC	3
$define WHERE_BRKP	4
$define WHERE_PRELUDE	5
$define WHERE_POSTLUDE	6

#
#-------- Record types --------
#

#
#-------- Globals --------
#

global __dbg_default_prelude, __dbg_default_postlude
# The source text for the default pre/postlude (single command assumed).

global __dbg_g_automacro
# The 'prelude' and 'postlude' macros.
# List of two components:
# (1) prelude commands,
# (2) postlude commands.
# Both are lists of compiled commands, not complete macros.

global __dbg_g_brkpcnt
# Counter incremented each break.
# Used to identify the file written by 'display' which is used by several
# commands.
# In this way we can check if we have to write the file anew.

global __dbg_g_brkpdef
# Lookup table for breakpoints.
# Entry key is a breakpoint id (integer).
# Entry value is a breakpoint descriptor (list).

global __dbg_g_brlookup
# Lookup table for breakpoints.
# Entry key is a file index or'ed with a line number (integer).
# Entry value is a breakpoint descriptor (list).

global __dbg_g_brkpid
# Id of the latest breakpoint created (integer).

global __dbg_g_cmd
# Table of command and macro definitions.
# Entry key is an unabbreviated command/macro name.
# Entry value is a command descriptor (list).

global __dbg_g_display
# Name of temporary file used by '__dbg_x_opendisplay' and others.

global __dbg_g_fileidx
# Table mapping source file names on (large) integers.
# Entry key is a source file name (string).
# Entry value is a file index (integer).

global __dbg_g_in
# The file through which debugging input is taken.

global __dbg_g_level
# Value of &level for the interrupted procedure.
# Calculated as &level for the breakpoint procedure - 1.

global __dbg_g_local
# Table containing local variables.
# Entry key is variable name (string).
# Entry value is the value of the variable (any type).

global __dbg_g_out1
# Primary file for debugging output.

global __dbg_g_out2, __dbg_g_out2name
# Secondary file for debugging output; used for 'set echo'.
# Null when no echoing is not active.
# The name of this file.

global  __dbg_g_src
# Stack of input files used by the 'source' command (list of file).
# Empty list when no 'source' command is active.

global __dbg_g_trace
# Current trace level (passed to &trace when resuming execution).

global __dbg_g_where
# A list with data about the current breakpoint.
# Contents (symbolic names below):
# (1) Source file name (string).
# (2) Source line number (integer).
# (3) Procedure name (string).
# (4) The breakpoint causing this break (breakpoint descriptor, a list).

global __dbg_g_white
# This program's definition of white space.

# A note on the use of global '__dbg_test' (defined in 'dbg_init.icn').
# The runtime system assigns this variable one of the following values.
# ** Function 'member' for ordinary testing against the breakpoint sets.
# ** Function 'integer' (which is guaranteed to always fail, given a
# set as its first parameter) in the 'nobreak' mode; execution continues
# without break until the program completes.
# ** Integer '2' which causes a break at every intercept point.
# (Returns the second parameter which is the line number.)

#
#-------- Globals for Icon functions used by the debuggin runtime --------
# In an excruciating effort to avoid being hit by bad manners from the
# program under test we use our own variables for Icon functions.

global __dbg_fany, __dbg_fclose, __dbg_fdelete, __dbg_fexit, __dbg_ffind
global __dbg_fgetenv, __dbg_fimage, __dbg_finsert, __dbg_finteger, __dbg_fior
global __dbg_fishift, __dbg_fkey, __dbg_fmany, __dbg_fmatch
global __dbg_fmove, __dbg_fpop, __dbg_fpos, __dbg_fproc, __dbg_fpush
global __dbg_fput, __dbg_fread, __dbg_fremove, __dbg_freverse, __dbg_fright
global __dbg_fsort, __dbg_fstring, __dbg_ftab, __dbg_ftable, __dbg_ftrim
global __dbg_ftype, __dbg_fupto, __dbg_fwrite, __dbg_fwrites

#
#-------------- Expression management globals -----------		
#

global __dbg_ge_message
# Holds message if there is a conflict in expression compilation or
# evaluation

global __dbg_ge_singular
# Value used as default for the local variable table.
# Must be initialized to an empty list (or other suitable value).

#
#-------- Main --------
#

procedure __dbg_proc (file, line, proc_name, var_name, var_val[])
# This procedure is invoked a first time during initialization with parameters
# all null.
# Then it is called every time we hit a breakpoint during a debugging session.
# The parameters define the breakpoint, as follows,
# 'file': source file name (string).
# 'line': source line number (integer).
# 'proc_name': name of the current procedure (string).
# 'var_name': names of variables local to the current procedure
# (list of string).
# The list is sorted alphabetically.
# 'Local' variables include parameters and static variables.
# 'var_val': The current values of the local variables (list).
# The values occur in the same order as the names in 'var_name'.
# NOTE: In order not to affect the logic of the debugged program this
# procedure MUST FAIL.
# If it returns anything the current procedure will fail immediately.
local bdescr, cond, cmd, idx, tfname
	# Save trace level; turn tracing off.
	__dbg_g_trace := &trace
	&trace := 0

	if \file then { # Not the first-time invocation from "dbg_init".
		# Increment the global breakpoint counter.
		__dbg_g_brkpcnt +:= 1

		# Compute the procedure nesting level.
		__dbg_g_level := &level - 1

		# Begin setting up the 'where' structure.
		__dbg_g_where := [file, line, proc_name, &null]

		# We get here either because of a 'next', or because we hit a
		# breakpoint.
		# If we break because of a 'next' we should not treat this as
		# a breakpoint, even if there is one on this source line.
		if __dbg_test === member then {
			# This is a breakpoint; get it.
			if bdescr := __dbg_g_brlookup[__dbg_fior (__dbg_g_fileidx[file],
						line)] then {
				# Check ignore count.
				((bdescr[BRKP_IGNORE] -:= 1) = -1) | fail
				bdescr[BRKP_IGNORE] := 0
				}
			else
				__dbg_io_cfl ("Mysterious break: %1 (%2:%3).",
					proc_name, file, line)
			}
		else {  # Break caused by 'next'.
			# By convention treated as breakpoint number 0.
			bdescr := __dbg_g_brkpdef[0]
			# Check ignore count.
			((bdescr[BRKP_IGNORE] -:= 1) = -1) | fail
			bdescr[BRKP_IGNORE] := 0
			}
		__dbg_g_where[WHERE_BRKP] := bdescr

		# Create table of locals.
		__dbg_g_local := __dbg_ftable (__dbg_ge_singular)
		every idx := 1 to *var_name do
			__dbg_g_local[var_name[idx]] := var_val[idx]

		# Evaluate the condition of the breakpoint, if any.
		if cond := \(bdescr)[BRKP_COND] then {
			idx := 0
			__dbg_e_eval (cond[1]) & (idx +:= 1)
			# Check for conflict.
			# Make sure we don't resume in such case.
			__dbg_io_cfl ("[%1] condition '%2'\n   %3",
				bdescr[BRKP_ID], cond[2], \__dbg_ge_message) &
				(idx +:= 1)
			(idx > 0) | fail
			}

		# Reset the test procedure (effective if this is a 'next' break).
		__dbg_test := member

		# The first command to execute is the macro attached to the
		# breakpoint, if any; otherwise the prelude.
		cmd := (\(\bdescr)[BRKP_DO] | __dbg_g_automacro[1])
		}
	else {	# Initialize global variables for Icon functions.
		__dbg_func_init ()
		# Initialize breakpoint globals.
		__dbg_g_brkpcnt := 0
		__dbg_g_brkpdef := __dbg_ftable ()
		__dbg_g_brlookup := __dbg_ftable ()
		__dbg_g_brkpid := 0

		# Compute the procedure nesting level.
		__dbg_g_level := &level - 2

		# Create breakpoint number 0, used for 'next' breaks.
		__dbg_g_brkpdef[0] := [0, "*any*", 0, 0, 0, 0, , ]

		# Display file name.
		__dbg_g_display := "_DBG" || &clock[4:6] || &clock[7:0] || ".tmp"

		# More globals.
		__dbg_g_src := []
		__dbg_g_white := ' \t'
		__dbg_ge_singular := []

		# Create file index table.
		idx := -1
		__dbg_g_fileidx := __dbg_ftable ()
		every __dbg_g_fileidx[key(__dbg_file_map)] :=
			__dbg_fishift ((idx +:= 1), FIDX_SHIFT)

		# Open input and output files.
		if tfname := __dbg_fgetenv (DBG_INPUT_ENV) then
			__dbg_g_in := __dbg_x_openfile (tfname)
		(/__dbg_g_in := &input) | __dbg_fpush (__dbg_g_src, &input)

		if tfname := __dbg_fgetenv (DBG_OUTPUT_ENV) then
			__dbg_g_out1 := __dbg_x_openfile (tfname, 1)
		/__dbg_g_out1 := &errout

		# Initialize command definitions.
		__dbg_cmd_init ()

		# Set up the breakpoint data structure.
		# This is not a breakpoint; the following keeps some commands from
		# crashing.
		__dbg_g_local := __dbg_ftable ()
		__dbg_g_where := [&null, 0, "main", &null]
		__dbg_default_prelude :=
		"fprint \"[%1] %2 (%3:%4)\\n\";&bp;&proc;&file;&line"
		__dbg_default_postlude := ""
		__dbg_g_automacro := [[__dbg_c_compile (__dbg_default_prelude)],
			[]]
		cmd := []
		}

	# Command processing.
	repeat {
		case __dbg_c_interp (cmd) of {
		RESUME_STATUS: break
		STOP_STATUS: {
			__dbg_fremove (__dbg_g_display)
			__dbg_io_note ("Debug session terminates.")
			__dbg_fexit (0)
			}
		}
		# Get input until it compiles OK.
		repeat {
			(*__dbg_g_src > 0) | __dbg_fwrites ("$ ")
			if cmd := [__dbg_c_compile (__dbg_io_getline ())] then
				break
			}
		}
	# Run the postlude, if any; status discarded.
	__dbg_c_interp (__dbg_g_automacro[2])
	&trace := __dbg_g_trace
end

#
#-------- Command processing procedures --------
#

procedure __dbg_c_compile (str, macro_def)
# Compiles a command.
# 'str' must be a command to compile (string).
# 'macro_def' must be non-null to indicate a macro is being defined.
# RETURNS a command instance (list), or
# FAILS on conflict.
local cmd, keywd
	str ? {
		__dbg_ftab (__dbg_fmany (__dbg_g_white))
		keywd := __dbg_ftab (__dbg_fupto (__dbg_g_white) | 0)
		if *keywd = 0 then # empty line treated as comment
			return [__dbg_cx_NOOP, COMMENT_CMD]
		__dbg_ftab (__dbg_fmany (__dbg_g_white))
		(cmd := __dbg_c_findcmd (keywd)) | fail
		return cmd[CMD_COMPILE] (cmd, macro_def)
		}
end

procedure __dbg_c_brkpt (not_zero)
# Extracts a breakpoint id from a command.
# A breakpoint id is either an integer, or one of the special forms
# '.' (current), '$' (last defined).
# 'not_zero' may be non-null to indicate that breakpoint number zero
# is not accepted.
# RETURNS a breakpoint identifier (integer) on success;
# FAILS with a suitable conflict message otherwise.
local id, res
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	(res := (__dbg_finteger (__dbg_ftab (__dbg_fmany (&digits))) |
		2(id := =".", BRKP_CURRENT) |
		2(id := ="$", BRKP_LAST))) | {
		__dbg_io_cfl ("Breakpoint id (integer, '.', '$') expected.")
		fail
		}
	(res > 0) | /not_zero | {
		__dbg_io_cfl ("Breakpoint number 0 not accepted here.")
		fail
		}
	return res
end

procedure __dbg_c_interp (clist)
# Command interpreter.
# 'clist' must be a list of command instances.
# The interpreter may call itself indirectly through commands.
# RETURNS a status code, or
# FAILS on conflict, abandoning its command list.
local cmd, code
	every cmd := !clist do {
		(code := cmd[1]!cmd) | fail
		(code = OK_STATUS) | return code
		}
	return OK_STATUS
end

procedure __dbg_c_findcmd (keywd)
# Finds a command descriptor given a keyword.
# 'keywd' must be a command keyword candidate, possibly abbreviated (string).
# RETURNS a command definition, or
# FAILS with a message on conflict.
local count, cmd, mstr, sep, try
	count := 0
	sep := mstr := ""
	every __dbg_fmatch (keywd, (try := !__dbg_g_cmd)[CMD_NAME], 1, 0) do {
		cmd := try
		count +:= 1
		mstr ||:= sep || cmd[CMD_NAME]
		sep := ", "
		}
	case count of {
	0: {
		__dbg_io_cfl ("%1: unrecognized command.", keywd)
		fail
		}
	1: return cmd
	default : {
		__dbg_io_cfl ("'%1': ambiguous (matches %2).", keywd, mstr)
		fail
		}
	}
end

procedure __dbg_c_findkey (keywd, keylist)
# Finds a command descriptor given a keyword.
# 'keywd' must be a keyword candidate, possibly abbreviated (string).
# 'keylist' must be a list of available keywords.
# RETURNS an integer index into 'keylist', or
# FAILS with a message on conflict.
local count, cmd, idx, mstr, sep
	count := 0
	sep := mstr := ""
	every __dbg_fmatch (keywd, keylist[idx := 1 to *keylist], 1, 0) do {
		count +:= 1
		mstr ||:= sep || keylist[cmd := idx]
		sep := ", "
		}
	case count of {
	0: {
		__dbg_io_cfl ("%1: unrecognized keyword.", keywd)
		fail
		}
	1: return cmd
	default : {
		__dbg_io_cfl ("'%1': ambiguous (matches %2).", keywd, mstr)
		fail
		}
	}
end

procedure __dbg_c_mcompile (fname)
# Compiles a macro.
# 'fname' must contain a file name (string) if the macro definition should
# be read from a file; otherwise null.
# If 'fname' is defined and can be opened, a null value is pushed on the file
# stack before the file, as a mark.
# RETURNS a macro, i.e. a list of compiled commands -- on success.
# FAILS if a conflict arises during the macro definition.
local cfl_count, cmd, f, line, macro
	cfl_count := 0
	macro := []
	if \fname then {
		if f := __dbg_x_openfile (fname) then {
			__dbg_fpush (__dbg_g_src, __dbg_g_in)
			__dbg_fpush (__dbg_g_src, &null)
			__dbg_g_in := f
			}
		else
			fail
		}
	repeat {
		(*__dbg_g_src > 0) | __dbg_fwrites ("> ")
		(line := __dbg_io_getline ()) | break
		if cmd := __dbg_c_compile (line, 1) then {
			if cmd[CMD_CODE] = END_CMD then
				break
			else
				__dbg_fput (macro, cmd)
			}
		 else
			cfl_count +:= 1
		(cfl_count < 30) | break
		}
	/__dbg_g_in := __dbg_fpop (__dbg_g_src)
	if cfl_count = 0 then
		return macro
	else {
		__dbg_io_note ("The definition did not take effect.")
		fail
		}
end

procedure __dbg_c_msource ()
# Checks if the source of a macro is a file.
# RETURNS a file name if there is a '<' followed by a file name.
# RETURNS null if there is nothing but white space.
# FAILS with a message on conflict.
local fname
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	if ="<" then {
		__dbg_ftab (__dbg_fmany (__dbg_g_white))
		if __dbg_fpos (0) then {
			__dbg_io_cfl ("File name expected.")
			fail
			}
		fname := __dbg_ftrim (__dbg_ftab (0))
		}
	return fname
end

procedure __dbg_x_brkpt (id)
# RETURNS a breakpoint descriptor, given a breakpoint id ('id', integer).
# FAILS with a diagnostic message on conflict.
local bdescr
	bdescr := case id of {
	BRKP_CURRENT:	\__dbg_g_where[WHERE_BRKP] |
			(__dbg_io_cfl ("No current breakpoint."), &null)
	BRKP_LAST:	\__dbg_g_brkpdef[__dbg_g_brkpid] |
		(__dbg_io_cfl ("Breakpoint [%1] undefined.", __dbg_g_brkpid),
			&null)
	default:	\__dbg_g_brkpdef[id] |
			(__dbg_io_cfl ("Breakpoint [%1] undefined.", id), &null)
	}
	return \bdescr
end

procedure __dbg_x_dispglob (f, pat)
# Essentially performs the 'info globals' command.
# 'f' must be a display file open for input.
# 'pat' must be a substring that variable names must contain.
local fchanged, line, word
static func
initial {
	func := set ()
	# A set containing all function names.
	every insert (func, function ())
	}
	fchanged := []
	until __dbg_fread (f) == "global identifiers:"
	repeat {
		(line := __dbg_fread (f)) | break
		word := []
		line ? repeat {
			__dbg_ftab (__dbg_fmany (__dbg_g_white))
			if __dbg_fpos (0) then
				break
			__dbg_fput (word, __dbg_ftab (__dbg_fupto (__dbg_g_white) | 0))
			}
		__dbg_fmatch (DBG_PREFIX, word[1]) | (word[1] == word[-1]) |
		if __dbg_ffind (pat, word[1]) then
			__dbg_io_info ("%1", word[1])

		# Check if function name has been used for other things.
		if member (func, word[1]) then {
			(word[-2] == "function" & word[-1] == word[1]) |
			put (fchanged, word[1])
			}
		}
	if *fchanged > 0 then {
		__dbg_io_note ("The following global(s) no longer hold their usual Icon functions:")
		every __dbg_io_wrline ("  " || !fchanged)
		}
end

procedure __dbg_x_dispinit (f)
# Reads the display file, skipping over lines caused by the debugger.
# 'f' must be the display file, open for input.
# RETURNS the first 'significant' line.
# NOTE that you must take care of the 'co-expression' line before calling
# this procedure.
local line
	until __dbg_fmatch (DBG_PREFIX, line := __dbg_fread (f))
	while line[1] == " " | __dbg_fmatch (DBG_PREFIX, line) do
		line := __dbg_fread (f)
	return line
end

procedure __dbg_x_lbreak (bdescr)
# Lists the nominal definition of a breakpoint.
# 'bdescr' may be a breakpoint descriptor, or null.
# If null all breakpoints are listed.
local bd, blist, cond, dodef, tmplist
	(blist := [\bdescr]) | {
		tmplist := __dbg_fsort (__dbg_g_brkpdef)
		blist := []
		every __dbg_fput (blist, (!tmplist)[2])
		}
	every bd := !blist do {
		dodef := if \bd[BRKP_DO] then "  DO defined" else ""
		__dbg_io_info ("[%1] %2 %3:%4%5", bd[BRKP_ID], bd[BRKP_FILE],
			bd[BRKP_LINE1], bd[BRKP_LINE2], dodef)
		if cond := \bd[BRKP_COND] then
			__dbg_io_info ("   CONDITION: %1", cond[2])
		}
end

procedure __dbg_x_openfile (fname, output, quiet)
# Opens a file.
# 'fname' must be the name of the file to open.
# 'output' must be non-null if the file is to be opened for output.
# 'quiet' must be non-null to prevent a conflict from generating a message.
# RETURNS an open file on success;
# FAILS with a message otherwise, unless 'quiet' is set.
# FAILS silently if 'quiet' is set.
local f, mode, modestr
	if \output then {
		mode := "w"
		modestr := "output"
		}
	else {
		mode := "r"
		modestr := "input"
		}
	(f := open (fname, mode)) | (\quiet & fail) |
	__dbg_io_cfl ("Cannot open '%1' for %2.", fname, modestr)
	return \f
end

procedure __dbg_x_opendisplay ()
# Opens the display file for reading; writes it first, if necessary.
# RETURNS a file open for input on success.
# FAILS with a message on conflict.
local f, res
	if f := __dbg_x_openfile (__dbg_g_display,, 1) then {
		if __dbg_finteger (__dbg_fread (f)) = __dbg_g_brkpcnt then
			res := f
		else
			__dbg_fclose (f)
		}
	\res | {
		(f := __dbg_x_openfile (__dbg_g_display, 1)) | fail
		__dbg_fwrite (f, __dbg_g_brkpcnt)
		display (, f)
		__dbg_fclose (f)
		(f := __dbg_x_openfile (__dbg_g_display)) | fail
		__dbg_fread (f) # Throw away breakpoint counter.
		res := f
		}
	return res
end

#-------- Command compilation procedures --------
# 'macro_def' must be non-null to indicate that a macro is being defined.
# The command compilation procedures must return a list representing the
# compiled command, or fail on conflict.
# When they are invoked the keyword and any following white space has been
# parsed.


procedure __dbg_cc_break (cmd, macro_def)
local fidx, fname, line1, line2
	__dbg_fany (&digits) | (fname := __dbg_ftab (__dbg_fupto (__dbg_g_white))) | {
		__dbg_io_cfl ("File name and/or line number expected.")
		fail
		}

	# Get file name.
	if \fname then {
		(fidx := \__dbg_g_fileidx[fname]) | {
			__dbg_io_cfl ("File name '%1' not recognized.", fname)
			fail
			}
		}
	else if fname := \__dbg_g_where[WHERE_FILE] then
		fidx := __dbg_g_fileidx[fname]
	else { # init mode
		__dbg_io_cfl ("File name required.")
		fail
		}

	# Get line number(s).
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	(line1 := __dbg_finteger (__dbg_ftab (__dbg_fmany (&digits)))) | {
		__dbg_io_cfl ("Line number expected.")
		fail
		}
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	if =":" then {
		__dbg_ftab (__dbg_fmany (__dbg_g_white))
			(line2 := __dbg_finteger (__dbg_ftab (__dbg_fmany (&digits)))) | {
				__dbg_io_cfl ("Line number expected.")
				fail
				}
		}
	else
		line2 := line1
	(line1 <= line2 < 1000000) | {
		__dbg_io_cfl ("Weird line number.")
		fail
		}

	# Create an almost finished breakpoint descriptor (id is missing).
	return [cmd[CMD_EXEC], cmd[CMD_CODE], [ , fname, fidx, line1, line2, 0, ,]]
end

procedure __dbg_cc_clear (cmd, macro_def)
# A compound command.
local keyidx, parm
static ckey
initial ckey := ["breakpoint", "condition", "do", "echo", "macro"]
	(keyidx := __dbg_c_findkey (__dbg_ftab (__dbg_fupto (__dbg_g_white) | 0), ckey)) |
		fail
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	case keyidx of {
	CLEAR_BREAKPOINT:
		(parm := __dbg_c_brkpt (1)) | fail
	(CLEAR_COND | CLEAR_DO):
		(parm := __dbg_c_brkpt ()) | fail
	CLEAR_MACRO:
		(parm := __dbg_e_idf ()) | {
			__dbg_io_cfl ("Macro name expected.")
			fail
			}
	}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], ckey, keyidx, parm]
end

procedure __dbg_cc_condition (cmd, macro_def)
local brkpt, expr
	(brkpt := __dbg_c_brkpt ()) | fail
	# This makes the expression cleaner, but not necessary.
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	(expr := __dbg_e_compile (__dbg_ftab (0))) | {
		__dbg_io_cfl (__dbg_ge_message)
		fail
		}
	(*expr = 1) | __dbg_io_note ("Last %1 expressions ignored.", *expr - 1)
	return [cmd[CMD_EXEC], cmd[CMD_CODE], brkpt, expr[1]]
end

procedure __dbg_cc_do (cmd, macro_def)
local brkpt, fname
	/macro_def | {
		__dbg_io_cfl ("Sorry, nested macros not accepted.")
		fail
		}
	(brkpt := __dbg_c_brkpt ()) | fail
	(fname := __dbg_c_msource ()) | fail
	return [cmd[CMD_EXEC], cmd[CMD_CODE], brkpt, fname]
end

procedure __dbg_cc_end (cmd, macro_def)
	\macro_def | {
		__dbg_io_cfl ("'end' out of context.")
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE]]
end

procedure __dbg_cc_eprint (cmd, macro_def)
local expr
	(expr := __dbg_e_compile (__dbg_ftab (0))) | {
		__dbg_io_cfl (__dbg_ge_message)
		fail
		}
	(*expr = 1) | __dbg_io_note ("Last %1 expressions ignored.", *expr - 1)
	return [cmd[CMD_EXEC], cmd[CMD_CODE], expr[1]]
end

procedure __dbg_cc_frame (cmd, macro_def)
local frame_no
	__dbg_fpos (0) | (frame_no := __dbg_finteger (__dbg_ftab (__dbg_fmany (&digits ++ '-')))) | {
		__dbg_io_cfl ("Frame number expected.")
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], frame_no]
end

procedure __dbg_cc_goon (cmd, macro_def)
local opt
	__dbg_fpos (0) | __dbg_fmatch (opt := __dbg_ftab (__dbg_fmany (&lcase)), "nobreak", 1, 0) | {
		__dbg_io_cfl ("Expected 'nobreak', found '%1'.", opt)
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], opt]
end

procedure __dbg_cc_help (cmd, macro_def)
local keywd
	__dbg_fpos (0) | (keywd := __dbg_ftab (__dbg_fmany (&lcase))) | {
		__dbg_io_cfl ("Command keyword expected.")
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], keywd]
end

procedure __dbg_cc_ignore (cmd, macro_def)
local brkpt, count
	(brkpt := __dbg_c_brkpt ()) | fail
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	(count := __dbg_finteger (__dbg_ftab (__dbg_fmany (&digits ++ '+-')))) | {
		__dbg_io_cfl ("Integer ignore count expected.")
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], brkpt, count]
end

procedure __dbg_cc_info (cmd, macro_def)
# A compound command.
local keyidx, parm
static ckey
initial ckey := ["breakpoint", "echo", "files", "globals", "locals", "macros",
	"trace", "version"]
	(keyidx := __dbg_c_findkey (__dbg_ftab (__dbg_fupto (__dbg_g_white) | 0), ckey)) |
		fail
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	if keyidx = INFO_BREAKPOINT then
		__dbg_fpos (0) | (parm := __dbg_c_brkpt ()) | fail
	else if keyidx = INFO_GLOBALS then
		__dbg_fpos (0) | (parm := __dbg_ftab (__dbg_fupto (__dbg_g_white) | 0))
	return [cmd[CMD_EXEC], cmd[CMD_CODE], ckey, keyidx, parm]
end

procedure __dbg_cc_macro (cmd, macro_def)
local fname, idf
	/macro_def | {
		__dbg_io_cfl ("Sorry, nested macros not accepted.")
		fail
		}
	(idf := __dbg_ftab (__dbg_fmany (&lcase))) | {
		__dbg_io_cfl ("Macro name expected.")
		fail
		}
	(fname := __dbg_c_msource ()) | fail
	return [cmd[CMD_EXEC], cmd[CMD_CODE], idf, fname]
end

procedure __dbg_cc_next (cmd, macro_def)
local count
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	__dbg_fpos (0) | (count := __dbg_finteger (__dbg_ftab (__dbg_fmany (&digits ++ '+-')))) | {
		__dbg_io_cfl ("Integer ignore count expected.")
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], count]
end

procedure __dbg_cc_print (cmd, macro_def)
# Used to compile 'fprint' and 'print'.
local expr
	(expr := __dbg_e_compile (__dbg_ftab (0))) | {
		__dbg_io_cfl (__dbg_ge_message)
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], expr]
end

procedure __dbg_cc_set (cmd, macro_def)
# A compound command.
local keyidx, parm
static ckey
initial ckey := ["echo", "prelude", "postlude"]
	(keyidx := __dbg_c_findkey (__dbg_ftab (__dbg_fupto (__dbg_g_white) | 0), ckey)) |
		fail
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	case keyidx of {
	SET_ECHO: {
		parm := __dbg_ftrim (__dbg_ftab (__dbg_fupto (__dbg_g_white) | 0))
		(*parm > 0) | {
			__dbg_io_cfl ("File name expected.")
			fail
			}
		}
	(SET_PRELUDE | SET_POSTLUDE):
		(parm := __dbg_c_msource ()) | fail
	}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], ckey, keyidx, parm]
end

procedure __dbg_cc_source (cmd, macro_def)
# The 'source' command is different from other commands, because it is not
# really compiled; it takes effect immediately.
# In contrast to macro compilation, no null marker is pushed on the file stack.
# RETURNS a dummy 'source' command.
local f, fname, res
	__dbg_ftab (__dbg_fmany (__dbg_g_white))
	if __dbg_fpos (0) then
		__dbg_io_cfl ("File name expected.")
	else {
		fname := __dbg_ftrim (__dbg_ftab (0))
		if *__dbg_g_src >= MAX_SOURCE_NESTING then
			__dbg_io_cfl ("%1: Too deeply nested 'source' file.", fname)
		else if f := __dbg_x_openfile (fname) then {
			__dbg_fpush (__dbg_g_src, __dbg_g_in)
			__dbg_g_in := f
			res := [cmd[CMD_EXEC], cmd[CMD_CODE], fname]
			}
		}
	return \res
end

procedure __dbg_cc_trace (cmd, macro_def)
local tlevel
	(tlevel := __dbg_finteger (__dbg_ftab (__dbg_fmany (&digits ++ '+-')))) | {
		__dbg_io_cfl ("Integer value expected.")
		fail
		}
	return [cmd[CMD_EXEC], cmd[CMD_CODE], \tlevel]
end

procedure __dbg_cc_SIMPLE (cmd, macro_def)
# Used to compile all keyword-only commands, including macros.
	return [cmd[CMD_EXEC], cmd[CMD_CODE], cmd[CMD_MACRO]]
end

#-------- Command executing procedures --------
# The first parameter of these procedures is the procedure itself.
# (Not a very interesting parameter.)
# The command executing procedures must return a return code on success.
# Return codes are defined among the symbolic constants.
# The procedures must fail on conflict.


procedure __dbg_cx_break (proced, ccode, brkp)
local id, bpset, fidx, line1, line2
	# Add the breakpoint id to the descriptor.
	brkp[BRKP_ID] := id := (__dbg_g_brkpid +:= 1)
	__dbg_io_wrline ("[" || id || "]")
	# Make sure we can find the breakpint descriptor, given its id.
	__dbg_g_brkpdef[id] := brkp
	# Install the breakpoint lines in the lookup table.
	fidx := brkp[BRKP_FIDX]
	line1 := brkp[BRKP_LINE1]
	line2 := brkp[BRKP_LINE2]
	every __dbg_g_brlookup[__dbg_fior (fidx, line1 to line2)] := brkp
	# Add the line numbers to the breakpoint set.
	bpset := __dbg_file_map[brkp[BRKP_FILE]]
	every __dbg_finsert (bpset, line1 to line2)
	return OK_STATUS
end

procedure __dbg_cx_clear (proced, ccode, ckey, keyidx, parm)
# 'ckey' will be a list containing all the possible keywords to 'clear'.
# 'keyidx' is an index into that list, indicating a subcommand.
local bdescr, bpset, cmd, fidx, lcode, line, line1, line2
	if keyidx = (CLEAR_BREAKPOINT | CLEAR_COND | CLEAR_DO) then
		(bdescr := __dbg_x_brkpt (parm)) | fail
	else if keyidx = CLEAR_MACRO then
		(cmd := __dbg_c_findcmd (parm)) | fail
	case keyidx of {
	CLEAR_BREAKPOINT: {
		__dbg_fdelete (__dbg_g_brkpdef, bdescr[BRKP_ID])
		fidx := bdescr[BRKP_FIDX]
		line1 := bdescr[BRKP_LINE1]
		line2 := bdescr[BRKP_LINE2]
		bpset := __dbg_file_map[bdescr[BRKP_FILE]]
		# The range of lines once defined for the breakpoint might
		# have been overwritten by later breakpoints.
		every lcode := __dbg_fior (fidx, line := line1 to line2) do {
			if __dbg_g_brlookup[lcode] === bdescr then {
				__dbg_fdelete (__dbg_g_brlookup, lcode)
				__dbg_fdelete (bpset, line)
				}
			}
		}
	CLEAR_COND:	bdescr[BRKP_COND] := &null
	CLEAR_DO:	bdescr[BRKP_DO] := &null
	CLEAR_ECHO: {
		__dbg_fclose (\__dbg_g_out2)
		__dbg_g_out2 := &null
		}
	CLEAR_MACRO: {
		(cmd := __dbg_c_findcmd (parm)) | fail
		__dbg_fdelete (__dbg_g_cmd, cmd[CMD_NAME])
		}
	}
	return OK_STATUS
end

procedure __dbg_cx_condition (proced, ccode, brkpt, expr)
local bdescr
	(bdescr := __dbg_x_brkpt (brkpt)) | fail
	bdescr[BRKP_COND] := expr
	return OK_STATUS
end

procedure __dbg_cx_do (proced, ccode, brkpt, fname)
local bdescr
	(bdescr := __dbg_x_brkpt (brkpt)) | fail
	(bdescr[BRKP_DO] := __dbg_c_mcompile (fname)) | fail
	return OK_STATUS
end

procedure __dbg_cx_eprint (proced, ccode, expr)
local count, val
	__dbg_io_wrline ("{" || expr[2] || "}")
	count := 0
	every val := __dbg_fimage (__dbg_e_eval (expr[1])) do {
		if __dbg_io_cfl (\__dbg_ge_message) then
			fail
		else
			__dbg_io_wrline ("" || __dbg_fright ((count +:= 1), 3) ||
				": " || val)
		}
	return OK_STATUS
end

procedure __dbg_cx_fprint (proced, ccode, elist)
# 'elist' must be a list on the format returned by '__dbg_e_compile'.
local expr, fmt, idx, sval, val
	val := []
	every expr := !elist do {
		__dbg_fput (val, __dbg_e_eval (expr[1]) | "&fail")
		if __dbg_io_cfl (\__dbg_ge_message) then
			fail
		}
	(fmt := __dbg_fstring (val[1])) | {
		__dbg_io_cfl ("Expected format string; got '%1'.", __dbg_fimage (val[1]))
		fail
		}
	sval := []
	every idx := 2 to *val do {
		__dbg_fput (sval, __dbg_fstring (val[idx])) | {
		__dbg_io_cfl ("Expression not string-convertible: {%1} %2",
			elist[idx][2], __dbg_fimage (val[idx]))
			fail
			}
		}
	__dbg_io_wrstr (__dbg_x_subst (fmt, sval))
	return OK_STATUS
end

procedure __dbg_cx_frame (proced, ccode, frame_spec)
local f, frame_no, idx, line
	frame_no := if \frame_spec then {
		if frame_spec < 0 then __dbg_g_level + frame_spec else frame_spec
		} else __dbg_g_level
	(1 <= frame_no <= __dbg_g_level) | {
		__dbg_io_cfl ("Invalid frame number.")
		fail
		}
	(f := __dbg_x_opendisplay ()) | fail
	line := __dbg_x_dispinit (f)
	idx := __dbg_g_level
	while idx > frame_no do {
		repeat if (line := __dbg_fread (f))[1] ~== " " then
				break
		idx -:= 1
		}
	__dbg_io_info ("(%1) %2", frame_no, line)
	repeat {
		if (line := __dbg_fread (f))[1] ~== " " then
			break
		line ? {
			__dbg_ftab (__dbg_fmany (__dbg_g_white))
			=DBG_PREFIX | __dbg_io_info ("%1", line, *line > 0)
			}
		}
	__dbg_fclose (f)
	return OK_STATUS
end

procedure __dbg_cx_goon (proced, ccode, nobreak)
	if \nobreak then {
		__dbg_test := integer
		__dbg_fremove (__dbg_g_display)
		}
	return RESUME_STATUS
end

procedure __dbg_cx_help (proced, ccode, keywd)
# 'keywd' will be an identifier if the command had a keyword.
local cmd, hstr
	if cmd := __dbg_c_findcmd (\keywd) then {
		if hstr := \cmd[CMD_HELP] then
			__dbg_io_wrline (hstr)
		else
			__dbg_io_note ("No help available for '%1'.", cmd[CMD_NAME])
		}
	else
__dbg_io_wrline ("Available commands: (all keywords may be abbreviated)\n_
break		(set breakpoint)\n_
clear		(clear breakpoint or debugger parameter)\n_
condition	(attach condition to breakpoint)\n_
do		(attach macro to breakpoint)\n_
end		(terminate macro definition)\n_
eprint		(print every value from expression)\n_
fprint		(formatted print)\n_
frame		(inspect procedure call chain)\n_
goon		(resume execution)\n_
help		(print explanatory text)\n_
ignore		(set ignore counter on breakpoint)\n_
info		(print information about breakpoint or debugger parameter)\n_
macro		(define new command)\n_
next		(resume execution, break on every line)\n_
print		(print expressions)\n_
set		(set a debugger parameter)\n_
source		(read debugging commands from file)\n_
stop		(terminate program and debugging session)\n_
trace		(set value of Icon &trace)\n_
where		(print procedure call chain)\n\n_
An expression may be formed from a large subset of Icon operators; integer,\n_
string, list literals; locals from the current procedure, and globals.\n_
Procedure/function invocation, subscripting, record field reference is\n_
supported. Several keywords are also included.\n\n_
New/altered keywords,\n_
\	&bp, &breakpoint	current breakpoint id (integer)\n_
\	&file			current breakpoint source file name (string)\n_
\	&line			current breakpoint line number (integer)\n_
\	&proc			current breakpoint procedure name (string)")
	return OK_STATUS
end

procedure __dbg_cx_ignore (proced, ccode, brkpt, count)
local bdescr
	(bdescr := __dbg_x_brkpt (brkpt)) | fail
	bdescr[BRKP_IGNORE] := count
	return OK_STATUS
end

procedure __dbg_cx_info (proced, ccode, ckey, keyidx, parm)
# 'ckey' will be a list containing all the possible keywords to 'info'.
# 'keyidx' is an index into that list, indicating a subcommand.
local cmd, bdescr, f, nlist, version
	case keyidx of {
	INFO_BREAKPOINT:
		if \parm then {
			(bdescr := __dbg_x_brkpt (parm)) | fail
			__dbg_x_lbreak (bdescr)
			}
		else
			__dbg_x_lbreak ()
	INFO_ECHO:
		if \__dbg_g_out2 then
			__dbg_io_info ("Echo file: %1.", __dbg_g_out2name)
		else
			__dbg_io_info ("No echo file.")
	INFO_FILES: {
		nlist := []
		every __dbg_fput (nlist, __dbg_fkey (__dbg_file_map))
		nlist := __dbg_fsort (nlist)
		__dbg_io_info ("Tweaked source files in this program:")
		every __dbg_io_info ("   %1", !nlist)
		}
	INFO_GLOBALS: {
		(f := __dbg_x_opendisplay ()) | fail
		if \parm then
			__dbg_x_dispglob (f, parm)
		else
			__dbg_x_dispglob (f, "")
		__dbg_fclose (f)
		}
	INFO_LOCALS: {
		nlist := []
		every __dbg_fput (nlist, __dbg_fkey (__dbg_g_local))
		nlist := __dbg_fsort (nlist)
		__dbg_io_info ("Local identifiers in the current procedure:",
			*nlist > 0)
		every __dbg_io_info ("   %1", !nlist)
		}
	INFO_MACROS: {
		nlist := []
		every \(cmd := !__dbg_g_cmd)[CMD_MACRO] do
			__dbg_fput (nlist, cmd[CMD_NAME])
		nlist := __dbg_fsort (nlist)
		__dbg_io_info ("Currently defined macros:", *nlist > 0)
		every __dbg_io_info ("   %1", !nlist)
		}
	INFO_TRACE:
		__dbg_io_info ("Current trace level: %1.", __dbg_g_trace)
	INFO_VERSION: {
		version := (PROGRAM_VERSION ? (__dbg_ftab (__dbg_fupto (&digits)),
			__dbg_ftab (__dbg_fmany (&digits++'.'))))
		__dbg_io_info ("Program tweaked by itweak version %1.\n_
		This is runtime version %2.", __dbg_itweak_ver, version)
		}
	}
	return OK_STATUS
end

procedure __dbg_cx_macro (proced, ccode, idf, fname)
# Executes a 'macro' statement (not the resulting macro).
# 'fname' contains a file name (string) if the macro definition should be
# read from a file; otherwise null.
# SIDE EFFECT: Adds a command definition to '__dbg_g_cmd' on success.
local count, macro, mstr, sep, try
	count := 0
	mlist := []
	# Macro name must not be an abbreviation of an existing command.
	every __dbg_fmatch (idf, try := (!__dbg_g_cmd)[CMD_NAME], 1, 0) do {
		count +:= 1
		__dbg_fput (mlist, try)
		}
	# Check that no existing command is an abbreviation of macro name.
	every __dbg_fmatch (try := (!__dbg_g_cmd)[CMD_NAME], idf, 1, 0) do {
		count +:= 1
		(try == !mlist) | __dbg_fput (mlist, try)
		}
	(count = 0) | {
		mstr := sep := ""
		every mstr ||:= sep || !mlist do
			sep := ", "
		__dbg_io_cfl ("'%1' clashes with existing command (%2).", idf, mstr)
		fail
		}
	(macro := __dbg_c_mcompile (fname)) | fail
	__dbg_g_cmd[idf] := [idf, USERDEF_CMD, , __dbg_cc_SIMPLE, macro, __dbg_cx_userdef]
	return OK_STATUS
end

procedure __dbg_cx_next (proced, ccode, count)
# 'count' may be an ignore count.
	__dbg_g_brkpdef[0][BRKP_IGNORE] := \count
	__dbg_test := 2
	return RESUME_STATUS
end

procedure __dbg_cx_print (proced, ccode, elist)
# 'elist' must be a list on the format returned by '__dbg_e_compile'.
local expr, val
	every expr := !elist do {
		val := (__dbg_fimage (__dbg_e_eval (expr[1])) | "&fail")
		if __dbg_io_cfl (\__dbg_ge_message) then
			fail
		else
			__dbg_io_wrline ("{" || expr[2] || "} " || val)
		}
	return OK_STATUS
end

procedure __dbg_cx_set (proced, ccode, ckey, keyidx, parm)
# 'ckey' will be a list containing all the possible keywords to 'set'.
# 'keyidx' is an index into that list, indicating a subcommand.
	case keyidx of {
	SET_ECHO: {
		(__dbg_g_out2 := __dbg_x_openfile (parm, 1)) | fail
		__dbg_g_out2name := parm
		}
	SET_PRELUDE:
		(__dbg_g_automacro[1] := __dbg_c_mcompile (parm)) | fail
	SET_POSTLUDE:
		(__dbg_g_automacro[2] := __dbg_c_mcompile (parm)) | fail
	}
	return OK_STATUS
end

procedure __dbg_cx_stop (proced, ccode)
	return STOP_STATUS
end

procedure __dbg_cx_trace (proced, ccode, tlevel)
	__dbg_g_trace := tlevel
	return OK_STATUS
end

procedure __dbg_cx_where (proced, ccode)
local f, idf, idx, line
	(f := __dbg_x_opendisplay ()) | fail
	__dbg_io_info ("Current call stack in %1:", __dbg_fread (f))
	idx := __dbg_g_level
	line := __dbg_x_dispinit (f)
	repeat {
		idf := (line ? __dbg_ftab (__dbg_fupto (__dbg_g_white)))
		if idf == "global" then
			break
		if *idf > 0 then {
			__dbg_io_info ("(%1) %2", idx, idf)
			idx -:= 1
			}
		(line := __dbg_fread (f)) | break # Sanity.
		}
	__dbg_fclose (f)
	return OK_STATUS
end

procedure __dbg_cx_userdef (proced, ccode, macro)
	return __dbg_c_interp (macro)
end

procedure __dbg_cx_NOOP (proced, ccode)
	return OK_STATUS
end

#
#-------- General-purpose procedures --------
#

procedure __dbg_x_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 := __dbg_finteger (__dbg_ftab (__dbg_fmany (&digits)))) then
		res := just (str, wid)
	else {
		res := str
		&pos := init_p
		}
	return res
end

procedure __dbg_x_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 := [__dbg_fstring (parm)]
	res := ""
	msg ? until __dbg_fpos (0) do {
		res ||:= __dbg_ftab (__dbg_fupto ('%\\') | 0)
		if ="%" then res ||:= {
			if __dbg_fany (p_digit) then {
				sub := (\parm[__dbg_finteger (__dbg_fmove (1))] | "")
				__dbg_x_fld_adj (sub)	
				}
			else if __dbg_fany ('%') then
				__dbg_fmove (1)
			else ""
			}
		else if ="\\" then res ||:= case esc := __dbg_fmove (1) of {
			"n": "\n"
			"t": "\t"
			default: esc
			}
		}
	return res
end

#
#-------- Input/Output procedures --------
#

procedure __dbg_io_cfl (format, parm[])
# Writes a conflict message to debugging output.
# 'format' must be a format string.
# 'parm' must be string-convertibles to insert into placeholders in the
# format string, if any.
# RETURNS 1 (i.e. always succeeds).
	__dbg_io_wrline ("[debug CONFLICT] " || __dbg_x_subst (format, parm))
	return 1
end

procedure __dbg_io_getline ()
# RETURNS the next line from debugging input, or
# FAILS on end of file.
local line
	(line := __dbg_fread (__dbg_g_in)) | {
		__dbg_fclose (__dbg_g_in)
		# Check for a macro definition marker.
		\(__dbg_g_in := __dbg_fpop (__dbg_g_src)) | fail
		if *__dbg_g_src > 0 then
			return __dbg_io_getline ()
		}
	__dbg_fwrite (\__dbg_g_out2, "$ ", \line)
	return \line
end

procedure __dbg_io_info (format, parm[])
# Writes an info message to debugging output.
# 'format' must be a format string.
# 'parm' must be string-convertibles to insert into placeholders in the
# format string, if any.
	__dbg_io_wrline (__dbg_x_subst (format, parm))
end

procedure __dbg_io_note (format, parm[])
# Writes a note to debugging output.
# 'format' must be a format string.
# 'parm' must be string-convertibles to insert into placeholders in the
# format string, if any.
	__dbg_io_wrline ("[debug NOTE] " || __dbg_x_subst (format, parm))
end

procedure __dbg_io_wrline (line)
# Writes a string and a newline to debugging output.
# 'line' must be the string to write.
# It may contains additional newlines.
	__dbg_fwrite (__dbg_g_out1, line)
	__dbg_fwrite (\__dbg_g_out2, line)
end

procedure __dbg_io_wrstr (line)
# Writes a string without a newline to debugging output.
# 'line' must be the string to write.
# It may contains additional newlines.
	__dbg_fwrites (__dbg_g_out1, line)
	__dbg_fwrites (\__dbg_g_out2, line)
end

#
#-------- Function initialization ---------
#
procedure __dbg_func_init ()
	__dbg_fany	:= any
	__dbg_fclose	:= close
	__dbg_fdelete	:= delete
	__dbg_fexit	:= exit
	__dbg_ffind	:= find
	__dbg_fgetenv	:= getenv
	__dbg_fimage	:= image
	__dbg_finsert	:= insert
	__dbg_finteger	:= integer
	__dbg_fior	:= ior
	__dbg_fishift	:= ishift
	__dbg_fkey	:= key
	__dbg_fmany	:= many
	__dbg_fmatch	:= match
	__dbg_fmove	:= move
	__dbg_fpop	:= pop
	__dbg_fpos	:= pos
	__dbg_fproc	:= proc
	__dbg_fpush	:= push
	__dbg_fput	:= put
	__dbg_fread	:= read
	__dbg_fremove	:= remove
	__dbg_freverse	:= reverse
	__dbg_fright	:= right
	__dbg_fsort	:= sort
	__dbg_fstring	:= string
	__dbg_ftab	:= tab
	__dbg_ftable	:= table
	__dbg_ftrim	:= trim
	__dbg_ftype	:= type
	__dbg_fupto	:= upto
	__dbg_fwrite	:= write
	__dbg_fwrites	:= writes
end

#
#-------- Command initialization ---------
#

procedure __dbg_cmd_init ()
# Initialize command definitions.
	__dbg_g_cmd := __dbg_ftable ()
### break
		__dbg_g_cmd["break"] := ["break", BREAK_CMD,
"	break [file] [line [: line]]\n_
Sets a breakpoint on a line or a range of lines. The file name (if present)\n_
must be one of the tweaked files (cf. the 'info files' command). If omitted\n_
the file of the current breakpoint is assumed. The identity of the new\n_
breakpoint (an integer) is displayed. It may be used in other commands.\n_
Besides an integer there are two other ways to identify a breakpoint,\n_
\	.	(dot) the current breakpoint,\n_
\	$	(dollar) the last breakpoint defined by a 'break' command.\n_
Breakpoint 0 (zero) is special; see the 'next' command.\n\n_
As a rule a breakpoint takes effect AFTER the breakpointed line has been\n_
executed. If two breakpoints are defined on the same line, only the latest\n_
is in effect.",
__dbg_cc_break, , __dbg_cx_break]
### clear
		__dbg_g_cmd["clear"] := ["clear", CLEAR_CMD,
"	clear breakpoint brkpt\n_
Deletes breakpoint identified by 'brkpt'.\n_
\	clear condition brkpt\n_
Removes condition from breakpoint 'brkpt'. The breakpoint becomes\n_
unconditional.\n_
\	clear do brkpt\n_
Removes commands associated with breakpoint 'brkpt'.\n_
\	clear echo\n_
Stops output to echo file.\n_
\	clear macro name\n_
Removes macro identified by 'name'.",
__dbg_cc_clear, , __dbg_cx_clear]
### comment
		__dbg_g_cmd["#"] := ["#", COMMENT_CMD,
"	# comment text\n_
A line beginning with '#' is ignored.",
__dbg_cc_SIMPLE, , __dbg_cx_NOOP]
### condition
		__dbg_g_cmd["condition"] := ["condition", CONDITION_CMD,
"	condition brkpt expr\n_
Attaches a condition to breakpoint 'brkpt'. The expression 'expr' must\n_
succeed for a break to occur.",
__dbg_cc_condition, , __dbg_cx_condition]
### do
		__dbg_g_cmd["do"] := ["do", DO_CMD,
"	do brkpt [<filename]\n_
Attaches commands to the breakpoint identified by 'brkpt'. The commands\n_
are entered interactively (terminate with 'end'), or are read from a file.",
__dbg_cc_do, , __dbg_cx_do]
### end
		__dbg_g_cmd["end"] := ["end", END_CMD,
"	end\n_
Terminates a macro definition.",
__dbg_cc_end, , __dbg_cx_NOOP]
### eprint
		__dbg_g_cmd["eprint"] := ["eprint", EPRINT_CMD,
"	eprint expr\n_
Prints image of every value generated by expression 'expr'.",
__dbg_cc_eprint, , __dbg_cx_eprint]
### fprint
		__dbg_g_cmd["fprint"] := ["fprint", FPRINT_CMD,
"	fprint format-expr {; expr}\n_
Formatted print. The first expression must evaluate to a format string,\n_
possibly containing placeholders (%1, %2, etc). The result of evaluating\n_
remaining expressions will be substituted for the placeholders. You must\n_
make sure their values are string-convertible (the 'image' function is\n_
available). Insert '\\n' in format string to obtain newline.",
__dbg_cc_print, , __dbg_cx_fprint]
### frame
		__dbg_g_cmd["frame"] := ["frame", FRAME_CMD,
"	frame [n]\n_
Shows a call frame. 'n' may be an integer frame number (obtained from\n_
the 'where' command), or may be omitted. Omitted frame number = current\n_
procedure. Negative frame number is relative to the current procedure.\n_
The command prints the image of all local variables.",
__dbg_cc_frame, , __dbg_cx_frame]
### goon
		__dbg_g_cmd["goon"] := ["goon", GOON_CMD,
"	goon [nobreak]\n_
Resumes execution. With 'nobreak': lets the program run to completion\n_
without breaking.",
__dbg_cc_goon, , __dbg_cx_goon]
### help
		__dbg_g_cmd["help"] := ["help", HELP_CMD,
"	help [command]\n_
Displays information. Prints short command description if command keyword\n_
is included. Otherwise prints list of available commands.",
__dbg_cc_help, , __dbg_cx_help]
### ignore
		__dbg_g_cmd["ignore"] := ["ignore", IGNORE_CMD,
"	ignore brkpt count\n_
Sets the ignore counter of breakpoint 'brkpt'. 'count' may be a positive\n_
or negative integer. It replaces the previous ignore counter value.\n_
A breakpoint with a non-zero ignore count does not cause a break, but the\n_
ignore count is decremented by 1.",
__dbg_cc_ignore, , __dbg_cx_ignore]
### info
		__dbg_g_cmd["info"] := ["info", INFO_CMD,
"	info breakpoint [brkpt]\n_
Prints info about breakpoint identified by 'brkpt', or about all\n_
breakpoints if 'brkpt' is omitted.\n_
\	info echo\n_
Prints the current 'echo' file name, if any.\n_
\	info files\n_
Prints names of source files with tweaked ucode in this program.\n_
\	info globals [substr]\n_
Prints names of global variables. The optional substring limits output\n_
to global names containing this substring.\n_
\	info locals\n_
Prints names of all local variables in current procedure.\n_
\	info macros\n_
Prints names of all currently defined macros.\n_
\	info trace\n_
Prints the current value of &trace.\n_
\	info version\n_
Prints itweak and runtime versions.",
__dbg_cc_info, , __dbg_cx_info]
### macro
		__dbg_g_cmd["macro"] := ["macro", MACRO_CMD,
"	macro name\n_
Creates a new command called 'name'. The command will consist of\n_
subsequent lines, up to a line containing 'end'.\n_
\	macro name <filename\n_
As above, but macro definition read from a file. 'end' command optional.",
__dbg_cc_macro, , __dbg_cx_macro]
### next
		__dbg_g_cmd["next"] := ["next", NEXT_CMD,
"	next [count]\n_
Resumes execution as if a breakpoint were defined on every line. An\n_
ignore count may be included (see the 'ignore' command). A break\n_
caused by 'next' is considered breakpoint 0 (zero), even if an\n_
ordinary breakpoint is in effect on the same line. The 'condition',\n_
'do', 'info' commands accept 0 as a breakpoint number.",
__dbg_cc_next, , __dbg_cx_next]
### print
		__dbg_g_cmd["print"] := ["print", PRINT_CMD,
"	print expr {; expr}\n_
Evaluates and print image of expression(s). Only the first value from\n_
each expression is printed. '&fail' printed if an expression fails.",
__dbg_cc_print, , __dbg_cx_print]
### set
		__dbg_g_cmd["set"] := ["set", SET_CMD,
"	set echo filename\n_
Starts echoing output to a file.\n_
\	set prelude [<file]\n_
Defines a macro to be exeucted at breaks. The default prelude is\n_
\	fprint \"[%1] %2 (%3:%4)\\n\";&bp;&proc;&file;&line\n_
It prints breakpoint number, procedure name, source file name, and\n_
line number.\n_
\	set postlude [<file]\n_
Defines a macro to be executed when resuming execution. The default\n_
postlude does nothing.",
__dbg_cc_set, , __dbg_cx_set]
### source
		__dbg_g_cmd["source"] := ["source", SOURCE_CMD,
"	source filename\n_
Reads commands from a file. Takes effect immediately when used in a macro\n_
definition.",
__dbg_cc_source, , __dbg_cx_NOOP]
### stop
		__dbg_g_cmd["stop"] := ["stop", STOP_CMD,
"	stop\n_
Stops the program and terminates the debugging session.",
__dbg_cc_SIMPLE, , __dbg_cx_stop]
### trace
		__dbg_g_cmd["trace"] := ["trace", TRACE_CMD,
"	trace count\n_
Sets the value of the Icon trace counter (&trace) to 'count'.",
__dbg_cc_trace, , __dbg_cx_trace]
### where
		__dbg_g_cmd["where"] := ["where", WHERE_CMD,
"	where\n_
Prints the call chain leading up to the current procedure.\n_
Displays frame numbers which may be used by the 'frame' command.",
__dbg_cc_SIMPLE, , __dbg_cx_where]
end

############### EXPRESSIONS ##############################
#
# Parses a fair subset of Icon expressions.
# Compiles them into a linear post-fix representation.
# Evaluates.
# Somewhat adapted to the debugging environment, but
# generally useful with small modifications.
#
##########################################################

#
#-------------- Expression management constants ----------
#

$define IDENT_T		1
$define INTEGER_T	2
$define STRING_T	3
$define SPECIAL_T	4
$define FIELD_T		5
$define LIST_T		6
$define EXPR_T		8
$define ELIST_T		9
$define UNOP_T		10
$define BINOP_T		11
$define TEROP_T		12
$define INVOKE_T	13

$define NOTN_OP		901
$define ISN_OP		902
$define SIZ_OP		903
$define BNG_OP		904
$define NEG_OP		905

$define ALT_OP		1501
$define CNJ_OP		1401
# N -- numerical comparison.
$define NEQ_OP		1301
$define NNE_OP		1302
$define NLE_OP		1303
$define NLT_OP		1304
$define NGE_OP		1305
$define NGT_OP		1306
# L -- lexical comparison.
$define LLT_OP		1307
$define LLE_OP		1308
$define LEQ_OP		1309
$define LNE_OP		1310
$define LGE_OP		1311
$define LGT_OP		1312
$define EQ_OP		1313
$define NE_OP		1314
$define ADD_OP		1201
$define SUBTR_OP	1202
$define UNION_OP	1203
$define DIFF_OP		1204
$define CAT_OP		1101
$define LCAT_OP		1102
$define MUL_OP		1001
$define DIV_OP		1002
$define REM_OP		1003
$define ISCT_OP		1004
$define EXP_OP		1001
$define INVOKE_OP	801
$define SSC_OP		802
$define PART_OP		803
$define FLD_OP		804

$define CLOCK_SP	1
$define CURRENT_SP	2
$define DATE_SP		3
$define DATELINE_SP	4
$define POS_SP		5
$define REGIONS_SP	6
$define SOURCE_SP	7
$define STORAGE_SP	8
$define SUBJECT_SP	9
$define VERSION_SP	10

$define BREAK_SP	101
$define FILE_SP		102
$define LEVEL_SP	103
$define LINE_SP		104
$define PROC_SP		105
$define TRACE_SP	106

#
#-------------- Expression parsing ----------------------		
#

procedure __dbg_e_compile (str)
# Compiles one or more expressions separated by a semicolon.
# 'str' must be the candidate expression (string).
# RETURNS a list of lists where each sublist has the following components:
# (1) The compiled expression in postfix representation (list).
# This representation can be used with the '__dbg_e_eval' procedure.
# (2) The expression source string.
# FAILS on conflict.
# SIDE EFFECT: Assigns a message (string) to '__dbg_ge_message' on conflict;
# assigns &null otherwise.
local elist, res1, res2, pos1, pos2
	elist := []
	# Parse the expression(s).
	str ? repeat {
		pos1 := &pos
		(res1 := 1(__dbg_e_expr(), pos2:= &pos, __dbg_e_ws (),
			(__dbg_fpos (0) | __dbg_fany (';')))) | {
			__dbg_ge_message := "Expression syntax error."
			fail
			}
		# Linearize, convert to postfix.
		__dbg_ge_message := &null
		res2 := []
		__dbg_e_ecode (res1, res2)
		# Check for conflict.
		/__dbg_ge_message | fail
		__dbg_fput (elist, [res2, str[pos1:pos2]])
		if __dbg_fpos (0) then
			break
		else {
			__dbg_fmove (1)
			__dbg_e_ws ()
			}
		}
	return elist
end

procedure __dbg_e_expr()
	__dbg_ftab (__dbg_fmany (' \t'))
	suspend [__dbg_e_term()] |
 		([__dbg_e_term(), __dbg_e_bin()] ||| __dbg_e_expr())
end

procedure __dbg_e_term()
	__dbg_ftab (__dbg_fmany (' \t'))
	suspend [__dbg_e_factor()] |
		[__dbg_e_factor(), __dbg_e_form()] |
		[__dbg_e_un(), __dbg_e_factor()] |
		[__dbg_e_un(), __dbg_e_factor(), __dbg_e_form()]
end
	
procedure __dbg_e_form()
	__dbg_ftab (__dbg_fmany (' \t'))
	suspend 2(=".", [FLD_OP, [FIELD_T, __dbg_e_idf()]]) |
		2(="[", [SSC_OP, __dbg_e_expr()], ="]") |
		2(="(", [INVOKE_OP, __dbg_e_elist()], =")") |
		2(="[", [PART_OP, __dbg_e_expr(),
			3(__dbg_e_ws(), =":", __dbg_e_expr())], ="]") |
 		(2(=".", [FLD_OP, [FIELD_T, __dbg_e_idf()]]) ||| __dbg_e_form()) |
		(2(="[", [SSC_OP, __dbg_e_expr()], ="]") ||| __dbg_e_form()) |
		(2(="(", [INVOKE_OP, __dbg_e_elist()], =")") ||| __dbg_e_form()) |
		(2(="[", [PART_OP, __dbg_e_expr(),
			3(__dbg_e_ws(), =":", __dbg_e_expr())], ="]") |||
			__dbg_e_form())
end

procedure __dbg_e_elist()
	__dbg_ftab (__dbg_fmany (' \t'))
	suspend [] |
		[__dbg_e_expr()] |
		[__dbg_e_expr()] ||| 3(__dbg_e_ws(), =",", __dbg_e_elist())
end

procedure __dbg_e_factor()
	__dbg_ftab (__dbg_fmany (' \t'))
	suspend [IDENT_T, __dbg_e_idf()] |
		[INTEGER_T, __dbg_e_ilit()] |
		[STRING_T, __dbg_e_slit()] |
		[SPECIAL_T, (="&", __dbg_e_idf())] |
		2(="(", [EXPR_T, __dbg_e_expr()], __dbg_e_ws(), =")") |
		2(="[", [LIST_T, __dbg_e_elist()], __dbg_e_ws(), ="]")
end

procedure __dbg_e_idf()
static char1, char2
initial {
	char1 := &ucase ++ &lcase ++ '_'
	char2 := char1 ++ &digits
	}
	suspend __dbg_ftab (__dbg_fmany (char1)) || (__dbg_ftab (__dbg_fmany (char2)) | "")
end

procedure __dbg_e_ilit()
	suspend __dbg_ftab (__dbg_fmany (&digits))
end

procedure __dbg_e_strend()
static signal, nonsignal
initial {
	signal := '\"\\'
	nonsignal := ~signal
	}
	suspend 2(="\"", "") |
		1(__dbg_e_stresc(), ="\"") |
		(__dbg_e_stresc() || __dbg_ftab (__dbg_fmany (nonsignal)) || __dbg_e_strend()) |
		(__dbg_e_stresc() || __dbg_e_strend())
end

procedure __dbg_e_stresc()
	suspend (="\\n", "\n") |
		(="\\t", "\t") |
		(="\\r", "\r") |
		(="\\", __dbg_fmove (1))
end

procedure __dbg_e_slit()
static signal, nonsignal
initial {
	signal := '\"\\'
	nonsignal := ~signal
	}
	suspend 2(="\"",
		(__dbg_ftab (__dbg_fmany (nonsignal)) || __dbg_e_strend()) | __dbg_e_strend())
end

procedure __dbg_e_un()
# Sequence of unary operators.
# Always succeeds.
# NOTE: Assumes no space between operators.
static unop
initial unop := '\\/*!-'
	__dbg_ftab (__dbg_fmany (' \t'))
	suspend [UNOP_T, __dbg_ftab (__dbg_fmany (unop))]
end

procedure __dbg_e_bin()
# Binary operators.
static optab
initial {
	# Table of operators.
	# Operators are coded as decimal integers where the hundreds
	# digit defines precedence.
	optab := table()
	optab["|"] :=		ALT_OP
	optab["&"] :=		CNJ_OP
	optab["="] :=		NEQ_OP
	optab["~="] :=		NNE_OP
	optab["<="] :=		NLE_OP
	optab["<"] :=		NLT_OP
	optab[">="] :=		NGE_OP
	optab[">"] :=		NGT_OP
	optab["<<"] :=		LLT_OP
	optab["<<="] :=		LLE_OP
	optab["=="] :=		LEQ_OP
	optab["~=="] :=		LNE_OP
	optab[">>="] :=		LGE_OP
	optab[">>"] :=		LGT_OP
	optab["==="] :=		EQ_OP
	optab["~==="] :=	NE_OP
	optab["+"] :=		ADD_OP
	optab["-"] :=		SUBTR_OP
	optab["++"] :=		UNION_OP
	optab["--"] :=		DIFF_OP
	optab["||"] :=		CAT_OP
	optab["|||"] :=		LCAT_OP
	optab["*"] :=		MUL_OP
	optab["/"] :=		DIV_OP
	optab["%"] :=		REM_OP
	optab["**"] :=		ISCT_OP
	optab["^"] :=		EXP_OP
	}
	__dbg_ftab (__dbg_fmany (' \t'))
	suspend \optab[__dbg_fmove (3)] |
		\optab[__dbg_fmove (2)] |
		\optab[__dbg_fmove (1)] |
		\optab[=("~===")]
end

procedure __dbg_e_ws()
# Removes optional white space.
# The point is that it always succeeds.
	__dbg_ftab (__dbg_fmany (' \t'))
	return 1
end

#-------------- Linearization ----------------------		

procedure __dbg_e_ecode (ex, res)
# 'Evaluates' the list resulting from pattern matching.
# Produces a single list with everything in postfix order.
# 'ex' must be an expression in the form that '__dbg_e_compile' generates.
# 'res' must be an (empty) list where the expression elements are to
# be inserted.
# Always FAILS.
# SIDE EFFECT: Adds elements to 'res'.
# Assigns a message string to '__dbg_ge_message' on conflict.
local opnd, oprt, op_stack
	if *ex = 1 then
		__dbg_e_tcode (ex[1], res)
	else {
		op_stack := []
		opnd := create !ex
		__dbg_e_tcode (@opnd, res)
		while oprt := @opnd do {
			while (op_stack[1]/100) <= (oprt/100) do
				__dbg_fput (res, __dbg_e_proc ([BINOP_T, __dbg_fpop (op_stack),]))
			__dbg_fpush (op_stack, oprt)
			__dbg_e_tcode (@opnd, res)
			}
		while __dbg_fput (res, __dbg_e_proc ([BINOP_T, __dbg_fpop (op_stack),]))
		}
end

procedure __dbg_e_tcode (tm, res)
# Disentangles a term.
local comp, unary
static special, unop
initial {
	special := __dbg_ftable ()
	# The 'normal' keywords.
	special["clock"] :=	CLOCK_SP
	special["current"] :=	CURRENT_SP
	special["date"] :=	DATE_SP
	special["dateline"] :=	DATELINE_SP
	special["pos"] :=	POS_SP
	special["regions"] :=	REGIONS_SP
	special["source"] :=	SOURCE_SP
	special["storage"] :=	STORAGE_SP
	special["subject"] :=	SUBJECT_SP
	special["trace"] :=	TRACE_SP
	special["version"] :=	VERSION_SP
	
	# The special keywords.
	special["bp"] :=BREAK_SP
	special["breakpoint"] :=BREAK_SP
	special["file"]	:=	FILE_SP
	special["level"] :=	LEVEL_SP
	special["line"] :=	LINE_SP
	special["proc"] :=	PROC_SP

	unop := __dbg_ftable ()
	unop["\\"] :=	NOTN_OP
	unop["/"] :=	ISN_OP
	unop["*"] :=	SIZ_OP
	unop["!"] :=	BNG_OP
	unop["-"] :=	NEG_OP
	}
	every comp := !tm do case comp[1] of {
	UNOP_T:	unary := comp	# Save for later.
	INTEGER_T: {
		comp[2] := __dbg_finteger (comp[2])
		__dbg_fput (res, comp)
		}
	SPECIAL_T: {
		if comp[2] := \special[comp[2]] then
			__dbg_fput (res, comp)
		else
			__dbg_ge_message := "'" || comp[2] ||
				"': unrecognized special identifier."
		}
	EXPR_T:		__dbg_e_ecode (comp[2], res)
	LIST_T:	{
		every __dbg_e_ecode (!comp[2], res)
		__dbg_fput (res, [LIST_T, *comp[2]])
		}
	(FLD_OP | SSC_OP | INVOKE_OP | PART_OP) :
		__dbg_e_fcode (comp, res)
	default:	__dbg_fput (res, comp)
	# This includes: IDENT_T, STRING_T
	}
	every __dbg_fput (res, __dbg_e_proc ([UNOP_T, unop[!__dbg_freverse ((\unary)[2])],]))
end

procedure __dbg_e_fcode (fm, res)
# Disentangles a form.
# The operators have the same precedence; stack not needed.
local comp, opnd, oprt
	comp := create !fm
	while oprt := @comp do {
		opnd := @comp	# There is at least one operand.
		case oprt of {
		FLD_OP:	{
			__dbg_fput (res, opnd)
			__dbg_fput (res, [BINOP_T, oprt, __dbg_e_field])
		}
		SSC_OP:	{
			__dbg_e_ecode (opnd, res)
			__dbg_fput (res, [BINOP_T, oprt, __dbg_fproc ("[]", 2)])
		}
		INVOKE_OP: {
			every __dbg_e_ecode (!opnd, res)
			__dbg_fput (res, [INVOKE_T, *opnd])
		}
		PART_OP: {
			__dbg_e_ecode (opnd, res)
			__dbg_e_ecode (@comp, res)
			__dbg_fput (res, [TEROP_T, oprt, __dbg_fproc ("[:]", 3)])
		}
		default: __dbg_ge_message := __dbg_fimage (oprt) || ": weird operator."
		}
		}
end

procedure __dbg_e_proc (op_d)
# 'op_d' must be an operator descriptor (list(3)).
# RETURNS the descriptor with the 3rd component filled in by a
# procedure/function.
static opt
initial {
	opt := __dbg_ftable ()
	opt[NOTN_OP] :=		__dbg_fproc ("\\", 1)
	opt[ISN_OP] :=		__dbg_fproc ("/", 1)
	opt[SIZ_OP] :=		__dbg_fproc ("*", 1)
	opt[BNG_OP] :=		__dbg_fproc ("!", 1)
	opt[NEG_OP] :=		__dbg_fproc ("-", 1)
	opt[ALT_OP] :=		__dbg_e_alt
	opt[CNJ_OP] :=		__dbg_e_cnj
	opt[NEQ_OP] :=		__dbg_fproc ("=", 2)
	opt[NNE_OP] :=		__dbg_fproc ("~=", 2)
	opt[NLE_OP] :=		__dbg_fproc ("<=", 2)
	opt[NLT_OP] :=		__dbg_fproc ("<", 2)
	opt[NGE_OP] :=		__dbg_fproc (">=", 2)
	opt[NGT_OP] :=		__dbg_fproc (">", 2)
	opt[LLT_OP] :=		__dbg_fproc ("<<", 2)
	opt[LLE_OP] :=		__dbg_fproc ("<<=", 2)
	opt[LEQ_OP] :=		__dbg_fproc ("==", 2)
	opt[LNE_OP] :=		__dbg_fproc ("~==", 2)
	opt[LGE_OP] :=		__dbg_fproc (">>=", 2)
	opt[LGT_OP] :=		__dbg_fproc (">>", 2)
	opt[EQ_OP] :=		__dbg_fproc ("===", 2)
	opt[NE_OP] :=		__dbg_fproc ("~===", 2)
	opt[ADD_OP] :=		__dbg_fproc ("+", 2)
	opt[SUBTR_OP] :=	__dbg_fproc ("-", 2)
	opt[UNION_OP] :=	__dbg_fproc ("++", 2)
	opt[DIFF_OP] :=		__dbg_fproc ("--", 2)
	opt[CAT_OP] :=		__dbg_fproc ("||", 2)
	opt[LCAT_OP] :=		__dbg_fproc ("|||", 2)
	opt[MUL_OP] :=		__dbg_fproc ("*", 2)
	opt[DIV_OP] :=		__dbg_fproc ("/", 2)
	opt[REM_OP] :=		__dbg_fproc ("%", 2)
	opt[ISCT_OP] :=		__dbg_fproc ("**", 2)
	opt[EXP_OP] :=		__dbg_fproc ("^", 2)
	opt[SSC_OP] :=		__dbg_fproc ("[]", 2)
	opt[PART_OP] :=		__dbg_fproc ("[:]", 2)
	opt[FLD_OP] :=		__dbg_e_field
	}
	op_d[3] := opt[op_d[2]]
	return op_d
end

#-------------- Evaluation ----------------------		

procedure __dbg_e_eval (expr)
# Evaluates a compiled expression.
# 'expr' must be an expression using the representation created by
# '__dbg_e_compile' (list).
# GENERATES all expression values.
# SIDE EFFECT: Assigns a message (string) to '__dbg_ge_message' on conflict;
# assigns &null otherwise.
local val
	__dbg_ge_message := &null
	&error := -1
	every val := __dbg_e_eval1 (expr, []) do {
		&error := 0
		suspend val
		__dbg_ge_message := &null
		&error := -1
		}
	if &error < -1 then
		__dbg_ge_message := "Error number " || &errornumber || ": " ||
		&errortext || "." ||
		(("\nOffending value: " || __dbg_fimage (\&errorvalue) || ".") | "")
	&error := 0
end

procedure __dbg_e_alt (opnd1, opnd2)
# Our version of alternation.
	suspend (opnd1 | opnd2)
end

procedure __dbg_e_cnj (opnd1, opnd2)
# Our version of conjunction.
	suspend (opnd1 & opnd2)
end

procedure __dbg_e_field (opnd1, opnd2)
# Record field access.
# Any better way to determine if a value is a record of any type?
static builtin
initial {
	builtin := __dbg_ftable ()
	builtin["co-expression"] := 1
	builtin["cset"] := 1
	builtin["file"] := 1
	builtin["integer"] := 1
	builtin["list"] := 1
	builtin["null"] := 1
	builtin["procedure"] := 1
	builtin["real"] := 1
	builtin["set"] := 1
	builtin["string"] := 1
	builtin["table"] := 1
	}
	if \builtin[__dbg_ftype (opnd1)] then {
		__dbg_ge_message := "Record expected; found " || __dbg_fimage (opnd1)
		fail
		}
	suspend opnd1[opnd2]
end

procedure __dbg_e_ident (idf)
# Evaluates an identifier.
local val
	(val := ((__dbg_ge_singular ~=== __dbg_g_local[idf]) | variable (idf))) | {
		__dbg_ge_message := "Identifier '" || idf || "' not visible."
		fail
		}
	suspend val
end

procedure __dbg_e_special (sp_code)
# Evaluates a special identifier.
	suspend case sp_code of {
	# Regular Icon keyword variables.
	CLOCK_SP:	&clock
	CURRENT_SP:	&current
	DATE_SP:	&date
	DATELINE_SP:	&dateline
	POS_SP:		&pos
	REGIONS_SP:	&regions
	SOURCE_SP:	&source
	STORAGE_SP:	&storage
	SUBJECT_SP:	&subject
	VERSION_SP:	&version
	# Special keywords.
	BREAK_SP:	(\__dbg_g_where[WHERE_BRKP])[BRKP_ID]
	FILE_SP:	__dbg_g_where[WHERE_FILE]
	LEVEL_SP:	__dbg_g_level
	LINE_SP:	__dbg_g_where[WHERE_LINE]
	PROC_SP:	__dbg_g_where[WHERE_PROC]
	TRACE_SP:	__dbg_g_trace
	default: {
		__dbg_ge_message := __dbg_fimage (sp_code) ||
			": weird special identifier code."
		fail
		}
	}
end

procedure __dbg_e_eval1 (expr, stack)
# Evaluates an expression.
# 'stack' must be the current evaluation stack (list).
# The procedure is recursive; the initial invocation must supply an
# empty list.
local comp
	(comp := expr[1]) | while suspend __dbg_fpop (stack) | fail
	suspend __dbg_e_eval1 (expr[2:0], case comp[1] of {
	IDENT_T:	stack ||| [__dbg_e_ident (comp[2])]
	SPECIAL_T:	stack ||| [__dbg_e_special (comp[2])]
	LIST_T:		stack[1:-comp[2]] ||| [stack[-comp[2]:0]]
	UNOP_T:		stack[1:-1] ||| [comp[3](stack[-1])]
	BINOP_T:	stack[1:-2] ||| [comp[3]!stack[-2:0]]
	TEROP_T:	stack[1:-3] ||| [comp[3]!stack[-3:0]]
	INVOKE_T:	stack[1:-(comp[2]+1)] |||
				[stack[-(comp[2]+1)]!stack[-comp[2]:0]]
	default:	stack ||| [comp[2]]
	})
end