#!/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/^ *//; |
#!/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; |
elsif ($key eq ")" && $#mactype >= 0) { &invoke; |
} sub rs { local($handle,$default) = @_; $handle = STDIN if $handle eq ""; $/ = $meta{$handle}; $result = <$handle>; if ($result eq "") { $mactype[$#mactype] = 1; $result = $default; |
$args[$#args] .= $key; |
chop $result; |
} 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; |
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; |
$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; |
$formptr{$name}++; return; } $formptr{$name} = $fp; |
$mactype[$#mactype] = 1; |
else { chop $result; |
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 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) { |
sub oi { local($handle,$filename,$default) = @_; $result = ""; $meta{$handle} = $meta{STDIN}; return if open($handle,"<$filename"); |
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; |
sub oo { local($handle,$filename,$default) = @_; $result = ""; return if open($handle,">$filename"); $result = $default; $mactype[$#mactype] = 1; |
else { |
sub oa { local($handle,$filename,$default) = @_; $result = ""; return if open($handle,">>$filename"); |
} 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"; |
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 = ""; |
else { foreach $name (@names) { |
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; |
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; |
$formargs{$name} = $nargs; |
$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; |
close(BLOCK); $result = ""; |
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; |
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; } |
$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; |
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; } |
else { $result = $else; |
sub gr { local($x1, $x2, $then, $else) = @_; if ($x1 > $x2) { $result = $then; } else { $result = $else; } |
} |
|
#!/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; } }