home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.cs.arizona.edu
/
ftp.cs.arizona.edu.tar
/
ftp.cs.arizona.edu
/
icon
/
historic
/
v941.tgz
/
icon.v941src.tar
/
icon.v941src
/
ipl
/
progs
/
ipp.icn
< prev
next >
Wrap
Text File
|
2002-03-26
|
36KB
|
1,179 lines
############################################################################
#
# File: ipp.icn
#
# Subject: Program to preprocess Icon programs
#
# Author: Robert C. Wieland, revised by Frank J. Lhota
#
# Date: March 26, 2002
#
############################################################################
#
# This file is in the public domain.
#
############################################################################
#
# Ipp is a preprocessor for the Icon language. Ipp has many operations and
# features that are unique to the Icon environment and should not be used as
# a generic preprocessor (such as m4). Ipp produces output which when written
# to a file is designed to be the source for icont, the command processor for
# Icon programs.
#
############################################################################
#
# Ipp may be invoked from the command line as:
#
# ipp [option ...] [ifile [ofile]]
#
# Two file names may be specified as arguments. 'ifile' and 'ofile' are
# respectively the input and output files for the preprocessor. By default
# these are standard input and standard output. If the output file is to be
# specified while the input file should remain standard input a dash ('-')
# should be given as 'ifile'. For example, 'ipp - test' makes test the output
# file while retaining standard input as the input file.
#
# The following special names are predefined by ipp and may not be
# redefined # or undefined. The name _LINE_ is defined as the line number
# (as an integer) of the line of the source file currently processed. The
# name _FILE_ is defined as the name of the current source file
# (as a string). If the source is standard input then it has the value
# 'stdin'.
#
# Ipp will also set _LINE_ and _FILE_ from the "#line" directives it
# encounters, and will insert line directives to indicate source origins.
#
# Also predefined are names corresponding to the features supported by the
# implementation of Icon at the location the preprocessor is run. This allows
# conditional translations using the 'if' commands, depending on what features
# are available. Given below is a list of the features on a 4.nbsd UNIX
# implementation and the corresponding predefined names:
#
# Feature Name
# -----------------------------------------------------
# UNIX UNIX
# co-expressions co_expressions
# overflow checking overflow_checking
# direct execution direct_execution
# environment variables environment_variables
# error traceback error_traceback
# executable images executable_images
# string invocation string_invocation
# expandable regions expandable_regions
#
#
# Command-Line Options:
# ---------------------
#
# The following options to ipp are recognized:
#
# -C By default ipp strips Icon-style comments. If this option
# is specified all comments are passed along except those
# found on ipp command lines (lines starting with a '$'
# command).
#
# -D name
# -D name=def Allows the user to define a name on the command line instead
# of using a $define command in a source file. In the first
# form the name is defined as '1'. In the second form name is
# defined as the text following the equal sign. This is less
# powerful than the $define command line since def can not
# contain any white space (spaces or tabs).
#
# -d depth By default ipp allows include files to be nested to a depth
# of ten. This allows the preprocessor to detect infinitely
# recursive include sequences. If a different limit for the
# nesting depth is needed it may changed by using this option
# with an integer argument greater than zero. Also, if a file
# is found to already be in a nested include sequence an
# error message is written regardless of the limit.
#
# -I dir The following algorithm is normally used in searching for
# $include files. On a UNIX system names enclosed in "" are
# searched for by trying in order the directories specified by the
# PATH environment variable, and names enclosed in <> are always
# expected to be in the /usr/icon/src directory. On other systems
# names enclosed in <> are searched for by trying in order the
# directories specified by the IPATH environment variable; names
# in "" are searched for in a similar fashion, except that the
# current directory is tried first. If the -I option is given the
# directory specified is searched before the 'standard'
# directories. If this option is specified more than once the
# directories specified are tried in the order that they appear on
# the command line, then followed by the 'standard' directories.
#
# Preprocessor commands:
# ----------------------
#
# All ipp commands start with a line that has '$' as its first non-space
# character. The name of the command must follow the '$'. White space
# (any number of spaces or tabs) may be used to separate the '$' and the
# command name. Any line beginning with a '$' and not followed by a valid
# name will cause an error message to be sent to standard error and
# termination of the preprocessor. If the command requires an argument then
# it must be separated from the command name by white space otherwise the
# argument will be considered part of the name and the result will likely
# produce an error. In processing the $ commands ipp responds to exceptional
# conditions in one of two ways. It may produce a warning and continue
# processing or produce an error message and terminate. In both cases the
# message is sent to standard error. With the exception of error conditions
# encountered during the processing of the command line, the messages normally
# include the name and line number of the source file at the point the
# condition was encountered. Ipp was designed so that most exception
# conditions encountered will produce errors and terminate. This protects the
# user since warnings could simply be overlooked or misinterpreted.
#
# Many ipp command require names as arguments. Names must begin with a
# letter or an underscore, which may be followed by any number of letters,
# underscores, and digits. Icon-style comments may appear on ipp command
# lines, however they must be separated from the normal end of the command by
# white_space. If any extraneous characters appear on a command line a
# warning is issued. This occurs when characters other than white-space or a
# comment follow the normal end of a command.
#
# The following commands are implemented:
#
# $define: This command may be used in one of two forms. The first form
# only allows simple textual substitution. It would be invoked as
# '$define name text'. Subsequent occurrences of name are replaced
# with text. Name and text must be separated by one white space
# character which is not considered to be part of the replacement
# text. Normally the replacement text ends at the end of the line.
# The text however may be continued on the next line if the backslash
# character '\' is the last character on the line. If name occurs
# in the replacement text an error message (recursive textual substi-
# tution) is written.
#
# The second form is '$define name(arg,...,arg) text' which defines
# a macro with arguments. There may be no white space between the
# name and the '('. Each occurrence of arg in the replacement text
# is replaced by the formal arg specified when the macro is
# encountered. When a macro with arguments is expanded the arguments
# are placed into the expanded replacement text unchanged. After the
# entire replacement text is expanded, ipp restarts its scan for names
# to expand at the beginning of the newly formed replacement text.
# As with the first form above, the replacement text may be continued
# on following lines. The replacement text starts immediately after
# the ')'.
# The names of arguments must comply with the convention for regular
# names. See the section below on Macro processing for more
# information on the replacement process.
#
# $undef: Invoked as '$undef name'. Removes the definition of name. If
# name is not a valid name or if name is one of the reserved names
# _FILE_ or _LINE_ a message is issued.
#
# $include: Invoked as '$include <filename>' or '$include "filename"'. This
# causes the preprocessor to make filename the new source until
# end of file is reached upon which input is again taken from the
# original source. See the -I option above for more detail.
#
# $dump: This command, which has no arguments, causes the preprocessor to
# write to standard error all names which are currently defined.
# See '$ifdef' below for a definition of 'defined'.
#
# $warning:
# This command issues a warning, with the text coming from the
# argument field of the command.
#
# $error: This command issues a error, with the text coming from the
# argument field of the command. As with all errors, processing
# is terminated.
#
# $ifdef: Invoked as 'ifdef name'. The lines following this command appear
# in the output only if the name given is defined. 'Defined' means
# 1. The name is a predefined name and was not undefined using
# $undef, or
# 2. The name was defined using $define and has not been undefined
# by an intervening $undef.
#
# $ifndef: Invoked as 'ifndef name'. The lines following this command do
# not appear in the output if the name is not defined.
#
# $if: Invoked as 'if constant-expression'. Lines following this
# command are processed only if the constant-expression produces a
# result. The following arithmetic operators may be applied to
# integer arguments: + - * / % ^
#
# If an argument to one of the above operators is not an integer an
# error is produced.
#
# The following functions are provided: def(name), ndef(name)
# This allows the utility of $ifdef and $ifndef in a $if command.
# def produces a result if name is defined and ndef produces a
# result if name is not defined.
#
# The following comparison operators may be used on integer
# operands:
#
# > >= = < <= ~=
#
# Also provided are alternation (|), conjunction (&), and
# negation (not). The following table lists all operators with
# regard to decreasing precedence:
#
# not + - (unary)
# ^ (associates right to left)
# * / %
# + - (binary)
# > >= = < <= ~=
# |
# &
#
# The precedence of '|' and '&' are the same as the corresponding
# Icon counterparts. Parentheses may be used for grouping.
# Backtracking is performed, so that the expression
#
# FOO = (1|2)
#
# will produce a result precisely when FOO is either 1 or 2.
#
# $elif: Invoked as 'elif constant-expression'. If the lines preceding
# this command were processed, this command and the lines following
# it up to the matching $endif command are ignored. Otherwise,
# the constant-expression is evaluated, and the lines following this
# command are processed only if it produces a result.
#
# $else: This command has no arguments and reverses the notion of the
# test command which matches this directive. If the lines preceding
# this command where ignored the lines following are processed, and
# vice versa.
#
# $endif: This command has no arguments and ends the section of lines
# begun by a test command ($ifdef, $ifndef, or $if). Each test
# command must have a matching $endif.
#
# Macro Processing and Textual Substitution
# -----------------------------------------
# No substitution is performed on text inside single quotes (cset literals)
# and double quotes (strings) when a line is processed. The preprocessor
# will # detect unclosed cset literals or strings on a line and issue an
# error message unless the underscore character is the last character on the
# line. The output from
#
# $define foo bar
# write("foo")
#
# is
#
# write("foo")
#
# Unless the -C option is specified comments are stripped from the source.
# Even if the option is given the text after the '#' is never expanded.
#
# Macro formal parameters are recognized in $define bodies even inside cset
# constants and strings. The output from
#
# $define test(a) "a"
# test(processed)
#
# is the following sequence of characters: "processed".
#
# Macros are not expanded while processing a $define or $undef. Thus:
#
# $define off invalid
# $define bar off
# $undef off
# bar
#
# produces off. The name argument to $ifdef or $ifndef is also not expanded.
#
# Mismatches between the number of formal and actual parameters in a macro
# call are caught by ipp. If the number of actual parameters is greater than
# the number of formal parameters is error is produced. If the number of
# actual parameters is less than the number of formal parameters a warning is
# issued and the missing actual parameters are turned into null strings.
#
############################################################################
#
# The records and global variables used by ipp are described below:
#
# Src_desc: Record which holds the 'file descriptor' and name
# of the corresponding file. Used in a stack to keep
# track of the source files when $includes are used.
# Opt_rec Record returned by the get_args() routine which returns
# the options and arguments on the command line. options
# is a cset containing options that have no arguments.
# pairs is a list of [option, argument] pairs. ifile and
# ofile are set if the input or output files have been
# specified.
# Defs_rec Record stored in a table keyed by names. Holds the
# names of formal arguments, if any, and the replacement
# text for that name.
# Expr_node Node of a parse tree for $if / $elif expressions.
# Holds the operator, or a string representing the
# control structure. Also, holds a list of the args for
# the operation / control structure, which are either
# scalars or other Expr_node records.
# Chars Cset of all characters that may appear in the input.
# Defs The table holding the definition data for each name.
# Depth The maximum depth of the input source stack.
# Ifile Descriptor for the input file.
# Ifile_name Name of the input file.
# Init_name_char Cset of valid initial characters for names.
# Line_no The current line number.
# Name_char Cset of valid characters for names.
# Non_name_char The complement of the above cset.
# Ofile The descriptor of the output file.
# Options Cset of no-argument options specified on the command
# line.
# Path_list List of directories to search in for "" include files.
# Src_stack The stack of input source records.
# Std_include_paths List of directories to search in for <> include files.
# White_space Cset for white-space characters.
# TRUE Defined as 1.
#
############################################################################
record Src_desc(fd, fname, line)
record Opt_rec(options, pairs, ifile, ofile)
record Defs_rec(arg_list, text)
record Expr_node(op, arg)
global Chars, Defs, Depth, Ifile, Ifile_name, Init_name_char,
Line_no, Name_char, Non_name_char, Ofile, Options, Path_list,
Src_stack, Std_include_paths, White_space, TRUE, DIR_SEP
procedure main(arg_list)
local line, source
init(arg_list)
repeat {
while line := get_line(Ifile) do
line ? process_cmd(get_cmd())
# Get new source
close(Ifile)
if source := pop(Src_stack) then {
Ifile := source.fd
Ifile_name := source.fname
Line_no := source.line
}
else break
}
end
procedure conditional(expr)
return if eval(expr) then
true_cond()
else
false_cond()
end
#
# In order to simplify the parsing the four operators that are longer
# than one character (<= ~= >= not) are replaced by one character
# 'aliases'. Also, all white space is removed.
#
procedure const_expr(expr)
local new
static White_space_plus
initial White_space_plus := White_space ++ '<>~n'
new := ""
expr ? {
while new ||:= tab(upto(White_space_plus)) ||
if any(White_space) then {
tab(many(White_space))
""
}
else if =">=" then "\x01"
else if ="<=" then "\x02"
else if ="~=" then "\x03"
else if not any(Name_char, ,&pos - 1) &
="not" &
not any(Name_char) then "\x04"
else move (1)
new ||:= tab(0)
}
#
# Now recursively parse the transformed string.
#
return parse(new)
end
procedure decoded(op)
return case op of {
"\x01": ">="
"\x02": "<="
"\x03": "~="
"\x04": "not"
default: op
}
end
procedure def_opt(s)
local name, text
s ? {
name := tab(find("=")) | tab(0)
text := (move(1) & tab(0)) | "1"
}
if name == ("_LINE_" | "_FILE_") then
error(name, " is a reserved name and can not be redefined by the -D option")
if not name ? (get_name() & pos(0)) then
error(name, " : Illegal name argument to -D option")
if member(Defs, name) then
warning(name, " : redefined by -D option")
insert(Defs, name, Defs_rec(, text))
end
procedure define()
local args, name, text
get_opt_ws()
if name := get_name() & (any(White_space ++ '(') | pos(0)) then {
if name == ("_LINE_" | "_FILE_") then
error(name, " is a reserved name and can not be redefined")
if match("(") then # A macro
args := get_formals()
text := get_text(args)
if member(Defs,name) then
warning(name, " redefined")
insert(Defs, name, Defs_rec(args, text))
}
else
error("Illegal or missing name in define")
end
procedure dump()
if not pos(0) then
warning("Extraneous characters after dump command")
every write(&errout, (!sort(Defs))[1])
end
procedure error(s1, s2)
s1 ||:= \s2
stop(Ifile_name, ": ", Line_no, ": ", "Error ", s1)
end
procedure eval(node)
suspend case type(node) of {
"Expr_node": {
case node.op of {
"|" : eval(node.arg[1]) | eval(node.arg[2])
"&" : eval(node.arg[1]) & eval(node.arg[2])
"not" : not eval(node.arg[1])
"def" : member(Defs, node.arg[1])
"ndef" : not member(Defs, node.arg[1])
default :
case *node.arg of {
1 : node.op(eval(node.arg[1]))
2 : node.op(eval(node.arg[1]), eval(node.arg[2]))
}
}
}
default: node
}
end
procedure false_cond()
local cmd, line
# Skip to next $else / $elif branch, or $endif
cmd := skip_to("elif", "else", "endif")
case cmd of {
"elif" : return if_cond(cmd)
"else" : {
while line := get_line(Ifile) do
line ? {
cmd := get_cmd()
case cmd of {
"elif" :
error("'elif' encountered after 'else'")
"else" :
error("multiple 'else' sections")
"endif" : return
default : process_cmd(cmd)
}
}
error("'endif' not encountered before end of file")
}
"endif": return
}
end
procedure find_file(fname, path_list)
local ifile, ifname, path
every path := !path_list do {
ifname :=
if path == ("" | ".") then
fname
else
path || DIR_SEP || fname
if ifile := open(ifname) then {
if *Src_stack >= Depth then {
close(ifile)
error("Possibly infinitely recursive file inclusion")
}
if ifname == (Ifile_name | (!Src_stack).fname) then
error("Infinitely recursive file inclusion")
push(Src_stack, Src_desc(Ifile, Ifile_name, Line_no))
Ifile := ifile
Ifile_name := ifname
Line_no := 0
return
}
}
error("Can not open include file ", fname)
end
procedure func(expr)
local op, arg
expr ? {
if op := tab(find("(")) & move(1) &
arg := get_name() & =")" & pos(0) then {
if op == ("def" | "ndef") then
return Expr_node(op, [arg])
else
error("Invalid function name")
}
}
end
procedure get_args(arg_list, simple_opts, arg_opts)
local arg, ch, get_ofile, i, opts, queue
opts := Opt_rec('', [])
queue := []
every arg := arg_list[i := 1 to *arg_list] do
if arg == "-" then # Next argument should be output file
get_ofile := (i = *arg_list - 1) |
stop("Invalid position of '-' argument")
else if arg[1] == "-" then # Get options
every ch := !arg[2: 0] do
if any(simple_opts, ch) then
opts.options ++:= ch
else if any(arg_opts, ch) then
put(queue, ch)
else
stop("Invalid option - ", ch)
else if ch := pop(queue) then # Get argument for option
push(opts.pairs, [ch, arg])
else if \get_ofile then { # Get output file
opts.ofile := arg
get_ofile := &null
}
else { # Get input file
opts.ifile := arg
get_ofile := (i < *arg_list)
}
if \get_ofile | *queue ~= 0 then
stop("Invalid number of arguments")
return opts
end
procedure get_cmd()
local cmd
static no_arg_cmds
initial no_arg_cmds := set(["dump", "else", "endif"])
if ="#" & cmd := ="line" then
get_opt_ws()
else if (get_opt_ws()) & ="$" then {
get_opt_ws()
(cmd := tab(many(Chars))) | error("Missing command")
get_opt_ws()
if not pos(0) & member(no_arg_cmds, cmd) then
warning("Extraneous characters after argument to '" || cmd || "'")
}
else
tab (1)
return cmd
end
procedure get_formals()
local formal, arglist, ch
arglist := []
="("
get_opt_ws()
if not =")" then
repeat {
if (formal := get_name()) & get_opt_ws() & any(',)') then
put(arglist, formal)
else
error("Invalid formal argument in macro definition")
if =")" then break
=","
get_opt_ws()
}
get_opt_ws()
return arglist
end
procedure get_line(Ifile)
return 1(read(Ifile), Line_no +:= 1)
end
procedure get_name()
return tab(any(Init_name_char)) || (tab(many(Name_char)) | "")
end
procedure get_opt_ws()
return (tab(many(White_space)) | "") || (="#" || tab(0) | "")
end
procedure get_text(is_macro)
local text
if \is_macro then
text := tab(0)
else
text := (tab(any(White_space)) & tab(0)) | ""
while (text[-1] == "\\") do
(text := text[1:-1] || get_line(Ifile)) |
error("Continuation line not found before end of file")
return text
end
# if_cond is the procedure for $if or $elif.
#
# Procedure true_cond is invoked if the evaluation of a previous $if, $ifdef, or
# $ifndef causes subsequent lines to be processed. Lines will be processed
# upto an $elif, $else, or $endif. If $elif or $else is encountered, lines
# are skipped until the matching $endif is encountered.
#
# Procedure false_cond is invoked if the evaluation of a previous $if, $ifdef,
# or $ifndef causes subsequent lines to be skipped. Lines will be skipped
# upto an $elif, $else, or, $endif. If $else is encountered, lines are
# processed until the $endif matching the $else is encountered.
procedure if_cond(cmd)
if pos(0) then
error("Constant expression argument to '" || cmd || "' missing")
else
return conditional(const_expr(tab(0)))
end
procedure ifdef()
local name
if name := get_name() then
{
get_opt_ws()
if not pos(0) then
warning("Extraneous characters after argument to 'ifdef'")
return conditional(Expr_node("def", [name]))
}
else
error("Argument to 'ifdef' is not a valid name")
end
procedure ifndef()
local name
if name := get_name() then {
get_opt_ws()
if not pos(0) then
warning("Extraneous characters after argument to 'ifndef'")
return conditional(Expr_node("ndef", [name]))
}
else
error("Argument to 'ifndef' is not a valid name")
end
procedure in_text(name, text)
return text ?
tab(find(name)) &
(if move(-1) then tab(any(Non_name_char)) else "") &
move(*name) &
(tab(any(Non_name_char)) | pos(0))
end
procedure include()
local ch, fname
static fname_chars, stopper
initial {
fname_chars := Chars -- '<>"'
stopper := table()
insert(stopper, "\"", "\"")
insert(stopper, "<", ">")
}
if (ch := tab(any('"<'))) &
(fname := tab(many(fname_chars))) &
=stopper[ch] then {
get_opt_ws()
if not pos(0) then
warning("Extraneous characters after include file name")
find_file(fname,
case ch of {
"\"" : Path_list
"<" : Std_include_paths
}
)
}
else
error("Missing or invalid include file name")
end
procedure init(arg_list)
local s
TRUE := 1
Defs := table()
Init_name_char := &letters ++ '_'
Name_char := Init_name_char ++ &digits
Non_name_char := ~Name_char
White_space := ' \t\b'
Chars := &ascii -- White_space
Line_no := 0
Depth := 10
# Predefine features
every s := &features do {
s := map(s, " -/", "___")
insert(Defs, s, Defs_rec(, "1"))
}
# Set path list for $include files given in "", <>
if member(Defs, "UNIX") then {
Path_list := []
getenv("PATH") ? while put(Path_list, 1(tab(find(":")), move(1)))
Std_include_paths := ["/usr/icon/src"]
}
else {
Std_include_paths := []
(getenv("IPATH") || " ") ?
while put(Std_include_paths, tab(find(" "))) do move(1)
Path_list := [""] ||| Std_include_paths
}
process_options(arg_list)
end
procedure lassoc(expr, op)
local j, arg1, arg2
expr ? {
every j := bal(op)
# Succeeds if op found.
if arg1 := tab(\j) & op := decoded(move(1)) & arg2 := tab(0) then {
op := proc(op, 2) # Fails for control structures
return Expr_node(op, [parse(arg1), parse(arg2)])
}
}
end
#
# Programmer's note: Ifile_name and Line_no should not be assigned new
# values until the very end, so that if there is an error, the error
# message will include the file/line no of the current line directive,
# instead of the file/line of the text that follows the directive.
#
procedure line()
local new_line, new_file
new_line := tab(many(&digits)) | error("No line number in line directive")
get_opt_ws()
if ="\"" then {
new_file := ""
#
# Get escaped chars. We assume that the only escaped chars
# appearing in a file name would be \\ or \", where the actual
# character to be used is simply the character following the slash.
# In the unlikely event that other escape sequences are encountered,
# this section would have to revised.
#
while new_file ||:= tab(find("\\")) || (move(1) & move(1))
new_file ||:= tab(find("\"")) |
error("Invalid file name in line directive")
}
Line_no := integer(new_line)
Ifile_name := \new_file
return
end
procedure macro_call(entry, args)
local i, value, result, token
value := table()
every i := 1 to *entry.arg_list do
insert(value, entry.arg_list[i], args[i] | "")
entry.text ? {
result := tab(upto(Name_char) | 0)
while token := tab(many(Name_char)) do {
result ||:= \value[token] | token
result ||:= tab(many(Non_name_char))
}
}
return result
end
procedure no_endif_error()
error("'endif' not encountered before end of file")
end
procedure parse(expr)
# strip surrounding parens.
while expr ?:= 2(="(", tab(bal (')')), pos(-1))
return lassoc(expr, '&' | '|') |
lassoc(expr, '<=>\x01\x02\x03' | '+-' | '*/%') |
rassoc(expr, '^') |
unary(expr, '+-\x04') |
func(expr) |
integer(process_text(expr)) |
error(expr, " : Integer expected")
end
procedure process_cmd(cmd)
static last_cmd
initial last_cmd := ""
case cmd of {
"dump" : dump()
"define" : define()
"undef" : undefine()
"include" : include()
"line" : line()
"error" : error(tab(0))
"warning" : warning(tab(0))
"if" : if_cond( last_cmd := cmd )
"ifdef" : ifdef( last_cmd := cmd )
"ifndef" : ifndef( last_cmd := cmd )
"elif" |
"else" |
"endif" : error("No previous 'if' expression")
&null : {
if \last_cmd then
put_linedir(Ofile, Line_no, Ifile_name)
write(Ofile, process_text(tab(0)))
}
default : error("Undefined command")
}
last_cmd := cmd
return
end
procedure process_macro(name, entry, s)
local arg, args, new_entry, news, token
s ? {
args := []
if ="(" then {
#
# Get args if list is not empty.
#
get_opt_ws ()
if not =")" then
repeat {
arg := get_opt_ws()
if token := tab(many(Chars -- '(,)')) then {
if /(new_entry := Defs[token]) then
arg ||:= token
else if /new_entry.arg_list then
arg ||:= new_entry.text
else { # Macro with arguments
if news := tab(bal(White_space ++ ',)')) then
arg ||:= process_macro(token, new_entry, news)
else
error(token, ": Error in arguments to macro call")
} # if
} # if
else if not any(',)') then
error(name, ": Incomplete macro call")
arg ||:= tab(many(White_space))
put(args, arg)
if match(")") then
break
move(1)
} # repeat
if *args > *entry.arg_list then
error(name, ": Too many arguments in macro call")
else if *args < *entry.arg_list then
warning(name, ": Missing arguments in macro call")
return macro_call(entry, args)
} # if
}
end
procedure process_options(arg_list)
local args, arg_opts, pair, simple_opts, tmp_list, value
simple_opts := 'C'
arg_opts := 'dDI'
Src_stack := []
args := get_args(arg_list, simple_opts, arg_opts)
if \args.ifile then {
(Ifile := open(args.ifile)) | stop("Can not open input file ", args.ifile)
Ifile_name := args.ifile
}
else {
Ifile := &input
Ifile_name := "stdin"
}
if \args.ofile then
(Ofile := open(args.ofile, "w")) | stop("Can not open output file",
args.ofile)
else
Ofile := &output
Options := args.options
tmp_list := []
every pair := !args.pairs do
case pair[1] of {
"D": def_opt(pair[2])
"d": if (value := integer(pair[2])) > 0 then
Depth := value
else
stop("Invalid argument for depth")
"I": push(tmp_list, pair[2])
}
Path_list := tmp_list ||| Path_list
end
procedure process_text(line)
local add, entry, new, position, s, token
static in_string, in_cset
new := ""
while *line > 0 do {
add := ""
line ?:= {
if \in_string then {
# Ignore escaped chars
while new ||:= tab(find("\\")) || move(2)
if new ||:= tab(find("\"")) || move(1) then
in_string := &null
else {
new ||:= tab(0)
if line[-1] ~== "_" then {
in_string := &null
warning("Unclosed double quote")
}
}
}
else if \in_cset then {
# Ignore escaped chars.
while new ||:= tab(find("\\")) || move(2)
if new ||:= (tab(find("'")) || move(1)) then
in_cset := &null
else {
new ||:= tab(0)
if line[-1] ~== "_" then {
in_cset := &null
warning("Unclosed single quote")
}
}
}
new ||:= tab(many(White_space))
case token := tab(many(Name_char) | any(Non_name_char)) of {
"\"": {
new ||:= "\""
if \in_string then
in_string := &null
else if not pos(0) then {
in_string := TRUE
}
else {
warning("Unclosed double quote")
}
add ||:= tab(0)
}
"'": {
new ||:= "'"
if \in_cset then
in_cset := &null
else if not pos(0) then {
in_cset := TRUE
}
else {
warning("Unclosed double quote")
}
add ||:= tab(0)
}
"#": {
new ||:= if any(Options, 'C') then token || tab(0)
else tab(0) & token ? tab(find("#"))
}
"__LINE__":
new ||:= Line_no
"__FILE__":
new ||:= Ifile_name
default: {
if /(entry := Defs[token]) then
new ||:= token
else if /entry.arg_list then
if in_text(token, entry.text) then
error("Recursive textual substitution")
else
add := entry.text
else { # Macro with arguments
s := tab(bal(White_space) | 0)
if not any('(', s) then
error(token, ": Incomplete macro call")
add := process_macro(token, entry, s)
}
} # default
} # case
add || tab(0)
} # ?:=
} # while
return new
end
procedure put_linedir(Ofile, Line_no, Ifile_name)
static last_filename
initial last_filename := ""
writes(Ofile, "#line ", Line_no - 1)
#
# Output file name part only if the
# filename differs from the last one used.
#
if last_filename ~==:= Ifile_name then
writes(Ofile, " ", image(last_filename))
write(Ofile)
return
end
procedure rassoc(expr, op)
local arg1, arg2
# Succeeds if op found.
expr ? if arg1 := tab(bal(op)) & op := move(1) & arg2 := tab(0) then {
op := decoded(op)
op := proc(op, 2) # Fails for control structures
return Expr_node(op, [parse(arg1), parse(arg2)])
}
end
#
# skip_to is used to skip over parts of the an '$if' structure. targets
# are the $if - related commands to skip to, and should always include
# "endif".
#
# We do not, of course, wish to skip to a command in an $if structure
# that is embedded in the current one; also, we want to make sure that
# embedded $if structures, even in skipped lines, are well formed. We
# therefore maintain a stack, if_sects, of the currently applicable $if
# structure commands encountered in the skipped lines. For example, if
# we have skipped over the commands
#
# $ifdef ...
# $if ...
# $elif ...
# $if ...
# $else
#
# if_sect would be ["else", "elif", "ifdef"].
#
procedure skip_to(targets[])
local cmd, if_sects, line, argpos
if_sects := []
while line := get_line(Ifile) | no_endif_error () do
line ? {
cmd := get_cmd()
if *if_sects = 0 & \cmd == !targets then {
argpos := &pos
break
}
case cmd of {
"if" |
"ifdef" |
"ifndef" : {
if pos(0) then
error("Argument to '" || cmd || "' missing")
push(if_sects, cmd)
}
"elif" : {
if pos(0) then
error("Argument to '" || cmd || "' missing")
if if_sects[1] == "else" then
error("'elif' encountered after 'else'")
else
if_sects[1] := cmd
}
"else" : {
if if_sects[1] == "else" then
error("multiple 'else' sections")
else
if_sects[1] := cmd
}
"endif" : pop(if_sects)
}
}
#
# Now reset the &subject to the current line, and &pos to the argument
# field of the current line, so that if we skipped to a line which will
# require further processing (such as $elif), the scanning functions can
# be used.
#
&subject := line
&pos := argpos
return cmd
end
procedure true_cond()
local cmd, line
while line := get_line(Ifile) | no_endif_error () do
line ? {
case cmd := get_cmd() of {
"elif" |
"else" : return skip_to("endif")
"endif" : return cmd
default : process_cmd(cmd)
}
}
end
procedure unary(expr, op)
local arg1
# Succeeds if op found.
expr ?
if op := decoded(tab(any(op))) & arg1 := tab(0) then {
op := proc(op, 1) # fails for control structures
return Expr_node(op, [parse(arg1)])
}
end
procedure undefine()
local name
if name := get_name() then {
get_opt_ws()
if not pos(0) then
warning("Extraneous characters after argument to undef")
if name == ("_LINE_" | "_FILE_") then
error(name, " is a reserved name that can not be undefined")
delete(Defs, name)
}
else
error("Name missing in undefine")
end
procedure warning(s1, s2)
s1 ||:= \s2
write(&errout, Ifile_name, ": ", Line_no, ": ", "Warning " || s1)
end