A preprocessor for FORM. #bin #form

pform

#! /usr/bin/env perl

##
# @file pform
#
# pform - (pre)preprocessor of FORM
#

# Copyright (c) 2011 Takahiro Ueda
#
# Permission is granted for use, copying, modification, distribution,
# and distribution of modified versions of this work as long as the
# above copyright notice is included.
#
use 5.6.0;
use strict;
use warnings;
use integer;
use Getopt::Long qw/:config bundling_override no_ignore_case no_auto_abbrev/;
use Pod::Usage;

$main::VERSION  = '1.0.0 20111104';

my $APPNAME     = 'pFORM';
my $APPVER      = "$APPNAME $main::VERSION";

my $opt_help            = 0;         # show this help message and exit
my $opt_version         = 0;         # show version number and exit
my $opt_verbose         = 0;         # enable verbose output
my $opt_warn_error      = 0;         # turn warnings into errors
my $opt_output          = undef;     # place the output into FILE (used with -E)
my $opt_preprocess_only = 0;         # preprocess only
my $opt_optimize        = 0;         # optimize FORM source
my $opt_keep_lineno     = 0;         # keep line numbers as possible
my $opt_save_temps      = 0;         # do not delete all temporary files
my $opt_deprecated      = 0;         # warn deprecated features
my $opt_quiet           = 0;         # suppress all normal output
my $opt_form            = undef;     # specify FORM binary

my @opt_formopt         = ();        # options for invoking FORM program

my @opt_includes        = ();        # include pathes (-I PATH, -p PATH)
my $opt_tmppath         = undef;     # path to temporary directory (-t PATH)
my $opt_multithreaded   = 0;         # multithreaded or not (-w N)

my $opt_printf          = 'printf';  # The printf command.
my $opt_perl            = 'perl';    # The perl command.
my $opt_namespace_sep   = '';        # The default value of the namespace separator.
my $opt_comment_char    = '*';       # The "CommentChar" which we assume.
my $opt_always_assert   = 1;         # Use assertion even if no-debug mode.
my $opt_comment         = 1;         # Generates additional comments.

# Prototypes.

sub error($);
sub warning($);
sub verbose($);

sub open_file($);
sub close_file($);

sub trim_str($);
sub trim_LF($);
sub get_localtime_str();
sub change_file_ext($$);
sub canon_path($);

sub get_full_filename($);
sub get_target_filename($);
sub delete_tempfiles();

sub get_first_source_file();
sub get_next_source_file();
sub add_source_file($);

sub parse_opts();
sub invoke_form($);
sub preprocess(;$$);
sub main();

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

my $g_program_name     = "\L$APPNAME";
my $g_current_filename = undef;
my $g_current_lineno   = 0;

{
	use File::Basename qw/basename/;
	my $s = basename($0);
	if ($s ne '') {
		$g_program_name = $s;
	}
}

##
# Shows the error message and terminates the program.
#
# Usage:
#   error($message)
#
sub error($) {
	my $str = shift || '';

	if (defined($g_current_filename)) {
		if ($g_current_lineno >= 1) {
			die "$g_program_name:$g_current_filename:$g_current_lineno: error: $str\n";
		} else {
			die "$g_program_name:$g_current_filename: error: $str\n";
		}
	} else {
		die "$g_program_name: error: $str\n";
	}
}

##
# Shows the warning message.
#
# Usage:
#   warning($message)
#
sub warning($) {
	my $str = shift;

	if ($opt_warn_error) {
		error($str);
		return;
	}

	if (defined($g_current_filename)) {
		if ($g_current_lineno >= 1) {
			print STDERR "$g_program_name:$g_current_filename:$g_current_lineno: warning: $str\n";
		} else {
			print STDERR "$g_program_name:$g_current_filename: warning: $str\n";
		}
	} else {
		print STDERR "$g_program_name: warning: $str\n";
	}
}

##
# Does verbose output.
#
# Usage:
#   verbose($message)
#
sub verbose($) {
	if (! $opt_verbose) {
		return;
	}

	my $str = shift;

	if ($g_current_filename) {
		print STDERR "$g_program_name:$g_current_filename:$g_current_lineno: $str\n";
	} else {
		print STDERR "$g_program_name: $str\n";
	}
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

my %opened_file_handles = ();

##
# Opens a file and returns the file handle.
#
# Usage:
#   $fh = open_file($filename)
#
sub open_file($) {
	my $filename = shift;

	my $filename_body = $filename;
	   $filename_body =~ s/^[<>\+\-\|\s]*//;

	# In some cases, `open' with writing mode failed if filename exists
	# with different case, but the file can be deleted, so we try to
	# delete the output file.

#	if ($filename =~ /^\s*>[^<>\+\-\|\s]/) {
#		unlink $filename_body;
#	}

	open(my $fh, $filename) or error(qq/cannot open "$filename_body" ($!)/);

	# Set BINMODE for output, which may be needed in Windows.

#	if ($BIN_MODE) {
#		binmode $fh;
#	}

	$opened_file_handles{$fh} = $filename_body;

	return $fh;
}

##
# Closes a file explicitly.
#
# Usage:
#   close_file($fh)
#
sub close_file($) {
	my $fh       = shift;
	my $filename = '';

	if (defined($opened_file_handles{$fh})) {
		$filename = $opened_file_handles{$fh};
		delete $opened_file_handles{$fh};
	}

	if (! close($fh)) {
		if ($filename) {
			warning(qq/cannot close "$filename" ($!)/);
		} else {
			warning(qq/cannot close a file handle ($!)/);
		}
	}
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

##
# Removes leading and trailing spaces.
#
# Usage:
#   $new_str = trim_str($str)
#
sub trim_str($) {
	my $str = shift;

	$str =~ s/^\s+//;
	$str =~ s/\s+$//;

	return $str;
}

##
# Removes trailing linefeed code.
#
# Usage:
#   $new_str        = trim_LF($str)
#   ($new_str, $LF) = trim_LF($str)
#
sub trim_LF($) {
	my $str = shift;

	if (wantarray) {
		if ($str =~ s/(\x0D?\x0A?)$//) {
			return ($str, $1);
		} else {
			return ($str, '');
		}
	} else {
		$str =~ s/\x0D?\x0A?$//;
		return $str;
	}
}

##
# Returns a string representing the current local time.
#
# Usage:
#   $localtime_str = get_localtime_str()
#
sub get_localtime_str() {
	use Time::Local;

	my $now = time();
	my $off = (timegm(localtime($now)) - timegm(gmtime($now))) / 60;

	return localtime($now) . ' ' . sprintf("(%+03d:%02d)", $off / 60, $off % 60);
}

##
# Returns the filename with changing its extension.
#
# Usage:
#   $new_filename = change_file_ext($filename, $new_ext)
#
sub change_file_ext($$) {
	use File::Basename qw/basename fileparse/;

	my $filename = shift;
	my $new_ext  = shift;

	my ($name, $path) = fileparse($filename, qr/\.[^.]*/);

	if (basename($filename) eq $filename) { # $path == $curdir . $path_separator
		$path = '';
	}

	return $path . $name . $new_ext;
}

##
# Canonicalize the file path, i.e., "foo" -> "foo/".
#
# Usage:
#   $new_path = canon_path($path)
#
sub canon_path($) {
	my $path = shift;

	# XXX: System dependent path separator.

	if ($path ne '' && $path !~ m|/$|) {
		$path .= '/';
	}

	return $path;
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

sub get_full_filename_suppl($);

my $self_path = undef;  # Path of the pFORM.

##
# Resolves/finds the full filename, e.g., `foo' -> `foo.frm'.
#
# Usage:
#   $full_filename = get_full_filename($filename)
#
sub get_full_filename($) {
	my $s = shift;
	my $file;

	# Search in the current directory.

	$file = get_full_filename_suppl($s);
	if (defined($file)) {
		verbose(qq/search a file "$s"...found as "$file"/);
		return $file;
	}

	# Search in the include path.

	foreach (@opt_includes) {
		$file = get_full_filename_suppl($_ . $s);
		if (defined($file)) {
			verbose(qq/search a file "$s"...found as "$file"/);
			return $file;
		}
	}

	# Search in the pFORM directory.

	if (! defined($self_path)) {
		use File::Basename qw/fileparse/;
		my ($name, $path) = fileparse($0);
		$self_path = $path;
	}

	$file = get_full_filename_suppl($self_path . $s);
	if (defined($file)) {
		verbose(qq/search a file "$s"...found as "$file"/);
		return $file;
	}

	# The file is not found. Return the original file name, anyway.

	verbose(qq/search a file "$s"...not found/);
	return $s;
}

sub get_full_filename_suppl($) {

#	Helper function for checking files with some extensions.

	my $s = shift;
	my $file;

	if (-f ($file = $s)) {
		return $file;
	}

	if (-f ($file = $s . '.frm')) {
		return $file;
	}

#	if (-f ($file = $s . '.FRM')) {
#		return $file;
#	}

	return undef;
}

##
# The cache table for translating the source file to the target
# (temporary source file for FORM).
#
my %source_table  = ();

##
# The unique suffix for the temporary files for this process.
#
my $unique_suffix = undef;

##
# The path to the directory for temporary files.s
#
my $tmppath = undef;

##
# Returns the (temporary) target file name, which is generated
# from the source file name.
#
# Usage:
#   $dst_file = get_target_filename($src_file)
#
sub get_target_filename($) {
	my $src_file = shift;

	if ( defined($source_table{$src_file}) ) {
		# Cached. Return it.
		return $source_table{$src_file};
	}

	# This is new source file.

	use File::Basename qw/fileparse/;
	my ($name, undef, $ext) = fileparse($src_file, qr/\.[^.]*/);

	# Create the temporary directory.

	if (! defined($tmppath)) {
		use File::Temp qw/tempdir/;
		# TODO: The temporary directory name is too long in some system ?
		$tmppath = tempdir('tmp_pform_XXXXXXXXXX', DIR => defined($opt_tmppath) ? $opt_tmppath : undef, CLEANUP => $opt_save_temps ? 0 : 1);
		$tmppath = canon_path($tmppath);

		verbose(qq/temporary files are in "$tmppath"/);
	}

	# Find an available temporary file name.

	my $dst_file = "$tmppath$name$ext";

	my $unique_no = 1;

	while (-e $dst_file) {
		$dst_file = "$tmppath$name-$unique_no$ext";
	}

	# XXX: timing ?

	verbose(qq/create a temporary file "$dst_file" for "$src_file"/);
	open(my $fh, ">$dst_file") or error(qq/cannot create "$dst_file" ($!)/);
	close($fh) or warning(qq/cannot close "$dst_file" ($!)/);

	# Register the new target to $source_table, and return it.

	return $source_table{$src_file} = $dst_file;
}

##
# Deletes all temporary files (registered targets in %source_table and
# FORM log files).
#
# Usage:
#   delete_tempfiles();
#
sub delete_tempfiles() {
	use File::Copy qw/copy move/;

	foreach my $src (keys(%source_table)) {
		my $tmp = $source_table{$src};

		if (! $opt_save_temps) {
#			verbose(qq/delete a temporary file "$tmp"/);
			unlink $tmp;
		}

		my $src_log = change_file_ext($src, '.log');
		my $tmp_log = change_file_ext($tmp, '.log');

		if (-e $tmp_log) {
			if (! $opt_save_temps) {
				verbose(qq/rename a temporary log file "$tmp_log" to "$src_log"/);
				move($tmp_log, $src_log) or warning(qq/cannot rename the file "$tmp_log" to "$src_log" ($!)/);
			} else {
				verbose(qq/copy a temporary log file "$tmp_log" to "$src_log"/);
				copy($tmp_log, $src_log) or warning(qq/cannot copy the file "$tmp_log" to "$src_log" ($!)/);
			}
		}
	}

	%source_table = ();
}

##
# Finallization/signals.
#
END { delete_tempfiles(); }

$SIG{HUP} = $SIG{INT} = $SIG{PIPE} = $SIG{QUIT} = $SIG{TERM} = sub { delete_tempfiles(); exit(1); };

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

my @source_file_list = (); # The list of source files.
my $source_file_index = 0; # The current position in the source list.

##
# Returns the first source file, which is registered by `add_source_file'.
#
# Usage:
#   $first_source = get_first_source_file()
#
sub get_first_source_file() {
	if (@source_file_list == 0) {
		return undef;
	}
	return $source_file_list[0];
}

##
# Returns the next source file, which is registered by `add_source_file'.
#
# Usage:
#   $next_source = get_next_source_file()
#
sub get_next_source_file() {
	if ($source_file_index > $#source_file_list) {
		return undef;
	}
	return $source_file_list[$source_file_index ++];
}

##
# Registers the source file to the list.
#
# Usage:
#   add_source_file($src_file)
#
sub add_source_file($) {
	my $src = shift;

	if (grep { $src eq $_ } @source_file_list) {
		return;
	}

	push @source_file_list, $src;
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

##
# Parses command line options.
#
# Usage:
#   parse_opts()
#
sub parse_opts() {
	my @ARGV_ = @ARGV;

	GetOptions(
		'help|h'            => \$opt_help,
		'version|V'         => \$opt_version,
		'verbose!'          => \$opt_verbose,
		'v'                 => \$opt_verbose,
		'warn-error!'       => \$opt_warn_error,
		'W'                 => \$opt_warn_error,
		'output|o=s'        => \$opt_output,
		'preprocess-only!'  => \$opt_preprocess_only,
		'E'                 => \$opt_preprocess_only,
		'optimize!'         => \$opt_optimize,
		'O'                 => \$opt_optimize,
		'keep-lineno!'      => \$opt_keep_lineno,
		'k'                 => \$opt_keep_lineno,
		'save-temps!'       => \$opt_save_temps,
		'deprecated!'       => \$opt_deprecated,
		'quiet!'            => \$opt_quiet,
		'silent!'           => \$opt_quiet,
		'Q'                 => \$opt_quiet,
		'form|b=s'          => \$opt_form,
		'formopt|Wf=s'      => \@opt_formopt,

		# Options for FORM.

		'c'         => sub { push @opt_formopt, '-c' },
		'd=s'       => sub { push @opt_formopt, '-d', $_[1] },
		'D=s'       => sub { push @opt_formopt, '-D', $_[1] },
		'f'         => sub { push @opt_formopt, '-f' },
		'F'         => sub { push @opt_formopt, '-F' },
		'I=s'       => sub { push @opt_formopt, '-I', $_[1]; push @opt_includes, $_[1] },
		'l'         => sub { push @opt_formopt, '-l' },
		'll'        => sub { push @opt_formopt, '-ll' },
		'L'         => sub { push @opt_formopt, '-L' },
		'M'         => sub { push @opt_formopt, '-M' },
		'p=s'       => sub { push @opt_formopt, '-p', $_[1]; push @opt_includes, $_[1] },
		'pipe'      => sub { push @opt_formopt, '-pipe' },
		'q'         => sub { push @opt_formopt, '-q' },
		'R'         => sub { push @opt_formopt, '-R' },
		's=s'       => sub { push @opt_formopt, '-s', $_[1] },
		'si'        => sub { push @opt_formopt, '-si' },
		'S=s'       => sub { push @opt_formopt, '-S', $_[1] },
		't=s'       => sub { push @opt_formopt, '-t', $_[1]; $opt_tmppath = $_[1] },
		'T'         => sub { push @opt_formopt, '-T' },
		'w=n'       => sub { push @opt_formopt, '-w' . $_[1]; $opt_multithreaded = $_[1] >= 2 ? 1 : 0 },
		'y'         => sub { push @opt_formopt, '-y' },

		'i'         => sub { push @opt_formopt, '-i' },
		'm=n'       => sub { push @opt_formopt, '-m' . $_[1] },
		'n=n'       => sub { push @opt_formopt, '-n' . $_[1] },

		'debug!'    => sub { push @opt_formopt, $_[1] ? "-D DEBUG_ -D NDEBUG_=" : "-D DEBUG_= -D NDEBUG_"; },
		'g'         => sub { push @opt_formopt, "-D DEBUG_ -D NDEBUG_="; }
	) or pod2usage(2);

	# Default program for FORM.

	$opt_form = 'form' unless defined($opt_form);

	# If -w N is used, we try to use TFORM.

	if ($opt_multithreaded) {
		use File::Basename qw/basename fileparse/;
		my ($name, $path) = fileparse($opt_form);
		$name =~ s/^form/tform/;
		if (basename($opt_form) eq $opt_form) { # $path == $curdir . $path_separator
			$opt_form = $name;
		} else {
			$opt_form = $path . $name;
		}
	}

	# The environment variable FORMPATH.

	if (defined($ENV{FORMPATH})) {
		push @opt_includes, $ENV{FORMPATH};
	}

	# The environment variable FORMTMP.

	if (! defined($opt_tmppath) && defined($ENV{FORMTMP})) {
		$opt_tmppath = $ENV{FORMTMP};
	}

	# The default temporary directory.

	if (! defined($opt_tmppath)) {
		# XXX: System dependent current directory (?)
		$opt_tmppath = '';
	}

	# Canonicalize @opt_includes.

	foreach (@opt_includes) {
		$_ = canon_path($_);
	}

	# Canonicalize $opt_tmppath.

	$opt_tmppath = canon_path($opt_tmppath);

	# Show help.

	if ($opt_help) {
		if ($opt_verbose) {
			pod2usage(-exitstatus => 0, -verbose => 2);
		}
		pod2usage(0);
	}

	# Show version.

	if ($opt_version) {
		print "$APPVER\n";

		# Check FORM version.

		my $tmpf = get_target_filename('version.frm');
		my $fh = open_file(">$tmpf");
		print $fh <<'END';
#-
#if ("{2^32}" == "0") && ("{2^16}" != "0")
	#write "INTSIZE=32"
#elseif ("{2^64}" == "0") && ("{2^32}" != "0")
	#write "INTSIZE=64"
#endif
.end
END
		close_file($fh);

		eval {
			my $pH = open_file("$opt_form $tmpf |");
			my @str = <$pH>;
			close_file($pH);

			# Parse FORM output.

			my @s1 = grep { /FORM/; } @str;
			my @s2 = grep { /INTSIZE/; } @str;

			my $ver_name   = $opt_form;
			my $ver_number = '';
			my $ver_date   = '';
			my $ver_bits   = '';

			if (@s1) {
				$ver_name   = $s1[0];
				$ver_name   =~ s/ .*//;
				$ver_name   = trim_LF($ver_name);
				$ver_number = $s1[0];
				$ver_number =~ s/.*version *([^(]*).*/$1/;
				$ver_number = trim_LF($ver_number);
				$ver_date   = $s1[0];
				$ver_date   =~ s/.*\((.*)\).*/$1/;
				$ver_date   = trim_LF($ver_date);
			}
			if (@s2) {
				$ver_bits   = $s2[0];
				$ver_bits   =~ s/.*INTSIZE=(\d+).*/$1/;
				$ver_bits   = trim_LF($ver_bits);
			}
			my $str = $ver_name;
			if ($ver_number) {
				$str .= " version $ver_number";
			}
			if ($ver_date && $ver_bits) {
				$str .= " ($ver_date; ${ver_bits}bits)";
			} elsif ($ver_date) {
				$str .= " ($ver_date)";
			} elsif ($ver_bits) {
				$str .= " (${ver_bits}bits)";
			}

			print "[$str]\n";
		};

		exit(0);
	}

	# Print verbose information.

	verbose(qq/invoked as "$0 @{[ join(' ', @ARGV_) ]}"/);
	verbose(qq/include path: "@{[ join(';', @opt_includes) ]}"/);
}

##
# Invokes the FORM program with $src_file_name.
#
# Usage:
#   invoke_form($src_file_name)
#
sub invoke_form($) {
	my $src = shift;

	my @cmds = ($opt_form);    # The FORM program.
	push @cmds, @opt_formopt;  # Add options.
	push @cmds, $src;          # Add source file name.

	my $cmd = join(' ', @cmds);

	if ($opt_quiet) {
		# XXX: Unix-like OS.
		use File::Spec;
		$cmd .= ' > ' . File::Spec->devnull() . ' 2>&1';
	}

	verbose(qq/execute "$cmd"/);

	system $cmd;

	if ($? == -1) {
		error(qq/cannot execute "$cmd" ($!)/);
	}

	my $exit_value  = $? >> 8;
	my $signal_num  = $? & 0x7f;
	my $dumped_core = $? & 0x80;

	if ($dumped_core) {
		error(qq/core dumped: "$cmd" ($signal_num)/);
	}

	if ($signal_num) {
		error(qq/signal received: "$cmd" ($signal_num)/);
	}

	if ($exit_value) {
		verbose(qq/"$cmd" returned non-zero value ($exit_value)/);
		exit($exit_value);
	}
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

##
# The list of already preprocessed files for -E option.
#
my @preprocessed_files = ();

my @namespace;         # The stack for storing namespaces.
my $namespace_prefix;  # The variable prefix for the current namespace.
my $namespace_sep;     # The string for namespace separator.
my $comment_char;      # The charactor for comment lines.

my $printf_is_used;    # Flag for that printf is used.
my $perl_is_used;      # Flag for that perl is used.

sub is_legal_form_symbol($);
sub update_prefix();
sub piped_printf($$$);
sub piped_perl_printf($$$);
sub get_extra_options();

##
# Preprocess Processes $fh_in and outputs the result into $fh_out.
#
# Usage:
#   preprocess($fh_in, $fh_out)
#
sub preprocess(;$$) {
	my $IN  = shift || *STDIN;
	my $OUT = shift || *STDOUT;

	# FIXME: We process a line-at-a-time and therefore it is possible to
	#        falsely recognize the multi-line commands or statements.

	# FIXME: Some code bellow, $comment_char == '*' is assumed.

	# Initialize some variables.

	@namespace = ();
	$namespace_prefix = '';
	$namespace_sep    = $opt_namespace_sep;
	$comment_char     = $opt_comment_char;

	update_prefix();

	my @includes = ();   # See `#include'.
	my @requires = ();   # See `#require'.
	my @overloads = ();  # See `#overload'.

	my $line_count = 0;  # The line count excluding comments.
	my $proc_level = 0;  # The nest level of procedures.

	my $COMMENT_PREFIX  = $comment_char x 2 . " $g_program_name:";
	my $PRIVATE_PREFIX  = 'iNtErNaL';
	my $OVERLOAD_SUFFIX = 'ArGc';
	my $OVERLOAD_MAXARG = 'MaXaRg';

	my $LF = "\n";

	# The main loop.

	while (<$IN>) {
		$g_current_lineno ++;

		# Trim trailing LF. $LF will be overwritten.

		my $LF;
		($_, $LF) = trim_LF($_);

		# Empty line.

		if (/^\s*$/) {
			if (! $opt_keep_lineno && $opt_optimize) {
				next;
			}
			goto output_line;
		}

		# Comment line.

		if (substr($_, 0, 1) eq $comment_char) {

			# The lines starting with `*--#[' or `*--#]' have special
			# meaning.

			if ( /^\*--#[\[\]]/) {
				$line_count ++;
				goto output_line;
			}

			# Remove commentary inside procedures if possible.

			if ($opt_optimize && $proc_level > 0) {
				if ($opt_keep_lineno) {
					print $OUT "$LF";
				}
				next;
			}

			goto output_line;
		}

		# Here, the line is not empty/commentary.

		$line_count ++;

		# Escape characters, '\@' and '\:'.

		s/\\@/___pFORM_ESCAPED_ATMARK___/g;
		s/\\:/___pFORM_ESCAPED_COLON___/g;

		# Apply namespace.

		s/@/$namespace_prefix/g;
		s/::/$namespace_sep/g;

		# Restore escaped characters.

		s/___pFORM_ESCAPED_ATMARK___/@/g;
		s/___pFORM_ESCAPED_COLON___/:/g;

		# Optimizations.

		if ($opt_optimize) {
			# Remove irrevant spaces.

			if (/^\s+\*/) {  # Begins with ' s*'.
				s/^\s+//;
				$_ = ' ' . $_;  # We need at least one space before '*'.
			} else {
				s/^\s+//;
			}

			if (substr($_, 0, 1) ne '#') {  # Not preprocessor command.
				s/;\s*\*.*/;/;  # One-line comments after `;*'.
				s/\s+$//;       # Trailing spaces.
			} else {
				s/^#\s+/#/;     # spaces after `#'.
			}
		}

		##
		# Changes namespace separator.
		#
		# Syntax:
		#   #:namespacesep none
		#   #:namespacesep <separator>
		#
		if (s/^\s*#\s*\:\s*namespacesep\b//i) {
			if (! s/^\s*(\S+?)\b//) {
				error(qq/illegal usage of #:namespacesep/);
			}

			my $name = $1;

			if (! is_legal_form_symbol($name)) {
				error(qq/illegal namespace-separator "$name"/);
			}

			if ($name eq 'none') {
				$namespace_sep = '';
			} else {
				$namespace_sep = $name;
			}

			update_prefix();

			if ($opt_keep_lineno || ! $opt_optimize) {
				if ($opt_comment) {
					print $OUT qq/$COMMENT_PREFIX set namespace-separator to "$name"$LF/;
				} elsif ($opt_keep_lineno) {
					print $OUT "$LF";
				}
			}

			next;
		}

		##
		# Enters the namespace.
		#
		# Syntax:
		#   #namespace <namespace>
		#
		if (s/^\s*#\s*namespace\b//i) {
			if (! s/^\s*(\S+?)\b//) {
				error(qq/illegal usage of #namespace/);
			}

			my $name = $1;

			if (! is_legal_form_symbol($name)) {
				error(qq/illegal namespace "$name"/);
			}

			push @namespace, $name;
			update_prefix();

			if ($opt_keep_lineno || ! $opt_optimize) {
				if ($opt_comment) {
					print $OUT qq/$COMMENT_PREFIX namespace "$name"$LF/;
				} elsif ($opt_keep_lineno) {
					print $OUT "$LF";
				}
			}

			next;
		}

		##
		# Exits the namespace.
		#
		# Syntax:
		#   #endnamespace
		#
		if (s/^\s*#\s*endnamespace\b//i) {
			if ($#namespace < 0) {
				error(qq/#endnamespace without #namespace/);
			}

			if ($opt_keep_lineno || ! $opt_optimize) {
				if ($opt_comment) {
					my $name = join('::', @namespace);
					print $OUT qq/$COMMENT_PREFIX end of namespace "$name"$LF/;
				} elsif ($opt_keep_lineno) {
					print $OUT "$LF";
				}
			}

			pop @namespace;
			update_prefix();

			next;
		}

		##
		# Declares a file to be pre-processed.
		#
		# Syntax:
		#   #require <filename>
		#
		if (s/^\s*#\s*require\b//i) {
			my $file = trim_str($_);

			if ($file eq '') {
				error(qq/illegal usage of #require/);
			}

			my $file2 = get_full_filename($file);

			push @requires, $file2;

			if ($opt_keep_lineno || ! $opt_optimize) {
				if ($opt_comment) {
					my $name = join('::', @namespace);
					print $OUT qq/$COMMENT_PREFIX require "$file2"$LF/;
				} elsif ($opt_keep_lineno) {
					print $OUT "$LF";
				}
			}

			next;
		}

		##
		# Includes a file.
		#
		# Syntax:
		#   #include [+|-] <filename> [# <foldname>]
		#
		# (Intrinsic)
		#
		if (/^\s*#\s*include\b/i) {
			my $file = $_;

			$file =~ s/^\s*#\s*include\b\s*[+-]?\s*//i;
			$file =~ s/\s*#.*$//;

			my $file2 = get_full_filename($file);

			push @includes, $file2;

			if ($opt_preprocess_only) {
				# Remove #include if this file is already written to the output.
				if (grep { $_ eq $file2 } @preprocessed_files) {
					if ($opt_keep_lineno || ! $opt_optimize) {
						if ($opt_comment) {
							print $OUT qq/$COMMENT_PREFIX disabled: $_$LF/;
						} elsif ($opt_keep_lineno) {
							print $OUT "$LF";
						}
					}
					next;
				}
			} else {
				# If the included file is also processed, rewrite #include <filename>
				# as #include <preprocessed-filename>.
				my $target = get_target_filename($file2);
				if ($file ne $target && -e $file2) {
					s/$file/$target/;
				}
			}

			goto output_line;
		}

		##
		# Declares a procedure to be overloaded.
		#
		# Syntax:
		#   #overload <procname>
		#
		if (s/^\s*#\s*overload\b//i) {
			if (! s/^\s*(\S+?)\b//) {
				error(qq/illegal usage of #overload/);
			}

			my $name = $1;

			if (! is_legal_form_symbol($name)) {
				error(qq/illegal procedure name "$name"/);
			}

			# Check whether $name already exists.

			if (grep { $_ eq $name } @overloads) {
				warning(qq/duplicated procedure overload "$name"/);
				if ($opt_keep_lineno) {
					print $OUT "$LF";
				}
				next;
			}

			# This is new overloading.

			push @overloads, $name;

			my $prefix = $PRIVATE_PREFIX;

			my $a = "${PRIVATE_PREFIX}a";
			my $n = "${PRIVATE_PREFIX}n";
			my $i = "${PRIVATE_PREFIX}i";
			my $maxarg = "$name$OVERLOAD_MAXARG";

			if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
				print $OUT qq/$COMMENT_PREFIX procedure overloading "$name"$LF/;
			}

			piped_printf($OUT, << "END", $LF);
#procedure $name(?$a)
  #if "`?$a'" == ""
    #define $n "0"
  #else
    #define $n "-1"
    #do $i={`?$a',}
      #redefine $n "{`$n'+1}"
    #enddo
  #endif
  #ifdef `$maxarg'
    #if `$n' > `$maxarg'
      #redefine $n "`$maxarg'"
    #endif
  #endif
  #call $name$OVERLOAD_SUFFIX`$n'(`?$a')
#endprocedure
END

			next;
		}

		##
		# Defines a procedure.
		#
		# Syntax:
		#   #procedure <procname>
		#   #procedure <procname>(...)
		#
		# (Intrinsic)
		#
		if (/^\s*#\s*procedure\b/i) {
			$proc_level ++;

			my $str = $_;

			$str =~ s/^\s*#\s*procedure\b\s*//i;

			my $args = '';

			if ($str =~ s/\(([^\(]*?)\).*//) {
				$args = $1;
			}

			my $name = trim_str($str);

			if (grep { $_ eq $name } @overloads) {
				my $lines = '';

				# First count the arguments.

				my $nargs = 0;

				if (length($args) > 0) {
					$nargs = ($args =~ s/,/,/g) + 1;
				}

				# Check whether it contains ?a.

				my $wildcard = 0;

				if ($args =~ /\?/) {
					$wildcard = 1;
					$nargs --; # foo(?a) has zero args and extra args.
					$lines .= "#define $name$OVERLOAD_MAXARG \"$nargs\"$LF";
				}

				# Output.

				if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
					if (! $wildcard) {
						print $OUT qq/$COMMENT_PREFIX overloaded procedure "$name" with $nargs args$LF/;
					} else {
						print $OUT qq/$COMMENT_PREFIX overloaded procedure "$name" with $nargs args or more$LF/;
					}
				}

				s/\b$name\b/$name$OVERLOAD_SUFFIX$nargs/; # To overloaded procedure name.

				$lines .= $_ . $LF;

				piped_printf($OUT, $lines, $LF);

				next;
			}

			goto output_line;
		}

		##
		# End of a procedure.
		#
		# Syntax:
		#   #endprocedure
		#
		# (Intrinsic)
		#
		if (/^\s*#\s*endprocedure\b/i) {
			if ($proc_level > 0) {
				$proc_level --;
			}
		}

		##
		# Asserts <constraint> should be true.
		#
		# Syntax:
		#   #assert <constraint>
		#   #assert <constraint>[,] "message"
		#
		if (s/^\s*#\s*assert\b//i) {

			# Get constraints and message.

			my $const;
			my $msg = '';

			if (s/\s*,?\s*\"(.*)\"\s*$//) {
				$msg = $1;

				$msg =~ s/\"/\\\"/g;
#				$msg =~ s/\`/\\\`/g;
#				$msg =~ s/\'/\\\'/g;
#				$msg =~ s/\{/\\\{/g;
#				$msg =~ s/\}/\\\}/g;

				$msg = ': ' . $msg;
			}

			$const = trim_str($_);

# FIXME: for (...) || (...), so currently disabled.

#			# Remove irrevant brackets in the constraints.
#
#			while ($const =~ /^\((.*)\)$/) {
#				$const = trim_str($1);
#			}

			# Construct text representing constrants.

			my $const_str = $const;
			my $const_str_replaced;

#			$const_str =~ s/\&\&/ AND /g;
#			$const_str =~ s/\|\|/ OR /g;
			$const_str =~ s/\s\s+/ /g;

			if ($const_str eq '0' || $const_str eq '(0)') {
				# `#assert 0' means unreachable branch, so do not show.

				$const_str = '';
				$const_str_replaced = '';
			} else {
				$const_str =~ s/\"/\\\"/g;

				$const_str_replaced = $const_str;

				$const_str =~ s/\`/\\`/g;
				$const_str =~ s/\'/\\'/g;

				$const_str =~ s/%/%%/g;

				$const_str          = ': '  . $const_str;
				$const_str_replaced = ' : ' . $const_str_replaced;
			}

			# Construct FORM source.

			my $lines = '';

			if (! $opt_always_assert) {
				$lines .= "#ifdef \`DEBUG_\'$LF";
			}

			$lines .= << "END";
#if $const
#else
  #write "$g_current_filename Line $g_current_lineno ==> Assertion failed$msg$const_str$const_str_replaced"
  #terminate 1
#endif
END

			if (! $opt_always_assert) {
				$lines .= "#endif$LF";
			}

			# Output.

			if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
				print $OUT qq/$COMMENT_PREFIX assertion $const$LF/;
			}

			piped_printf($OUT, $lines, $LF);

			next;
		}

		##
		# Checks whether a file exists.
		#
		# Syntax:
		#   #ifexist <filename>
		#
		#  (DEPRECATED)
		#
		if (s/^\s*#\s*ifexist\b//i) {
			my $file = trim_str($_);

			if ($file eq '') {
				error('illegal usage of #ifexist');
			}

			if ($opt_deprecated) {
				warning('#ifexist is deprecated');
			}

			$perl_is_used = 1;

			if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
				print $OUT qq/$COMMENT_PREFIX #ifexist $file$LF/;
			}

			piped_perl_printf($OUT, qq/"#if %s\\n", (-e "$file" ? 1 : 0)/, $LF);

			next;
		}

		##
		# Checks whether a file should be updated.
		#
		# Syntax:
		#   #ifdated <filename>
		#
		#  (DEPRECATED)
		#
		if (s/^\s*#\s*ifdated\b//i) {
			my $file = trim_str($_);

			if ($file eq '') {
				error('illegal usage of #ifdated');
			}

			if ($opt_deprecated) {
				warning('#ifdated is deprecated');
			}

			$perl_is_used = 1;

			# FIXME: This does not work if the source is generated as a temporary file.

			if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
				print $OUT qq/$COMMENT_PREFIX #ifdated $file$LF/;
			}

			piped_perl_printf($OUT, qq/"#if %s\\n", (! -e "$file" || (stat "`NAME_'")[9] > (stat "$file")[9] ? 1 : 0)/, $LF);

			next;
		}

		##
		# Enumerates files.
		#
		# Syntax:
		#   #find <procvar> <filename>
		#
		#  (DEPRECATED)
		#
		if (s/^\s*#\s*find\b//i) {
			if (! s/^\s*(\S+?)\b\s*(.*)//) {
				error(qq/illegal usage of #find/);
			}

			my $var = $1;
			my $file = $2;

			$var  = trim_str($var);
			$file = trim_str($file);

			if (! is_legal_form_symbol($var)) {
				error(qq/illegal preprocessor variable "$var"/);
			}

			$file =~ s/\./\\./g;
			$file =~ s/\+/\\+/g;
			$file =~ s/\-/\\-/g;

			$file =~ s/\*/.*/g;
			$file =~ s/\?/./g;

			if ($opt_deprecated) {
				warning('#find is deprecated');
			}

			$perl_is_used = 1;

			if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
				print $OUT qq/$COMMENT_PREFIX #find $var $file$LF/;
			}

			piped_perl_printf($OUT, qq/"#define $var \\\\""/
			  . ";opendir DIR,\".\";\@s=readdir DIR;closedir DIR;print join(\",\",grep(/$file/,\@s));printf"
			  . qq/"\\\\"\\n"/, $LF);

			next;
		}

		##
		# Reads the user input.
		#
		# Syntax:
		#   #readline <procvar>
		#
		#  (DEPRECATED)
		#
		if (s/^\s*#\s*readline\b//i) {
			if (! s/^\s*(\S+?)\b//) {
				error(qq/illegal usage of #readline/);
			}

			my $var = $1;

			if (! is_legal_form_symbol($var)) {
				error(qq/illegal preprocessor variable "$var"/);
			}

			if ($opt_deprecated) {
				warning('#readline is deprecated');
			}

			$perl_is_used = 1;

			if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
				print $OUT qq/$COMMENT_PREFIX #readline $var$LF/;
			}

			piped_perl_printf($OUT, qq/"#define $var \\\\\"\@{[(chomp (\\\$s=<>) and 0) or \\\$s]}\\\\\"\\n"/, $LF);

			next;
		}

		##
		# Asserts <constraint> should be true.
		#
		# Syntax:
		#   assert(<constraint>);
		#   assert(<constraint>) [,] "message";
		#
		# Experimental:
		#   <constraint> can contain `free(<x>)' or `free(<x>,<level>)'.
		#
		if (s/^\s*assert\s*\((.*)\)\s*();\s*($|\*)//i || s/^\s*assert\s*\((.*)\)\s*,?\s*\"(.*)\"\s*;\s*($|\*)//i) {

			# Get constraints and message.

			my $const = $1;
			my $msg   = $2;

			$const = trim_str($const);
			$msg   = trim_str($msg);

			if ($msg ne '') {
				$msg = ': ' . $msg;
			}

#FIXME: for (...) || (...), so currently disabled.

#			# Remove irrevant brackets in the constraints.
#
#			while ($const =~ /^\((.*)\)$/) {
#				$const = trim_str($1);
#			}

			my $const_org = $const;

			# Construct text representing constrants.

			my $const_str = $const;

			$const_str =~ s/\&\&/ AND /g;
			$const_str =~ s/\|\|/ OR /g;
			$const_str =~ s/\s\s+/ /g;

			if ($const_str eq '0') {
				# `assert(0)' means unreachable branch, so do not show.

				$const_str = '';
			} else {
				$const_str = ': ' . $const_str;
			}

			# Construct FORM source.

			my $lines = '';

			if (! $opt_always_assert) {
				$lines .= "#ifdef \`DEBUG_\'$LF";
			}

			for (my $free_vars = 1; $const =~ s/free\s*\(([^()]+)\)/\$${PRIVATE_PREFIX}f$free_vars/i; $free_vars ++) {
				my $free_arg = trim_str($1);
				my $free_level = 9;

				if ($free_arg =~ s/\s*,\s*(\d+)$//) {
					$free_level = $1;
				}

				my $sub_lines = '';

				my @free_arg = split(/,/, $free_arg);

				my $free_cond = '';

				foreach my $i (@free_arg) {
					if ($free_cond) {
						$free_cond .= '||';
					}

					$free_cond .= "count($i,1)";
				}

				$sub_lines .= "\$${PRIVATE_PREFIX}f$free_vars=1;$LF";

				if ($free_level == 0) {
					$sub_lines .= "if ($free_cond) \$${PRIVATE_PREFIX}f$free_vars = 0;$LF";
				} elsif ($free_level == 1) {
					$sub_lines .= << "END";
if (\$${PRIVATE_PREFIX}f$free_vars);
  if ($free_cond);
    \$${PRIVATE_PREFIX}f$free_vars = 0;
  else;
    argument;
      if ($free_cond) \$${PRIVATE_PREFIX}f$free_vars = 0;
    endargument;
  endif;
endif;
END
				} else {
					$sub_lines .= << "END";
#do ${PRIVATE_PREFIX}i = 0, $free_level
  if (\$${PRIVATE_PREFIX}f$free_vars);
    if ($free_cond);
      \$${PRIVATE_PREFIX}f$free_vars = 0;
    else;
      argument;
#enddo
#do ${PRIVATE_PREFIX}i = 0, $free_level
      endargument;
    endif;
  endif;
#enddo
END
				}

				$lines .= $sub_lines;
			}

			# NOTE: we need "" after `exit' statement. Otherwise,
			#       FORM error message "Program terminating at ..." becomes "rogram terminating at ...".
			#       (FORM 3.3 Feb 10 2009).

			$lines .= << "END";
if ($const); else;
  P "$g_current_filename Line $g_current_lineno --> Assertion failed$msg$const_str: %t";
  exit "";
endif;
END

			if (! $opt_always_assert) {
				$lines .= "#endif$LF";
			}

			# Output.

			if (! $opt_keep_lineno && ! $opt_optimize && $opt_comment) {
				print $OUT qq/$COMMENT_PREFIX assertion $const_org$LF/;
			}

			piped_printf($OUT, $lines, $LF);

			next;
		}

output_line:

		# Output the current line.

		print $OUT $_ . $LF;
	}

	# Enumerate include files.

	{
		# Eliminate duplicated include files.
		my %count;
		@includes = grep {! $count{$_} ++} @includes;
	}

	{
		# Eliminate duplicated required files.
		my %count;
		@requires = grep {! $count{$_} ++} @requires;
	}

	if (! $opt_preprocess_only) {
		foreach (@includes, @requires) {
			if (-e $_) {
				add_source_file($_);
			}
		}
	}

	# Make file footer commentary.

	if (! $opt_comment) {
		return;
	}

	if (! $opt_optimize) {
		print $OUT "$LF";
	}

	$COMMENT_PREFIX  = $comment_char x 2;

	my $time = get_localtime_str();
	my $extopt = get_extra_options();

#	print $OUT "$COMMENT_PREFIX Generated by $APPVER on $time$LF";
	print $OUT "$COMMENT_PREFIX Source file: $g_current_filename, $g_current_lineno lines ($line_count lines without comments)$LF";

	foreach (@includes) {
		# Skip entries using preprocessor variables, such as `file'.
		if (index($_, '\`') < 0 && index($_, '\'') < 0) {
			print $OUT "$COMMENT_PREFIX Include file: $_$LF";
		}
	}

	foreach (@requires) {
		# Skip entries using preprocessor variables, such as `file'.
		if (index($_, '\`') < 0 && index($_, '\'') < 0) {
			print $OUT "$COMMENT_PREFIX Required file: $_$LF";
		}
	}

#	if ($extopt ne '') {
#		print $OUT "$COMMENT_PREFIX Extra options: $extopt$LF";
#	}

#	print $OUT "$COMMENT_PREFIX End of output by $APPNAME$LF";
}

##
# Returns non-zero value if the given string is valid symbol name
# in FORM.
#
# Usage:
#   $is_legal = is_legal_form_symbol($symbol_str)
#
sub is_legal_form_symbol($) {
	my $s = shift;

	# This is not accurate. Actually a pair of [] and trailing
	# underscore are also allowed for compiler variable names (not for
	# preprocessor variables).

	if ($s =~ /^[a-zA-Z]+[a-zA-Z0-9]*$/) {
		return 1;
	}

	return 0;
}

##
# Updates $namespace_prefix for the current namespace.
#
# Usage:
#   update_prefix()
#
sub update_prefix() {
	if (@namespace == 0) {
		$namespace_prefix = 'GLOBAL'. $namespace_sep;
	} else {
		$namespace_prefix = join($namespace_sep, @namespace) . $namespace_sep;
	}
}

##
# Generates and outputs `#pipe printf ...' command.
#
# Usage:
#   piped_printf($fh_out, $lines, $LF)
#
sub piped_printf($$$) {
	my $OUT = shift;
	my $lines_str  = shift;
	my $LF = shift;

	# Split each line.

	my @lines = split(/\x0D\x0A?|\x0A/, $lines_str);

	foreach (@lines) {
		s/^\s+//;
	}

	# First, we join the non-preprocessor lines as possible.

	if ($opt_keep_lineno) {
		for (my $i = $#lines - 1; $i >= 0; $i --) {
			if (substr($lines[$i], 0, 1) ne '#' && substr($lines[$i + 1], 0, 1) ne '#') {
				$lines[$i] .= $lines[$i + 1];
				splice @lines, $i + 1, 1;
			}
		}
	}

	if (@lines == 1) {
		# Here is one line command. It is better not to use pipe command
		# as possible.
		print $OUT $lines[0] . $LF;
		return;
	}

	if ($opt_keep_lineno) {
		# We keep line numbers.

		my $out = join('\n', '', @lines, '', '');

		# '\', '$' and '"' must be escaped for shell.

		$out =~ s/\\/\\\\/g;
		$out =~ s/\"/\\"/g;
		$out =~ s/\$/\\\$/g;

		# "`" and "'" must be escaed for FORM & shell.

		$out =~ s/\`/\\`/g;
		$out =~ s/\'/\\'/g;

		# '%' must be escaped for printf.

		$out =~ s/%/%%/g;

		print $OUT "#pipe $opt_printf \"$out\"$LF";

		$printf_is_used = 1;
	} else {
		# We have not to keep line numbers, so it is better not to use
		# pipe command as possible.

		foreach (@lines) {
			print $OUT $_ . $LF;
		}
	}
}

##
# Generates and outputs `#pipe perl -e "printf ..."' command.
#
# Usage:
#   piped_perl_printf($fh_out, $lines, $LF)
#
sub piped_perl_printf($$$) {
	my $OUT = shift;
	my $str  = shift;
	my $LF = shift;

	$str = "printf $str";
	$str =~ s/\"/\\\"/g;
	print $OUT qq/#pipe perl -e "$str"$LF/;
}

##
# Returns a string which represents the extra options.
#
# Usage:
#   $extra_opts = get_extra_options()
#
sub get_extra_options() {
	my $extopt = '';

	if ($opt_optimize) {
		$extopt .= ' --optimize';
	}

	if ($opt_keep_lineno) {
		$extopt .= ' --keep-lineno';
	}

	return trim_str($extopt);
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

##
# Entry point.
#
# Usage:
#   main()
#
sub main() {
	parse_opts();

# DEBUG:
#	foreach (@ARGV) {
#		my $s1 = get_full_filename($_);
#		my $s2 = get_target_filename($s1);
#		verbose(qq/"$_" -> "$s1" -> "$s2"/);
#	}
#

#	# Set BINMODE for output, which is needed for Windows.
#
#	if ($BIN_MODE) {
#		binmode STDIN;
#		binmode STDOUT;
##		binmode STDERR;
#	}

	if ($opt_preprocess_only) {
		# Here is the preprocessor mode; do preprocess only.

		my $out = undef;

		if (defined($opt_output)) {
			$out = open_file(">$opt_output");
		}

		if (@ARGV == 0) {
			# No arguments; input is STDIN.
			verbose(qq/preprocess <STDIN>/);
			$g_current_filename = 'STDIN';
			$g_current_lineno   = 0;
			preprocess(undef, $out);
			$g_current_filename = undef;
		} else {
			for (my $i = 0; $i < @ARGV; $i ++) {
				my $src = get_full_filename($ARGV[$i]);
				my $in = open_file($src);
				verbose(qq/preprocess "$src"/);
				$g_current_filename = $src;
				$g_current_lineno   = 0;
				preprocess($in, $out);
				$g_current_filename = undef;
				close_file($in);
				push @preprocessed_files, $src;
			}
		}

		if ($out) {
			close_file($out);
		}

		exit(0);
	}

	# Here is the normal mode; do preprocess and invoke FORM. The name
	# of output files (i.e., FORM sources) are automatically determined.

	if (@ARGV == 0) {
		# No arguments; Error message such as original `FORM'.
		pod2usage(-msg => "=== No filename specified in call of $APPNAME", -exitstatus => 2);
	}

	foreach (@ARGV) {
		add_source_file(get_full_filename($_));
	}

	for (my $src; $src = get_next_source_file(), defined($src); ) {
		my $dst = get_target_filename($src);
		verbose(qq/preprocess "$src" to "$dst"/);
		my $in  = open_file($src);
		my $out = open_file(">$dst");
		$g_current_filename = $src;
		$g_current_lineno   = 0;
		preprocess($in, $out);
		$g_current_filename = undef;
		close_file($in);
		close_file($out);
	}

	invoke_form(get_target_filename(get_first_source_file()));
}

main();

__END__

=pod

=head1 NAME

pform - (pre)preprocessor of B<FORM>

=head1 SYNOPSIS

pform [options] [--] files...

 Options:
   -h, --help                 show this help message and exit
                              (use "-h -v" for more help message)
   -V, --version              show version number and exit
   -v, --[no]verbose          enable verbose output
   -W, --[no]warn-error       turn warnings into errors
   -o FILE, --output FILE     place the output into FILE (used with -E)
   -E, --[no]preprocess-only  preprocess only
   -O, --[no]optimize         optimize FORM source
   -k, --[no]keep-lineno      keep line numbers as possible
       --[no]save-temps       do not delete all temporary files
       --[no]deprecated       warn deprecated features
   -Q, --[no]quiet, --[no]silent
                              suppress all normal output
   -g, --[no]debug            define DEBUG_ and undefine NDEBUG_
   -b, --form FORM            specify FORM binary
   -Wf OPT, --formopt OPT     pass option OPT on to FORM program

 Following options are passed to FORM:
   -c                         error checking only
   -d NAME, -d NAME=VALUE     define a preprocessor variable
   -D NAME, -D NAME=VALUE     same as -d
   -f                         output only to log file
   -F                         output only to log file (like -L)
   -I PATH                    set the directory for include files
   -l                         make a regular log file
   -ll                        make a log file without intermediate stats
   -L                         same as -ll
   -M                         put the PID in the temporary file names
   -p PATH                    set the path of a directory for input
   -pipe                      start up as the receiving end of a pipe
   -q                         be quiet
   -R                         recover from saved snapshot
   -s PATH                    set the directory for the setup file
   -si                        same as -q
   -S FILE                    set the setup file
   -t PATH                    set the directory for temporary files
   -T                         enable totalsize mode
   -w N                       set the number of worker threads for TFORM
   -y                         preprocessor dumps output

=head1 DESCRIPTION

B<pFORM> is a wrapper/preprocessor for B<FORM>, a symbolic manipulation
system originally developed by Jos Vermaseren. It provides several
syntax sugars, such as
   - namespace (#namespace)
   - procedure overloading (#overload)
   - assertions (#assert and assert)

=over 2

=item B<Namespace>

In order to avoid possible conflictions of symbols in a library package
and those in a user program, an author of library package often feels a
strong urge to put a prefix to all private symbols. For the safety, it
is better that the prefix is longer, but then the readability of the
library code may be lost. B<#namespace> and B<#endnamespace>
preprocessor commands are used to generate private symbols or variables
for B<@-variables>. For example,

    #namespace my
    S @x;
    #procedure sqr(f)
      id `f'(@x?) = @x^2;
    #endprocedure
    #endnamespace

is translated as

    S myx;
    #procedure sqr(f)
      id `f'(myx?) = myx^2;
    #endprocedure

Note that B<pFORM> simply replaces B<@> with B<my>. So they can be
used to privatize symbols, $-variables, procedures, processor varibales
and so on. Namespaces can nest, e.g.,

    #namespace foo
    S @x;
    #namespace bar
    S @y;
    #endnamespace
    #endnamespace

which results

    S foox;
    S foobary;

In above examples, it is assumed that the namespace-separator is
the default value, "" (empty). One can change it by
B<#:namespaceseparator> command, e.g.,

    #:namespaceseparator xxx
    #namespace my
    S @a;
    #endnamespace

results

    S myxxxa;

One can use B<none> keyword to use "empty" namespace-separator,

    #:namespaceseparator none

In order access symbols in a namespace from outside, one can use "::",
e.g.,

    #:namespaceseparator xxx
    #namespace foo
    #define @a "1"
    #endnamespace
    L F = `my::a';

results

    #define myxxxa "1"
    L F = `myxxxa';

One can use escape sequences B<\@> and B<\::>, will be replaced with
B<@> and B<::>, respectively.

=item B<Procedure overloading>

If you think it is sometimes convenient to define a procedure in
multiple versions using the same name but different arguments,
B<#overload> is for you. An example is:

    #overload proc
    #procedure proc(a)
      #message one argument:           `a'
    #endprocedure
    #procedure proc(a,b)
      #message two arguments:          `a',`b'
    #endprocedure
    #procedure proc(a,b,c)
      #message three arguments:        `a',`b',`c'
    #endprocedure
    #procedure proc(a,b,c,d,?e)
      #ifndef `?e'
        #message four arguments:         `a',`b',`c',`d'
      #else
        #message five or more arguments: `a',`b',`c',`d',`?e'
      #endif
    #endprocedure

    #call proc(1)
    #call proc(1,2)
    #call proc(1,2,3)
    #call proc(1,2,3,4)
    #call proc(1,2,3,4,5)
    #call proc(1,2,3,4,5,6)

which prints

    ~~~one argument:           1
    ~~~two arguments:          1,2
    ~~~three arguments:        1,2,3
    ~~~four arguments:         1,2,3,4
    ~~~five or more arguments: 1,2,3,4,5
    ~~~five or more arguments: 1,2,3,4,5,6

=item B<Assertions>

Both static and runtime assertions are available. E.g.,

    #define x "1"
    #assert `x' == 1
    #assert `x' == 2, "some message"

or

    S x,y;
    L F = (1+x+y)^2;
    assert(count(x,1) == 0);
    assert(count(x,1) == 1), "some message";

(Restriction: B<#assert> command and B<assert> statement must be in
one line.) For the runtime assertions, one can use a fancy function
B<free> in the condition, e.g.,

    CF f;
    S x;
    L F = f(f(f(f(x))));
    assert(free(x));
    assert(free(x,3));  * Check up to level 3.

(Restriction: B<free> uses global $-variables as if they are local in
each thread. This may do not work in the parallel versions of FORM.)

=back

=head1 AUTHOR

Takahiro Ueda <ueda@particle.uni-karlsruhe.de>

=cut

# vim: ft=perl noet ts=4 sts=0 sw=4