Skip to content

Instantly share code, notes, and snippets.

@texdraft

texdraft/tangle.txt

Created September 3, 2019 13:03
Show Gist options
  • Save texdraft/6392d089c6bfd626bb20824b997073d6 to your computer and use it in GitHub Desktop.
Save texdraft/6392d089c6bfd626bb20824b997073d6 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
tangle.txt
program tangle(web_file, change_file, Pascal_file, pool);
label
end_of_TANGLE;
const
buf_size = 100;
max_bytes = 45000;
max_toks = 50000;
max_names = 4000;
max_texts = 2000;
hash_size = 353;
longest_name = 400;
line_length = 72;
out_buf_size = 144;
stack_size = 50;
max_id_length = 12;
unambig_length = 7;
type
ASCII_code = 0..255;
text_file = packed file of char;
eight_bits = 0..255;
sixteen_bits = 0..65535;
name_pointer = 0..max_names;
text_pointer = 0..max_texts;
output_state = record
end_field: sixteen_bits; {ending location of replacement text}
byte_field: sixteen_bits; {present location within replacement text}
name_field: name_pointer; {|byte_start| index for text being output}
repl_field: text_pointer; {|tok_start| index for text being output}
mod_field: 0..027777; {module number or zero if not a module}
end;
var
history: spotless..fatal_message; {how bad was this run?}
xord: array[char] of ASCII_code; {specifies conversion of input characters}
xchr: array[ASCII_code] of char; {specifies conversion of output characters}
term_out: text_file; {the terminal as an output file}
web_file: text_file; {primary input}
change_file: text_file; {updates}
Pascal_file: text_file;
pool: text_file;
buffer: array[0..buf_size] of ASCII_code;
phase_one: boolean; {|true| in Phase I, |false| in Phase II}
byte_mem: packed array[0..1, 0..max_bytes] of ASCII_code; {characters of names}
tok_mem: packed array[0..2, 0..max_toks] of eight_bits; {tokens}
byte_start: array[0..max_names] of sixteen_bits; {directory into |byte_mem|}
tok_start: array[0..max_texts] of sixteen_bits; {directory into |tok_mem|}
link: array[0..max_names] of sixteen_bits; {hash table or tree links}
ilk: array[0..max_names] of sixteen_bits; {type codes or tree links}
equiv: array[0..max_names] of sixteen_bits; {info corresponding to names}
text_link: array[0..max_texts] of sixteen_bits; {relates replacement texts}
name_ptr: name_pointer; {first unused position in |byte_start|}
string_ptr: name_pointer; {next number to be given to a string of length | <> 1|}
byte_ptr: array[0..1] of 0..max_bytes; {first unused position in |byte_mem|}
pool_check_sum: integer; {sort of a hash for the whole string pool}
text_ptr: text_pointer; {first unused position in |tok_start|}
tok_ptr: array[0..2] of 0..max_toks; {first unused position in a given segment of |tok_mem|}
z: 0..2; {current segment of |tok_mem|}
id_first: 0..buf_size; {where the current identifier begins in the buffer}
id_loc: 0..buf_size; {just after the current identifier in the buffer}
double_chars: 0..buf_size; {correction to length in case of strings}
hash, chop_hash: array[0..hash_size] of sixteen_bits; {heads of hash lists}
chopped_id: array[0..unambig_length] of ASCII_code; {chopped identifier}
mod_text: array[0..longest_name] of ASCII_code; {name being sought for}
xxxxx: integer;
last_unnamed: text_pointer; {most recent replacement text of unnamed module}
cur_state: output_state; {|cur_end|, |cur_byte|, |cur_name|, |cur_repl|, |cur_mod|}
stack: array[1..stack_size] of output_state; {info for non - current levels}
stack_ptr: 0..stack_size; {first unused location in the output state stack}
zo: 0..2; {the segment of |tok_mem| from which output is coming}
brace_level: eight_bits; (*current depth of $\.{@@\{}\ldots\.{@@\}}$ nesting*)
cur_val: integer; {additional information corresponding to output token}
out_buf: array[0..out_buf_size] of ASCII_code; {assembled characters}
out_ptr: 0..out_buf_size; {first available place in |out_buf|}
break_ptr: 0..out_buf_size; {last breaking place in |out_buf|}
semi_ptr: 0..out_buf_size; {last semicolon breaking place in |out_buf|}
out_state: eight_bits; {current status of partial output}
out_val, out_app: integer; {pending values}
out_sign: ASCII_code; {sign to use if appending |out_val >= 0|}
last_sign: - 1.. + 1; {sign to use if appending a zero}
out_contrib: array[1..line_length] of ASCII_code; {a contribution to |out_buf|}
ii: integer; {general purpose |for| loop variable in the outer block}
line: integer; {the number of the current line in the current file}
other_line: integer; {the number of the current line in the input file that
is not currently being read}
temp_line: integer; {used when interchanging |line| with |other_line|}
limit: 0..buf_size; {the last character position occupied in the buffer}
loc: 0..buf_size; {the next character position to be read from the buffer}
input_has_ended: boolean; {if |true|, there is no more input}
changing: boolean; {if |true|, the current line is from |change_file|}
change_buffer: array[0..buf_size] of ASCII_code;
change_limit: 0..buf_size; {the last position occupied in |change_buffer|}
cur_mod: name_pointer; {name of module just scanned}
scanning_hex: boolean; {are we scanning a hexadecimal constant?}
next_control: eight_bits; {control code waiting to be acted upon}
cur_repl_text: text_pointer; {replacement text formed by |scan_repl|}
module_count: 0..027777; {the current module number}
procedure error; {prints '\..' and location of error message}
var
j: 0..out_buf_size; {index into |out_buf|}
k, l: 0..buf_size; {indices into |buffer|}
begin
if phase_one then
begin
if changing then
print('. (change file ')
else
print('. (');
print_ln('l.', line:1, ')');
if loc >= limit then
l := limit
else
l := loc;
for k := 1 to l do
if buffer[k - 1] = tab_mark then
print(' ')
else
print(xchr[buffer[k - 1]]); {print the characters already read}
new_line;
for k := 1 to l do
print(' '); {space out the next line}
for k := l + 1 to limit do
print(xchr[buffer[k - 1]]); {print the part not yet read}
print(' '); {this space separates the message from future asterisks}
end
else
begin
print_ln('. (l.', line:1, ')');
for j := 1 to out_ptr do
print(xchr[out_buf[j - 1]]); {print current partial line}
print('... '); {indicate that this information is partial}
end;
update_terminal;
mark_error;
end;
procedure jumpout;
begin
goto end_of_TANGLE;
end;
procedure initialize;
var
i: 0..255;
wi: 0..1; {to initialize the |byte_mem| indices}
zi: 0..2;
h: 0..hash_size; {index into hash-head arrays}
begin
history := spotless;
xchr[32] := ' ';
xchr[33] := '!';
xchr[34] := '"';
xchr[35] := '#';
xchr[36] := '$';
xchr[37] := '%';
xchr[38] := '&';
xchr[39] := '''';
xchr[40] := '(';
xchr[41] := ')';
xchr[42] := '*';
xchr[43] := ' + ';
xchr[44] := ', ';
xchr[45] := ' - ';
xchr[46] := '.';
xchr[47] := '/';
xchr[48] := '0';
xchr[49] := '1';
xchr[50] := '2';
xchr[51] := '3';
xchr[52] := '4';
xchr[53] := '5';
xchr[54] := '6';
xchr[55] := '7';
xchr[56] := '8';
xchr[57] := '9';
xchr[58] := ':';
xchr[59] := ';';
xchr[60] := '<';
xchr[61] := ' = ';
xchr[62] := ' > ';
xchr[63] := '?';
xchr[64] := '@';
xchr[65] := 'A';
xchr[66] := 'B';
xchr[67] := 'C';
xchr[68] := 'D';
xchr[69] := 'E';
xchr[70] := 'F';
xchr[71] := 'G';
xchr[72] := 'H';
xchr[73] := 'I';
xchr[74] := 'J';
xchr[75] := 'K';
xchr[76] := 'L';
xchr[77] := 'M';
xchr[78] := 'N';
xchr[79] := 'O';
xchr[80] := 'P';
xchr[81] := 'Q';
xchr[82] := 'R';
xchr[83] := 'S';
xchr[84] := 'T';
xchr[85] := 'U';
xchr[86] := 'V';
xchr[87] := 'W';
xchr[88] := 'X';
xchr[89] := 'Y';
xchr[90] := 'Z';
xchr[91] := '[';
xchr[92] := '\';
xchr[93] := ']';
xchr[94] := '^';
xchr[95] := '_';
xchr[96] := '`';
xchr[97] := 'a';
xchr[98] := 'b';
xchr[99] := 'c';
xchr[100] := 'd';
xchr[101] := 'e';
xchr[102] := 'f';
xchr[103] := 'g';
xchr[104] := 'h';
xchr[105] := 'i';
xchr[106] := 'j';
xchr[107] := 'k';
xchr[108] := 'l';
xchr[109] := 'm';
xchr[110] := 'n';
xchr[111] := 'o';
xchr[112] := 'p';
xchr[113] := 'q';
xchr[114] := 'r';
xchr[115] := 's';
xchr[116] := 't';
xchr[117] := 'u';
xchr[118] := 'v';
xchr[119] := 'w';
xchr[120] := 'x';
xchr[121] := 'y';
xchr[122] := 'z';
xchr[123] := '{';
xchr[124] := '|';
xchr[125] := '}';
xchr[126] := '~';
xchr[0] := ' ';
xchr[127] := ' ';
for i := 1 to 037 do
xchr[i] := ' ';
for i := 0200 to 0377 do
xchr[i] := ' ';
for i := first_text_char to last_text_char do
xord[chr(i)] := " ";
for i := 1 to 0377 do
xord[xchr[i]] := i;
xord[' '] := " ";
rewrite(term_out, 'tty:');
rewrite(Pascal_file);
rewrite(pool);
for wi := 0 to ww - 1 do
begin
byte_start[wi] := 0;
byte_ptr[wi] := 0;
end;
byte_start[2] := 0;
name_ptr := 1;
string_ptr := 256;
pool_check_sum := 271828;
for zi := 0 to 2 do
begin
tok_start[zi] := 0;
tok_ptr[zi] := 0;
end;
tok_start[3] := 0;
text_ptr := 1;
z := 1 mod 3;
ilk[0] := 0;
equiv[0] := 0;
for h := 0 to hash_size - 1 do
begin
hash[h] := 0;
chop_hash[h] := 0;
end;
xxxxx := 0;
last_unnamed := 0;
text_link[0] := 0;
scanning_hex := false;
mod_text[0] := 32;
end;
procedure open_input;
begin
reset(web_file);
reset(change_file);
end;
function input_ln(var f: text_file): boolean; {inputs a line or returns |false|}
var
final_limit: 0..buf_size; {|limit| without trailing blanks}
begin
limit := 0;
final_limit := 0;
if eof(f) then
input_ln := false
else
begin
while not eoln(f) do
begin
buffer[limit] := xord[f^];
get(f);
incr(limit);
if buffer[limit - 1] <> " " then
final_limit := limit;
if limit = buf_size then
begin
while not eoln(f) do
get(f);
limit := limit - 1;
if final_limit > limit then
final_limit := limit;
print_nl('! Input line too long');
loc := 0;
error;
end;
end;
read_ln(f);
limit := final_limit;
input_ln := true;
end;
end;
procedure print_id(p:name_pointer); {print identifier or module name}
var
k: 0..max_bytes; {index into |byte_mem|}
w: 0..1; {segment of |byte_mem|}
begin
if p >= name_ptr then
print('IMPOSSIBLE')
else
begin
w := p mod ww;
for k := byte_start[p] to byte_start[p + ww] - 1 do
print(xchr[byte_mem[w, k]]);
end;
end;
function id_lookup(t: eight_bits): name_pointer;
label
found, not_found;
var
c: eight_bits; {byte being chopped}
i: 0..buf_size; {index into |buffer|}
h: 0..hash_size; {hash code}
k: 0..max_bytes; {index into |byte_mem|}
w: 0..1; {segment of |byte_mem|}
l: 0..buf_size; {length of the given identifier}
p, q: name_pointer; {where the identifier is being sought}
s: 0..unambig_length; {index into |chopped_id|}
begin
l := id_loc - id_first; {compute the length}
h := buffer[id_first];
i := id_first + 1;
while i < id_loc do
begin
h := (h + h + buffer[i]) mod hash_size;
incr(i);
end;
p := hash[h];
while p <> 0 do
begin
if length(p) = l then
begin
i := id_first;
k := byte_start[p];
w := p mod ww;
while (i < id_loc) and (buffer[i] = byte_mem[w, k]) do
begin
incr(i);
incr(k);
end;
if i = id_loc then
goto found; {all characters agree}
end;
p := link[p];
end;
p := name_ptr; {the current identifier is new}
link[p] := hash[h]; {insert |p| at beginning of hash list}
hash[h] := p;
found:;
if (p = name_ptr) or (t <> 0)then
begin
if ((p <> name_ptr) and (t <> normal) and (ilk[p] = normal)) or ((p = name_ptr) and
(t = normal) and (buffer[id_first] <> """")) then
begin
i := id_first;
s := 0;
h := 0;
while (i < id_loc) and (s < unambig_length) do
begin
if buffer[i] <> "_" then
begin
if buffer[i] >= "a" then
chopped_id[s] := buffer[i] - 040
else
chopped_id[s] := buffer[i];
h := (h + h + chopped_id[s]) mod hash_size;
incr(s);
end;
incr(i);
end;
chopped_id[s] := 0;
end;
if p <> name_ptr then
begin {now |p <> name_ptr| and |t <> normal|}
if ilk[p] = normal then
begin
if t = numeric then
err_print('! This identifier has already appeared');
q := chop_hash[h];
if q = p then
chop_hash[h] := equiv[p]
else
begin
while equiv[q] <> p do
q := equiv[q];
equiv[q] := equiv[p];
end;
end
else
err_print('! This identifier was defined before');
ilk[p] := t;
end
else
begin
if (t = normal) and (buffer[id_first] <> """")then
begin
q := chop_hash[h];
while q <> 0 do
begin
begin
k := byte_start[q];
s := 0;
w := q mod ww;
while (k < byte_start[q + ww]) and (s < unambig_length) do
begin
c := byte_mem[w, k];
if c <> "_" then
begin
if c >= "a" then
c := c - 040; {merge lowercase with uppercase}
if chopped_id[s] <> c then
goto not_found;
incr(s);
end;
incr(k);
end;
if (k = byte_start[q + ww]) and (chopped_id[s] <> 0) then
goto not_found;
print_nl('! identifier conflict with ');
for k := byte_start[q] to byte_start[q + ww] - 1 do
print(xchr[byte_mem[w, k]]);
error;
q := 0; {only one conflict will be printed, since |equiv[0]=0|}
not_found:
end;
q := equiv[q];
end;
equiv[p] := chop_hash[h];
chop_hash[h] := p;
end;
w := name_ptr mod ww;
k := byte_ptr[w];
if k + l > max_bytes then
overflow('byte memory');
if name_ptr > max_names - ww then
overflow('name');
i := id_first; {get ready to move the identifier into |byte_mem|}
while i < id_loc do
begin
byte_mem[w, k] := buffer[i];
incr(k);
incr(i);
end;
byte_ptr[w] := k;
byte_start[name_ptr + ww] := k;
incr(name_ptr);
if buffer[id_first] <> """" then
ilk[p] := t
else
begin
ilk[p] := numeric; {strings are like numeric macros}
if l - double_chars = 2 then {this string is for a single character}
equiv[p] := buffer[id_first + 1] + 0100000
else
begin
equiv[p] := string_ptr + 0100000;
l := l - double_chars - 1;
if l > 99 then
err_print('! Preprocessed string is too long');
incr(string_ptr);
write(pool, xchr["0" + l div 10], xchr["0" + l mod 10]); {output the length}
pool_check_sum := pool_check_sum + pool_check_sum + l;
while pool_check_sum > check_sum_prime do
pool_check_sum := pool_check_sum - check_sum_prime;
i := id_first + 1;
while i < id_loc do
begin
write(pool, xchr[buffer[i]]); {output characters of string}
pool_check_sum := pool_check_sum + pool_check_sum + buffer[i];
while pool_check_sum > check_sum_prime do
pool_check_sum := pool_check_sum - check_sum_prime;
if (buffer[i] = """") or (buffer[i] = "@") then
i := i + 2 {omit second appearance of doubled character}
else
incr(i);
end;
write_ln(pool);
end;
end;
end;
end;
id_lookup := p;
end;
function mod_lookup(l: sixteen_bits): name_pointer;
label
found;
var
c: less..extension; {comparison between two names}
j: 0..longest_name; {index into |mod_text|}
k: 0..max_bytes; {index into |byte_mem|}
w: 0..ww - 1; {segment of |byte_mem|}
p: name_pointer; {current node of the search tree}
q: name_pointer; {father of node |p|}
begin
c := greater;
q := 0;
p := rlink[0]; {|rlink[0]| is the root of the tree}
while p <> 0 do
begin
begin
k := byte_start[p];
w := p mod ww;
c := equal;
j := 1;
while (k < byte_start[p + ww]) and (j< = l) and (mod_text[j] = byte_mem[w, k]) do
begin
incr(k);
incr(j);
end;
if k = byte_start[p + ww] then
if j > l then
c := equal
else
c := extension
else
if j > l then
c := equal
else
if mod_text[j]<byte_mem[w, k] then
c := prefix
else c := greater;
end;
q := p;
if c = less then
p := llink[q]
else
if c = greater then
p := rlink[q]
else
goto found;
end;
w := name_ptr mod ww;
k := byte_ptr[w];
if k + l > max_bytes then
overflow('byte memory');
if name_ptr > max_names - ww then
overflow('name');
p := name_ptr;
if c = less then
llink[q] := p
else
rlink[q] := p;
llink[p] := 0;
rlink[p] := 0;
c := equal;
equiv[p] := 0;
for j := 1 to l do
byte_mem[w, k + j - 1] := mod_text[j];
byte_ptr[w] := k + l;
byte_start[name_ptr + ww] := k + l;
incr(name_ptr);
found:
if c <> equal then
begin
err_print('! Incompatible section names');
p := 0;
end;
print_id(p);
new_line;
xxxxx := xxxxx + 1;
print_ln(xxxxx);
mod_lookup := p;
end;
function prefix_lookup(l: sixteen_bits): name_pointer; {finds name extension}
var
c: less..extension; {comparison between two names}
count: 0..max_names; {the number of hits}
j: 0..longest_name; {index into |mod_text|}
k: 0..max_bytes; {index into |byte_mem|}
w: 0..ww - 1; {segment of |byte_mem|}
p: name_pointer; {current node of the search tree}
q: name_pointer; {another place to resume the search after one branch is done}
r: name_pointer; {extension found}
begin
q := 0;
p := rlink[0];
count := 0;
r := 0; {begin search at root of tree}
while p <> 0 do
begin
begin
k := byte_start[p];
w := p mod ww;
c := equal;
j := 1;
while (k < byte_start[p + ww]) and (j <= l) and (mod_text[j] = byte_mem[w, k]) do
begin
incr(k);
incr(j);
end;
if k = byte_start[p + ww] then
if j > l then
c := equal
else
c := extension
else
if j > l then
c := prefix
else
if mod_text[j] < byte_mem[w, k] then
c := less
else
c := greater;
end;
if c = less then
p := llink[p]
else
if c = greater then
p := rlink[p]
else
begin
r := p;
incr(count);
q := rlink[p];
p := llink[p];
end;
if p = 0 then
begin
p := q;
q := 0;
end;
end;
if count <> 1 then
if count = 0 then
err_print('! Name does not match')
else
err_print('! Ambiguous prefix');
prefix_lookup := r;
end;
procedure store_two_bytes(x: sixteen_bits); {stores high byte, then low byte}
begin
if tok_ptr[z] + 2 > max_toks then
overflow('token');
tok_mem[z, tok_ptr[z]] := x div 0400; {this could be done by a shift command}
tok_mem[z, tok_ptr[z] + 1] := x mod 0400; {this could be done by a logical and}
tok_ptr[z] := tok_ptr[z] + 2;
end;
procedure push_level(p: name_pointer); {suspends the current level}
begin
if stack_ptr = stack_size then
overflow('stack')
else
begin
stack[stack_ptr] := cur_state; {save |cur_end|, |cur_byte|, etc.}
incr(stack_ptr);
print_nl(stack_ptr);
cur_name := p;
cur_repl := equiv[p];
zo := cur_repl mod zz;
cur_byte := tok_start[cur_repl];
cur_end := tok_start[cur_repl + zz];
cur_mod := 0;
end;
end;
procedure pop_level; {do this when |cur_byte| reaches |cur_end|}
label exit;
begin
if text_link[cur_repl] = 0 then {end of macro expansion}
begin
if ilk[cur_name] = parametric then
begin
decr(name_ptr);
decr(text_ptr);
z := text_ptr mod zz;
tok_ptr[z] := tok_start[text_ptr];
end;
end
else
if text_link[cur_repl] < module_flag then {link to a continuation}
begin
cur_repl := text_link[cur_repl]; {we will stay on the same level}
zo := cur_repl mod 3;
cur_byte := tok_start[cur_repl];
cur_end := tok_start[cur_repl + zz];
return;
end;
decr(stack_ptr); {we will go down to the previous level}
if stack_ptr > 0 then
begin
cur_state := stack[stack_ptr];
zo := cur_repl mod zz;
end;
exit:
end;
function get_output: sixteen_bits; {returns next token after macro expansion}
label
restart, done, found;
var
a: sixteen_bits; {value of current byte}
b: eight_bits; {byte being copied}
bal: sixteen_bits; {excess of \.( versus \.) while copying a parameter}
k: 0..max_bytes; {index into |byte_mem|}
w: 0..ww - 1; {segment of |byte_mem|}
begin
restart:
if stack_ptr = 0 then
begin
a := 0;
goto found;
end;
if cur_byte = cur_end then
begin
cur_val := -cur_mod;
pop_level;
if cur_val = 0 then
goto restart;
a := module_number;
goto found;
end;
a := tok_mem[zo, cur_byte];
incr(cur_byte);
if a < 0200 then {one-byte token}
if a = param then
begin
push_level(name_ptr - 1);
goto restart;
end
else goto found;
a := (a - 0200) * 0400 + tok_mem[zo, cur_byte];
cur_byte := cur_byte + 1;
if a < 024000 then {|@'24000=(@'250-@'200)*@'400|}
begin
case ilk[a] of
normal:
begin
cur_val := a;
a := identifier;
end;
numeric:
begin
cur_val := equiv[a] - 010000;
a := number;
end;
simple:
begin
push_level(a);
goto restart;
end;
parametric:
begin
while (cur_byte = cur_end) and (stack_ptr > 0) do
pop_level;
if (stack_ptr = 0) or (tok_mem[zo, cur_byte] <> "(") then
begin
print_nl('! no parameter given for ');
print_id(a);
error;
goto restart;
end;
bal := 1;
incr(cur_byte);
while true do
begin
b := tok_mem[zo, cur_byte];
incr(cur_byte);
if b = 0 then
store_two_bytes(name_ptr + 077777)
else
begin
if b >= 0200 then
begin
app_repl(b);
b := tok_mem[zo, cur_byte];
incr(cur_byte); {skip the opening `\.('}
end
else
case b of
"(":
bal := bal + 1;
")":
begin
bal := bal - 1;
if bal = 0 then goto 30;
end;
"'":
repeat
begin
if tok_ptr[z] = max_toks then
overflow('token');
tok_mem[z, tok_ptr[z]] := b;
tok_ptr[z] := tok_ptr[z] + 1;
end;
b := tok_mem[zo, cur_byte];
incr(cur_byte);
until b = "'"; {copy string, don't change |bal|}
others:
end;
app_repl(b)
end;
end;
done:;
equiv[name_ptr] := text_ptr;
ilk[name_ptr] := simple;
w := name_ptr mod ww;
k := byte_ptr[w];
if name_ptr > max_names - ww then
overflow('name');
byte_start[name_ptr + ww] := k;
name_ptr := name_ptr + 1;
if text_ptr > max_texts - zz then
overflow('text');
text_link[text_ptr] := 0;
tok_start[text_ptr + zz] := tok_ptr[z];
incr(text_ptr);
z := text_ptr mod zz;
push_level(a);
goto restart;
end;
others:
confusion('output')
end;
goto found;
end;
if a < 050000 then {|@'50000=(@'320-@'200)*@'400|}
begin
a := a - 024000;
if equiv[a] <> 0 then
push_level(a)
else
if a <> 0 then
begin
print_nl('! not present: <');
print_id(a);
print('>');
error;
end;
goto restart;
end;
cur_val := a - 050000;
a := module_number;
cur_mod := cur_val;
found:
get_output := a;
end;
procedure flush_buffer; {writes one line to output file}
var
k: 0..out_buf_size; {index into |out_buf|}
b: 0..out_buf_size; {value of |break_ptr| upon entry}
begin
b := break_ptr;
if (semi_ptr <> 0) and (out_ptr - semi_ptr< = line_length) then
break_ptr := semi_ptr;
for k := 1 to break_ptr do
write(Pascal_file, xchr[out_buf[k - 1]]);
write_ln(Pascal_file);
line := line + 1;
if line mod 100 = 0 then
begin
print('.');
if line mod 500 = 0 then print(line:1);
update_terminal; {progress report}
end;
if break_ptr<out_ptr then
begin
if out_buf[break_ptr] = " " then
begin
incr(break_ptr); {drop space at break}
if break_ptr > b then
b := break_ptr;
end;
for k := break_ptr to out_ptr - 1 do
out_buf[k - break_ptr] := out_buf[k];
end;
out_ptr := out_ptr - break_ptr;
break_ptr := b - break_ptr;
semi_ptr := 0;
if out_ptr > line_length then
begin
err_print('! Long line must be truncated');
out_ptr := line_length;
end;
end;
procedure app_val(v: integer); {puts |v| into buffer, assumes |v>=0|}
var
k: 0..out_buf_size; {index into |out_buf|}
begin
k := out_buf_size; {first we put the digits at the very end of |out_buf|}
repeat
out_buf[k] := v mod 10;
v := v div 10;
decr(k);
until v = 0;
repeat
incr(k);
app(out_buf[k]+"0");
until k = out_buf_size; {then we append them, most significant first}
end;
procedure send_out(t: eight_bits; v: sixteen_bits); {outputs |v| of type |t|}
label
restart;
var
k: 0..line_length; {index into |out_contrib|}
begin
restart:
case out_state of
num_or_id:
if t <> frac then
begin
break_ptr := out_ptr;
if t = ident then
app(" ");
end;
sign:
begin
app("," - out_app);
if out_ptr > line_length then flush_buffer;
break_ptr := out_ptr;
end;
sign_val, sign_val_sign:
begin
if (out_val < 0) or ((out_val = 0) and (last_sign<0)) then
app("-")
else
if out_sign > 0 then
app(out_sign);
app_val(abs(out_val));
if out_ptr > line_length then
flush_buffer;;
out_state := out_state - 2;
goto restart;
end;
sign_val_val:
begin
if (t = frac) or (((t = ident) and (v = 3) and
(((out_contrib[1] = "D") and (out_contrib[2] = "I") and (out_contrib[3] = "V")) or
((out_contrib[1] = "M") and (out_contrib[2] = "O") and (out_contrib[3] = "D")))) or
((t = misc) and ((v = "*") or (v = "/")))) then
begin
if (out_val < 0) or ((out_val = 0) and (last_sign < 0)) then
app("-")
else
if out_sign > 0 then
app(out_sign);
app_val(abs(out_val));
check_break;
out_sign := "+";
out_val := out_app;
end
else
out_val := out_val + out_app;
out_state := sign_val;
goto restart;
end;
misc:
if t <> frac then
break_ptr := out_ptr;
others:; {this is for |unbreakable| state}
end;
if t <> 0 then
for k := 1 to v do
app(out_contrib[k])
else
app(v);
check_break;
if (t = misc) and ((v = ";") or (v = "}")) then
begin
semi_ptr := out_ptr;
break_ptr := out_ptr;
end;
if t >= ident then
out_state := num_or_id {|t=ident| or |frac|}
else
out_state := 0 {|t=str| or |misc|}
end;
procedure send_sign(v: integer);
begin
case out_state of
2, 4:
out_app := out_app * v;
3:
begin
out_app := v;
out_state := sign_val_sign;
end;
5:
begin
out_val := out_val + out_app;
out_app := v;
out_state := sign_val_sign;
end;
others:
begin
break_ptr := out_ptr;
out_app := v;
out_state := sign;
end
end;
last_sign := out_app;
end;
procedure send_val(v: integer); {output the (signed) value |v|}
label
bad_case, {go here if we can't keep |v| in the output state}
exit;
begin
case out_state of
num_or_id:
begin
if (out_ptr = break_ptr + 3)or((out_ptr = break_ptr + 4)and(out_buf[break_ptr] = 32)) then
if ((out_buf[out_ptr - 3] = "D") and (out_buf[out_ptr - 2] = "I") and
(out_buf[out_ptr - 1] = "V")) or
((out_buf[out_ptr - 3] = "M") and (out_buf[out_ptr - 2] = "O") and
(out_buf[out_ptr - 1] = "D")) then
goto bad_case;
out_sign := " ";
out_state := sign_val;
out_val := v;
break_ptr := out_ptr;
last_sign := +1;
end;
misc:
begin
if (out_ptr = break_ptr + 1) and ((out_buf[break_ptr] = "*") or
(out_buf[break_ptr] = "/")) then
goto bad_case;
out_sign := 0;
out_state := sign_val;
out_val := v;
break_ptr := out_ptr;
last_sign := + 1;
end;
sign:
begin
out_sign := "+";
out_state := sign_val;
out_val := out_app * v;
end;
sign_val:
begin
out_state := sign_val_val;
out_app := v;
err_print('! Two numbers occurred without a sign between them');
end;
sign_val_sign:
begin
out_state := sign_val_val;
out_app := out_app * v;
end;
sign_val_val:
begin
out_val := out_val + out_app;
out_app := v;
err_print('! Two numbers occurred without a sign between them');
end;
others: goto bad_case
end;
return;
bad_case:
if v >= 0 then
begin
if out_state = num_or_id then
begin
break_ptr := out_ptr;
app(" ")
end;
app_val(v);
check_break;
out_state := num_or_id;
end
else
begin
app("(");
app("-");
app_val(-v);
app(")");
check_break;
out_state := misc;
end
10:
end;
procedure send_the_output;
label
get_fraction, {go here to finish scanning a real constant}
reswitch, continue;
var
cur_char: eight_bits;
k: 0..line_length;
j: 0..max_bytes;
w: 0..1;
n: integer;
begin
while stack_ptr > 0 do
begin
cur_char := get_output;
reswitch:
case cur_char of
0:; {this case might arise if output ends unexpectedly}
"A",up_to("Z"):
begin
out_contrib[1] := cur_char;
send_out(ident, 1);
end;
"a",up_to("z"):
begin
out_contrib[1] := cur_char - 32;
send_out(ident, 1);
end;
identifier:
begin
k := 0;
j := byte_start[cur_val];
w := cur_val mod ww;
while (k < max_id_length) and (j < byte_start[cur_val + ww]) do
begin
incr(k);
out_contrib[k] := byte_mem[w, j];
incr(j);
if out_contrib[k] >= "a" then
out_contrib[k] := out_contrib[k] - 040
else
if out_contrib[k] = "_" then
decr(k);
end;
send_out(2, k);
end;
digits:
begin
n := 0;
repeat
cur_char := cur_char - "0";
if n >= 01463146314 then
err_print('! Constant too big')
else
n := 10 * n + cur_char;
cur_char := get_output;
until (cur_char > "9")or(cur_char < "0");
send_val(n);
k := 0;
if cur_char = "e" then
cur_char := "E";
if cur_char = "E" then
goto get_fraction
else
goto reswitch;
end;
check_sum:
send_val(pool_check_sum);
octal:
begin
n := 0;
cur_char := "0";
repeat
cur_char := cur_char - "0";
if n >= 02000000000 then
err_print('! Constant too big')
else
n := 8 * n + cur_char;
cur_char := get_output;
until (cur_char > "7") or (cur_char < "0");
send_val(n);
goto reswitch;
end;
hex:
begin
n := 0;
cur_char := "0";
repeat
if cur_char >= "A" then
cur_char := cur_char + 10 - "A"
else
cur_char := cur_char - "0";
if n >= 08000000 then
err_print('! Constant too big')
else
n := 16 * n + cur_char;
cur_char := get_output;
until (cur_char > "F") or (cur_char < "0") or
((cur_char > "9") and (cur_char < "A"));
send_val(n);
goto reswitch;
end;
number:
send_val(cur_val);
".":
begin
k := 1;
out_contrib[1] := ".";
cur_char := get_output;
if cur_char = "." then
begin
out_contrib[2] := ".";
send_out(str, 2);
end
else
if (cur_char >= "0") and (cur_char< = "9") then
goto get_fraction
else
begin
send_out(misc, ".");
goto 21;
end;
end;
"+", "-":
send_sign("," - cur_char);
and_sign:
begin
out_contrib[1]:="A";
out_contrib[2]:="N";
out_contrib[3]:="D";
send_out(ident,3);
end;
not_sign:
begin
out_contrib[1]:="N";
out_contrib[2]:="O";
out_contrib[3]:="T";
send_out(ident,3);
end;
set_element_sign:
begin
out_contrib[1]:="I";
out_contrib[2]:="N";
send_out(ident,2);
end;
or_sign:
begin
out_contrib[1]:="O";
out_contrib[2]:="R";
send_out(ident,2);
end;
left_arrow:
begin
out_contrib[1]:=":";
out_contrib[2]:="=";
send_out(str,2);
end;
not_equal:
begin
out_contrib[1]:="<";
out_contrib[2]:=">";
send_out(str,2);
end;
less_or_equal:
begin
out_contrib[1]:="<";
out_contrib[2]:="=";
send_out(str,2);
end;
greater_or_equal:
begin
out_contrib[1]:=">";
out_contrib[2]:="=";
send_out(str,2);
end;
equivalence_sign:
begin
out_contrib[1]:="=";
out_contrib[2]:="=";
send_out(str,2);
end;
double_dot:
begin
out_contrib[1]:=".";
out_contrib[2]:=".";
send_out(str,2);
end;
"'":
begin
k := 1;
out_contrib[1] := "'";
repeat
if k < line_length then
incr(k);
out_contrib[k] := get_output;
until (out_contrib[k] = "'") or (stack_ptr = 0);
if k = line_length then
err_print('! String too long');
send_out(str, k);
cur_char := get_output;
if cur_char = "'" then
out_state := unbreakable;
goto reswitch;
end;
"!", """", "#", "$", "%", "&", "(", ")", "*", ",", "/", ":", ";", "<", "=", ">", "?",
"@@", "[", "\\", "]", "^", "_", "`", '{', "|":
send_out(0, cur_char);
begin_comment:
begin
if brace_level = 0 then
send_out(misc, "{")
else
send_out(misc, "[");
incr(brace_level);
end;
end_comment:
if brace_level>0 then
begin
decr(brace_level);
if brace_level = 0 then
send_out(misc,"}")
else
send_out(misc,"]");
end
else err_print('! Extra @@}');
module_number:
begin
k := 2;
if brace_level = 0 then
out_contrib[1] := "{"
else
out_contrib[1] := "[";
if cur_val < 0 then
begin
out_contrib[k] := ":";
cur_val := -cur_val;
incr(k);
end;
n := 10;
while cur_val >= n do
n := 10 * n;
repeat
n := n div 10;
out_contrib[k] := "0" + (cur_val div n);
cur_val := cur_val mod n;
incr(k);
until n = 1;
if out_contrib[2] <> ":" then
begin
out_contrib[k] := ":";
incr(k);
end;
if brace_level=0 then
out_contrib[k] := "}"
else
out_contrib[k] := "]";
send_out(str, k);
end;
join:
begin
send_out(frac, 0);
out_state := 6;
end;
verbatim:
begin
k := 0;
repeat
if k < line_length then k := k + 1;
out_contrib[k] := get_output;
until (out_contrib[k] = 2) or (stack_ptr = 0);
if k = line_length then
err_print('! Verbatim string too long');
send_out(str, k - 1);
end;
force_line:
begin
send_out(str, 0); {normalize the buffer}
while out_ptr > 0 do
begin
if out_ptr <= line_length then
break_ptr := out_ptr;
flush_buffer;
end;
out_state := misc;
end;
others:
err_print('! Can''t output ascii code ', cur_char:1);
end;
goto continue;
get_fraction:
repeat
if k < line_length then
incr(k);
out_contrib[k] := cur_char;
cur_char := get_output;
if (out_contrib[k] = "E") and ((cur_char = "+") or (cur_char = "-"))then
begin
if k < line_length then
incr(k);
out_contrib[k] := cur_char;
cur_char := get_output;
end
else
if cur_char = "e" then
cur_char := "E";
until (cur_char <> "E") and ((cur_char < "0") or (cur_char > "9"));
if k = line_length then
err_print('! Fraction too long');
send_out(frac, k);
goto reswitch;
continue:
end;
end;
function lines_dont_match: boolean;
label
exit;
var
k: 0..buf_size; {index into the buffers}
begin
lines_dont_match := true;
if change_limit <> limit then
return;
if limit > 0 then
for k := 0 to limit - 1 do
if change_buffer[k] <> buffer[k] then
return;
lines_dont_match := false;
exit:
end;
procedure prime_the_change_buffer;
label
continue, done, exit;
var
k: 0..buf_size; {index into the buffers}
begin
change_limit := 0; {this value will be used if the change file ends}
while true do
begin
incr(line);
if not input_ln(change_file) then
return;
if limit < 2 then
goto continue;
if buffer[0] <> "@" then
goto continue;
if (buffer[1] >= "X") and (buffer[1] <= "Z") then
buffer[1] := buffer[1] + "z" - "Z"; {lowercasify}
if buffer[1] = "x" then
goto done;
if (buffer[1] = "y") or (buffer[1] = "z") then
begin
loc := 2;
err_print('! Where is the matching @x?');
end;
continue:
end;
done:;
repeat
incr(line);
if not input_ln(change_file) then
begin
err_print('! Change file ended after @@x');
return;
end;
until limit > 0;;
begin
change_limit := limit;
if limit > 0 then
for k := 0 to limit - 1 do
change_buffer[k] := buffer[k];
end;
exit:
end;
procedure check_change; {switches to |change_file| if the buffers match}
label exit;
var
n: integer; {the number of discrepancies found}
k: 0..buf_size; {index into the buffers}
begin
if lines_dont_match then
return;
n := 0;
while true do
begin
changing := not changing;
temp_line := other_line;
other_line := line;
line := temp_line;
line := line + 1;
if not input_ln(change_file)then
begin
err_print('! Change file ended before @@y');
change_limit := 0;
change_changing; {|false| again}
return;
end;
if limit > 1 then
if buffer[0] = "@" then
begin
if (buffer[1] >= "X") and (buffer[1] <= "Z") then
buffer[1] := buffer[1] + "z" - "Z"; {lowercasify}
if (buffer[1] = "x") or (buffer[1] = "z") then
begin
loc := 2;
err_print('! Where is the matching @y?');
end
else
if buffer[1] = "y" then
begin
if n > 0 then
begin
loc := 2;
err_print('! Hmm... ', n:1, ' of the preceding lines failed to match');
end;
return;
end;
end;
change_limit := limit;
if limit > 0 then
for k := 0 to limit - 1 do
change_buffer[k] := buffer[k];
change_changing; {now it's |false|}
incr(line);
if not input_ln(web_file)then
begin
err_print('! Web file ended during a change');
input_has_ended := true;
return;
end;
if lines_dont_match then
incr(n);
end;
exit:
end;
procedure get_line; {inputs the next line}
label
restart;
begin
restart:
if changing then
begin
incr(line);
if not input_ln(change_file) then
begin
err_print('! change file ended without @z');
buffer[0] := "@";
buffer[1] := "z";
limit := 2;
end;
if limit > 1 then {check if the change has ended}
if buffer[0] = "@" then
begin
if (buffer[1] >= "X") and (buffer[1] <= "Z") then
buffer[1] := buffer[1] + "z" - "Z"; {lowercasify}
if (buffer[1] = "x") or (buffer[1] = "y") then
begin
loc := 2;
err_print('! Where is the matching @z?');
end
else
if buffer[1] = "z" then
begin
prime_the_change_buffer;
change_changing;
end;
end;
end;
if not changing then
begin
begin
incr(line);
if not input_ln(web_file) then
input_has_ended := true
else if limit = change_limit then
if buffer[0] = change_buffer[0] then
if change_limit > 0 then
check_change;
end;
if changing then
goto restart;
end;
loc := 0;
buffer[limit] := " ";
end;
function control_code(c: ASCII_code): eight_bits; {convert |c| after \.{@@}}
begin
case c of
"@@":
control_code:="@@"; {`quoted' at sign}
"'":
control_code:=octal; {precedes octal constant}
"""":
control_code:=hex; {precedes hexadecimal constant}
"$":
control_code:=check_sum; {string pool check sum}
" ", tab_mark:
control_code:=new_module; {beginning of a new module}
"*":
begin
print('*',module_count+1:1);
update_terminal; {print a progress report}
control_code:=new_module; {beginning of a new module}
end;
"D","d":
control_code:=definition; {macro definition}
"F","f":
control_code:=format; {format definition}
"{":
control_code:=begin_comment; {begin-comment delimiter}
"}":
control_code:=end_comment; {end-comment delimiter}
"P","p":
control_code:=begin_Pascal; {\PASCAL\ text in unnamed module}
"T","t","^",".",":":
control_code:=control_text; {control text to be ignored}
"&":
control_code:=join; {concatenate two tokens}
"<":
control_code:=module_name; {beginning of a module name}
"=":
control_code:=verbatim; {beginning of \PASCAL\ verbatim mode}
"\\":
control_code:=force_line; {force a new line in \PASCAL\ output}
others:
control_code := ignore {ignore all other cases}
end;
end;
function skip_ahead: eight_bits; {skip to next control code}
label
done;
var
c: eight_bits; {control code found}
begin
while true do
begin
if loc > limit then
begin
get_line;
if input_has_ended then
begin
c := new_module;
goto done;
end;
end;
buffer[limit + 1] := "@";
while buffer[loc] <> "@" do
incr(loc);
if loc <= limit then
begin
loc := loc + 2;
c := control_code(buffer[loc - 1]);
if (c <> ignore)or(buffer[loc - 1] = ">") then
goto done;
end;
end;
done:
skip_ahead := c;
end;
procedure skip_comment; (*skips to next unmatched `\.\}'*)
label exit;
var
bal: eight_bits; {excess of left braces}
c: ASCII_code; {current character}
begin
bal := 0;
while true do
begin
if loc > limit then
begin
get_line;
if input_has_ended then
begin
err_print('! Input ended in mid - comment');
return;
end;
end;
c := buffer[loc];
incr(loc);
if c = 64 then
begin
c := buffer[loc];
if (c <> " ") and (c <> tab_mark) and (c <> "*") and (c <> "z") and (c <> "Z") then
incr(loc)
else
begin
err_print('! section ended in mid - comment');
decr(loc);
return;
end
end
else
if (c = "\\") and (buffer[loc] <> "@") then
incr(loc)
else if c = "{" then
incr(bal)
else if c = 125 then
begin
if bal = 0 then
return;
decr(bal);
end;
end;
exit:
end;
function get_next: eight_bits;
label
restart,
done,
found;
var
c: eight_bits; {the current character}
d: eight_bits; {the next character}
j, k: 0..longest_name; {indices into |mod_text|}
begin
restart:
if loc > limit then
begin
get_line;
if input_has_ended then
begin
c := new_module;
goto found;
end;
end;
c := buffer[loc];
loc := loc + 1;
if scanning_hex then
if ((c >= "0") and c <= "9")) or ((c >= "A") and (c <= "F")) then
goto found
else
scanning_hex := false;
case c of
"A", up_to("Z"), "a", up_to("z"):
begin
if ((c = "e") or (c = "E")) and (loc > 1) then
if (buffer[loc - 2]< = "9") and (buffer[loc - 2] >= "0") then
c := 0;
if c <> 0 then
begin
decr(loc);
id_first := loc;
repeat
incr(loc);
d := buffer[loc];
until ((d < "0") or ((d > "9") and (d < "A")) or ((d > "Z") and (d < "a")) or
(d > "z")) and (d <> "_");
if loc > id_first + 1 then
begin
c := identifier;
id_loc := loc;
end;
end
else c := "E"; {exponent of a real constant}
end;
"""":
begin
double_chars := 0;
id_first := loc - 1;
repeat
d := buffer[loc];
incr(loc);
if (d = """") or (d = "@") then
if buffer[loc] = d then
begin
incr(loc);
d := 0;
incr(double_chars);
end
else
begin
if d = "@" then
err_print('! Double @ sign missing');
end
else
if loc > limit then
begin
err_print('! String constant didn''t end');
d := 34;
end;
until d = """";
id_loc := loc - 1;
c := identifier;
end;
"@":
begin
c := control_code(buffer[loc]);
incr(loc);
if c = 0 then
goto restart
else if c = hex then
scanning_hex := true
else if c = module_name then
begin
k := 0;
while true do
begin
if loc > limit then
begin
get_line;
if input_has_ended then
begin
err_print('! Input ended in section name');
goto done;
end;
end;
d := buffer[loc];
if d = "@" then
begin
d := buffer[loc + 1];
if d = ">" then
begin
loc := loc + 2;
goto done;
end;
if (d = " ") or (d = tab_mark) or (d = "*") then
begin
err_print('! section name didn''t end');
goto done;
end;
incr(k);
mod_text[k] := "@";
incr(loc); {now |d=buffer[loc]| again}
end;
loc := loc + 1;
if k<longest_name - 1 then k := k + 1;
if (d = 32)or(d = 9)then
begin
d := 32;
if mod_text[k - 1] = 32 then k := k - 1;
end;
mod_text[k] := d;
end;
done: if k >= longest_name - 2 then
begin
print_nl('! section name too long: ');
for j := 1 to 25 do
print(xchr[mod_text[j]]);
print('...');
mark_harmless;
end;
if (mod_text[k] = " ") and (k > 0) then
decr(k);
if k > 3 then
begin
if (mod_text[k] = ".") and (mod_text[k - 1] = ".")
and (mod_text[k - 2] = ".") then
cur_mod := prefix_lookup(k - 3)
else
cur_mod := mod_lookup(k);
end
else cur_mod := mod_lookup(k);
end
else
if c = control_code then
begin
repeat
c := skip_ahead;
until c <> "@";
if buffer[loc - 1] <> ">" then
err_print('! Improper @ within control text');
goto restart;
end;
end;
".":
if buffer[loc]="." then
compress(double_dot)
else
if buffer[loc]=")" then
compress("]");
":":
if buffer[loc]="=" then
compress(left_arrow);
"=":
if buffer[loc]="=" then
compress(equivalence_sign);
">":
if buffer[loc]="=" then
compress(greater_or_equal);
"<":
if buffer[loc]="=" then
compress(less_or_equal)
else
if buffer[loc]=">" then
compress(not_equal);
"(":
if buffer[loc]="*" then
compress(begin_comment)
else
if buffer[loc]="." then
compress("[");
"*":
if buffer[loc]=")" then
compress(end_comment);
" ", tab_mark: goto restart;
"{":
begin
skip_comment;
goto 20;
end;
"}":
begin
err_print('! extra }');
goto restart;
end;
others:
if c >= 128 then {ignore nonstandard characters}
goto restart
else
end;
found:
get_next := c;
end;
procedure scan_numeric(p:name_pointer);
label
reswitch,
done;
var
accumulator: integer; {accumulates sums}
next_sign: - 1.. + 1; {sign to attach to next value}
q: name_pointer; {points to identifiers being evaluated}
val: integer; {constants being evaluated}
begin
accumulator := 0;
next_sign := +1;
while true do
begin
next_control := get_next;
reswitch:
case next_control of
digits:
begin
val := 0;
repeat
val := 10 * val + next_control - "0";
next_control := get_next;
until (next_control > "9") or (next_control < "0");
add_in(val);
goto reswitch;
end;
octal:
begin
val := 0;
next_control := "0";
repeat
val := 8*val + next_control - "0";
next_control := get_next;
until (next_control > "7")or(next_control<"0");
add_in(val);
goto reswitch;
end;
hex:
begin
val := 0;
next_control := "0";
repeat
if next_control >= "A" then next_control := next_control + "0" + 10 - "A";
val := 16 * val + next_control - "0";
next_control := get_next;
until (next_control > "F") or (next_control<"0") or ((next_control > "9") and
(next_control < "A"));
add_in(val);
goto reswitch;
end;
identifier:
begin
q := id_lookup(normal);
if ilk[q] <> numeric then
begin
next_control := "*";
goto reswitch; {leads to error}
end;
add_in(equiv[q] - 0100000);
end;
"+":;
"-":
next_sign := -next_sign;
format, definition, module_name, begin_Pascal, new_module:
goto done;
";":
err_print('! Omit semicolon in numeric definition');
others:
begin
err_print('! Improper numeric definition will be flushed');
repeat
next_control := skip_ahead
until end_of_definition(next_control);
if next_control = module_name then
begin {we want to scan the module name too}
loc := loc - 2;
next_control := get_next;
end;
accumulator := 0;
goto done;
end
end;
end;
done:;
if abs(accumulator) >= 0100000 then
begin
err_print('! Value too big: ', accumulator:1);
accumulator := 0;
end;
equiv[p] := accumulator + 0100000; {name |p| now is defined to equal |accumulator|}
end;
procedure scan_repl(t: eight_bits); {creates a replacement text}
label
continue,
done,
found,
reswitch;
var
a: sixteen_bits; {the current token}
b: ASCII_code; {a character from the buffer}
bal: eight_bits; {left parentheses minus right parentheses}
begin
bal := 0;
while true do
begin
continue:
a := get_next;
case a of
"(":
bal := bal + 1;
")":
if bal = 0 then
err_print('! extra )');
else
decr(bal);
"'":
begin
b := "'";
while true do
begin
app_repl(b);
if b = "@" then
if buffer[loc] = "@" then
incr(loc) {store only one \.{@@}}
else
err_print('! You should double @ signs in strings');
if loc = limit then
begin
err_print('! String didn''t end');
buffer[loc] := "'";
buffer[loc + 1] := 0;
end;
b := buffer[loc];
incr(loc);
if b = "'" then
begin
if buffer[loc] <> "'" then
goto found
else
begin
incr(loc);
app_repl(b);
end;
end;
end;
found: {now |a| holds the final |"'"| that will be stored}
end;
"#":
if t = parametric then
a := param;
identifier:
begin
a := id_lookup(0);
app_repl((a div 0400) + 0200);
a := a mod 0400;
end;
module_name:
if t <> module_name then
goto done
else
begin
app_repl((cur_mod div 0400) + 0250)
a := cur_mod mod 0400;
end;
verbatim:
begin
app_repl(verbatim);
buffer[limit + 1] := "@";
reswitch: if buffer[loc] = "@" then
begin
if loc < limit then
if buffer[loc + 1] = "@" then
begin
app_repl("@");
loc := loc + 2;
goto reswitch;
end;
end
else
begin
app_repl(buffer[loc]);
incr(loc);
goto reswitch;
end;
if loc >= limit then
err_print('! Verbatim string didn''t end');
else
if buffer[loc + 1] <> ">" then
err_print('! You should double @ signs in verbatim strings');
loc := loc + 2;
end; {another |verbatim| byte will be stored, since |a=verbatim|}
definition, format, begin_Pascal:
if t <> module_name then
goto done
else
begin
err_print('! @', xchr[buffer[loc - 1]], ' is ignored in pascal text');
goto continue;
end;
new_module:
goto done;
others:
end;
app_repl(a);
end;
end;
done: next_control := a;
if bal > 0 then
begin
if bal = 1 then
err_print('! missing )');
else
err_print('! missing ', bal:1, ' )''s');
while bal > 0 do
begin
app_repl(")")
decr(bal);
end;
end;
if text_ptr > max_texts - zz then
overflow('text');
cur_repl_text := text_ptr;
tok_start[text_ptr + zz] := tok_ptr[z];
incr(text_ptr);
if z = zz - 1 then
z := 0
else
incr(z);
end;
procedure define_macro(t:eight_bits);
var
p: name_pointer; {the identifier being defined}
begin
p := id_lookup(t);
scan_repl(t);
equiv[p] := cur_repl_text;
text_link[cur_repl_text] := 0;
end;
procedure scan_module;
label
continue,
done,
exit;
var
p: name_pointer; {module name for the current module}
begin
incr(module_count);
next_control := 0;
while true do
begin
continue:
while next_control <= format do
begin
next_control := skip_ahead;
if next_control = module_name then
begin {we want to scan the module name too}
loc := loc - 2;
next_control := get_next;
end;
end;
if next_control <> definition then
goto done;
next_control := get_next;
if next_control <> identifier then
begin
err_print('! Definition flushed, must start with ', 'identifier of length > 1');
goto continue;
end;
next_control := get_next;
if next_control = "=" then
begin
scan_numeric(id_lookup(numeric));
goto continue;
end
else
if next_control = equivalence_sign then
begin
define_macro(simple);
goto continue;
end
else
if next_control = "(" then
begin
next_control := get_next;
if next_control = "#" then
begin
next_control := get_next;
if next_control = ")" then
begin
next_control := get_next;
if next_control = "=" then
begin
err_print('! Use == for macros');
next_control := equivalence_sign;
end;
if next_control = equivalence_sign then
begin
define_macro(parametric);
goto continue;
end;
end;
end;
end;
err_print('! Definition flushed since it starts badly');
end;
done:;
case next_control of
begin_Pascal:
p := 0;
module_name:
begin
p := cur_mod;
repeat
next_control := get_next;
until next_control <> "+"; (*allow optional `\.{+=}'*)
if (next_control <> "=")and(next_control <> equivalence_sign)then
begin
err_print('! Pascal text flushed, = sign is missing');
repeat
next_control := skip_ahead;
until next_control = new_module;
return;
end;
end;
others: return
end;
store_two_bytes(0150000 + module_count); {|@'150000=@'320*@'400|}
scan_repl(135); {now |cur_repl_text| points to the replacement text}
if p = 0 then {unnamed module}
begin
text_link[last_unnamed] := cur_repl_text;
last_unnamed := cur_repl_text;
end
else
if equiv[p] = 0 then {first module of this name}
equiv[p] := cur_repl_text
else
begin
p := equiv[p];
while text_link[p] < max_texts do {find end of list}
p := text_link[p];
text_link[p] := cur_repl_text;
end;
text_link[cur_repl_text] := module_flag; {mark this replacement text as a nonmacro}
exit:
end;
begin
initialize;
open_input;
line := 0;
other_line := 0;
changing := true;
prime_the_change_buffer;
change_changing;
limit := 0;
loc := 1;
buffer[0] := " ";
input_has_ended := false;
print_ln('This is TANGLE, version 4.5'); {print a ``banner line''}
phase_one := true;
module_count := 0;
repeat
next_control := skip_ahead;
until next_control = new_module;
while not input_has_ended do
scan_module;
if change_limit <> 0 then
begin
for ii := 0 to change_limit do
buffer[ii
] := change_buffer[ii];
limit := change_limit;
changing := true;
line := other_line;
loc := change_limit;
begin
new_line;
print('! change file entry did not match');
error;
end;
end;
phase_one := false;
if text_link[0] = 0 then
begin
print_nl('! No output was specified.');
mark_harmless;
end
else
begin
print_nl('Writing the output file');
update_terminal;
stack_ptr := 1;
brace_level := 0;
cur_name := 0;
cur_repl := text_link[0];
zo := cur_repl mod zz;
cur_byte := tok_start[cur_repl];
cur_end := tok_start[cur_repl + zz];
cur_mod := 0;
out_state := misc;
out_ptr := 0;
break_ptr := 0;
semi_ptr := 0;
out_buf[0] := 0;
line := 1;;
send_the_output;
break_ptr := out_ptr;
semi_ptr := 0;
flush_buffer;
if brace_level <> 0 then
err_print('! Program ended at brace level ', brace_level:1);
print_nl('Done.');
end;
end_of_TANGLE:
if string_ptr > 256 then
begin
print_nl(string_ptr - 256:1, ' strings written to string pool file.');
write(pool, '*');
for ii := 1 to 9 do
begin
out_buf[ii] := pool_check_sum mod 10;
pool_check_sum := pool_check_sum div 10;
end;
for ii := 9 downto 1 do
write(pool, xchr["0" + out_buf[ii]]);
write_ln(pool);
end;
case history of
0:
begin
new_line;
print('(No errors were found.)');
end;
1:
begin
new_line;
print('(Did you see the warning message above?)');
end;
2:
begin
new_line;
print('(Pardon me, but I think I spotted something wrong.)');
end;
3:
begin
new_line;
print('(That was a fatal error, my friend.)');
end;
end;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment