TRAC Program

HomePage | RecentChanges | EditorIndex | TextEditorFamilies | Preferences

	#!/usr/bin/perl
	# The main TRAC interpreter.
	# Copyright 1994 by John Cowan.  All rights reserved.

	# System variables:
	#	$active - the string being scanned for macro invocations
	#	$trace - true if tracing is in effect
	#	@args - a stack of all arguments of all pending invocations
	#		(note: the macro name is also pushed here)
	#	@mactype - a stack of invocation types for all pending invocations,
	#		where 1 is active and 0 is neutral
	#	@macnargs - a stack of argument counts for all pending invocations
	#	@macname - a stack of the index in @args of the macro name
	#		for all pending invocations
	#	The @mac* arrays are kept in synchrony.

	#	%meta - associates handles to meta characters

	#	%form - associates form name to form body
	#	%formptr - associates form name to form pointer (an index, really)
	#	%formsrc - associates form name to source filename
	#	%formargs - associates form name to number of formal args
	#	The %form* arrays are kept in synchrony.

	open(TTY, "+</dev/tty");
	$meta{STDIN} = "'";	# FIXME

	$form{"ARGV"} = join(pack("C", 0200), @ARGV);
	$formptr{"ARGV"} = 0;
	$formargs{"ARGV"} = 1;

	@env = ();
	$marker = pack("C", 0201);
	while (($key, $value) = each %ENV) {
		push (@env, $key . $marker . $value);
		}
	$form{"ENV"} = join(pack("C", 0200), @env);
	$formptr{"ENV"} = 0;
	$formargs{"ENV"} = 2;
	undef @env;

	for (;;) {
		$active = "#(ps,#(rs,,(#(ex))))";
		$#args = $#mactype = $#macnargs = $#macname = -1;
		push(@args, "")			;
		while (length($active)) {	
			($normals, $key) = $active =~ /^([^\t\n#,()]*)([\t\n#,()])/;
			$args[$#args] .= $normals;
			substr($active, 0, length($normals) + 1) = "";
			if ($key eq "\t" || $key eq "\n") {
				# skip tabs and newlines
				}
			elsif ($key eq "#" && substr($active, 0, 1) eq "(") {
				substr($active, 0, 1) = "";
				&begin(1);
				}
			elsif ($key eq "#" && substr($active, 0, 2) eq "#(") {
				substr($active, 0, 2) = "";
				&begin(0);
				}
			elsif ($key eq "(") {
				"e;
				}
			elsif ($key eq "," && $#mactype >= 0) {
				push(@args, "");
				$macnargs[$#macnargs]++;
				$active =~ s/^ *//;
				}
			elsif ($key eq ")" && $#mactype >= 0) {
				&invoke;
				}
			else {
				$args[$#args] .= $key;
				}
			}
		}

	sub begin {
		local($mactype) = @_;
		push(@mactype,$mactype);
		push(@macnargs,0);
		push(@args,"");
		push(@macname,$#args);
		}

	sub quote {
		local($normals, $paren);
		local($depth) = 1;
		while (length($active)) {
			($normals, $paren) = $active =~ /([^()]*)([()])/;
			$args[$#args] .= $normals;
			substr($active, 0, length($normals) + 1) = "";
			if ($paren eq "(") {
				$depth++;
				$args[$#args] .= $paren;
				}
			else {
				$depth--;
				last if $depth <= 0;
				$args[$#args] .= $paren;
				}
			}
		}

	sub invoke {
		local($macindex) = $macname[$#macname];
		local($macro) = $args[$macindex];
		local($result);
		@_ = @args[$macindex + 1 .. $macindex + $macnargs[$#macnargs]];

		if ($trace) {
			local(@args) = @_;
			print TTY "*** TRACE $macro: ";
			print TTY join(", ", grep($_ = "`$_'", @args)), "? ";
			$/ = "\n";
			$result = <TTY>;
			}
		INVOKE: {
			&rs, last INVOKE if $macro eq "rs";
			&rs, last INVOKE if $macro eq "read string";
			&rc, last INVOKE if $macro eq "rc";
			&rc, last INVOKE if $macro eq "read character";
			&ps, last INVOKE if $macro eq "ps";
			&ps, last INVOKE if $macro eq "print string";
			&cm, last INVOKE if $macro eq "cm";
			&cm, last INVOKE if $macro eq "change meta";
			&ds, last INVOKE if $macro eq "ds";
			&ds, last INVOKE if $macro eq "define string";
			&ss, last INVOKE if $macro eq "ss";
			&ss, last INVOKE if $macro eq "segment string";
			&cl, last INVOKE if $macro eq "cl";
			&cl, last INVOKE if $macro eq "call";
			&dd, last INVOKE if $macro eq "dd";
			&dd, last INVOKE if $macro eq "delete definition";
			&da, last INVOKE if $macro eq "da";
			&da, last INVOKE if $macro eq "delete all";
			&cs, last INVOKE if $macro eq "cs";
			&cs, last INVOKE if $macro eq "call segment";
			&cc, last INVOKE if $macro eq "cc";
			&cc, last INVOKE if $macro eq "call characters";
			&in, last INVOKE if $macro eq "in";
			&in, last INVOKE if $macro eq "initial";
			&cr, last INVOKE if $macro eq "cr";
			&cr, last INVOKE if $macro eq "call reset";
			&ad, last INVOKE if $macro eq "ad";
			&ad, last INVOKE if $macro eq "+";
			&su, last INVOKE if $macro eq "su";
			&su, last INVOKE if $macro eq "-";
			&ml, last INVOKE if $macro eq "ml";
			&ml, last INVOKE if $macro eq "*";
			&dv, last INVOKE if $macro eq "dv";
			&dv, last INVOKE if $macro eq "/";
			&eq, last INVOKE if $macro eq "eq";
			&eq, last INVOKE if $macro eq "=";
			&gr, last INVOKE if $macro eq "gr";
			&gr, last INVOKE if $macro eq ">";
			&bu, last INVOKE if $macro eq "bu";
			&bu, last INVOKE if $macro eq "|";
			&bi, last INVOKE if $macro eq "bi";
			&bi, last INVOKE if $macro eq "&";
			&bc, last INVOKE if $macro eq "bc";
			&bc, last INVOKE if $macro eq "~";
			&tn, last INVOKE if $macro eq "tn";
			&tn, last INVOKE if $macro eq "trace on";
			&tf, last INVOKE if $macro eq "tf";
			&tf, last INVOKE if $macro eq "trace off";
			&ln, last INVOKE if $macro eq "ln";
			&ln, last INVOKE if $macro eq "list names";
			&pf, last INVOKE if $macro eq "pf";
			&pf, last INVOKE if $macro eq "print form";
			&sb, last INVOKE if $macro eq "sb";
			&sb, last INVOKE if $macro eq "save block";
			&fb, last INVOKE if $macro eq "fb";
			&fb, last INVOKE if $macro eq "fetch block";
			&eb, last INVOKE if $macro eq "eb";
			&eb, last INVOKE if $macro eq "erase block";
			&oi, last INVOKE if $macro eq "oi";
			&oi, last INVOKE if $macro eq "open input";
			&oo, last INVOKE if $macro eq "oo";
			&oo, last INVOKE if $macro eq "open output";
			&oa, last INVOKE if $macro eq "oa";
			&oa, last INVOKE if $macro eq "open append";
			&cf, last INVOKE if $macro eq "cf";
			&cf, last INVOKE if $macro eq "close file";
			&ld, last INVOKE if $macro eq "ld";
			&ld, last INVOKE if $macro eq "load";
			&sy, last INVOKE if $macro eq "sy";
			&sy, last INVOKE if $macro eq "system";
			&ex, last INVOKE if $macro eq "ex";
			&ex, last INVOKE if $macro eq "exit";
			}
		pop @macnargs;
		$#args = (pop @macname) - 1;
		if (pop @mactype) {
			substr($active, 0, 0) = $result;
			}
		else {
			@args[$#args] .= $result;
			}
		}

	sub rs {
		local($handle,$default) = @_;
		$handle = STDIN if $handle eq "";
		$/ = $meta{$handle};
		$result = <$handle>;
		if ($result eq "") {
			$mactype[$#mactype] = 1;
			$result = $default;
			}
		else {
			chop $result;
			}
		}

	sub ps {
		local($text, $handle) = @_;
		$handle = "STDOUT" if $handle eq "";
		print $handle $text;
		$result = "";
		}

	sub rc {
		local($handle) = @_;
		$handle = STDIN if $handle eq "";
		$result = getc($handle);
		}

	sub cm {
		local($char, $handle) = @_;
		local($oldmeta);
		$handle = STDIN if $handle eq "";
		$oldmeta = $meta{$handle};
		$meta{$handle} = substr($char,0,1);
		$result = $oldmeta;
		}

	sub ds {
		local($name,$form) = @_;
		$form{$name} = $form;
		$formargs{$name} = 0;
		$formptr{$name} = 0;
		$result = "";
		}

	sub ss {
		local($name,@args) = @_;
		local($form, $i, $marker);

		$form = $form{$name};
		foreach $i (0..$#args) {
			$args[$i] =~ s/(\W)/\\\1/g;
			$marker = pack("C", 0200 + $i);
			$form =~ s/$args[$i]/$marker/g;
			}
		$form{$name} = $form;
		$formptr{$name} = 0;
		$formargs{$name} = @args;
		$result = "";
		}

	sub cl {
		local($name,@args) = @_;
		local($i, $marker);

		$result = $form{$name};
		foreach $i (0..$formargs{$name} - 1) {
			$marker = pack("C", 0200 + $i);
			$result =~ s/$marker/$args[$i]/g;
			}
		}

	sub dd {
		local($name) = @_;
		undef $form{$name};
		undef $formptr{$name};
		undef $formargs{$name};
		undef $formsrc{$name};
		}

	sub da {
		local($name);
		foreach $name (keys(%form)) {
			&dd($name);
			}
		}

	sub cs {
		local($name,$default) = @_;
		local($form) = $form{$name};
		local($fp) = $formptr{$name};
		local($ch);

		if ($fp == -1) {
			$result = $default;
			$mactype[$#mactype] = 1;
			return;
			}
		$result = "";
		for (;;) {
			$ch = substr($form, $fp, 1);
			last if $ch eq "" || ord($ch) >= 0200;
			$result .= $ch;
			$fp++;
			}
		$formptr{$name} = ($ch eq "") ? -1 : $fp + 1;
		}

	sub cc {
		local($name, $default) = @_;
		local($form) = $form{$name};
		local($fp) = $formptr{$name};

		$result = substr($form, $fp, 1);
		if ($result eq "") {
			$fp = -1;
			}
		elsif (ord($result) >= 0200) {
			$fp += 2;
			}
		else {
			$formptr{$name}++;
			return;
			}
		$formptr{$name} = $fp;
		$result = $default;
		$mactype[$#mactype] = 1;
		}

	sub in {
		local($name,$pat,$default) = @_;
		local($form) = $form{$name};
		local($fp) = $formptr{$name};
		local($pos);

		$pos = index($form, $pat, $fp);
		if ($pos != -1) {
			$result = "";
			$fp = $pos + length($pat);
			$fp = -1 if $fp > length($form);
			$fp++ if ord(substr($form, $fp, 1)) >= 0200;
			$formptr{$name} = $fp;
			}
		else {
			$result = $default;
			$mactype[$#mactype] = 1;
			}
		}

	sub cr {
		local($name) = @_;
		$formptr{$name} = 0;
		}

	sub tn {
		$trace = 1;
		}

	sub tf {
		$trace = 0;
		}

	sub ln {
		$result = join(" ", keys %form);
		}

	sub mung_form {
		local($i, $marker);

		$result =~ s/\\/\\\\/;
		foreach $i (0..$formargs{$name} - 1) {
			$marker = pack("C", 0200 + $i);
			$result =~ s/$marker/\\$i\\/g;
			}
		}

	sub pf {
		local($name, $handle) = @_;

		$result = $form{$name};
		$handle = "STDOUT" if $handle eq "";
		&mung_form;
		print $handle $result, "\n";
		$result = "";
		}

	sub oi {
		local($handle,$filename,$default) = @_;

		$result = "";
		$meta{$handle} = $meta{STDIN};
		return if open($handle,"<$filename");
		$result = $default;
		$mactype[$#mactype] = 1;
		}

	sub oo {
		local($handle,$filename,$default) = @_;

		$result = "";
		return if open($handle,">$filename");
		$result = $default;
		$mactype[$#mactype] = 1;
		}

	sub oa {
		local($handle,$filename,$default) = @_;

		$result = "";
		return if open($handle,">>$filename");
		$result = $default;
		$mactype[$#mactype] = 1;
		}

	sub cf {
		local($handle) = @_;

		close($handle);
		$result = "";
		}

	sub ld {
		local($filename, $default) = @_;
		local(*LOAD);

		open(LOAD, "<$filename") ||
			(($result = $default), ($mactype[$#mactype] = 1), return);
		$/ = "";
		$result = <LOAD>;
		close(LOAD);
		}

	sub sy {
		local($command) = @_;

		$result = system($command);
		}

	sub ex {
		local($value) = @_;

		exit $value;
		}

	sub sb {
		local($filename, @names) = @_;
		local(*BLOCK);

		$result = "";
		open(BLOCK, ">$filename") ||
			warn "sb: open failed: $!\n", return;
		if (@names == 0) {
			foreach $name (keys %formsrc) {
				next if $formsrc{$name} != $filename;
				$result = $form{$name};
				&mung_form;
				$name =~ s/\\/\\\\/;
				print BLOCK "$name\\=$result\\;\n";
				}
			}
		else {
			foreach $name (@names) {
				$formsrc{$name} = $filename;
				print BLOCK "$name\\=";
				$result = $form{$name};
				&mung_form;
				print BLOCK "$result\\;\n";
				}
			}
		close(BLOCK);
		$result = "";
		}

	sub fb {
		local($filename) = @_;
		local($pos, $name, $form, $nargs, $marker);
		local(*BLOCK);

		open(BLOCK, $filename) ||
			warn "fb: open failed: $!\n", return;
		$/ = "\\;\n";
		while (<BLOCK>) {
			chop; chop; chop;
			$pos = index($_, "\\=");
			$name = substr($_, 0, $pos);
			$form = substr($_, $pos + 2);
			$name =~ s/\\\\/\\/;
			for ($nargs = 0; ; $nargs++) {
				$marker = pack("C", 0200 + $nargs);
				last unless $form =~ s/\\$nargs\\/$marker/g;
				}
			$form =~ s/\\\\/\\/;
			$form{$name} = $form;
			$formptr{$name} = 0;
			$formsrc{$name} = $filename;
			$formargs{$name} = $nargs;
			}
		close(BLOCK);
		$result = "";
		}

	sub tracnum {
		local($value) = @_;
		local($sign, $prefix, $digits);

		($sign, $prefix, $digits) = $value =~ /([+-]?)(\D*)(\d*)/;
		wantarray ? ($prefix, $sign . $digits) : $sign . $digits;
		}

	sub makenum {
		local($value, $prefix, $default) = @_;

		if ($value =~ /e/) {
			$mactype[$#mactype] = 1;
			return $default;
			}
		elsif ($value < 0) {
			$value = -$value;
			return "-" . $prefix . $value;
			}
		else {
			return $prefix . $value;
			}
		}

	sub ad {
		local($n1, $n2, $default) = @_;
		local($prefix);

		($prefix, $n1) = &tracnum($n1);
		$n2 = &tracnum($n2);
		$result = &makenum($n1 + $n2, $prefix, $default);
		}

	sub su {
		local($n1, $n2, $default) = @_;
		local($prefix);

		($prefix, $n1) = &tracnum($n1);
		$n2 = &tracnum($n2);
		$result = &makenum($n1 - $n2, $prefix, $default);
		}

	sub ml {
		local($n1, $n2, $default) = @_;
		local($prefix);

		($prefix, $n1) = &tracnum($n1);
		$n2 = &tracnum($n2);
		$result = &makenum($n1 * $n2, $prefix, $default);
		}

	sub dv {
		local($n1, $n2, $default) = @_;
		local($prefix);

		($prefix, $n1) = &tracnum($n1);
		$n2 = &tracnum($n2);
		if ($n2 == 0) {
			$result = $default;
			$mactype[$#mactype] = 1;
			return;
			}
		$result = &makenum(int($n1 / $n2), $prefix, $default);
		}

	sub bu {
		local($n1, $n2) = @_;
		local($prefix);

		($prefix, $n1) = &tracnum($n1);
		$n2 = &tracnum($n2);
		$result = &makenum($n1 | $n2, $prefix, "");
		}

	sub bi {
		local($n1, $n2) = @_;
		local($prefix);

		($prefix, $n1) = &tracnum($n1);
		$n2 = &tracnum($n2);
		$result = &makenum($n1 & $n2, $prefix, "");
		}

	sub bc {
		local($n1) = @_;
		local($prefix);

		($prefix, $n1) = &tracnum($n1);
		$result = &makenum(~ $n1, $prefix, "");
		}

	sub eq {
		local($x1, $x2, $then, $else) = @_;

		if ($x1 eq $x2) {
			$result = $then;
			}
		else {
			$result = $else;
			}
		}

	sub gr {
		local($x1, $x2, $then, $else) = @_;

		if ($x1 > $x2) {
			$result = $then;
			}
		else {
			$result = $else;
			}
		}


HomePage | RecentChanges | EditorIndex | TextEditorFamilies | Preferences
Edit text of this page | View other revisions
Last edited August 17, 2012 11:54 am (diff)
Search: