[llvm-commits] CVS: llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/README grading.p mf.p ptc.p
John Criswell
criswell at cs.uiuc.edu
Mon Feb 16 17:44:05 PST 2004
Changes in directory llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT:
README added (r1.1)
grading.p added (r1.1)
mf.p added (r1.1)
ptc.p added (r1.1)
---
Log message:
Initial commit of the p2c benchmark (part of the Malloc Benchmark).
---
Diffs of the changes: (+29755 -0)
Index: llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/README
diff -c /dev/null llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/README:1.1
*** /dev/null Mon Feb 16 17:43:41 2004
--- llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/README Mon Feb 16 17:43:31 2004
***************
*** 0 ****
--- 1,8 ----
+
+ Test Inputs to p2c program:
+
+ p2c -v < INPUT/grading.p
+ p2c -v < INPUT/ptc.p
+ p2c -v < INPUT/mf.p
+
+
Index: llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/grading.p
diff -c /dev/null llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/grading.p:1.1
*** /dev/null Mon Feb 16 17:43:41 2004
--- llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/grading.p Mon Feb 16 17:43:31 2004
***************
*** 0 ****
--- 1,514 ----
+ program grading (input, output);
+
+ const
+ namelength = 34;
+ idlength = 12;
+ commentlength = 6;
+ headlinelength = 40;
+
+ type
+
+ scores =
+ (
+ assign1, assign2, assign3, assign4,
+ assign5, assign6, assign7, assign8, assigns,
+ exam1, exam2, better, final, total
+ );
+
+ gradetype =
+ (
+ A, Aminus,
+ Bplus, B, Bminus,
+ Cplus, C, Cminus,
+ Dplus, D, Dminus,
+ F
+ );
+
+ grades =
+ (
+ absolu, curved, course
+ );
+
+ namestring = packed array [1.. namelength] of char;
+ idstring = packed array [1.. idlength] of char;
+ commentstring = packed array [1.. commentlength] of char;
+ headlinestring = packed array [1..headlinelength] of char;
+
+ studentpointer = ^ studentrecord;
+ studentrecord =
+ record
+ name : namestring;
+ id : idstring;
+ score : array [scores] of integer;
+ grade : array [grades] of gradetype;
+ rank : integer;
+ percentile : integer;
+ comment : commentstring;
+ next : studentpointer;
+ nextinrank : studentpointer
+ end;
+
+ var
+ studentlist : studentpointer;
+ nonames : boolean;
+ nstudents, noshows, nofinals : integer;
+
+ scoresfile : text;
+
+ histogram : array [0..100] of integer;
+ histogramlist : array [0..100] of studentpointer;
+
+ scoretorank : array [0..100] of integer; (* scoretorank [76] = rank of student(s)
+ with total score of 76 *)
+ percent : array [0..100] of integer; (* percent [76] = percentile of student(s)
+ with total score of 76 *)
+
+ function isnoshow (student : studentrecord) : boolean;
+ begin
+ isnoshow := (student.score [total] = 0)
+ end (* isnoshow *);
+
+ procedure computescoretorank;
+ var
+ score, nhigher : integer;
+ begin
+ nhigher := 0;
+ for score := 100 downto 0 do begin
+ scoretorank [score] := 1 + nhigher;
+ if
+ (nstudents - noshows - nofinals) > 0
+ then
+ percent [score] :=
+ ((nstudents - noshows - nofinals - nhigher) * 100)
+ div
+ (nstudents - noshows - nofinals)
+ else
+ percent [score] := 0;
+ nhigher := nhigher + histogram [score];
+ end
+ end (* computescoretorank *);
+
+ procedure settitle (headline : headlinestring);
+ begin
+ writeln ('.bp');
+ writeln ('.ds Ti ', headline)
+ end (* settitle *);
+
+ procedure writetroffheader;
+ begin
+ writeln ('.po 1.2c');
+ writeln ('.m3 0');
+ writeln ('.m4 10');
+ writeln ('.ps 8');
+ writeln ('.vs 10');
+ writeln ('.pl 10.0i');
+ writeln ('.ll 7.3i');
+ writeln ('.lt 7.3i');
+ writeln ('\ ');
+ writeln ('.bp');
+ writeln ('.de $f');
+ writeln ('.ev 1');
+ writeln ('.nf');
+ writeln ('.ti 4.85c');
+ writeln ('\fC\ Gr\ \ \ \ \ Id\ \ \ \ \ \ \ \ A1\ A2\ A3\ A4\ A5\ A6\ A7\ A8\ A\ \ E1\ E2\ E\ \ Fi\ To\ Ab\ Cu\ Gr\ Rank\ Percentile\ Coll');
+ writeln ('.sp 2');
+ writeln ('.in 1.0i');
+ writeln ('\fC\s+2A = \fRsum of all assignments');
+ writeln ('\fCE1 = \fRfirst exam');
+ writeln ('\fCE2 = \fRsecond exam');
+ writeln ('\fCE = \fR better of first two exams');
+ writeln ('\fCFi = \fRfinal exam');
+ writeln ('.sp -5');
+ writeln ('.in +2.3i');
+ writeln ('\fCTo = \fRtotal score in course');
+ writeln ('\fCAb = \fRgrade according to first (absolute, i.e. not curved) policy');
+ writeln ('\fCCu = \fRgrade according to second (curved) policy');
+ writeln ('\fCGr = \fRcourse grade');
+ writeln ('Percentiles are computed ignoring ''No shows'' and ''No finals''.\s-2');
+ writeln ('.sp 2');
+ writeln ('.in 0');
+ writeln ('.tl ^\s+8\fB\\*(Ti^^\*(td\s-8\fP^^');
+ writeln ('.ev');
+ writeln ('..');
+ writeln ('.de $h');
+ writeln ('.ev 1');
+ writeln ('.ps 8');
+ writeln ('.vs 10');
+ writeln ('\ ');
+ writeln ('.sp |2.5c');
+ writeln ('.ti 4.85c');
+ writeln ('\fC\ Gr\ \ \ \ \ Id\ \ \ \ \ \ \ \ A1\ A2\ A3\ A4\ A5\ A6\ A7\ A8\ A\ \ E1\ E2\ E\ \ Fi\ To\ Ab\ Cu\ Gr\ Rank\ Percentile\ Coll');
+ writeln ('.sp 2');
+ writeln ('.ev');
+ writeln ('..');
+ writeln ('\ ');
+ writeln ('.bp');
+ writeln ('\fC');
+ writeln ('.nf');
+ writeln ('.ev 1');
+ writeln ('.ps 8');
+ writeln ('.vs 10');
+ writeln ('.ev');
+ end (* writetroffheader *);
+
+ procedure initialize;
+ var
+ score : integer;
+ begin
+ nstudents := 0;
+ noshows := 0;
+ nofinals := 0;
+ studentlist := nil;
+
+ for score := 0 to 100 do begin
+ histogram [score] := 0;
+ histogramlist [score] := nil
+ end;
+
+ writetroffheader
+ end (* initialize *);
+
+ procedure readscores;
+ var
+ newstudent : studentpointer;
+ s : scores;
+ c : integer;
+ begin
+ new (newstudent);
+ nstudents := nstudents + 1;
+
+ with newstudent^ do begin
+ next := studentlist;
+
+ for c := 1 to namelength do
+ read (input, name [c]);
+
+ for c := 1 to idlength do
+ read (input, id [c]);
+
+ for s := assign1 to assign8 do
+ read (input, score [s]);
+
+ read (input, score [exam1]);
+ read (input, score [exam2]);
+ read (input, score [final]);
+
+ for c := 1 to commentlength do
+ read (input, comment [c])
+ end;
+
+ readln (input);
+ studentlist := newstudent
+ end (* readscores *);
+
+ procedure computescores (student : studentpointer);
+ var
+ s : scores;
+ begin
+ with student^ do begin
+ score [assigns] := 0;
+ for s := assign1 to assign8 do
+ score [assigns] := score [assigns] + score [s];
+
+ if
+ score [exam1] > score [exam2]
+ then
+ score [better] := score [exam1]
+ else
+ score [better] := score [exam2];
+
+ score [total] := score [assigns]
+ + score [better ]
+ + score [final ];
+
+ if
+ isnoshow (student^)
+ then
+ noshows := noshows + 1
+ else if
+ score [final] = 0
+ then
+ nofinals := nofinals + 1
+ else
+ histogram [score [total]] := histogram [score [total]] + 1;
+
+ end
+ end (* computescores *);
+
+ procedure computeallscores (studentlist : studentpointer);
+ begin
+ if
+ studentlist <> nil
+ then begin
+ computescores (studentlist);
+ computeallscores (studentlist^.next)
+ end
+ end (* computeallscores *);
+
+ procedure computegrades (student : studentpointer);
+
+ begin
+ with student^ do begin
+ if score [total] >= 90 then grade [absolu] := A else
+ if score [total] >= 88 then grade [absolu] := Aminus else
+ if score [total] >= 86 then grade [absolu] := Bplus else
+ if score [total] >= 80 then grade [absolu] := B else
+ if score [total] >= 78 then grade [absolu] := Bminus else
+ if score [total] >= 76 then grade [absolu] := Cplus else
+ if score [total] >= 70 then grade [absolu] := C else
+ if score [total] >= 65 then grade [absolu] := Cminus else
+ if score [total] >= 60 then grade [absolu] := Dplus else
+ if score [total] >= 55 then grade [absolu] := D else
+ if score [total] >= 50 then grade [absolu] := Dminus else
+ grade [absolu] := F
+ ;
+
+ rank := scoretorank [score [total]];
+ nextinrank := histogramlist [score [total]];
+ histogramlist [score [total]] := student;
+ percentile := percent [score [total]];
+
+ if percentile >= 80 then grade [curved] := A else
+ if percentile >= 78 then grade [curved] := Aminus else
+ if percentile >= 76 then grade [curved] := Bplus else
+ if percentile >= 50 then grade [curved] := B else
+ if percentile >= 48 then grade [curved] := Bminus else
+ if percentile >= 46 then grade [curved] := Cplus else
+ if percentile >= 25 then grade [curved] := C else
+ if percentile >= 23 then grade [curved] := Cminus else
+ if percentile >= 21 then grade [curved] := Dplus else
+ if percentile >= 10 then grade [curved] := D else
+ if percentile >= 8 then grade [curved] := Dminus else
+ grade [curved] := F
+ ;
+
+ if
+ grade [absolu] < grade [curved]
+ then
+ grade [course] := grade [absolu]
+ else
+ grade [course] := grade [curved]
+
+ end
+ end (* computegrades *);
+
+ procedure computeallgrades (studentlist : studentpointer);
+ begin
+ if
+ studentlist <> nil
+ then begin
+ computegrades (studentlist);
+ computeallgrades (studentlist^.next)
+ end
+ end (* computeallgrades *);
+
+ function gradepoint (g : gradetype) : real;
+ begin
+ if g = A then gradepoint := 4.0 else
+ if g = Aminus then gradepoint := 3.7 else
+ if g = Bplus then gradepoint := 3.3 else
+ if g = B then gradepoint := 3.0 else
+ if g = Bminus then gradepoint := 2.7 else
+ if g = Cplus then gradepoint := 2.3 else
+ if g = C then gradepoint := 2.0 else
+ if g = Cminus then gradepoint := 1.7 else
+ if g = Dplus then gradepoint := 1.3 else
+ if g = D then gradepoint := 1.0 else
+ if g = Dminus then gradepoint := 0.7 else
+ if g = F then gradepoint := 0.0 else
+ gradepoint := 0.0
+ end (* gradepoint *);
+
+ procedure writegrade (g : gradetype);
+ begin
+ if g = A then write (' A ') else
+ if g = Aminus then write (' A-') else
+ if g = Bplus then write (' B+') else
+ if g = B then write (' B ') else
+ if g = Bminus then write (' B-') else
+ if g = Cplus then write (' C+') else
+ if g = C then write (' C ') else
+ if g = Cminus then write (' C-') else
+ if g = Dplus then write (' D+') else
+ if g = D then write (' D ') else
+ if g = Dminus then write (' D-') else
+ if g = F then write (' F ') else
+ write (' ??')
+ end (* writegrade *);
+
+ procedure readallscores;
+ begin
+ while
+ not eof (input)
+ do
+ readscores
+ end (* readallscores *);
+
+ procedure writestudent (student : studentpointer);
+ var
+ c : integer;
+ s : scores;
+ g : grades;
+ begin
+ end (* writestudent *);
+
+ procedure writestraight (studentlist : studentpointer);
+ begin
+ if
+ studentlist <> nil
+ then begin
+ writestraight (studentlist^.next);
+ writestudent (studentlist);
+ end
+ end (* writestraight *);
+
+ procedure gotoXY (x, y : integer);
+ begin
+ writeln ('\ ');
+ writeln ('.sp |', 1500 - 40 * y : 0, 'u');
+ writeln ('.ti ', 40 * x : 0, 'u');
+ end (* gotoXY *);
+
+ procedure writehistogram;
+ var
+ score, height : integer;
+ begin
+ for score := 0 to 100 do
+ for height := 1 to histogram [score] do begin
+ gotoXY (score, height);
+ writeln ('X')
+ end;
+
+ score := 0;
+ repeat
+ gotoXY (score, - 1);
+ writeln ('\v''0.5c''|');
+ gotoXY (score, - 3);
+ writeln (score : 0);
+ score := score + 5
+ until
+ score > 100;
+
+ gotoXY (0,- 10)
+ end (* writehistogram *);
+
+ procedure writerank (studentlist : studentpointer);
+ begin
+ if
+ studentlist <> nil
+ then begin
+ writerank (studentlist^.nextinrank);
+ writestudent (studentlist)
+ end
+ end (* writerank *);
+
+ procedure writebyrank;
+ var
+ score : integer;
+ begin
+ for score := 100 downto 0 do
+ writerank (histogramlist [score])
+ end (* writebyrank *);
+
+ procedure stats;
+ var
+ scoresum : array [scores] of real;
+ gradecount : array [grades, gradetype] of integer;
+ s : scores;
+ g : grades;
+ gt : gradetype;
+ currentstudent : studentpointer;
+ begin
+ writeln ('.in 0');
+ writeln ('.hl');
+ writeln ('\fC');
+ writeln ('.2c');
+ write ('Number of students: ');
+ writeln (nstudents : 5);
+ write (' No-shows: ');
+ writeln (noshows : 5);
+ write (' No finals: ');
+ writeln (nofinals : 5);
+ write (' Assignment 1: ');
+ writeln (scoresum [assign1] / (nstudents - noshows) : 5 : 1);
+ write (' Assignment 2: ');
+ writeln (scoresum [assign2] / (nstudents - noshows) : 5 : 1);
+ write (' Assignment 3: ');
+ writeln (scoresum [assign3] / (nstudents - noshows) : 5 : 1);
+ write (' Assignment 4: ');
+ writeln (scoresum [assign4] / (nstudents - noshows) : 5 : 1);
+ write (' Assignment 5: ');
+ writeln (scoresum [assign5] / (nstudents - noshows) : 5 : 1);
+ write (' Assignment 6: ');
+ writeln (scoresum [assign6] / (nstudents - noshows) : 5 : 1);
+ write (' Assignment 7: ');
+ writeln (scoresum [assign7] / (nstudents - noshows) : 5 : 1);
+ write (' Assignment 8: ');
+ writeln (scoresum [assign8] / (nstudents - noshows) : 5 : 1);
+ write (' All assignments: ');
+ writeln (scoresum [assigns] / (nstudents - noshows) : 5 : 1);
+ write (' Exam 1: ');
+ writeln (scoresum [exam1 ] / (nstudents - noshows) : 5 : 1);
+ write (' Exam 2: ');
+ writeln (scoresum [exam2 ] / (nstudents - noshows) : 5 : 1);
+ write (' Better of 1,2: ');
+ writeln (scoresum [better ] / (nstudents - noshows) : 5 : 1);
+ write (' Final exam: ');
+ writeln (scoresum [final ] / (nstudents - noshows) : 5 : 1);
+ write (' Total score: ');
+ writeln (scoresum [total ] / (nstudents - noshows) : 5 : 1);
+
+ writeln ('.sp 2');
+ writeln ('Absolute grade distribution: ');
+ for gt := A to F do begin
+ writegrade (gt);
+ writeln (gradecount [absolu, gt])
+ end;
+ writeln ('.bc');
+
+ writeln ('Curved grade distribution: ');
+ for gt := A to F do begin
+ writegrade (gt);
+ writeln (gradecount [curved, gt])
+ end;
+ writeln ('.sp 2');
+
+ writeln ('Course grade distribution: ');
+ for gt := A to F do begin
+ writegrade (gt);
+ writeln (gradecount [course, gt])
+ end;
+
+ end (* stats *);
+
+ begin
+ initialize;
+ readallscores;
+ computeallscores (studentlist);
+ computescoretorank;
+ computeallgrades (studentlist);
+
+ settitle ('CSCI 1200, Spring 1989');
+ nonames := false;
+ writestraight (studentlist);
+
+ settitle ('CSCI 1200, Spring 1989');
+ nonames := true;
+ writestraight (studentlist);
+
+ settitle ('CSCI 1200, Spring 1989, grades by rank');
+ nonames := false;
+ writebyrank;
+
+ settitle ('CSCI 1200, Spring 1989, grade statistics');
+ writeln ('.de $f');
+ writeln ('.tl ^\v''1.0i''\s+8\fB\\*(Ti^^\*(td\s-8\fP\v''-1.0i''^^');
+ writeln ('..');
+ writeln ('.de $h');
+ writeln ('..');
+ writeln ('\ ');
+ writeln ('.bp');
+ writeln ('Histogram, without ''No-shows'' and ''No finals''');
+ writehistogram;
+ stats;
+ end.
Index: llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p
diff -c /dev/null llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p:1.1
*** /dev/null Mon Feb 16 17:43:42 2004
--- llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p Mon Feb 16 17:43:31 2004
***************
*** 0 ****
--- 1,19497 ----
+ program MF(input, output); {6:}
+
+ {------------------------------}
+ { declarations are in mf2ps1.h }
+ {------------------------------}
+ label
+ 1, 9998, 9999;
+ {:6} {11:}
+ const
+ memmax = 30000;
+ maxinternal = 100;
+ bufsize = 500;
+ errorline = 79;
+ halferrorline = 50;
+ maxprintline = 79;
+ screenwidth = 1024;
+ screendepth = 1024;
+ stacksize = 30;
+ maxstrings = 2000;
+ stringvacancies = 8000;
+ poolsize = 32000;
+ movesize = 5000;
+ maxwiggle = 300;
+ gfbufsize = 800;
+ filenamesize = 256;
+ poolname = 'mf.pool';
+ pathsize = 300;
+ bistacksize = 785;
+ headersize = 100;
+ ligtablesize = 300;
+ maxfontdimen = 50; {:11} {18:}
+ type
+ ASCIIcode = 0..127; {:18}
+ {24:}
+ eightbits = 0..255;
+ alphafile = text;
+ {------------------}
+ postscript = text;
+ {------------------}
+ UNIXfilename = packed array [1..filenamesize] of char;
+ bytefile =
+ record
+ stdioptr: ^ integer;
+ locptr: ^ integer;
+ filename: UNIXfilename
+ end; {:24} {37:}
+ poolpointer = 0..poolsize;
+ strnumber = 0..maxstrings; {:37}
+ {101:}
+ scaled = integer;
+ smallnumber = 0..63; {:101} {105:}
+ fraction = integer;
+ {:105}
+ {106:}
+ angle = integer; {:106} {156:}
+ quarterword = -128..127;
+ halfword = -32768..32767;
+ twochoices = 1..2;
+ threechoices = 1..3;
+ twohalves = packed
+ record
+ rh: halfword;
+ case twochoices of
+ 1: (
+ lh: halfword
+ );
+ 2: (
+ b0: quarterword;
+ b1: quarterword
+ )
+ end;
+ fourquarters = packed
+ record
+ b0: quarterword;
+ b1: quarterword;
+ b2: quarterword;
+ b3: quarterword
+ end;
+ memoryword =
+ record
+ case threechoices of
+ 1: (
+ int: integer
+ );
+ 2: (
+ hh: twohalves
+ );
+ 3: (
+ qqqq: fourquarters
+ )
+ end;
+ wordfile = file of memoryword; {:156} {186:}
+ commandcode = 1..82; {:186} {565:}
+ screenrow = 0..screendepth;
+ screencol = 0..screenwidth;
+ transspec = array [screencol] of screencol;
+ pixelcolor = 0..1; {:565} {571:}
+ windownumber = 0..15; {:571} {627:}
+ instaterecord =
+ record
+ indexfield: quarterword;
+ startfield, locfield, limitfield, namefield: halfword
+ end; {:627} {1151:}
+ gfindex = 0..gfbufsize;
+ gfbuftype = array [gfindex] of eightbits; {:1151} {13:}
+ var
+ bad: integer; {:13} {20:}
+ xord: array [char] of ASCIIcode;
+ xchr: array [ASCIIcode] of char; {:20} {25:}
+ nameoffile, realnameoffile: UNIXfilename;
+ namelength: 0..filenamesize; {:25}
+ {29:}
+ buffer: array [0..bufsize] of ASCIIcode;
+ first: 0..bufsize;
+ last: 0..bufsize;
+ maxbufstack: 0..bufsize; {:29} {38:}
+ strpool: packed array [poolpointer] of ASCIIcode;
+ strstart: array [strnumber] of poolpointer;
+ poolptr: poolpointer;
+ strptr: strnumber;
+ initpoolptr: poolpointer;
+ initstrptr: strnumber;
+ maxpoolptr: poolpointer;
+ maxstrptr: strnumber; {:38} {42:}
+ strref: array [strnumber] of 0..127; {:42} {50:}
+ poolfile: alphafile; {:50} {54:}
+ logfile: alphafile;
+ {-------------------------------------------------------------}
+ psfile :postscript; { the PostScript code }
+ g :postscript; { holds the character information after re-arrange}
+ lastx0 , lasty0 :real ; { last point in sunpath }
+ lastx3 , lasty3 :real ; { make optimization on commands }
+ prevtox3 , prevtoy3 :real;
+ lastyearval , { mark entering to macros }
+ lastmonthval :integer; { STROKE , FILL , and ERASE }
+ { in MY plain.mf }
+ my_xx , my_yy :integer; { hold the values of xx & yy }
+ LineSource : integer; { Identifier for sendline source }
+ CurveSource : integer; { Identifier for makemoves source }
+ foundnew : boolean; { true while xchr[s]='[' until ']' }
+ ascval : integer; { holds the ascii of curr. letter }
+ ascii_on : boolean; { reading ascval is 'on' }
+ {-------------------------------------------------------------}
+ selector: 0..5;
+ dig: array [0..22] of 0..15;
+ tally: integer;
+ termoffset: 0..maxprintline;
+ fileoffset: 0..maxprintline;
+ trickbuf: array [0..errorline] of ASCIIcode;
+ trickcount: integer;
+ firstcount: integer; {:54} {68:}
+ interaction: 0..3; {:68} {71:}
+ deletionsallowed: boolean;
+ history: 0..3;
+ errorcount: -1..100; {:71} {74:}
+ helpline: array [0..5] of strnumber;
+ helpptr: 0..6;
+ useerrhelp: boolean;
+ errhelp: strnumber; {:74} {91:}
+ interrupt: integer;
+ OKtointerrupt: boolean;
+ {:91}
+ {97:}
+ aritherror: boolean; {:97} {129:}
+ twotothe: array [0..30] of integer;
+ speclog: array [1..28] of integer; {:129} {137:}
+ specatan: array [1..26] of angle; {:137} {144:}
+ nsin, ncos: fraction; {:144}
+ {148:}
+ randoms: array [0..54] of fraction;
+ jrandom: 0..54; {:148} {158:}
+ tempptr: halfword; {:158} {159:}
+ mem: array [-30000..memmax] of memoryword;
+ lomemmax: halfword;
+ himemmin: halfword; {:159} {160:}
+ varused, dynused: integer;
+ {:160}
+ {161:}
+ avail: halfword;
+ memend: halfword; {:161} {166:}
+ rover: halfword;
+ {:166}
+ {178:}
+ freearr: packed array [-30000..memmax] of boolean;
+ wasfree: packed array [-30000..memmax] of boolean;
+ wasmemend, waslomax, washimin: halfword;
+ panicking: boolean; {:178} {190:}
+ internal: array [1..maxinternal] of scaled;
+ intname: array [1..maxinternal] of strnumber;
+ intptr: 40..maxinternal; {:190}
+ {196:}
+ oldsetting: 0..5; {:196} {198:}
+ charclass: array [ASCIIcode] of 0..20;
+ {:198}
+ {200:}
+ hashused: halfword;
+ stcount: integer; {:200} {201:}
+ hash: array [1..2241] of twohalves;
+ eqtb: array [1..2241] of twohalves; {:201}
+ {225:}
+ gpointer: halfword; {:225} {230:}
+ bignodesize: array [13..14] of smallnumber; {:230} {250:}
+ saveptr: halfword;
+ {:250}
+ {267:}
+ pathtail: halfword; {:267} {279:}
+ deltax, deltay, delta: array [0..pathsize] of scaled;
+ psi: array [1..pathsize] of angle; {:279} {283:}
+ theta: array [0..pathsize] of angle;
+ uu: array [0..pathsize] of fraction;
+ vv: array [0..pathsize] of angle;
+ ww: array [0..pathsize] of fraction; {:283}
+ {298:}
+ st, ct, sf, cf: fraction; {:298} {308:}
+ move: array [0..movesize] of integer;
+ moveptr: 0..movesize; {:308} {309:}
+ bisectstack: array [0..bistacksize] of integer;
+ bisectptr: 0..bistacksize;
+ {:309}
+ {327:}
+ curedges: halfword;
+ curwt: integer; {:327} {371:}
+ tracex: integer;
+ tracey: integer;
+ traceyy: integer; {:371} {379:}
+ octant: 1..8; {:379} {389:}
+ curx, cury: scaled; {:389} {395:}
+ octantdir: array [1..8] of strnumber; {:395}
+ {403:}
+ curspec: halfword;
+ turningnumber: integer;
+ curpen: halfword;
+ curpathtype: 0..2;
+ maxallowed: scaled; {:403} {427:}
+ before, after: array [0..maxwiggle] of scaled;
+ nodetoround: array [0..maxwiggle] of halfword;
+ curroundingptr: 0..maxwiggle;
+ maxroundingptr: 0..maxwiggle; {:427} {430:}
+ curgran: scaled; {:430} {448:}
+ octantnumber: array [1..8] of 1..8;
+ octantcode: array [1..8] of 1..8; {:448}
+ {455:}
+ revturns: boolean; {:455} {461:}
+ ycorr, xycorr, zcorr: array [1..8] of 0..1;
+ xcorr: array [1..8] of -1..1; {:461}
+ {464:}
+ m0, n0, m1, n1: integer;
+ d0, d1: 0..1; {:464} {507:}
+ envmove: array [0..movesize] of integer; {:507} {552:}
+ tolstep: 0..6; {:552}
+ {555:}
+ curt, curtt: integer;
+ timetogo: integer;
+ maxt: integer; {:555} {557:}
+ delx, dely: integer;
+ tol: integer;
+ uv, xy: 0..bistacksize;
+ threel: integer;
+ apprt, apprtt: integer; {:557} {566:}
+ {screenpixel:array[screenrow,screencol]of pixelcolor;}
+ {:566}
+ {569:}
+ screenstarted: boolean;
+ screenOK: boolean; {:569} {572:}
+ windowopen: array [windownumber] of boolean;
+ leftcol: array [windownumber] of screencol;
+ rightcol: array [windownumber] of screencol;
+ toprow: array [windownumber] of screenrow;
+ botrow: array [windownumber] of screenrow;
+ mwindow: array [windownumber] of integer;
+ nwindow: array [windownumber] of integer;
+ windowtime: array [windownumber] of integer; {:572} {579:}
+ rowtransition: transspec; {:579} {585:}
+ serialno: integer; {:585} {592:}
+ fixneeded: boolean;
+ watchcoefs: boolean;
+ depfinal: halfword; {:592} {624:}
+ curcmd: eightbits;
+ curmod: integer;
+ cursym: halfword; {:624} {628:}
+ inputstack: array [0..stacksize] of instaterecord;
+ inputptr: 0..stacksize;
+ maxinstack: 0..stacksize;
+ curinput: instaterecord; {:628} {631:}
+ inopen: 0..6;
+ inputfile: array [1..6] of alphafile;
+ line: integer;
+ linestack: array [1..6] of integer; {:631} {633:}
+ paramstack: array [0..150] of halfword;
+ paramptr: 0..150;
+ maxparamstack: integer; {:633} {634:}
+ fileptr: 0..stacksize; {:634} {659:}
+ scannerstatus: 0..6;
+ warninginfo: integer; {:659} {680:}
+ forceeof: boolean;
+ {:680}
+ {699:}
+ bgloc, egloc: 1..2241; {:699} {738:}
+ condptr: halfword;
+ iflimit: 0..4;
+ curif: smallnumber;
+ ifline: integer; {:738} {752:}
+ loopptr: halfword; {:752} {767:}
+ curname: strnumber;
+ curarea: strnumber;
+ curext: strnumber; {:767} {768:}
+ areadelimiter: poolpointer;
+ extdelimiter: poolpointer; {:768} {775:}
+ MFbasedefault: packed array [1..10] of char; {:775} {782:}
+ jobname: strnumber;
+ logname: strnumber; {:782} {785:}
+ gfext: strnumber; {:785} {791:}
+ gffile: bytefile;
+ outputfilename: strnumber; {:791} {796:}
+ curtype: smallnumber;
+ curexp: integer; {:796} {813:}
+ maxc: array [17..18] of integer;
+ maxptr: array [17..18] of halfword;
+ maxlink: array [17..18] of halfword; {:813} {821:}
+ varflag: 0..82; {:821} {954:}
+ txx, txy, tyx, tyy, tx, ty: scaled; {:954} {1077:}
+ startsym: halfword; {:1077}
+ {1084:}
+ longhelpseen: boolean; {:1084} {1087:}
+ tfmfile: bytefile;
+ metricfilename: strnumber; {:1087} {1096:}
+ bc, ec: eightbits;
+ tfmwidth: array [eightbits] of scaled;
+ tfmheight: array [eightbits] of scaled;
+ tfmdepth: array [eightbits] of scaled;
+ tfmitalcorr: array [eightbits] of scaled;
+ charexists: array [eightbits] of boolean;
+ chartag: array [eightbits] of 0..3;
+ charremainder: array [eightbits] of eightbits;
+ headerbyte: array [1..headersize] of -1..255;
+ ligkern: array [0..ligtablesize] of fourquarters;
+ nl: 0..ligtablesize;
+ kern: array [eightbits] of scaled;
+ nk: 0..256;
+ exten: array [eightbits] of fourquarters;
+ ne: 0..256;
+ param: array [1..maxfontdimen] of scaled;
+ np: 0..maxfontdimen;
+ nw, nh, nd, ni: 0..256; {:1096} {1119:}
+ perturbation: scaled; {:1119} {1125:}
+ dimenhead: array [1..4] of halfword; {:1125} {1130:}
+ maxtfmdimen: scaled;
+ tfmchanged: integer; {:1130} {1149:}
+ gfminm, gfmaxm, gfminn, gfmaxn: integer;
+ gfprevptr: integer;
+ totalchars: integer;
+ charptr: array [eightbits] of integer;
+ gfdx, gfdy: array [eightbits] of integer; {:1149} {1152:}
+ gfbuf: gfbuftype;
+ halfbuf: gfindex;
+ gflimit: gfindex;
+ gfptr: gfindex;
+ gfoffset: integer; {:1152}
+ {1162:}
+ bocc, bocp: integer; {:1162} {1183:}
+ baseident: strnumber; {:1183}
+ {1188:}
+ basefile: wordfile; {:1188} {1203:}
+ readyalready: integer; {:1203}
+ {1214:}
+ editnamestart: poolpointer;
+ editnamelength, editline: integer; {:1214}
+
+ procedure unskew(x, y: scaled; octant: smallnumber);external;
+
+ procedure sendcurve(x0,x1,x2,x3,y0,y1,y2,y3,octant:integer);external;
+
+ procedure sendline(x0,y0,x1,y1,octant,LineSource:integer);external;
+
+ procedure confusion(s: strnumber);external;
+
+ function abvscd(a, b, c, d: integer): integer;external;
+
+ procedure makemoves(xx0, xx1, xx2, xx3, yy0, yy1, yy2, yy3: scaled; xicorr, etacorr: smallnumber;CurveSource:integer;oc:smallnumber);external;
+
+ procedure print_start(var f:postscript);external;
+
+ procedure print_end(var f:postscript);external;
+
+ procedure init_ps(var f:postscript);external;
+
+ procedure tini_ps(var f:postscript);external;
+
+ procedure auxslowprint(s: integer);external;
+
+ procedure auxprintnl(s: strnumber);external;
+
+ procedure sendascii(asc: integer);external;
+
+ {------------------------------}
+ { $Header: /home/vadve/shared/PublicCVS/llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p,v 1.1 2004/02/16 23:43:31 criswell Exp $ }
+
+ { declarations for external C assist routines for MetaFont }
+
+ procedure exit(x : integer);
+ external;
+
+ procedure closea(var f:text);
+ external;
+
+ procedure closew(var f:wordfile);
+ external;
+
+ procedure dateandtime(var minutes, day, month, year : integer);
+ external;
+
+ procedure setpaths;
+ external;
+
+ function testaccess(var nameoffile, realnameoffile: UNIXfilename;
+ accessmode:integer; filepath:integer): boolean;
+ external;
+
+ procedure calledit(var filename: ASCIIcode; fnlength, linenumber: integer);
+ external;
+
+ function bopenout(var f: bytefile; var name: UNIXfilename): boolean;
+ external;
+
+ procedure bclose(var f: bytefile);
+ external;
+
+ procedure bgetname(var f: bytefile; var name: UNIXfilename);
+ external;
+
+ procedure bwritebuf(var f: bytefile; var buf: gfbuftype;
+ first, last: integer);
+ external;
+
+ procedure bwritebyte(var f: bytefile; b: integer);
+ external;
+
+ procedure bwrite2bytes(var f: bytefile; b: integer);
+ external;
+
+ procedure bwrite4bytes(var f: bytefile; b: integer);
+ external;
+
+ function makefraction(p, q: integer): fraction;
+ external;
+
+ function takefraction(q: integer; f: fraction): integer;
+ external;
+
+ { $Header: /home/vadve/shared/PublicCVS/llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p,v 1.1 2004/02/16 23:43:31 criswell Exp $ }
+
+ { External procedures for UNIX MetaFont VIRMF for display graphics }
+
+ function initscreen: boolean;
+ external;
+
+ procedure updatescreen;
+ external;
+
+ procedure blankrectangle(leftcol, rightcol: screencol; toprow, botrow: screenrow);
+ external;
+
+ procedure paintrow(r: screenrow; b: pixelcolor; var a: transspec; n: screencol);
+ external;
+
+
+ procedure initialize; {19:}
+ var
+ i: 0..127; {:19} {130:}
+ k: integer; {:130} {21:}
+ begin
+ 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] := ' '; {:21} {22:}
+ for i := 1 to 31 do
+ xchr[i] := ' ';
+ xchr[9] := chr(9);
+ xchr[12] := chr(12); {:22}
+ {23:}
+ for i := 0 to 127 do
+ xord[chr(i)] := 127;
+ for i := 1 to 126 do
+ xord[xchr[i]] := i; {:23} {69:}
+ interaction := 3; {:69} {72:}
+ deletionsallowed := true;
+ errorcount := 0; {:72} {75:}
+ helpptr := 0;
+ useerrhelp := false;
+ errhelp := 0; {:75} {92:}
+ interrupt := 0;
+ OKtointerrupt := true;
+ {:92}
+ {98:}
+ aritherror := false; {:98} {131:}
+ twotothe[0] := 1;
+ for k := 1 to 30 do
+ twotothe[k] := 2 * twotothe[k - 1];
+ speclog[1] := 93032640;
+ speclog[2] := 38612034;
+ speclog[3] := 17922280;
+ speclog[4] := 8662214;
+ speclog[5] := 4261238;
+ speclog[6] := 2113709;
+ speclog[7] := 1052693;
+ speclog[8] := 525315;
+ speclog[9] := 262400;
+ speclog[10] := 131136;
+ speclog[11] := 65552;
+ speclog[12] := 32772;
+ speclog[13] := 16385;
+ for k := 14 to 27 do
+ speclog[k] := twotothe[27 - k];
+ speclog[28] := 1; {:131}
+ {138:}
+ specatan[1] := 27855475;
+ specatan[2] := 14718068;
+ specatan[3] := 7471121;
+ specatan[4] := 3750058;
+ specatan[5] := 1876857;
+ specatan[6] := 938658;
+ specatan[7] := 469357;
+ specatan[8] := 234682;
+ specatan[9] := 117342;
+ specatan[10] := 58671;
+ specatan[11] := 29335;
+ specatan[12] := 14668;
+ specatan[13] := 7334;
+ specatan[14] := 3667;
+ specatan[15] := 1833;
+ specatan[16] := 917;
+ specatan[17] := 458;
+ specatan[18] := 229;
+ specatan[19] := 115;
+ specatan[20] := 57;
+ specatan[21] := 29;
+ specatan[22] := 14;
+ specatan[23] := 7;
+ specatan[24] := 4;
+ specatan[25] := 2;
+ specatan[26] := 1; {:138} {179:}
+ {wasmemend:=-30000;waslomax:=-30000;washimin:=memmax;panicking:=false;}
+ {:179}
+ {191:}
+ for k := 1 to 40 do
+ internal[k] := 0;
+ intptr := 40; {:191} {199:}
+ for k := 48 to 57 do
+ charclass[k] := 0;
+ charclass[46] := 1;
+ charclass[32] := 2;
+ charclass[37] := 3;
+ charclass[34] := 4;
+ charclass[44] := 5;
+ charclass[59] := 6;
+ charclass[40] := 7;
+ charclass[41] := 8;
+ for k := 65 to 90 do
+ charclass[k] := 9;
+ for k := 97 to 122 do
+ charclass[k] := 9;
+ charclass[95] := 9;
+ charclass[60] := 10;
+ charclass[61] := 10;
+ charclass[62] := 10;
+ charclass[58] := 10;
+ charclass[124] := 10;
+ charclass[96] := 11;
+ charclass[39] := 11;
+ charclass[43] := 12;
+ charclass[45] := 12;
+ charclass[47] := 13;
+ charclass[42] := 13;
+ charclass[92] := 13;
+ charclass[33] := 14;
+ charclass[63] := 14;
+ charclass[35] := 15;
+ charclass[38] := 15;
+ charclass[64] := 15;
+ charclass[36] := 15;
+ charclass[94] := 16;
+ charclass[126] := 16;
+ charclass[91] := 17;
+ charclass[93] := 18;
+ charclass[123] := 19;
+ charclass[125] := 19;
+ for k := 0 to 31 do
+ charclass[k] := 20;
+ charclass[127] := 20;
+ charclass[9] := 2;
+ charclass[12] := 2; {:199} {202:}
+ hash[1].lh := 0;
+ hash[1].rh := 0;
+ eqtb[1].lh := 41;
+ eqtb[1].rh := -30000;
+ for k := 2 to 2241 do begin
+ hash[k] := hash[1];
+ eqtb[k] := eqtb[1]
+ end; {:202} {231:}
+ bignodesize[13] := 12;
+ bignodesize[14] := 4;
+ {:231}
+ {251:}
+ saveptr := -30000; {:251} {396:}
+ octantdir[1] := 415;
+ octantdir[5] := 416;
+ octantdir[6] := 417;
+ octantdir[2] := 418;
+ octantdir[4] := 419;
+ octantdir[8] := 420;
+ octantdir[7] := 421;
+ octantdir[3] := 422; {:396} {428:}
+ maxroundingptr := 0; {:428} {449:}
+ octantcode[1] := 1;
+ octantcode[2] := 5;
+ octantcode[3] := 6;
+ octantcode[4] := 2;
+ octantcode[5] := 4;
+ octantcode[6] := 8;
+ octantcode[7] := 7;
+ octantcode[8] := 3;
+ for k := 1 to 8 do
+ octantnumber[octantcode[k]] := k; {:449} {456:}
+ revturns := false; {:456} {462:}
+ xcorr[1] := 0;
+ ycorr[1] := 0;
+ xycorr[1] := 0;
+ xcorr[5] := 0;
+ ycorr[5] := 0;
+ xycorr[5] := 1;
+ xcorr[6] := -1;
+ ycorr[6] := 1;
+ xycorr[6] := 0;
+ xcorr[2] := 1;
+ ycorr[2] := 0;
+ xycorr[2] := 1;
+ xcorr[4] := 0;
+ ycorr[4] := 1;
+ xycorr[4] := 1;
+ xcorr[8] := 0;
+ ycorr[8] := 1;
+ xycorr[8] := 0;
+ xcorr[7] := 1;
+ ycorr[7] := 0;
+ xycorr[7] := 1;
+ xcorr[3] := -1;
+ ycorr[3] := 1;
+ xycorr[3] := 0;
+ for k := 1 to 8 do
+ zcorr[k] := xycorr[k] - xcorr[k]; {:462} {570:}
+ screenstarted := false;
+ screenOK := false; {:570} {573:}
+ for k := 0 to 15 do begin
+ windowopen[k] := false;
+ windowtime[k] := 0
+ end; {:573}
+ {593:}
+ fixneeded := false;
+ watchcoefs := true; {:593} {739:}
+ condptr := -30000;
+ iflimit := 0;
+ curif := 0;
+ ifline := 0; {:739} {753:}
+ loopptr := -30000; {:753} {776:}
+ MFbasedefault := 'plain.base'; {:776} {797:}
+ curexp := 0; {:797} {822:}
+ varflag := 0; {:822} {1078:}
+ startsym := 0; {:1078} {1085:}
+ longhelpseen := false;
+ {:1085}
+ {1097:}
+ for k := 0 to 255 do begin
+ tfmwidth[k] := 0;
+ tfmheight[k] := 0;
+ tfmdepth[k] := 0;
+ tfmitalcorr[k] := 0;
+ charexists[k] := false;
+ chartag[k] := 0;
+ charremainder[k] := 0
+ end;
+ for k := 1 to headersize do
+ headerbyte[k] := -1;
+ bc := 255;
+ ec := 0;
+ nl := 0;
+ nk := 0;
+ ne := 0;
+ np := 0; {:1097} {1150:}
+ gfprevptr := 0;
+ totalchars := 0; {:1150} {1153:}
+ halfbuf := gfbufsize div 2;
+ gflimit := gfbufsize;
+ gfptr := 0;
+ gfoffset := 0; {:1153} {1184:}
+ baseident := 0; {:1184} {1215:}
+ editnamestart := 0
+ end; {:1215} {57:}
+
+ procedure println;
+ begin
+ case selector of
+ 3:
+ begin
+ writeln(output);
+ writeln(logfile);
+ termoffset := 0;
+ fileoffset := 0
+ end;
+ 2:
+ begin
+ writeln(logfile);
+ fileoffset := 0
+ end;
+ 1:
+ begin
+ writeln(output);
+ termoffset := 0
+ end;
+ 0, 4, 5:
+ end
+ end; {:57} {58:}
+
+ procedure printchar(s: ASCIIcode);
+ var tmp : integer;
+ begin
+ case selector of
+ 3:
+ begin
+ {----------------------------------}
+ if xchr[s] = '[' then
+ begin
+ ascii_on := true;
+ ascval := 0;
+ end
+ else if xchr[s] = ']' then
+ begin
+ ascii_on := false;
+ sendascii(ascval);
+ end
+ else if ascii_on then
+ begin
+ tmp := s - ord('0');
+ ascval := ascval*10+tmp;
+ end;
+ {-------------------------------------}
+ write(output, xchr[s]);
+ write(logfile, xchr[s]);
+ termoffset := termoffset + 1;
+ fileoffset := fileoffset + 1;
+ if termoffset = maxprintline then begin
+ writeln(output);
+ termoffset := 0
+ end;
+ if fileoffset = maxprintline then begin
+ writeln(logfile);
+ fileoffset := 0
+ end
+ end;
+ 2:
+ begin
+ write(logfile, xchr[s]);
+ fileoffset := fileoffset + 1;
+ if fileoffset = maxprintline then
+ println
+ end;
+ 1:
+ begin
+ write(output, xchr[s]);
+ termoffset := termoffset + 1;
+ if termoffset = maxprintline then
+ println
+ end;
+ 0:
+ ;
+ 4:
+ if tally < trickcount then
+ trickbuf[tally mod errorline] := s;
+ 5:
+ begin
+ if poolptr < poolsize then begin
+ strpool[poolptr] := s;
+ poolptr := poolptr + 1
+ end
+ end
+ end;
+ tally := tally + 1
+ end; {:58} {59:}
+
+ procedure print(s: integer);
+ var
+ j: poolpointer;
+ begin
+ if (s < 0) or (s >= strptr) then
+ s := 131;
+ j := strstart[s];
+ while j < strstart[s + 1] do begin
+ printchar(strpool[j]);
+ j := j + 1
+ end
+ end; {:59}
+ {60:}
+
+ procedure slowprint(s: integer);
+ var
+ j: poolpointer;
+ begin
+ if (s < 0) or (s >= strptr) then
+ s := 131;
+ j := strstart[s];
+ while j < strstart[s + 1] do begin
+ print(strpool[j]);
+ j := j + 1
+ end
+ end; {:60}
+ {62:}
+
+ procedure printnl(s: strnumber);
+ begin
+ if ((termoffset > 0) and odd(selector)) or ((fileoffset > 0) and (selector >= 2)) then
+ println;
+ print(s)
+ end; {:62} {63:}
+
+ procedure printthedigs(k: eightbits);
+ begin
+ while k > 0 do begin
+ k := k - 1;
+ printchar(48 + dig[k])
+ end
+ end; {:63} {64:}
+
+ procedure printint(n: integer);
+ var
+ k: 0..23;
+ m: integer;
+ begin
+ k := 0;
+ if n < 0 then begin
+ printchar(45);
+ if n > (-100000000) then
+ n := -n
+ else begin
+ m := (-1) - n;
+ n := m div 10;
+ m := (m mod 10) + 1;
+ k := 1;
+ if m < 10 then
+ dig[0] := m
+ else begin
+ dig[0] := 0;
+ n := n + 1
+ end
+ end
+ end;
+ repeat
+ dig[k] := n mod 10;
+ n := n div 10;
+ k := k + 1
+ until n = 0;
+ printthedigs(k)
+ end; {:64} {103:}
+
+ procedure printscaled(s: scaled);
+ var
+ delta: scaled;
+ begin
+ if s < 0 then begin
+ printchar(45);
+ s := -s
+ end;
+ printint(s div 65536);
+ s := (10 * (s mod 65536)) + 5;
+ if s <> 5 then begin
+ delta := 10;
+ printchar(46);
+ repeat
+ if delta > 65536 then
+ s := (s + 32768) - (delta div 2);
+ printchar(48 + (s div 65536));
+ s := 10 * (s mod 65536);
+ delta := delta * 10
+ until s <= delta
+ end
+ end; {:103} {104:}
+
+ procedure printtwo(x, y: scaled);
+ begin
+ printchar(40);
+ printscaled(x);
+ printchar(44);
+ printscaled(y);
+ printchar(41)
+ end; {:104} {187:}
+
+ procedure printtype(t: smallnumber);
+ begin
+ if t in
+ [1, 2, 3, 4, 5, 6, 7, 8,
+ 9, 10, 11, 12, 13, 14, 16, 17,
+ 18, 15, 19, 20, 21, 22, 23] then
+ case t of
+ 1:
+ print(194);
+ 2:
+ print(195);
+ 3:
+ print(196);
+ 4:
+ print(197);
+ 5:
+ print(198);
+ 6:
+ print(199);
+ 7:
+ print(200);
+ 8:
+ print(201);
+ 9:
+ print(202);
+ 10:
+ print(203);
+ 11:
+ print(204);
+ 12:
+ print(205);
+ 13:
+ print(206);
+ 14:
+ print(207);
+ 16:
+ print(208);
+ 17:
+ print(209);
+ 18:
+ print(210);
+ 15:
+ print(211);
+ 19:
+ print(212);
+ 20:
+ print(213);
+ 21:
+ print(214);
+ 22:
+ print(215);
+ 23:
+ print(216)
+ end
+ else
+ print(217)
+ end; {:187} {195:}
+
+ procedure begindiagnostic;
+ begin
+ oldsetting := selector;
+ if (internal[13] <= 0) and (selector = 3) then begin
+ selector := selector - 1;
+ if history = 0 then
+ history := 1
+ end
+ end; { begindiagnostic }
+
+ procedure enddiagnostic(blankline: boolean);
+ begin
+ printnl(155);
+ if blankline then
+ println;
+ selector := oldsetting
+ end; {:195} {197:}
+
+ procedure printdiagnostic(s, t: strnumber; nuline: boolean);
+ begin
+ begindiagnostic;
+ if nuline then
+ printnl(s)
+ else
+ print(s);
+ print(320);
+ printint(line);
+ print(t);
+ printchar(58)
+ end; {:197} {773:}
+
+ procedure printfilename(n, a, e: integer);
+ begin
+ print(a);
+ print(n);
+ print(e)
+ end; {:773} {73:}
+
+ procedure normalizeselector;
+ forward;
+
+ procedure getnext;
+ forward;
+
+ procedure terminput;
+ forward;
+
+ procedure showcontext;
+ forward;
+
+ procedure beginfilereading;
+ forward;
+
+ procedure openlogfile;
+ forward;
+
+ procedure closefilesandtermina;
+ forward;
+
+ procedure clearforerrorprompt;
+ forward; {procedure debughelp;forward;} {43:}
+
+ procedure flushstring(s: strnumber);
+ begin
+ if s < (strptr - 1) then
+ strref[s] := 0
+ else
+ repeat
+ strptr := strptr - 1
+ until strref[strptr - 1] <> 0;
+ poolptr := strstart[strptr]
+ end; {:43} {:73} {76:}
+
+ procedure jumpout;
+ begin
+ goto 9998
+ end; {:76} {77:}
+
+ procedure error;
+ label
+ 22, 10;
+ var
+ c: ASCIIcode;
+ s1, s2, s3: integer;
+ j: poolpointer;
+ begin
+ if history < 2 then
+ history := 2;
+ printchar(46);
+ showcontext;
+ if interaction = 3 then {78:}
+ while true do begin
+ 22:
+ clearforerrorprompt;
+ begin
+ print(135);
+ terminput
+ end;
+ if last = first then
+ goto 10;
+ c := buffer[first];
+ if c >= 97 then
+ c := c - 32; {79:}
+ if c in
+ [48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 69, 72, 73, 81, 82, 83,
+ 88] then
+ case c of
+ 48, 49, 50, 51, 52, 53, 54,
+ 55, 56, 57:
+ if deletionsallowed then begin {83:}
+ s1 := curcmd;
+ s2 := curmod;
+ s3 := cursym;
+ OKtointerrupt := false;
+ if ((last > (first + 1)) and (buffer[first + 1] >= 48)) and (buffer[first + 1] <= 57) then
+ c := ((c * 10) + buffer[first + 1]) - (48 * 11)
+ else
+ c := c - 48;
+ while c > 0 do begin
+ getnext;
+ {743:}
+ if curcmd = 39 then begin
+ if strref[curmod] < 127 then
+ if strref[curmod] > 1 then
+ strref[curmod] := strref[curmod] - 1
+ else
+ flushstring(curmod)
+ end {:743};
+ c := c - 1
+ end;
+ curcmd := s1;
+ curmod := s2;
+ cursym := s3;
+ OKtointerrupt := true;
+ begin
+ helpptr := 2;
+ helpline[1] := 148;
+ helpline[0] := 149
+ end;
+ showcontext;
+ goto 22
+ end {:83}; {68:begin debughelp;goto 22;end;}
+ 69:
+ if fileptr > 0 then begin
+ editnamestart := strstart[inputstack[fileptr].namefield];
+ editnamelength := strstart[inputstack[fileptr].namefield + 1] - strstart[inputstack[fileptr].namefield];
+ editline := line;
+ jumpout
+ end;
+ 72:
+ begin {84:}
+ if useerrhelp then begin {85:}
+ j := strstart[errhelp];
+ while j < strstart[errhelp + 1] do begin
+ if strpool[j] <> 37 then
+ print(strpool[j])
+ else if (j + 1) = strstart[errhelp + 1] then
+ println
+ else if strpool[j + 1] <> 37 then
+ println
+ else begin
+ j := j + 1;
+ printchar(37)
+ end;
+ j := j + 1
+ end {:85};
+ useerrhelp := false
+ end else begin
+ if helpptr = 0 then begin
+ helpptr := 2;
+ helpline[1] := 150;
+ helpline[0] := 151
+ end;
+ repeat
+ helpptr := helpptr - 1;
+ print(helpline[helpptr]);
+ println
+ until helpptr = 0
+ end;
+ begin
+ helpptr := 4;
+ helpline[3] := 152;
+ helpline[2] := 151;
+ helpline[1] := 153;
+ helpline[0] := 154
+ end;
+ goto 22
+ end; {:84}
+ 73:
+ begin {82:}
+ beginfilereading;
+ if last > (first + 1) then begin
+ curinput.locfield := first + 1;
+ buffer[first] := 32
+ end else begin
+ begin
+ print(147);
+ terminput
+ end;
+ curinput.locfield := first
+ end;
+ first := last + 1;
+ curinput.limitfield := last;
+ goto 10
+ end; {:82}
+ 81, 82, 83:
+ begin {81:}
+ errorcount := 0;
+ interaction := (0 + c) - 81;
+ print(142);
+ case c of
+ 81:
+ begin
+ print(143);
+ selector := selector - 1
+ end;
+ 82:
+ print(144);
+ 83:
+ print(145)
+ end;
+ print(146);
+ println;
+ flush(output);
+ goto 10
+ end; {:81}
+ 88:
+ begin
+ interaction := 2;
+ jumpout
+ end
+ end
+ else
+ ; {80:}
+ begin
+ print(136);
+ printnl(137);
+ printnl(138);
+ if fileptr > 0 then
+ print(139);
+ if deletionsallowed then
+ printnl(140);
+ printnl(141)
+ end {:80} {:79}
+ end {:78};
+ errorcount := errorcount + 1;
+ if errorcount = 100 then begin
+ printnl(134);
+ history := 3;
+ jumpout
+ end; {86:}
+ if interaction > 0 then
+ selector := selector - 1;
+ if useerrhelp then begin
+ printnl(155); {85:}
+ j := strstart[errhelp];
+ while j < strstart[errhelp + 1] do begin
+ if strpool[j] <> 37 then
+ print(strpool[j])
+ else if (j + 1) = strstart[errhelp + 1] then
+ println
+ else if strpool[j + 1] <> 37 then
+ println
+ else begin
+ j := j + 1;
+ printchar(37)
+ end;
+ j := j + 1
+ end {:85}
+ end else
+ while helpptr > 0 do begin
+ helpptr := helpptr - 1;
+ printnl(helpline[helpptr])
+ end;
+ println;
+ if interaction > 0 then
+ selector := selector + 1; {:86}
+ println;
+ 10:
+
+ end; {:77}
+ {88:}
+
+ procedure fatalerror(s: strnumber);
+ begin
+ normalizeselector;
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(156)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := s
+ end;
+ begin
+ if interaction = 3 then
+ interaction := 2;
+ error;
+ {if interaction>0 then debughelp;}
+ history := 3;
+ jumpout
+ end
+ end; {:88} {89:}
+
+ procedure overflow(s: strnumber; n: integer);
+ begin
+ normalizeselector;
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(157)
+ end;
+ print(s);
+ printchar(61);
+ printint(n);
+ printchar(93);
+ begin
+ helpptr := 2;
+ helpline[1] := 158;
+ helpline[0] := 159
+ end;
+ begin
+ if interaction = 3 then
+ interaction := 2;
+ error;
+ {if interaction>0 then debughelp;}
+ history := 3;
+ jumpout
+ end
+ end; {:89} {90:}
+
+ procedure confusion;
+ begin
+ normalizeselector;
+ if history < 2 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(160)
+ end;
+ print(s);
+ printchar(41);
+ begin
+ helpptr := 1;
+ helpline[0] := 161
+ end
+ end else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(162)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 163;
+ helpline[0] := 164
+ end
+ end;
+ begin
+ if interaction = 3 then
+ interaction := 2;
+ error;
+ {if interaction>0 then debughelp;}
+ history := 3;
+ jumpout
+ end
+ end; {:90} {:4}
+
+
+ {26:}
+
+ function aopenin(var f: alphafile; pathspecifier: integer): boolean;
+ var
+ ok: boolean;
+ begin
+ if testaccess(nameoffile, realnameoffile, 4, pathspecifier) then begin
+ reset(f, realnameoffile);
+ ok := true
+ end else
+ ok := false;
+ aopenin := ok
+ end; { aopenin }
+
+ function aopenout(var f: alphafile): boolean;
+ var
+ ok: boolean;
+ begin
+ if testaccess(nameoffile, realnameoffile, 2, 0) then begin
+ rewrite(f, realnameoffile);
+ ok := true
+ end else
+ ok := false;
+ aopenout := ok
+ end; { aopenout }
+
+ function wopenin(var f: wordfile): boolean;
+ var
+ ok: boolean;
+ begin
+ if testaccess(nameoffile, realnameoffile, 4, 7) then begin
+ reset(f, realnameoffile);
+ ok := true
+ end else
+ ok := false;
+ wopenin := ok
+ end; { wopenin }
+
+ function wopenout(var f: wordfile): boolean;
+ var
+ ok: boolean;
+ begin
+ if testaccess(nameoffile, realnameoffile, 2, 0) then begin
+ rewrite(f, nameoffile);
+ ok := true
+ end else
+ ok := false;
+ wopenout := ok
+ end; {:26} {27:}
+
+ procedure aclose(var f: alphafile);
+ begin
+ closea(f)
+ end; { aclose }
+
+ procedure wclose(var f: wordfile);
+ begin
+ closew(f)
+ end; {:27} {30:}
+
+ function inputln(var f: alphafile; bypasseoln: boolean): boolean;
+ var
+ lastnonblank: 0..bufsize;
+ begin
+ if bypasseoln then
+ if not eof(f) then
+ if eoln(f) then
+ get(f);
+ last := first;
+ if eof(f) then
+ inputln := false
+ else begin
+ lastnonblank := first;
+ while not eoln(f) do begin
+ if last >= maxbufstack then begin
+ maxbufstack := last + 1;
+ if maxbufstack = bufsize then
+ overflow(128, bufsize)
+ end;
+ buffer[last] := xord[f^];
+ get(f);
+ last := last + 1;
+ if buffer[last - 1] <> 32 then
+ lastnonblank := last
+ end;
+ last := lastnonblank;
+ inputln := true
+ end
+ end; {:30} {36:}
+
+ function initterminal: boolean;
+ label
+ 10;
+ var
+ dummy, i, j, k: integer;
+ arg: packed array [1..100] of char;
+ begin
+ if argc > 1 then begin
+ last := first;
+ for i := 1 to argc - 1 do begin
+ argv(i, arg);
+ j := 1;
+ k := 100;
+ while (k > 1) and (arg[k] = ' ') do
+ k := k - 1;
+ while j <= k do begin
+ buffer[last] := xord[arg[j]];
+ j := j + 1;
+ last := last + 1
+ end;
+ if k > 1 then begin
+ buffer[last] := xord[' '];
+ last := last + 1
+ end
+ end;
+ if last > first then begin
+ curinput.locfield := first;
+ initterminal := true;
+ goto 10
+ end
+ end;
+ while true do begin
+ write(output, '**');
+ flush(output);
+ if not inputln(input, true) then begin
+ writeln(output);
+ writeln(output, '! End of file on the terminal... why?');
+ initterminal := false;
+ goto 10
+ end;
+ curinput.locfield := first;
+ while (curinput.locfield < last) and (buffer[curinput.locfield] = 32) do
+ curinput.locfield := curinput.locfield + 1;
+ if curinput.locfield < last then begin
+ initterminal := true;
+ goto 10
+ end;
+ writeln(output, 'Please type the name of your input file.')
+ end;
+ 10:
+
+ end; { initterminal }
+ {:36}
+ {44:}
+
+ function makestring: strnumber;
+ begin
+ if strptr = maxstrptr then begin
+ if strptr = maxstrings then
+ overflow(130, maxstrings - initstrptr);
+ maxstrptr := maxstrptr + 1
+ end;
+ strref[strptr] := 1;
+ strptr := strptr + 1;
+ strstart[strptr] := poolptr;
+ makestring := strptr - 1
+ end; { makestring }
+ {:44}
+ {45:}
+
+ function streqbuf(s: strnumber; k: integer): boolean;
+ label
+ 45;
+ var
+ j: poolpointer;
+ result: boolean;
+ begin
+ j := strstart[s];
+ while j < strstart[s + 1] do begin
+ if strpool[j] <> buffer[k] then begin
+ result := false;
+ goto 45
+ end;
+ j := j + 1;
+ k := k + 1
+ end;
+ result := true;
+ 45:
+ streqbuf := result
+ end; {:45} {46:}
+
+ function strvsstr(s, t: strnumber): integer;
+ label
+ 10;
+ var
+ j, k: poolpointer;
+ ls, lt: integer;
+ l: integer;
+ begin
+ ls := strstart[s + 1] - strstart[s];
+ lt := strstart[t + 1] - strstart[t];
+ if ls <= lt then
+ l := ls
+ else
+ l := lt;
+ j := strstart[s];
+ k := strstart[t];
+ while l > 0 do begin
+ if strpool[j] <> strpool[k] then begin
+ strvsstr := strpool[j] - strpool[k];
+ goto 10
+ end;
+ j := j + 1;
+ k := k + 1;
+ l := l - 1
+ end;
+ strvsstr := ls - lt;
+ 10:
+
+ end; {:46} {47:}
+ {function getstringsstarted:boolean;label 30,10;
+ var k,l:0..127;m,n:char;g:strnumber;a:integer;c:boolean;
+ begin poolptr:=0;strptr:=0;maxpoolptr:=0;maxstrptr:=0;strstart[0]:=0;
+ [48:]for k:=0 to 127 do begin if([49:](k<32)or(k>126)[:49])then begin
+ begin strpool[poolptr]:=94;poolptr:=poolptr+1;end;
+ begin strpool[poolptr]:=94;poolptr:=poolptr+1;end;
+ if k<64 then begin strpool[poolptr]:=k+64;poolptr:=poolptr+1;
+ end else begin strpool[poolptr]:=k-64;poolptr:=poolptr+1;end;
+ end else begin strpool[poolptr]:=k;poolptr:=poolptr+1;end;g:=makestring;
+ strref[g]:=127;end[:48];[51:]nameoffile:=poolname;
+ if aopenin(poolfile,8)then begin c:=false;
+ repeat[52:]begin if eof(poolfile)then begin;
+ writeln(output,'! mf.pool has no check sum.');aclose(poolfile);
+ getstringsstarted:=false;goto 10;end;read(poolfile,m,n);
+ if m='*'then[53:]begin a:=0;k:=1;
+ while true do begin if(xord[n]<48)or(xord[n]>57)then begin;
+ writeln(output,'! mf.pool check sum doesn''t have nine digits.');
+ aclose(poolfile);getstringsstarted:=false;goto 10;end;
+ a:=10*a+xord[n]-48;if k=9 then goto 30;k:=k+1;read(poolfile,n);end;
+ 30:if a<>503742536 then begin;
+ writeln(output,'! mf.pool doesn''t match; tangle me again.');
+ aclose(poolfile);getstringsstarted:=false;goto 10;end;c:=true;
+ end[:53]else begin if(xord[m]<48)or(xord[m]>57)or(xord[n]<48)or(xord[n]>
+ 57)then begin;
+ writeln(output,'! mf.pool line doesn''t begin with two digits.');
+ aclose(poolfile);getstringsstarted:=false;goto 10;end;
+ l:=xord[m]*10+xord[n]-48*11;
+ if poolptr+l+stringvacancies>poolsize then begin;
+ writeln(output,'! You have to increase POOLSIZE.');aclose(poolfile);
+ getstringsstarted:=false;goto 10;end;
+ for k:=1 to l do begin if eoln(poolfile)then m:=' 'else read(poolfile,m)
+ ;begin strpool[poolptr]:=xord[m];poolptr:=poolptr+1;end;end;
+ readln(poolfile);g:=makestring;strref[g]:=127;end;end[:52];until c;
+ aclose(poolfile);getstringsstarted:=true;end else begin;
+ writeln(output,'! I can''t read mf.pool.');aclose(poolfile);
+ getstringsstarted:=false;goto 10;end[:51];10:end;}
+ {:47}
+ {65:}
+
+ procedure printdd(n: integer);
+ begin
+ n := abs(n) mod 100;
+ printchar(48 + (n div 10));
+ printchar(48 + (n mod 10))
+ end; {:65} {66:}
+
+ procedure terminput;
+ var
+ k: 0..bufsize;
+ begin
+ flush(output);
+ if not inputln(input, true) then
+ fatalerror(132);
+ termoffset := 0;
+ selector := selector - 1;
+ if last <> first then
+ for k := first to last - 1 do
+ print(buffer[k]);
+ println;
+ buffer[last] := 37;
+ selector := selector + 1
+ end; {:66} {87:}
+
+ procedure normalizeselector;
+ begin
+ if jobname > 0 then
+ selector := 3
+ else
+ selector := 1;
+ if jobname = 0 then
+ openlogfile;
+ if interaction = 0 then
+ selector := selector - 1
+ end; {:87} {93:}
+
+ procedure pauseforinstructions;
+ begin
+ if OKtointerrupt then begin
+ interaction := 3;
+ if (selector = 2) or (selector = 0) then
+ selector := selector + 1;
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(165)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 166;
+ helpline[1] := 167;
+ helpline[0] := 168
+ end;
+ deletionsallowed := false;
+ error;
+ deletionsallowed := true;
+ interrupt := 0
+ end
+ end; {:93} {94:}
+
+ procedure missingerr(s: strnumber);
+ begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(169)
+ end;
+ print(s);
+ print(170)
+ end; {:94} {99:}
+
+ procedure cleararith;
+ begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(171)
+ end;
+ begin
+ helpptr := 4;
+ helpline[3] := 172;
+ helpline[2] := 173;
+ helpline[1] := 174;
+ helpline[0] := 175
+ end;
+ error;
+ aritherror := false
+ end; {:99} {100:}
+
+ function slowadd(x, y: integer): integer;
+ begin
+ if x >= 0 then
+ if y <= (2147483647 - x) then
+ slowadd := x + y
+ else begin
+ aritherror := true;
+ slowadd := 2147483647
+ end
+ else if (-y) <= (2147483647 + x) then
+ slowadd := x + y
+ else begin
+ aritherror := true;
+ slowadd := -2147483647
+ end
+ end; {:100} {102:}
+
+ function rounddecimals(k: smallnumber): scaled;
+ var
+ a: integer;
+ begin
+ a := 0;
+ while k > 0 do begin
+ k := k - 1;
+ a := (a + (dig[k] * 131072)) div 10
+ end;
+ rounddecimals := (a + 1) div 2
+ end; {:102} {112:}
+
+ function takescaled(q: integer; f: scaled): integer;
+ var
+ p: integer;
+ negative: boolean;
+ n: integer;
+ becareful: integer; {110:}
+ begin
+ if f >= 0 then
+ negative := false
+ else begin
+ f := -f;
+ negative := true
+ end;
+ if q < 0 then begin
+ q := -q;
+ negative := not negative
+ end; {:110}
+ if f < 65536 then
+ n := 0
+ else begin
+ n := f div 65536;
+ f := f mod 65536;
+ if q <= (2147483647 div n) then
+ n := n * q
+ else begin
+ aritherror := true;
+ n := 2147483647
+ end
+ end;
+ f := f + 65536; {113:}
+ p := 32768;
+ if q < 1073741824 then
+ repeat
+ if odd(f) then
+ p := (p + q) div 2
+ else
+ p := p div 2;
+ f := f div 2
+ until f = 1
+ else
+ repeat
+ if odd(f) then
+ p := p + ((q - p) div 2)
+ else
+ p := p div 2;
+ f := f div 2
+ until f = 1 {:113};
+ becareful := n - 2147483647;
+ if (becareful + p) > 0 then begin
+ aritherror := true;
+ n := 2147483647 - p
+ end;
+ if negative then
+ takescaled := -(n + p)
+ else
+ takescaled := n + p
+ end; {:112} {114:}
+
+ function makescaled(p, q: integer): scaled;
+ var
+ f: integer;
+ n: integer;
+ negative: boolean;
+ becareful: integer;
+ begin
+ if p >= 0 then
+ negative := false
+ else begin
+ p := -p;
+ negative := true
+ end;
+ if q <= 0 then begin {if q=0 then confusion(47);}
+ q := -q;
+ negative := not negative
+ end;
+ n := p div q;
+ p := p mod q;
+ if n >= 32768 then begin
+ aritherror := true;
+ if negative then
+ makescaled := -2147483647
+ else
+ makescaled := 2147483647
+ end else begin
+ n := (n - 1) * 65536; {115:}
+ f := 1;
+ repeat
+ becareful := p - q;
+ p := becareful + p;
+ if p >= 0 then
+ f := (f + f) + 1
+ else begin
+ f := f + f;
+ p := p + q
+ end
+ until f >= 65536;
+ becareful := p - q;
+ if (becareful + p) >= 0 then
+ f := f + 1 {:115};
+ if negative then
+ makescaled := -(f + n)
+ else
+ makescaled := f + n
+ end
+ end; {:114}
+ {116:}
+
+ function velocity(st, ct, sf, cf: fraction; t: scaled): fraction;
+ var
+ acc, num, denom: integer;
+ begin
+ acc := takefraction(st - (sf div 16), sf - (st div 16));
+ acc := takefraction(acc, ct - cf);
+ num := 536870912 + takefraction(acc, 379625062);
+ denom := (805306368 + takefraction(ct, 497706707)) + takefraction(cf, 307599661);
+ if t <> 65536 then
+ num := makescaled(num, t);
+ if (num div 4) >= denom then
+ velocity := 1073741824
+ else
+ velocity := makefraction(num, denom)
+ end; {:116} {117:}
+
+ function abvscd ;
+ label
+ 10;
+ var
+ q, r: integer; {118:}
+ begin
+ if a < 0 then begin
+ a := -a;
+ b := -b
+ end;
+ if c < 0 then begin
+ c := -c;
+ d := -d
+ end;
+ if d <= 0 then begin
+ if b >= 0 then
+ if ((a = 0) or (b = 0)) and ((c = 0) or (d = 0)) then begin
+ abvscd := 0;
+ goto 10
+ end else begin
+ abvscd := 1;
+ goto 10
+ end;
+ if d = 0 then
+ if a = 0 then begin
+ abvscd := 0;
+ goto 10
+ end else begin
+ abvscd := -1;
+ goto 10
+ end;
+ q := a;
+ a := c;
+ c := q;
+ q := -b;
+ b := -d;
+ d := q
+ end else if b <= 0 then begin
+ if b < 0 then
+ if a > 0 then begin
+ abvscd := -1;
+ goto 10
+ end;
+ if c = 0 then begin
+ abvscd := 0;
+ goto 10
+ end else begin
+ abvscd := -1;
+ goto 10
+ end
+ end {:118};
+ while true do begin
+ q := a div d;
+ r := c div b;
+ if q <> r then
+ if q > r then begin
+ abvscd := 1;
+ goto 10
+ end else begin
+ abvscd := -1;
+ goto 10
+ end;
+ q := a mod d;
+ r := c mod b;
+ if r = 0 then
+ if q = 0 then begin
+ abvscd := 0;
+ goto 10
+ end else begin
+ abvscd := 1;
+ goto 10
+ end;
+ if q = 0 then begin
+ abvscd := -1;
+ goto 10
+ end;
+ a := b;
+ b := q;
+ c := d;
+ d := r
+ end;
+ 10:
+
+ end; {:117} {119:}
+
+ function floorscaled(x: scaled): scaled;
+ var
+ becareful: integer;
+ begin
+ if x >= 0 then
+ floorscaled := x - (x mod 65536)
+ else begin
+ becareful := x + 1;
+ floorscaled := (x + ((-becareful) mod 65536)) - 65535
+ end
+ end; { floorscaled }
+
+ function floorunscaled(x: scaled): integer;
+ var
+ becareful: integer;
+ begin
+ if x >= 0 then
+ floorunscaled := x div 65536
+ else begin
+ becareful := x + 1;
+ floorunscaled := -(1 + ((-becareful) div 65536))
+ end
+ end; { floorunscaled }
+
+ function roundunscaled(x: scaled): integer;
+ var
+ becareful: integer;
+ begin
+ if x >= 32768 then
+ roundunscaled := 1 + ((x - 32768) div 65536)
+ else if x >= (-32768) then
+ roundunscaled := 0
+ else begin
+ becareful := x + 1;
+ roundunscaled := -(1 + (((-becareful) - 32768) div 65536))
+ end
+ end; { roundunscaled }
+
+ function roundfraction(x: fraction): scaled;
+ var
+ becareful: integer;
+ begin
+ if x >= 2048 then
+ roundfraction := 1 + ((x - 2048) div 4096)
+ else if x >= (-2048) then
+ roundfraction := 0
+ else begin
+ becareful := x + 1;
+ roundfraction := -(1 + (((-becareful) - 2048) div 4096))
+ end
+ end; {:119} {121:}
+
+ function squarert(x: scaled): scaled;
+ var
+ k: smallnumber;
+ y, q: integer;
+ begin
+ if x <= 0 then begin {122:}
+ if x < 0 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(176)
+ end;
+ printscaled(x);
+ print(177);
+ begin
+ helpptr := 2;
+ helpline[1] := 178;
+ helpline[0] := 179
+ end;
+ error
+ end;
+ squarert := 0
+ end else begin {:122}
+ k := 23;
+ q := 2;
+ while x < 536870912 do begin
+ k := k - 1;
+ x := ((x + x) + x) + x
+ end;
+ if x < 1073741824 then
+ y := 0
+ else begin
+ x := x - 1073741824;
+ y := 1
+ end; {123:}
+ repeat
+ x := x + x;
+ y := y + y;
+ if x >= 1073741824 then begin
+ x := x - 1073741824;
+ y := y + 1
+ end;
+ x := x + x;
+ y := (y + y) - q;
+ q := q + q;
+ if x >= 1073741824 then begin
+ x := x - 1073741824;
+ y := y + 1
+ end;
+ if y > q then begin
+ y := y - q;
+ q := q + 2
+ end else if y <= 0 then begin
+ q := q - 2;
+ y := y + q
+ end;
+ k := k - 1 {:123}
+ until k = 0;
+ squarert := q div 2
+ end
+ end; {:121}
+ {124:}
+
+ function pythadd(a, b: integer): integer;
+ label
+ 30;
+ var
+ r: fraction;
+ big: boolean;
+ begin
+ a := abs(a);
+ b := abs(b);
+ if a < b then begin
+ r := b;
+ b := a;
+ a := r
+ end;
+ if a > 0 then begin
+ if a < 536870912 then
+ big := false
+ else begin
+ a := a div 4;
+ b := b div 4;
+ big := true
+ end; {125:}
+ while true do begin
+ r := makefraction(b, a);
+ r := takefraction(r, r);
+ if r = 0 then
+ goto 30;
+ r := makefraction(r, 1073741824 + r);
+ a := a + takefraction(a + a, r);
+ b := takefraction(b, r)
+ end;
+ 30: {:125}
+ ;
+ if big then
+ if a < 536870912 then
+ a := ((a + a) + a) + a
+ else begin
+ aritherror := true;
+ a := 2147483647
+ end
+ end;
+ pythadd := a
+ end; {:124} {126:}
+
+ function pythsub(a, b: integer): integer;
+ label
+ 30;
+ var
+ r: fraction;
+ big: boolean;
+ begin
+ a := abs(a);
+ b := abs(b);
+ if a <= b then begin {128:}
+ if a < b then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(180)
+ end;
+ printscaled(a);
+ print(181);
+ printscaled(b);
+ print(177);
+ begin
+ helpptr := 2;
+ helpline[1] := 178;
+ helpline[0] := 179
+ end;
+ error
+ end;
+ a := 0
+ end else begin {:128}
+ if a < 1073741824 then
+ big := false
+ else begin
+ a := a div 2;
+ b := b div 2;
+ big := true
+ end; {127:}
+ while true do begin
+ r := makefraction(b, a);
+ r := takefraction(r, r);
+ if r = 0 then
+ goto 30;
+ r := makefraction(r, 1073741824 - r);
+ a := a - takefraction(a + a, r);
+ b := takefraction(b, r)
+ end;
+ 30: {:127}
+ ;
+ if big then
+ a := a + a
+ end;
+ pythsub := a
+ end; {:126} {132:}
+
+ function mlog(x: scaled): scaled;
+ var
+ y, z: integer;
+ k: integer;
+ begin
+ if x <= 0 then begin {134:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(182)
+ end;
+ printscaled(x);
+ print(177);
+ begin
+ helpptr := 2;
+ helpline[1] := 183;
+ helpline[0] := 179
+ end;
+ error;
+ mlog := 0
+ end else begin {:134}
+ y := 1302456860;
+ z := 6581195;
+ while x < 1073741824 do begin
+ x := x + x;
+ y := y - 93032639;
+ z := z - 48782
+ end;
+ y := y + (z div 65536);
+ k := 2;
+ while x > 1073741828 do begin {133:}
+ z := ((x - 1) div twotothe[k]) + 1;
+ while x < (1073741824 + z) do begin
+ z := (z + 1) div 2;
+ k := k + 1
+ end;
+ y := y + speclog[k];
+ x := x - z
+ end {:133};
+ mlog := y div 8
+ end
+ end; {:132} {135:}
+
+ function mexp(x: scaled): scaled;
+ var
+ k: smallnumber;
+ y, z: integer;
+ begin
+ if x > 174436200 then begin
+ aritherror := true;
+ mexp := 2147483647
+ end else if x < (-197694359) then
+ mexp := 0
+ else begin
+ if x <= 0 then begin
+ z := -(8 * x);
+ y := 1048576
+ end else begin
+ if x <= 127919879 then
+ z := 1023359037 - (8 * x)
+ else
+ z := 8 * (174436200 - x);
+ y := 2147483647
+ end; {136:}
+ k := 1;
+ while z > 0 do begin
+ while z >= speclog[k] do begin
+ z := z - speclog[k];
+ y := (y - 1) - ((y - twotothe[k - 1]) div twotothe[k])
+ end;
+ k := k + 1
+ end {:136};
+ if x <= 127919879 then
+ mexp := (y + 8) div 16
+ else
+ mexp := y
+ end
+ end; {:135} {139:}
+
+ function narg(x, y: integer): angle;
+ var
+ z: angle;
+ t: integer;
+ k: smallnumber;
+ octant: 1..8;
+ begin
+ if x >= 0 then
+ octant := 1
+ else begin
+ x := -x;
+ octant := 2
+ end;
+ if y < 0 then begin
+ y := -y;
+ octant := octant + 2
+ end;
+ if x < y then begin
+ t := y;
+ y := x;
+ x := t;
+ octant := octant + 4
+ end;
+ if x = 0 then begin {140:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(184)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 185;
+ helpline[0] := 179
+ end;
+ error;
+ narg := 0
+ end else begin {:140} {142:}
+ while x >= 536870912 do begin
+ x := x div 2;
+ y := y div 2
+ end;
+ z := 0;
+ if y > 0 then begin
+ while x < 268435456 do begin
+ x := x + x;
+ y := y + y
+ end; {143:}
+ k := 0;
+ repeat
+ y := y + y;
+ k := k + 1;
+ if y > x then begin
+ z := z + specatan[k];
+ t := x;
+ x := x + (y div twotothe[k + k]);
+ y := y - t
+ end
+ until k = 15;
+ repeat
+ y := y + y;
+ k := k + 1;
+ if y > x then begin
+ z := z + specatan[k];
+ y := y - x
+ end
+ until k = 26 {:143}
+ end {:142}; {141:}
+ case octant of
+ 1:
+ narg := z;
+ 5:
+ narg := 94371840 - z;
+ 6:
+ narg := 94371840 + z;
+ 2:
+ narg := 188743680 - z;
+ 4:
+ narg := z - 188743680;
+ 8:
+ narg := (-z) - 94371840;
+ 7:
+ narg := z - 94371840;
+ 3:
+ narg := -z
+ end {:141}
+ end
+ end; {:139} {145:}
+
+ procedure nsincos(z: angle);
+ var
+ k: smallnumber;
+ q: 0..7;
+ r: fraction;
+ x, y, t: integer;
+ begin
+ while z < 0 do
+ z := z + 377487360;
+ z := z mod 377487360;
+ q := z div 47185920;
+ z := z mod 47185920;
+ x := 268435456;
+ y := x;
+ if not odd(q) then
+ z := 47185920 - z; {147:}
+ k := 1;
+ while z > 0 do begin
+ if z >= specatan[k] then begin
+ z := z - specatan[k];
+ t := x;
+ x := t + (y div twotothe[k]);
+ y := y - (t div twotothe[k])
+ end;
+ k := k + 1
+ end;
+ if y < 0 then
+ y := 0 {:147}; {146:}
+ case q of
+ 0:
+ ;
+ 1:
+ begin
+ t := x;
+ x := y;
+ y := t
+ end;
+ 2:
+ begin
+ t := x;
+ x := -y;
+ y := t
+ end;
+ 3:
+ x := -x;
+ 4:
+ begin
+ x := -x;
+ y := -y
+ end;
+ 5:
+ begin
+ t := x;
+ x := -y;
+ y := -t
+ end;
+ 6:
+ begin
+ t := x;
+ x := y;
+ y := -t
+ end;
+ 7:
+ y := -y
+ end {:146};
+ r := pythadd(x, y);
+ ncos := makefraction(x, r);
+ nsin := makefraction(y, r)
+ end; {:145} {149:}
+
+ procedure newrandoms;
+ var
+ k: 0..54;
+ x: fraction;
+ begin
+ for k := 0 to 23 do begin
+ x := randoms[k] - randoms[k + 31];
+ if x < 0 then
+ x := x + 268435456;
+ randoms[k] := x
+ end;
+ for k := 24 to 54 do begin
+ x := randoms[k] - randoms[k - 24];
+ if x < 0 then
+ x := x + 268435456;
+ randoms[k] := x
+ end;
+ jrandom := 54
+ end; {:149}
+ {150:}
+
+ procedure initrandoms(seed: scaled);
+ var
+ j, jj, k: fraction;
+ i: 0..54;
+ begin
+ j := abs(seed);
+ while j >= 268435456 do
+ j := j div 2;
+ k := 1;
+ for i := 0 to 54 do begin
+ jj := k;
+ k := j - k;
+ j := jj;
+ if k < 0 then
+ k := k + 268435456;
+ randoms[(i * 21) mod 55] := j
+ end;
+ newrandoms;
+ newrandoms;
+ newrandoms
+ end; {:150}
+ {151:}
+
+ function unifrand(x: scaled): scaled;
+ var
+ y: scaled;
+ begin
+ if jrandom = 0 then
+ newrandoms
+ else
+ jrandom := jrandom - 1;
+ y := takefraction(abs(x), randoms[jrandom]);
+ if y = abs(x) then
+ unifrand := 0
+ else if x > 0 then
+ unifrand := y
+ else
+ unifrand := -y
+ end; {:151} {152:}
+
+ function normrand: scaled;
+ var
+ x, u, l: integer;
+ begin
+ repeat
+ repeat
+ if jrandom = 0 then
+ newrandoms
+ else
+ jrandom := jrandom - 1;
+ x := takefraction(112429, randoms[jrandom] - 134217728);
+ if jrandom = 0 then
+ newrandoms
+ else
+ jrandom := jrandom - 1;
+ u := randoms[jrandom]
+ until abs(x) < u;
+ x := makefraction(x, u);
+ l := 139548960 - mlog(u)
+ until abvscd(1024, l, x, x) >= 0;
+ normrand := x
+ end; {:152}
+ {157:}
+ {procedure printword(w:memoryword);begin printint(w.int);
+ printchar(32);printscaled(w.int);printchar(32);
+ printscaled(w.int div 4096);println;printint(w.hh.lh);printchar(61);
+ printint(w.hh.b0);printchar(58);printint(w.hh.b1);printchar(59);
+ printint(w.hh.rh);printchar(32);printint(w.qqqq.b0);printchar(58);
+ printint(w.qqqq.b1);printchar(58);printint(w.qqqq.b2);printchar(58);
+ printint(w.qqqq.b3);end;}
+ {:157}
+ {162:}
+ {217:}
+
+ procedure printcapsule;
+ forward;
+
+ procedure showtokenlist(p, q: integer; l, nulltally: integer);
+ label
+ 10;
+ var
+ class, c: smallnumber;
+ r, v: integer;
+ begin
+ class := 3;
+ tally := nulltally;
+ while (p <> (-30000)) and (tally < l) do begin
+ if p = q then begin {646:}
+ firstcount := tally;
+ trickcount := ((tally + 1) + errorline) - halferrorline;
+ if trickcount < errorline then
+ trickcount := errorline
+ end {:646}; {218:}
+ c := 9;
+ if (p < (-30000)) or (p > memend) then begin
+ print(360);
+ goto 10
+ end;
+ if p < himemmin then {219:}
+ if mem[p].hh.b1 = 12 then
+ if mem[p].hh.b0 = 16 then begin {220:}
+ if class = 0 then
+ printchar(32);
+ v := mem[p + 1].int;
+ if v < 0 then begin
+ if class = 17 then
+ printchar(32);
+ printchar(91);
+ printscaled(v);
+ printchar(93);
+ c := 18
+ end else begin
+ printscaled(v);
+ c := 0
+ end
+ end else if mem[p].hh.b0 <> 4 then {:220}
+ print(363)
+ else begin
+ printchar(34);
+ slowprint(mem[p + 1].int);
+ printchar(34);
+ c := 4
+ end
+ else if ((mem[p].hh.b1 <> 11) or (mem[p].hh.b0 < 1)) or (mem[p].hh.b0 > 19) then
+ print(363)
+ else begin
+ gpointer := p;
+ printcapsule;
+ c := 8
+ end {:219}
+ else begin
+ r := mem[p].hh.lh;
+ if r >= 2242 then begin {222:}
+ if r < 2392 then begin
+ print(365);
+ r := r - 2242
+ end else if r < 2542 then begin
+ print(366);
+ r := r - 2392
+ end else begin
+ print(367);
+ r := r - 2542
+ end;
+ printint(r);
+ printchar(41);
+ c := 8
+ end else if r < 1 then {:222}
+ if r = 0 then begin {221:}
+ if class = 17 then
+ printchar(32);
+ print(364);
+ c := 18
+ end else {:221}
+ print(361)
+ else begin
+ r := hash[r].rh;
+ if (r < 0) or (r >= strptr) then
+ print(362) {223:}
+ else begin
+ c := charclass[strpool[strstart[r]]];
+ if c = class then
+ if c in
+ [9, 5, 6, 7, 8] then
+ case c of
+ 9:
+ printchar(46);
+ 5, 6, 7, 8:
+ end
+ else
+ printchar(32);
+ print(r)
+ end {:223}
+ end
+ end {:218};
+ class := c;
+ p := mem[p].hh.rh
+ end;
+ if p <> (-30000) then
+ print(359);
+ 10:
+
+ end; {:217} {665:}
+
+ procedure runaway;
+ begin
+ if scannerstatus > 2 then begin
+ printnl(503);
+ case scannerstatus of
+ 3:
+ print(504);
+ 4, 5:
+ print(505);
+ 6:
+ print(506)
+ end;
+ println;
+ showtokenlist(mem[29998].hh.rh, -30000, errorline - 10, 0)
+ end
+ end; { runaway }
+ {:665}
+ {:162}
+ {163:}
+
+ function getavail: halfword;
+ var
+ p: halfword;
+ begin
+ p := avail;
+ if p <> (-30000) then
+ avail := mem[avail].hh.rh
+ else if memend < memmax then begin
+ memend := memend + 1;
+ p := memend
+ end else begin
+ himemmin := himemmin - 1;
+ p := himemmin;
+ if himemmin <= lomemmax then begin
+ runaway;
+ overflow(186, memmax + 30001)
+ end
+ end;
+ mem[p].hh.rh := -30000;
+ {dynused:=dynused+1;}
+ getavail := p
+ end; {:163} {167:}
+
+ function getnode(s: integer): halfword;
+ label
+ 40, 10, 20;
+ var
+ p: halfword;
+ q: halfword;
+ r: integer;
+ t, tt: integer;
+ begin
+ 20:
+ p := rover; {169:}
+ repeat
+ q := p + mem[p].hh.lh;
+ while mem[q].hh.rh = 32767 do begin
+ t := mem[q + 1].hh.rh;
+ tt := mem[q + 1].hh.lh;
+ if q = rover then
+ rover := t;
+ mem[t + 1].hh.lh := tt;
+ mem[tt + 1].hh.rh := t;
+ q := q + mem[q].hh.lh
+ end;
+ r := q - s;
+ if r > (p + 1) then begin {170:}
+ mem[p].hh.lh := r - p;
+ rover := p;
+ goto 40
+ end {:170};
+ {171
+ :}
+ if r = p then
+ if (mem[p + 1].hh.rh <> rover) or (mem[p + 1].hh.lh <> rover) then begin
+ rover := mem[p + 1].hh.rh;
+ t := mem[p + 1].hh.lh;
+ mem[rover + 1].hh.lh := t;
+ mem[t + 1].hh.rh := rover;
+ goto 40
+ end {:171};
+ mem[p].hh.lh := q - p {:169};
+ p := mem[p + 1].hh.rh
+ until p = rover;
+ if s = 1073741824 then begin
+ getnode := 32767;
+ goto 10
+ end;
+ if (lomemmax + 2) < himemmin then
+ if (lomemmax + 2) <= 2767 then begin {168:}
+ if (lomemmax + 1000) < himemmin then
+ t := lomemmax + 1000
+ else
+ t := ((lomemmax + himemmin) + 2) div 2;
+ if t > 2767 then
+ t := 2767;
+ p := mem[rover + 1].hh.lh;
+ q := lomemmax;
+ mem[p + 1].hh.rh := q;
+ mem[rover + 1].hh.lh := q;
+ mem[q + 1].hh.rh := rover;
+ mem[q + 1].hh.lh := p;
+ mem[q].hh.rh := 32767;
+ mem[q].hh.lh := t - lomemmax;
+ lomemmax := t;
+ mem[lomemmax].hh.rh := -30000;
+ mem[lomemmax].hh.lh := -30000;
+ rover := q;
+ goto 20
+ end {:168};
+ overflow(186, memmax + 30001);
+ 40:
+ mem[r].hh.rh := -30000; {varused:=varused+s;}
+ getnode := r;
+ 10:
+
+ end; {:167} {172:}
+
+ procedure freenode(p: halfword; s: halfword);
+ var
+ q: halfword;
+ begin
+ mem[p].hh.lh := s;
+ mem[p].hh.rh := 32767;
+ q := mem[rover + 1].hh.lh;
+ mem[p + 1].hh.lh := q;
+ mem[p + 1].hh.rh := rover;
+ mem[rover + 1].hh.lh := p;
+ mem[q + 1].hh.rh := p
+ end; {varused:=varused-s;} {:172}
+ {173:}
+ {procedure sortavail;var p,q,r:halfword;oldrover:halfword;
+ begin p:=getnode(1073741824);p:=mem[rover+1].hh.rh;
+ mem[rover+1].hh.rh:=32767;oldrover:=rover;
+ while p<>oldrover do[174:]if p<rover then begin q:=p;p:=mem[q+1].hh.rh;
+ mem[q+1].hh.rh:=rover;rover:=q;end else begin q:=rover;
+ while mem[q+1].hh.rh<p do q:=mem[q+1].hh.rh;r:=mem[p+1].hh.rh;
+ mem[p+1].hh.rh:=mem[q+1].hh.rh;mem[q+1].hh.rh:=p;p:=r;end[:174];
+ p:=rover;
+ while mem[p+1].hh.rh<>32767 do begin mem[mem[p+1].hh.rh+1].hh.lh:=p;
+ p:=mem[p+1].hh.rh;end;mem[p+1].hh.rh:=rover;mem[rover+1].hh.lh:=p;end;}
+ {:173}
+ {177:}
+
+ procedure flushlist(p: halfword);
+ label
+ 30;
+ var
+ q, r: halfword;
+ begin
+ if p >= himemmin then
+ if p <> 30000 then begin
+ r := p;
+ repeat
+ q := r;
+ r := mem[r].hh.rh; {dynused:=dynused-1;}
+ if r < himemmin then
+ goto 30
+ until r = 30000;
+ 30:
+ mem[q].hh.rh := avail;
+ avail := p
+ end
+ end; { flushlist }
+
+ procedure flushnodelist(p: halfword);
+ var
+ q: halfword;
+ begin
+ while p <> (-30000) do begin
+ q := p;
+ p := mem[p].hh.rh;
+ if q < himemmin then
+ freenode(q, 2)
+ else begin
+ mem[q].hh.rh := avail;
+ avail := q
+ end
+ {dynused:=dynused-1;}
+ end
+ end; {:177} {180:}
+ {procedure checkmem(printlocs:boolean);label 31,32;var p,q,r:halfword;
+ clobbered:boolean;begin for p:=-30000 to lomemmax do freearr[p]:=false;
+ for p:=himemmin to memend do freearr[p]:=false;[181:]p:=avail;q:=-30000;
+ clobbered:=false;
+ while p<>-30000 do begin if(p>memend)or(p<himemmin)then clobbered:=true
+ else if freearr[p]then clobbered:=true;
+ if clobbered then begin printnl(187);printint(q);goto 31;end;
+ freearr[p]:=true;q:=p;p:=mem[q].hh.rh;end;31:[:181];[182:]p:=rover;
+ q:=-30000;clobbered:=false;
+ repeat if(p>=lomemmax)or(p<-30000)then clobbered:=true else if(mem[p+1].
+ hh.rh>=lomemmax)or(mem[p+1].hh.rh<-30000)then clobbered:=true else if
+ not((mem[p].hh.rh=32767))or(mem[p].hh.lh<2)or(p+mem[p].hh.lh>lomemmax)or
+ (mem[mem[p+1].hh.rh+1].hh.lh<>p)then clobbered:=true;
+ if clobbered then begin printnl(188);printint(q);goto 32;end;
+ for q:=p to p+mem[p].hh.lh-1 do begin if freearr[q]then begin printnl(
+ 189);printint(q);goto 32;end;freearr[q]:=true;end;q:=p;
+ p:=mem[p+1].hh.rh;until p=rover;32:[:182];[183:]p:=-30000;
+ while p<=lomemmax do begin if(mem[p].hh.rh=32767)then begin printnl(190)
+ ;printint(p);end;while(p<=lomemmax)and not freearr[p]do p:=p+1;
+ while(p<=lomemmax)and freearr[p]do p:=p+1;end[:183];[617:]q:=-29987;
+ p:=mem[q].hh.rh;
+ while p<>-29987 do begin if mem[p+1].hh.lh<>q then begin printnl(463);
+ printint(p);end;p:=mem[p+1].hh.rh;r:=himemmin;
+ repeat if mem[p].hh.lh>=r then begin printnl(464);printint(p);end;
+ r:=mem[p].hh.lh;q:=p;p:=mem[q].hh.rh;until r=-30000;end[:617];
+ if printlocs then[184:]begin printnl(191);
+ for p:=-30000 to lomemmax do if not freearr[p]and((p>waslomax)or wasfree
+ [p])then begin printchar(32);printint(p);end;
+ for p:=himemmin to memend do if not freearr[p]and((p<washimin)or(p>
+ wasmemend)or wasfree[p])then begin printchar(32);printint(p);end;
+ end[:184];for p:=-30000 to lomemmax do wasfree[p]:=freearr[p];
+ for p:=himemmin to memend do wasfree[p]:=freearr[p];wasmemend:=memend;
+ waslomax:=lomemmax;washimin:=himemmin;end;}
+ {:180}
+ {185:}
+ {procedure searchmem(p:halfword);var q:integer;
+ begin for q:=-30000 to lomemmax do begin if mem[q].hh.rh=p then begin
+ printnl(192);printint(q);printchar(41);end;
+ if mem[q].hh.lh=p then begin printnl(193);printint(q);printchar(41);end;
+ end;
+ for q:=himemmin to memend do begin if mem[q].hh.rh=p then begin printnl(
+ 192);printint(q);printchar(41);end;
+ if mem[q].hh.lh=p then begin printnl(193);printint(q);printchar(41);end;
+ end;
+ [209:]for q:=1 to 2241 do begin if eqtb[q].rh=p then begin printnl(328);
+ printint(q);printchar(41);end;end[:209];end;}
+ {:185}
+ {189:}
+
+ procedure printop(c: quarterword);
+ begin
+ if c <= 15 then
+ printtype(c)
+ else
+ if c in
+ [30, 31, 32, 33, 34, 35, 36, 37,
+ 38, 39, 40, 41, 42, 43, 44, 45,
+ 46, 47, 48, 49, 50, 51, 52, 53,
+ 54, 55, 56, 57, 58, 59, 60, 61,
+ 62, 63, 64, 65, 66, 67, 68, 69,
+ 70, 71, 72, 73, 74, 75, 76, 77,
+ 78, 79, 80, 81, 82, 83, 84, 85,
+ 86, 87, 88, 89, 90, 91, 92, 94,
+ 95, 96, 97, 98, 99, 100] then
+ case c of
+ 30:
+ print(218);
+ 31:
+ print(219);
+ 32:
+ print(220);
+ 33:
+ print(221);
+ 34:
+ print(222);
+ 35:
+ print(223);
+ 36:
+ print(224);
+ 37:
+ print(225);
+ 38:
+ print(226);
+ 39:
+ print(227);
+ 40:
+ print(228);
+ 41:
+ print(229);
+ 42:
+ print(230);
+ 43:
+ print(231);
+ 44:
+ print(232);
+ 45:
+ print(233);
+ 46:
+ print(234);
+ 47:
+ print(235);
+ 48:
+ print(236);
+ 49:
+ print(237);
+ 50:
+ print(238);
+ 51:
+ print(239);
+ 52:
+ print(240);
+ 53:
+ print(241);
+ 54:
+ print(242);
+ 55:
+ print(243);
+ 56:
+ print(244);
+ 57:
+ print(245);
+ 58:
+ print(246);
+ 59:
+ print(247);
+ 60:
+ print(248);
+ 61:
+ print(249);
+ 62:
+ print(250);
+ 63:
+ print(251);
+ 64:
+ print(252);
+ 65:
+ print(253);
+ 66:
+ print(254);
+ 67:
+ print(255);
+ 68:
+ print(256);
+ 69:
+ printchar(43);
+ 70:
+ printchar(45);
+ 71:
+ printchar(42);
+ 72:
+ printchar(47);
+ 73:
+ print(257);
+ 74:
+ print(181);
+ 75:
+ print(258);
+ 76:
+ print(259);
+ 77:
+ printchar(60);
+ 78:
+ print(260);
+ 79:
+ printchar(62);
+ 80:
+ print(261);
+ 81:
+ printchar(61);
+ 82:
+ print(262);
+ 83:
+ print(38);
+ 84:
+ print(263);
+ 85:
+ print(264);
+ 86:
+ print(265);
+ 87:
+ print(266);
+ 88:
+ print(267);
+ 89:
+ print(268);
+ 90:
+ print(269);
+ 91:
+ print(270);
+ 92:
+ print(271);
+ 94:
+ print(272);
+ 95:
+ print(273);
+ 96:
+ print(274);
+ 97:
+ print(275);
+ 98:
+ print(276);
+ 99:
+ print(277);
+ 100:
+ print(278)
+ end
+ else
+ print(279)
+ end; { printop }
+ {:189}
+ {194:}
+
+ procedure fixdateandtime;
+ begin
+ dateandtime(internal[17], internal[16], internal[15], internal[14]);
+ internal[17] := internal[17] * 65536;
+ internal[16] := internal[16] * 65536;
+ internal[15] := internal[15] * 65536;
+ internal[14] := internal[14] * 65536;
+ {----------------------------------}
+ lastyearval := internal[14];
+ lastmonthval:= internal[15];
+ {----------------------------------}
+ end; { fixdateandtime }
+ {:194}
+ {205:}
+
+ function idlookup(j, l: integer): halfword;
+ label
+ 40;
+ var
+ h: integer;
+ p: halfword;
+ k: halfword;
+ begin
+ if l = 1 then begin {206:}
+ p := buffer[j] + 1;
+ hash[p].rh := p - 1;
+ goto 40
+ end {:206}; {208:}
+ h := buffer[j];
+ for k := j + 1 to (j + l) - 1 do begin
+ h := (h + h) + buffer[k];
+ while h >= 1777 do
+ h := h - 1777
+ end {:208};
+ p := h + 129;
+ while true do begin
+ if hash[p].rh > 0 then
+ if (strstart[hash[p].rh + 1] - strstart[hash[p].rh]) = l then
+ if streqbuf(hash[p].rh, j) then
+ goto 40;
+ if hash[p].lh = 0 then begin {207:}
+ if hash[p].rh > 0 then begin
+ repeat
+ if hashused = 1 then
+ overflow(327, 2100);
+ hashused := hashused - 1
+ until hash[hashused].rh = 0;
+ hash[p].lh := hashused;
+ p := hashused
+ end;
+ begin
+ if (poolptr + l) > maxpoolptr then begin
+ if (poolptr + l) > poolsize then
+ overflow(129, poolsize - initpoolptr);
+ maxpoolptr := poolptr + l
+ end
+ end;
+ for k := j to (j + l) - 1 do begin
+ strpool[poolptr] := buffer[k];
+ poolptr := poolptr + 1
+ end;
+ hash[p].rh := makestring;
+ strref[hash[p].rh] := 127;
+ {stcount:=stcount+1;}
+ goto 40
+ end {:207};
+ p := hash[p].lh
+ end;
+ 40:
+ idlookup := p
+ end; {:205} {210:}
+ {procedure primitive(s:strnumber;c:halfword;o:halfword);
+ var k:poolpointer;j:smallnumber;l:smallnumber;begin k:=strstart[s];
+ l:=strstart[s+1]-k;for j:=0 to l-1 do buffer[j]:=strpool[k+j];
+ cursym:=idlookup(0,l);if s>=128 then begin flushstring(strptr-1);
+ hash[cursym].rh:=s;end;eqtb[cursym].lh:=c;eqtb[cursym].rh:=o;end;}
+ {:210}
+ {215:}
+
+ function newnumtok(v: scaled): halfword;
+ var
+ p: halfword;
+ begin
+ p := getnode(2);
+ mem[p + 1].int := v;
+ mem[p].hh.b0 := 16;
+ mem[p].hh.b1 := 12;
+ newnumtok := p
+ end; {:215} {216:}
+
+ procedure tokenrecycle;
+ forward;
+
+ procedure flushtokenlist(p: halfword);
+ var
+ q: halfword;
+ begin
+ while p <> (-30000) do begin
+ q := p;
+ p := mem[p].hh.rh;
+ if q >= himemmin then begin
+ mem[q].hh.rh := avail;
+ avail := q
+ end else begin
+ {dynused:=dynused-1;}
+ if mem[q].hh.b0 in
+ [1, 2, 16, 4, 3, 5, 7, 12,
+ 10, 6, 9, 8, 11, 14, 13, 17,
+ 18, 19] then
+ case mem[q].hh.b0 of
+ 1, 2, 16:
+ ;
+ 4:
+ begin
+ if strref[mem[q + 1].int] < 127 then
+ if strref[mem[q + 1].int] > 1 then
+ strref[mem[q + 1].int] := strref[mem[q + 1].int] - 1
+ else
+ flushstring(mem[q + 1].int)
+ end;
+ 3, 5, 7, 12, 10, 6, 9,
+ 8, 11, 14, 13, 17, 18, 19:
+ begin
+ gpointer := q;
+ tokenrecycle
+ end
+ end
+ else
+ confusion(358);
+ freenode(q, 2)
+ end
+ end
+ end; { flushtokenlist }
+ {:216}
+ {226:}
+
+ procedure deletemacref(p: halfword);
+ begin
+ if mem[p].hh.lh = (-30000) then
+ flushtokenlist(p)
+ else
+ mem[p].hh.lh := mem[p].hh.lh - 1
+ end; {:226} {227:} {625:}
+
+ procedure printcmdmod(c, m: integer);
+ begin
+ if c in
+ [18, 77, 59, 72, 32, 78, 79, 57,
+ 19, 60, 27, 11, 81, 26, 6, 9,
+ 70, 73, 13, 46, 63, 14, 15, 69,
+ 28, 47, 24, 7, 65, 64, 12, 8,
+ 80, 17, 74, 35, 58, 71, 75, 16,
+ 4, 61, 56, 3, 1, 2, 33, 34,
+ 37, 55, 45, 50, 36, 43, 54, 48,
+ 51, 52, 30, 82, 23, 21, 22, 31,
+ 62, 41, 10, 53, 44, 49, 5, 40,
+ 68, 66, 67, 25, 20, 76, 29] then
+ case c of {212:}
+ 18:
+ print(330);
+ 77:
+ print(329);
+ 59:
+ print(332);
+ 72:
+ print(331);
+ 32:
+ print(333);
+ 78:
+ print(58);
+ 79:
+ print(44);
+ 57:
+ print(334);
+ 19:
+ print(335);
+ 60:
+ print(336);
+ 27:
+ print(337);
+ 11:
+ print(338);
+ 81:
+ print(323);
+ 26:
+ print(339);
+ 6:
+ print(340);
+ 9:
+ print(341);
+ 70:
+ print(342);
+ 73:
+ print(343);
+ 13:
+ print(344);
+ 46:
+ print(123);
+ 63:
+ print(91);
+ 14:
+ print(345);
+ 15:
+ print(346);
+ 69:
+ print(347);
+ 28:
+ print(348);
+ 47:
+ print(279);
+ 24:
+ print(349);
+ 7:
+ printchar(92);
+ 65:
+ print(125);
+ 64:
+ print(93);
+ 12:
+ print(350);
+ 8:
+ print(351);
+ 80:
+ print(59);
+ 17:
+ print(352);
+ 74:
+ print(353);
+ 35:
+ print(354);
+ 58:
+ print(355);
+ 71:
+ print(356);
+ 75:
+ print(357); {:212} {684:}
+ 16:
+ if m <= 2 then
+ if m = 1 then
+ print(520)
+ else if m < 1 then
+ print(324)
+ else
+ print(521)
+ else if m = 53 then
+ print(522)
+ else if m = 44 then
+ print(523)
+ else
+ print(524);
+ 4:
+ if m <= 1 then
+ if m = 1 then
+ print(527)
+ else
+ print(325)
+ else if m = 2242 then
+ print(525)
+ else
+ print(526); {:684} {689:}
+ 61:
+ if m in
+ [1, 2, 3] then
+ case m of
+ 1:
+ print(529);
+ 2:
+ printchar(64);
+ 3:
+ print(530)
+ end
+ else
+ print(528); {:689} {696:}
+ 56:
+ if m >= 2242 then
+ if m = 2242 then
+ print(541)
+ else if m = 2392 then
+ print(542)
+ else
+ print(543)
+ else if m < 2 then
+ print(544)
+ else if m = 2 then
+ print(545)
+ else
+ print(546); {:696} {710:}
+ 3:
+ if m = 0 then
+ print(556)
+ else
+ print(482);
+ {:710}
+ {741:}
+ 1, 2:
+ if m in
+ [1, 2, 3] then
+ case m of
+ 1:
+ print(583);
+ 2:
+ print(322);
+ 3:
+ print(584)
+ end
+ else
+ print(585); {:741} {894:}
+ 33, 34, 37, 55, 45, 50, 36,
+ 43, 54, 48, 51, 52:
+ printop(m); {:894} {1014:}
+ 30:
+ printtype(m); {:1014} {1019:}
+ 82:
+ if m = 0 then
+ print(776)
+ else
+ print(777);
+ {:1019}
+ {1025:}
+ 23:
+ if m in
+ [0, 1, 2] then
+ case m of
+ 0:
+ print(143);
+ 1:
+ print(144);
+ 2:
+ print(145)
+ end
+ else
+ print(783); {:1025} {1028:}
+ 21:
+ if m = 0 then
+ print(784)
+ else
+ print(785); {:1028} {1038:}
+ 22:
+ if m in
+ [0, 1, 2, 3] then
+ case m of
+ 0:
+ print(799);
+ 1:
+ print(800);
+ 2:
+ print(801);
+ 3:
+ print(802)
+ end
+ else
+ print(803); {:1038} {1043:}
+ 31, 62:
+ begin
+ if c = 31 then
+ print(806)
+ else
+ print(807);
+ print(808);
+ print(hash[m].rh)
+ end;
+ 41:
+ if m = (-30000) then
+ print(809)
+ else
+ print(810);
+ 10:
+ print(811);
+ 53, 44, 49:
+ begin
+ printcmdmod(16, c);
+ print(812);
+ println;
+ showtokenlist(mem[mem[m].hh.rh].hh.rh, -30000, 1000, 0)
+ end;
+ 5:
+ print(813);
+ 40:
+ print(intname[m]); {:1043} {1053:}
+ 68:
+ if m = 1 then
+ print(820)
+ else if m = 0 then
+ print(821)
+ else
+ print(822);
+ 66:
+ if m = 6 then
+ print(823)
+ else
+ print(824);
+ 67:
+ if m = 0 then
+ print(825)
+ else
+ print(826); {:1053} {1080:}
+ 25:
+ if m < 1 then
+ print(856)
+ else if m = 1 then
+ print(857)
+ else
+ print(858);
+ {:1080}
+ {1102:}
+ 20:
+ if m in
+ [0, 1, 2, 3] then
+ case m of
+ 0:
+ print(868);
+ 1:
+ print(869);
+ 2:
+ print(870);
+ 3:
+ print(871)
+ end
+ else
+ print(872); {:1102} {1110:}
+ 76:
+ if m = 0 then
+ print(889)
+ else
+ print(890); {:1110} {1180:}
+ 29:
+ if m = 16 then
+ print(913)
+ else
+ print(912)
+ end
+ else {:1180}
+ print(468)
+ end; {:625}
+
+ procedure showmacro(p: halfword; q, l: integer);
+ label
+ 10;
+ var
+ r: halfword;
+ begin
+ p := mem[p].hh.rh;
+ while mem[p].hh.lh > 7 do begin
+ r := mem[p].hh.rh;
+ mem[p].hh.rh := -30000;
+ showtokenlist(p, -30000, l, 0);
+ mem[p].hh.rh := r;
+ p := r;
+ if l > 0 then
+ l := l - tally
+ else
+ goto 10
+ end;
+ tally := 0;
+ case mem[p].hh.lh of
+ 0:
+ print(368);
+ 1, 2, 3:
+ begin
+ printchar(60);
+ printcmdmod(56, mem[p].hh.lh);
+ print(369)
+ end;
+ 4:
+ print(370);
+ 5:
+ print(371);
+ 6:
+ print(372);
+ 7:
+ print(373)
+ end;
+ showtokenlist(mem[p].hh.rh, q, l - tally, 0);
+ 10:
+
+ end; {:227} {232:}
+
+ procedure initbignode(p: halfword);
+ var
+ q: halfword;
+ s: smallnumber;
+ begin
+ s := bignodesize[mem[p].hh.b0];
+ q := getnode(s);
+ repeat
+ s := s - 2; {586:}
+ begin
+ mem[q + s].hh.b0 := 19;
+ serialno := serialno + 64;
+ mem[(q + s) + 1].int := serialno
+ end {:586};
+ mem[q + s].hh.b1 := (s div 2) + 5;
+ mem[q + s].hh.rh := -30000
+ until s = 0;
+ mem[q].hh.rh := p;
+ mem[p + 1].int := q
+ end; { initbignode }
+ {:232}
+ {233:}
+
+ function idtransform: halfword;
+ var
+ p, q, r: halfword;
+ begin
+ p := getnode(2);
+ mem[p].hh.b0 := 13;
+ mem[p].hh.b1 := 11;
+ mem[p + 1].int := -30000;
+ initbignode(p);
+ q := mem[p + 1].int;
+ r := q + 12;
+ repeat
+ r := r - 2;
+ mem[r].hh.b0 := 16;
+ mem[r + 1].int := 0
+ until r = q;
+ mem[q + 5].int := 65536;
+ mem[q + 11].int := 65536;
+ idtransform := p
+ end; {:233} {234:}
+
+ procedure newroot(x: halfword);
+ var
+ p: halfword;
+ begin
+ p := getnode(2);
+ mem[p].hh.b0 := 0;
+ mem[p].hh.b1 := 0;
+ mem[p].hh.rh := x;
+ eqtb[x].rh := p
+ end; {:234}
+ {235:}
+
+ procedure printvariablename(p: halfword);
+ label
+ 40, 10;
+ var
+ q: halfword;
+ r: halfword;
+ begin
+ while mem[p].hh.b1 >= 5 do begin {237:}
+ case mem[p].hh.b1 of
+ 5:
+ printchar(120);
+ 6:
+ printchar(121);
+ 7:
+ print(376);
+ 8:
+ print(377);
+ 9:
+ print(378);
+ 10:
+ print(379);
+ 11:
+ begin
+ print(380);
+ printint(p + 30000);
+ goto 10
+ end
+ end;
+ print(381);
+ p := mem[p - (2 * (mem[p].hh.b1 - 5))].hh.rh
+ end {:237};
+ q := -30000;
+ while mem[p].hh.b1 > 1 do begin {236:}
+ if mem[p].hh.b1 = 3 then begin
+ r := newnumtok(mem[p + 2].int);
+ repeat
+ p := mem[p].hh.rh
+ until mem[p].hh.b1 = 4
+ end else if mem[p].hh.b1 = 2 then begin
+ p := mem[p].hh.rh;
+ goto 40
+ end else begin
+ if mem[p].hh.b1 <> 4 then
+ confusion(375);
+ r := getavail;
+ mem[r].hh.lh := mem[p + 2].hh.lh
+ end;
+ mem[r].hh.rh := q;
+ q := r;
+ 40:
+ p := mem[p + 2].hh.rh
+ end {:236};
+ r := getavail;
+ mem[r].hh.lh := mem[p].hh.rh;
+ mem[r].hh.rh := q;
+ if mem[p].hh.b1 = 1 then
+ print(374);
+ showtokenlist(r, -30000, 2147483647, tally);
+ flushtokenlist(r);
+ 10:
+
+ end; {:235}
+ {238:}
+
+ function interesting(p: halfword): boolean;
+ var
+ t: smallnumber;
+ begin
+ if internal[3] > 0 then
+ interesting := true
+ else begin
+ t := mem[p].hh.b1;
+ if t >= 5 then
+ if t <> 11 then
+ t := mem[mem[p - (2 * (t - 5))].hh.rh].hh.b1;
+ interesting := t <> 11
+ end
+ end; {:238} {239:}
+
+ function newstructure(p: halfword): halfword;
+ var
+ q, r: halfword;
+ begin
+ if mem[p].hh.b1 in
+ [0, 3, 4] then
+ case mem[p].hh.b1 of
+ 0:
+ begin
+ q := mem[p].hh.rh;
+ r := getnode(2);
+ eqtb[q].rh := r
+ end;
+ 3:
+ begin {240:}
+ q := p;
+ repeat
+ q := mem[q].hh.rh
+ until mem[q].hh.b1 = 4;
+ q := mem[q + 2].hh.rh;
+ r := q + 1;
+ repeat
+ q := r;
+ r := mem[r].hh.rh
+ until r = p;
+ r := getnode(3);
+ mem[q].hh.rh := r;
+ mem[r + 2].int := mem[p + 2].int
+ end; {:240}
+ 4:
+ begin {241:}
+ q := mem[p + 2].hh.rh;
+ r := mem[q + 1].hh.lh;
+ repeat
+ q := r;
+ r := mem[r].hh.rh
+ until r = p;
+ r := getnode(3);
+ mem[q].hh.rh := r;
+ mem[r + 2] := mem[p + 2];
+ if mem[p + 2].hh.lh = 0 then begin
+ q := mem[p + 2].hh.rh + 1;
+ while mem[q].hh.rh <> p do
+ q := mem[q].hh.rh;
+ mem[q].hh.rh := r
+ end
+ end
+ end
+ else {:241}
+ confusion(382);
+ mem[r].hh.rh := mem[p].hh.rh;
+ mem[r].hh.b0 := 21;
+ mem[r].hh.b1 := mem[p].hh.b1;
+ mem[r + 1].hh.lh := p;
+ mem[p].hh.b1 := 2;
+ q := getnode(3);
+ mem[p].hh.rh := q;
+ mem[r + 1].hh.rh := q;
+ mem[q + 2].hh.rh := r;
+ mem[q].hh.b0 := 0;
+ mem[q].hh.b1 := 4;
+ mem[q].hh.rh := -29983;
+ mem[q + 2].hh.lh := 0;
+ newstructure := r
+ end; {:239} {242:}
+
+ function findvariable(t: halfword): halfword;
+ label
+ 10;
+ var
+ p, q, r, s: halfword;
+ pp, qq, rr, ss: halfword;
+ n: integer;
+ saveword: memoryword;
+ begin
+ p := mem[t].hh.lh;
+ t := mem[t].hh.rh;
+ if (eqtb[p].lh mod 83) <> 41 then begin
+ findvariable := -30000;
+ goto 10
+ end;
+ if eqtb[p].rh = (-30000) then
+ newroot(p);
+ p := eqtb[p].rh;
+ pp := p;
+ while t <> (-30000) do begin {243:}
+ if mem[pp].hh.b0 <> 21 then begin
+ if mem[pp].hh.b0 > 21 then begin
+ findvariable := -30000;
+ goto 10
+ end;
+ ss := newstructure(pp);
+ if p = pp then
+ p := ss;
+ pp := ss
+ end;
+ if mem[p].hh.b0 <> 21 then
+ p := newstructure(p) {:243};
+ if t < himemmin then begin {244:}
+ n := mem[t + 1].int;
+ pp := mem[mem[pp + 1].hh.lh].hh.rh;
+ q := mem[mem[p + 1].hh.lh].hh.rh;
+ saveword := mem[q + 2];
+ mem[q + 2].int := 2147483647;
+ s := p + 1;
+ repeat
+ r := s;
+ s := mem[s].hh.rh
+ until n <= mem[s + 2].int;
+ if n = mem[s + 2].int then
+ p := s
+ else begin
+ p := getnode(3);
+ mem[r].hh.rh := p;
+ mem[p].hh.rh := s;
+ mem[p + 2].int := n;
+ mem[p].hh.b1 := 3;
+ mem[p].hh.b0 := 0
+ end;
+ mem[q + 2] := saveword
+ end else begin {:244} {245:}
+ n := mem[t].hh.lh;
+ ss := mem[pp + 1].hh.lh;
+ repeat
+ rr := ss;
+ ss := mem[ss].hh.rh
+ until n <= mem[ss + 2].hh.lh;
+ if n < mem[ss + 2].hh.lh then begin
+ qq := getnode(3);
+ mem[rr].hh.rh := qq;
+ mem[qq].hh.rh := ss;
+ mem[qq + 2].hh.lh := n;
+ mem[qq].hh.b1 := 4;
+ mem[qq].hh.b0 := 0;
+ mem[qq + 2].hh.rh := pp;
+ ss := qq
+ end;
+ if p = pp then begin
+ p := ss;
+ pp := ss
+ end else begin
+ pp := ss;
+ s := mem[p + 1].hh.lh;
+ repeat
+ r := s;
+ s := mem[s].hh.rh
+ until n <= mem[s + 2].hh.lh;
+ if n = mem[s + 2].hh.lh then
+ p := s
+ else begin
+ q := getnode(3);
+ mem[r].hh.rh := q;
+ mem[q].hh.rh := s;
+ mem[q + 2].hh.lh := n;
+ mem[q].hh.b1 := 4;
+ mem[q].hh.b0 := 0;
+ mem[q + 2].hh.rh := p;
+ p := q
+ end
+ end
+ end {:245};
+ t := mem[t].hh.rh
+ end;
+ if mem[pp].hh.b0 >= 21 then
+ if mem[pp].hh.b0 = 21 then
+ pp := mem[pp + 1].hh.lh
+ else begin
+ findvariable := -30000;
+ goto 10
+ end;
+ if mem[p].hh.b0 = 21 then
+ p := mem[p + 1].hh.lh;
+ if mem[p].hh.b0 = 0 then begin
+ if mem[pp].hh.b0 = 0 then begin
+ mem[pp].hh.b0 := 15;
+ mem[pp + 1].int := -30000
+ end;
+ mem[p].hh.b0 := mem[pp].hh.b0;
+ mem[p + 1].int := -30000
+ end;
+ findvariable := p;
+ 10:
+
+ end; {:242} {246:} {257:}
+
+ procedure printpath(h: halfword; s: strnumber; nuline: boolean);
+ label
+ 30, 31;
+ var
+ p, q: halfword;
+ begin
+ printdiagnostic(384, s, nuline);
+ println;
+ p := h;
+ repeat
+ q := mem[p].hh.rh;
+ if (p = (-30000)) or (q = (-30000)) then begin
+ printnl(131);
+ goto 30
+ end; {258:}
+ printtwo(mem[p + 1].int, mem[p + 2].int);
+ if mem[p].hh.b1 in
+ [0, 1, 4, 3, 2] then
+ case mem[p].hh.b1 of
+ 0:
+ begin
+ if mem[p].hh.b0 = 4 then
+ print(385);
+ if (mem[q].hh.b0 <> 0) or (q <> h) then
+ q := -30000;
+ goto 31
+ end;
+ 1:
+ begin {261:}
+ print(391);
+ printtwo(mem[p + 5].int, mem[p + 6].int);
+ print(390);
+ if mem[q].hh.b0 <> 1 then
+ print(392)
+ else
+ printtwo(mem[q + 3].int, mem[q + 4].int);
+ goto 31
+ end; {:261}
+ 4: {262:}
+ if (mem[p].hh.b0 <> 1) and (mem[p].hh.b0 <> 4) then
+ print(385) {:262};
+ 3, 2:
+ begin {263:}
+ if mem[p].hh.b0 = 4 then
+ print(392);
+ if mem[p].hh.b1 = 3 then begin
+ print(388);
+ printscaled(mem[p + 5].int)
+ end else begin
+ nsincos(mem[p + 5].int);
+ printchar(123);
+ printscaled(ncos);
+ printchar(44);
+ printscaled(nsin)
+ end;
+ printchar(125)
+ end
+ end
+ else {:263}
+ print(131);
+ if mem[q].hh.b0 <= 1 then
+ print(386)
+ else if (mem[p + 6].int <> 65536) or (mem[q + 4].int <> 65536) then begin {260:}
+ print(389);
+ if mem[p + 6].int < 0 then
+ print(332);
+ printscaled(abs(mem[p + 6].int));
+ if mem[p + 6].int <> mem[q + 4].int then begin
+ print(390);
+ if mem[q + 4].int < 0 then
+ print(332);
+ printscaled(abs(mem[q + 4].int))
+ end
+ end {:260};
+ 31: {:258}
+ ;
+ p := q;
+ if (p <> h) or (mem[h].hh.b0 <> 0) then begin {259:}
+ printnl(387);
+ if mem[p].hh.b0 = 2 then begin
+ nsincos(mem[p + 3].int);
+ printchar(123);
+ printscaled(ncos);
+ printchar(44);
+ printscaled(nsin);
+ printchar(125)
+ end else if mem[p].hh.b0 = 3 then begin
+ print(388);
+ printscaled(mem[p + 3].int);
+ printchar(125)
+ end
+ end {:259}
+ until p = h;
+ if mem[h].hh.b0 <> 0 then
+ print(256);
+ 30:
+ enddiagnostic(true)
+ end; {:257}
+ {332:}
+ {333:}
+
+ procedure printweight(q: halfword; xoff: integer);
+ var
+ w, m: integer;
+ d: integer;
+ begin
+ d := mem[q].hh.lh + 32768;
+ w := d mod 8;
+ m := (d div 8) - mem[curedges + 3].hh.lh;
+ if fileoffset > (maxprintline - 9) then
+ printnl(32)
+ else
+ printchar(32);
+ printint(m + xoff);
+ while w > 4 do begin
+ printchar(43);
+ w := w - 1
+ end;
+ while w < 4 do begin
+ printchar(45);
+ w := w + 1
+ end
+ end; {:333}
+
+ procedure printedges(s: strnumber; nuline: boolean; xoff, yoff: integer);
+ var
+ p, q, r: halfword;
+ n: integer;
+ begin
+ printdiagnostic(399, s, nuline);
+ p := mem[curedges].hh.lh;
+ n := mem[curedges + 1].hh.rh - 4096;
+ while p <> curedges do begin
+ q := mem[p + 1].hh.lh;
+ r := mem[p + 1].hh.rh;
+ if (q > (-29999)) or (r <> 30000) then begin
+ printnl(400);
+ printint(n + yoff);
+ printchar(58);
+ while q > (-29999) do begin
+ printweight(q, xoff);
+ q := mem[q].hh.rh
+ end;
+ print(401);
+ while r <> 30000 do begin
+ printweight(r, xoff);
+ r := mem[r].hh.rh
+ end
+ end;
+ p := mem[p].hh.lh;
+ n := n - 1
+ end;
+ enddiagnostic(true)
+ end; {:332} {388:}
+
+ {---------------------------------------------------
+ procedure unskew(x, y: scaled; octant: smallnumber);
+
+ moved to mf2ps1.p
+ ---------------------------------------------------}
+
+ procedure printpen(p: halfword; s: strnumber; nuline: boolean);
+ var
+ nothingprinted: boolean;
+ k: 1..8;
+ h: halfword;
+ m, n: integer;
+ w, ww: halfword;
+ begin
+ printdiagnostic(436, s, nuline);
+ nothingprinted := true;
+ println;
+ for k := 1 to 8 do begin
+ octant := octantcode[k];
+ h := p + octant;
+ n := mem[h].hh.lh;
+ w := mem[h].hh.rh;
+ if not odd(k) then
+ w := mem[w].hh.lh;
+ for m := 1 to n + 1 do begin
+ if odd(k) then
+ ww := mem[w].hh.rh
+ else
+ ww := mem[w].hh.lh;
+ if (mem[ww + 1].int <> mem[w + 1].int) or (mem[ww + 2].int <> mem[w + 2].int) then begin {474:}
+ if nothingprinted then
+ nothingprinted := false
+ else
+ printnl(438);
+ unskew(mem[ww + 1].int, mem[ww + 2].int, octant);
+ printtwo(curx, cury)
+ end {:474};
+ w := ww
+ end
+ end;
+ if nothingprinted then begin
+ w := mem[p + 1].hh.rh;
+ printtwo(mem[w + 1].int + mem[w + 2].int, mem[w + 2].int)
+ end;
+ printnl(437);
+ enddiagnostic(true)
+ end; {:473} {589:}
+
+ procedure printdependency(p: halfword; t: smallnumber);
+ label
+ 10;
+ var
+ v: integer;
+ pp, q: halfword;
+ begin
+ pp := p;
+ while true do begin
+ v := abs(mem[p + 1].int);
+ q := mem[p].hh.lh;
+ if q = (-30000) then begin
+ if (v <> 0) or (p = pp) then begin
+ if mem[p + 1].int > 0 then
+ if p <> pp then
+ printchar(43);
+ printscaled(mem[p + 1].int)
+ end;
+ goto 10
+ end;
+ {590:}
+ if mem[p + 1].int < 0 then
+ printchar(45)
+ else if p <> pp then
+ printchar(43);
+ if t = 17 then
+ v := roundfraction(v);
+ if v <> 65536 then
+ printscaled(v) {:590};
+ if mem[q].hh.b0 <> 19 then
+ confusion(454);
+ printvariablename(q);
+ v := mem[q + 1].int mod 64;
+ while v > 0 do begin
+ print(455);
+ v := v - 2
+ end;
+ p := mem[p].hh.rh
+ end;
+ 10:
+
+ end; {:589} {801:} {805:}
+
+ procedure printdp(t: smallnumber; p: halfword; verbosity: smallnumber);
+ var
+ q: halfword;
+ begin
+ q := mem[p].hh.rh;
+ if (mem[q].hh.lh = (-30000)) or (verbosity > 0) then
+ printdependency(p, t)
+ else
+ print(628)
+ end; {:805} {799:}
+
+ function stashcurexp: halfword;
+ var
+ p: halfword;
+ begin
+ if curtype in
+ [3, 5, 7, 12, 10, 13, 14, 17,
+ 18, 19] then
+ case curtype of
+ 3, 5, 7, 12, 10, 13, 14,
+ 17, 18, 19:
+ p := curexp
+ end
+ else
+ begin
+ p := getnode(2);
+ mem[p].hh.b1 := 11;
+ mem[p].hh.b0 := curtype;
+ mem[p + 1].int := curexp
+ end;
+ curtype := 1;
+ mem[p].hh.rh := -29999;
+ stashcurexp := p
+ end; {:799} {800:}
+
+ procedure unstashcurexp(p: halfword);
+ begin
+ curtype := mem[p].hh.b0;
+ if curtype in
+ [3, 5, 7, 12, 10, 13, 14, 17,
+ 18, 19] then
+ case curtype of
+ 3, 5, 7, 12, 10, 13, 14,
+ 17, 18, 19:
+ curexp := p
+ end
+ else
+ begin
+ curexp := mem[p + 1].int;
+ freenode(p, 2)
+ end
+ end; {:800}
+
+ procedure printexp(p: halfword; verbosity: smallnumber);
+ var
+ restorecurexp: boolean;
+ t: smallnumber;
+ v: integer;
+ q: halfword;
+ begin
+ if p <> (-30000) then
+ restorecurexp := false
+ else begin
+ p := stashcurexp;
+ restorecurexp := true
+ end;
+ t := mem[p].hh.b0;
+ if t < 17 then
+ v := mem[p + 1].int
+ else if t < 19 then
+ v := mem[p + 1].hh.rh; {802:}
+ if t in
+ [1, 2, 3, 5, 7, 12, 10, 15,
+ 4, 6, 8, 9, 11, 13, 14, 16,
+ 17, 18, 19] then
+ case t of
+ 1:
+ print(194);
+ 2:
+ if v = 30 then
+ print(218)
+ else
+ print(219);
+ 3, 5, 7, 12, 10, 15:
+ begin {806:}
+ printtype(t);
+ if v <> (-30000) then begin
+ printchar(32);
+ while (mem[v].hh.b1 = 11) and (v <> p) do
+ v := mem[v + 1].int;
+ printvariablename(v)
+ end
+ end; {:806}
+ 4:
+ begin
+ printchar(34);
+ slowprint(v);
+ printchar(34)
+ end;
+ 6, 8, 9, 11: {804:}
+ if verbosity <= 1 then
+ printtype(t)
+ else begin
+ if selector = 3 then
+ if internal[13] <= 0 then begin
+ selector := 1;
+ printtype(t);
+ print(626);
+ selector := 3
+ end;
+ case t of
+ 6:
+ printpen(v, 155, false);
+ 8:
+ printpath(v, 627, false);
+ 9:
+ printpath(v, 155, false);
+ 11:
+ begin
+ curedges := v;
+ printedges(155, false, 0, 0)
+ end
+ end
+ end {:804};
+ 13, 14:
+ if v = (-30000) then
+ printtype(t) {803:}
+ else begin
+ printchar(40);
+ q := v + bignodesize[t];
+ repeat
+ if mem[v].hh.b0 = 16 then
+ printscaled(mem[v + 1].int)
+ else if mem[v].hh.b0 = 19 then
+ printvariablename(v)
+ else
+ printdp(mem[v].hh.b0, mem[v + 1].hh.rh, verbosity);
+ v := v + 2;
+ if v <> q then
+ printchar(44)
+ until v = q;
+ printchar(41)
+ end {:803};
+ 16:
+ printscaled(v);
+ 17, 18:
+ printdp(t, v, verbosity);
+ 19:
+ printvariablename(p)
+ end
+ else
+ confusion(625) {:802};
+ if restorecurexp then
+ unstashcurexp(p)
+ end; {:801} {807:}
+
+ procedure disperr(p: halfword; s: strnumber);
+ begin
+ if interaction = 3 then
+ ;
+ printnl(629);
+ printexp(p, 1);
+ if s <> 155 then begin
+ printnl(133);
+ print(s)
+ end
+ end; {:807} {594:}
+
+ function pplusfq(p: halfword; f: integer; q: halfword; t, tt: smallnumber): halfword;
+ label
+ 30;
+ var
+ pp, qq: halfword;
+ r, s: halfword;
+ threshold: integer;
+ v: integer;
+ begin
+ if t = 17 then
+ threshold := 2685
+ else
+ threshold := 8;
+ r := 29999;
+ pp := mem[p].hh.lh;
+ qq := mem[q].hh.lh;
+ while true do
+ if pp = qq then
+ if pp = (-30000) then
+ goto 30 {595:}
+ else begin
+ if tt = 17 then
+ v := mem[p + 1].int + takefraction(f, mem[q + 1].int)
+ else
+ v := mem[p + 1].int + takescaled(f, mem[q + 1].int);
+ mem[p + 1].int := v;
+ s := p;
+ p := mem[p].hh.rh;
+ if abs(v) < threshold then
+ freenode(s, 2)
+ else begin
+ if abs(v) >= 626349397 then
+ if watchcoefs then begin
+ mem[qq].hh.b0 := 0;
+ fixneeded := true
+ end;
+ mem[r].hh.rh := s;
+ r := s
+ end;
+ pp := mem[p].hh.lh;
+ q := mem[q].hh.rh;
+ qq := mem[q].hh.lh
+ end {:595}
+ else if mem[pp + 1].int < mem[qq + 1].int then begin {596:}
+ if tt = 17 then
+ v := takefraction(f, mem[q + 1].int)
+ else
+ v := takescaled(f, mem[q + 1].int);
+ if abs(v) > (threshold div 2) then begin
+ s := getnode(2);
+ mem[s].hh.lh := qq;
+ mem[s + 1].int := v;
+ if abs(v) >= 626349397 then
+ if watchcoefs then begin
+ mem[qq].hh.b0 := 0;
+ fixneeded := true
+ end;
+ mem[r].hh.rh := s;
+ r := s
+ end;
+ q := mem[q].hh.rh;
+ qq := mem[q].hh.lh
+ end else begin {:596}
+ mem[r].hh.rh := p;
+ r := p;
+ p := mem[p].hh.rh;
+ pp := mem[p].hh.lh
+ end;
+ 30:
+ if t = 17 then
+ mem[p + 1].int := slowadd(mem[p + 1].int, takefraction(mem[q + 1].int, f))
+ else
+ mem[p + 1].int := slowadd(mem[p + 1].int, takescaled(mem[q + 1].int, f));
+ mem[r].hh.rh := p;
+ depfinal := p;
+ pplusfq := mem[29999].hh.rh
+ end; {:594}
+ {600:}
+
+ function poverv(p: halfword; v: scaled; t0, t1: smallnumber): halfword;
+ var
+ r, s: halfword;
+ w: integer;
+ threshold: integer;
+ scalingdown: boolean;
+ begin
+ if t0 <> t1 then
+ scalingdown := true
+ else
+ scalingdown := false;
+ if t1 = 17 then
+ threshold := 1342
+ else
+ threshold := 4;
+ r := 29999;
+ while mem[p].hh.lh <> (-30000) do begin
+ if scalingdown then
+ if abs(v) < 524288 then
+ w := makescaled(mem[p + 1].int, v * 4096)
+ else
+ w := makescaled(roundfraction(mem[p + 1].int), v)
+ else
+ w := makescaled(mem[p + 1].int, v);
+ if abs(w) <= threshold then begin
+ s := mem[p].hh.rh;
+ freenode(p, 2);
+ p := s
+ end else begin
+ if abs(w) >= 626349397 then begin
+ fixneeded := true;
+ mem[mem[p].hh.lh].hh.b0 := 0
+ end;
+ mem[r].hh.rh := p;
+ r := p;
+ mem[p + 1].int := w;
+ p := mem[p].hh.rh
+ end
+ end;
+ mem[r].hh.rh := p;
+ mem[p + 1].int := makescaled(mem[p + 1].int, v);
+ poverv := mem[29999].hh.rh
+ end; { poverv }
+ {:600}
+ {602:}
+
+ procedure valtoobig(x: scaled);
+ begin
+ if internal[40] > 0 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(456)
+ end;
+ printscaled(x);
+ printchar(41);
+ begin
+ helpptr := 4;
+ helpline[3] := 457;
+ helpline[2] := 458;
+ helpline[1] := 459;
+ helpline[0] := 460
+ end;
+ error
+ end
+ end; {:602} {603:}
+
+ procedure makeknown(p, q: halfword);
+ var
+ t: 17..18;
+ begin
+ mem[mem[q].hh.rh + 1].hh.lh := mem[p + 1].hh.lh;
+ mem[mem[p + 1].hh.lh].hh.rh := mem[q].hh.rh;
+ t := mem[p].hh.b0;
+ mem[p].hh.b0 := 16;
+ mem[p + 1].int := mem[q + 1].int;
+ freenode(q, 2);
+ if abs(mem[p + 1].int) >= 268435456 then
+ valtoobig(mem[p + 1].int);
+ if internal[2] > 0 then
+ if interesting(p) then begin
+ begindiagnostic;
+ printnl(461);
+ printvariablename(p);
+ printchar(61);
+ printscaled(mem[p + 1].int);
+ enddiagnostic(false)
+ end;
+ if curexp = p then
+ if curtype = t then begin
+ curtype := 16;
+ curexp := mem[p + 1].int;
+ freenode(p, 2)
+ end
+ end; {:603} {604:}
+
+ procedure fixdependencies;
+ label
+ 30;
+ var
+ p, q, r, s, t: halfword;
+ x: halfword;
+ begin
+ r := mem[-29987].hh.rh;
+ s := -30000;
+ while r <> (-29987) do begin
+ t := r;
+ {605:}
+ r := t + 1;
+ while true do begin
+ q := mem[r].hh.rh;
+ x := mem[q].hh.lh;
+ if x = (-30000) then
+ goto 30;
+ if mem[x].hh.b0 <= 1 then begin
+ if mem[x].hh.b0 < 1 then begin
+ p := getavail;
+ mem[p].hh.rh := s;
+ s := p;
+ mem[s].hh.lh := x;
+ mem[x].hh.b0 := 1
+ end;
+ mem[q + 1].int := mem[q + 1].int div 4;
+ if mem[q + 1].int = 0 then begin
+ mem[r].hh.rh := mem[q].hh.rh;
+ freenode(q, 2);
+ q := r
+ end
+ end;
+ r := q
+ end;
+ 30: {:605}
+ ;
+ r := mem[q].hh.rh;
+ if q = mem[t + 1].hh.rh then
+ makeknown(t, q)
+ end;
+ while s <> (-30000) do begin
+ p := mem[s].hh.rh;
+ x := mem[s].hh.lh;
+ begin
+ mem[s].hh.rh := avail;
+ avail := s
+ end {dynused:=dynused-1;};
+ s := p;
+ mem[x].hh.b0 := 19;
+ mem[x + 1].int := mem[x + 1].int + 2
+ end;
+ fixneeded := false
+ end; { fixdependencies }
+ {:604}
+ {268:}
+
+ procedure tossknotlist(p: halfword);
+ var
+ q: halfword;
+ r: halfword;
+ begin
+ q := p;
+ repeat
+ r := mem[q].hh.rh;
+ freenode(q, 7);
+ q := r
+ until q = p
+ end; {:268} {385:}
+
+ procedure tossedges(h: halfword);
+ var
+ p, q: halfword;
+ begin
+ q := mem[h].hh.rh;
+ while q <> h do begin
+ flushlist(mem[q + 1].hh.rh);
+ if mem[q + 1].hh.lh > (-29999) then
+ flushlist(mem[q + 1].hh.lh);
+ p := q;
+ q := mem[q].hh.rh;
+ freenode(p, 2)
+ end;
+ freenode(h, 6)
+ end; {:385} {487:}
+
+ procedure tosspen(p: halfword);
+ var
+ k: 1..8;
+ w, ww: halfword;
+ begin
+ if p <> (-29997) then begin
+ for k := 1 to 8 do begin
+ w := mem[p + k].hh.rh;
+ repeat
+ ww := mem[w].hh.rh;
+ freenode(w, 3);
+ w := ww
+ until w = mem[p + k].hh.rh
+ end;
+ freenode(p, 10)
+ end
+ end; {:487} {620:}
+
+ procedure ringdelete(p: halfword);
+ var
+ q: halfword;
+ begin
+ q := mem[p + 1].int;
+ if q <> (-30000) then
+ if q <> p then begin
+ while mem[q + 1].int <> p do
+ q := mem[q + 1].int;
+ mem[q + 1].int := mem[p + 1].int
+ end
+ end; {:620} {809:}
+
+ procedure recyclevalue(p: halfword);
+ label
+ 30;
+ var
+ t: smallnumber;
+ v: integer;
+ vv: integer;
+ q, r, s, pp: halfword;
+ begin
+ t := mem[p].hh.b0;
+ if t < 17 then
+ v := mem[p + 1].int;
+ case t of
+ 0, 1, 2, 16, 15:
+ ;
+ 3, 5, 7, 12, 10:
+ ringdelete(p);
+ 4:
+ begin
+ if strref[v] < 127 then
+ if strref[v] > 1 then
+ strref[v] := strref[v] - 1
+ else
+ flushstring(v)
+ end;
+ 6:
+ if mem[v].hh.lh = (-30000) then
+ tosspen(v)
+ else
+ mem[v].hh.lh := mem[v].hh.lh - 1;
+ 9, 8:
+ tossknotlist(v);
+ 11:
+ tossedges(v);
+ 14, 13: {810:}
+ if v <> (-30000) then begin
+ q := v + bignodesize[t];
+ repeat
+ q := q - 2;
+ recyclevalue(q)
+ until q = v;
+ freenode(v, bignodesize[t])
+ end {:810};
+ 17, 18:
+ begin {811:}
+ q := mem[p + 1].hh.rh;
+ while mem[q].hh.lh <> (-30000) do
+ q := mem[q].hh.rh;
+ mem[mem[p + 1].hh.lh].hh.rh := mem[q].hh.rh;
+ mem[mem[q].hh.rh + 1].hh.lh := mem[p + 1].hh.lh;
+ mem[q].hh.rh := -30000;
+ flushnodelist(mem[p + 1].hh.rh)
+ end; {:811}
+ 19:
+ begin {812:}
+ maxc[17] := 0;
+ maxc[18] := 0;
+ maxlink[17] := -30000;
+ maxlink[18] := -30000;
+ q := mem[-29987].hh.rh;
+ while q <> (-29987) do begin
+ s := q + 1;
+ while true do begin
+ r := mem[s].hh.rh;
+ if mem[r].hh.lh = (-30000) then
+ goto 30;
+ if mem[r].hh.lh <> p then
+ s := r
+ else begin
+ t := mem[q].hh.b0;
+ mem[s].hh.rh := mem[r].hh.rh;
+ mem[r].hh.lh := q;
+ if abs(mem[r + 1].int) > maxc[t] then begin {814:}
+ if maxc[t] > 0 then begin
+ mem[maxptr[t]].hh.rh := maxlink[t];
+ maxlink[t] := maxptr[t]
+ end;
+ maxc[t] := abs(mem[r + 1].int);
+ maxptr[t] := r
+ end else begin {:814}
+ mem[r].hh.rh := maxlink[t];
+ maxlink[t] := r
+ end
+ end
+ end;
+ 30:
+ q := mem[r].hh.rh
+ end;
+ if (maxc[17] > 0) or (maxc[18] > 0) then begin {815:}
+ if (maxc[17] >= 268435456) or ((maxc[17] div 4096) >= maxc[18]) then
+ t := 17
+ else
+ t := 18; {816:}
+ s := maxptr[t];
+ pp := mem[s].hh.lh;
+ v := mem[s + 1].int;
+ if t = 17 then
+ mem[s + 1].int := -268435456
+ else
+ mem[s + 1].int := -65536;
+ r := mem[pp + 1].hh.rh;
+ mem[s].hh.rh := r;
+ while mem[r].hh.lh <> (-30000) do
+ r := mem[r].hh.rh;
+ q := mem[r].hh.rh;
+ mem[r].hh.rh := -30000;
+ mem[q + 1].hh.lh := mem[pp + 1].hh.lh;
+ mem[mem[pp + 1].hh.lh].hh.rh := q;
+ begin
+ mem[pp].hh.b0 := 19;
+ serialno := serialno + 64;
+ mem[pp + 1].int := serialno
+ end;
+ if curexp = pp then
+ if curtype = t then
+ curtype := 19;
+ if internal[2] > 0 then {817:}
+ if interesting(p) then begin
+ begindiagnostic;
+ printnl(631);
+ if v > 0 then
+ printchar(45);
+ if t = 17 then
+ vv := roundfraction(maxc[17])
+ else
+ vv := maxc[18];
+ if vv <> 65536 then
+ printscaled(vv);
+ printvariablename(p);
+ while (mem[p + 1].int mod 64) > 0 do begin
+ print(455);
+ mem[p + 1].int := mem[p + 1].int - 2
+ end;
+ if t = 17 then
+ printchar(61)
+ else
+ print(632);
+ printdependency(s, t);
+ enddiagnostic(false)
+ end {:817} {:816};
+ t := 35 - t;
+ if maxc[t] > 0 then begin
+ mem[maxptr[t]].hh.rh := maxlink[t];
+ maxlink[t] := maxptr[t]
+ end;
+ if t <> 17 then {818:}
+ for t := 17 to 18 do begin
+ r := maxlink[t];
+ while r <> (-30000) do begin
+ q := mem[r].hh.lh;
+ mem[q + 1].hh.rh := pplusfq(mem[q + 1].hh.rh, makefraction(mem[r + 1].int, -v), s, t, 17);
+ if mem[q + 1].hh.rh = depfinal then
+ makeknown(q, depfinal);
+ q := r;
+ r := mem[r].hh.rh;
+ freenode(q, 2)
+ end
+ end {:818} {819:}
+ else
+ for t := 17 to 18 do begin
+ r := maxlink[t];
+ while r <> (-30000) do begin
+ q := mem[r].hh.lh;
+ if t = 17 then begin
+ if curexp = q then
+ if curtype = 17 then
+ curtype := 18;
+ mem[q + 1].hh.rh := poverv(mem[q + 1].hh.rh, 65536, 17, 18);
+ mem[q].hh.b0 := 18;
+ mem[r + 1].int := roundfraction(mem[r + 1].int)
+ end;
+ mem[q + 1].hh.rh := pplusfq(mem[q + 1].hh.rh, makescaled(mem[r + 1].int, -v), s, 18, 18);
+ if mem[q + 1].hh.rh = depfinal then
+ makeknown(q, depfinal);
+ q := r;
+ r := mem[r].hh.rh;
+ freenode(q, 2)
+ end
+ end {:819};
+ flushnodelist(s);
+ if fixneeded then
+ fixdependencies;
+ begin
+ if aritherror then
+ cleararith
+ end
+ end {:815}
+ end; {:812}
+ 20, 21:
+ confusion(630);
+ 22, 23:
+ deletemacref(mem[p + 1].int)
+ end;
+ mem[p].hh.b0 := 0
+ end; {:809} {808:}
+
+ procedure flushcurexp(v: scaled);
+ begin
+ if curtype in
+ [3, 5, 7, 12, 10, 13, 14, 17,
+ 18, 19, 6, 4, 8, 9, 11] then
+ case curtype of
+ 3, 5, 7, 12, 10, 13, 14,
+ 17, 18, 19:
+ begin
+ recyclevalue(curexp);
+ freenode(curexp, 2)
+ end;
+ 6:
+ if mem[curexp].hh.lh = (-30000) then
+ tosspen(curexp)
+ else
+ mem[curexp].hh.lh := mem[curexp].hh.lh - 1;
+ 4:
+ begin
+ if strref[curexp] < 127 then
+ if strref[curexp] > 1 then
+ strref[curexp] := strref[curexp] - 1
+ else
+ flushstring(curexp)
+ end;
+ 8, 9:
+ tossknotlist(curexp);
+ 11:
+ tossedges(curexp)
+ end
+ else
+ ;
+ curtype := 16;
+ curexp := v
+ end; {:808} {820:}
+
+ procedure flusherror(v: scaled);
+ begin
+ error;
+ flushcurexp(v)
+ end;
+
+ procedure backerror;
+ forward;
+
+ procedure getxnext;
+ forward;
+
+ procedure putgeterror;
+ begin
+ backerror;
+ getxnext
+ end; { putgeterror }
+
+ procedure putgetflusherror(v: scaled);
+ begin
+ putgeterror;
+ flushcurexp(v)
+ end; {:820} {247:}
+
+ procedure flushbelowvariable(p: halfword);
+ var
+ q, r: halfword;
+ begin
+ if mem[p].hh.b0 <> 21 then
+ recyclevalue(p)
+ else begin
+ q := mem[p + 1].hh.rh;
+ while mem[q].hh.b1 = 3 do begin
+ flushbelowvariable(q);
+ r := q;
+ q := mem[q].hh.rh;
+ freenode(r, 3)
+ end;
+ r := mem[p + 1].hh.lh;
+ q := mem[r].hh.rh;
+ recyclevalue(r);
+ if mem[p].hh.b1 <= 1 then
+ freenode(r, 2)
+ else
+ freenode(r, 3);
+ repeat
+ flushbelowvariable(q);
+ r := q;
+ q := mem[q].hh.rh;
+ freenode(r, 3)
+ until q = (-29983);
+ mem[p].hh.b0 := 0
+ end
+ end; {:247}
+
+ procedure flushvariable(p, t: halfword; discardsuffixes: boolean);
+ label
+ 10;
+ var
+ q, r: halfword;
+ n: halfword;
+ begin
+ while t <> (-30000) do begin
+ if mem[p].hh.b0 <> 21 then
+ goto 10;
+ n := mem[t].hh.lh;
+ t := mem[t].hh.rh;
+ if n = 0 then begin
+ r := p + 1;
+ q := mem[r].hh.rh;
+ while mem[q].hh.b1 = 3 do begin
+ flushvariable(q, t, discardsuffixes);
+ if t = (-30000) then
+ if mem[q].hh.b0 = 21 then
+ r := q
+ else begin
+ mem[r].hh.rh := mem[q].hh.rh;
+ freenode(q, 3)
+ end
+ else
+ r := q;
+ q := mem[r].hh.rh
+ end
+ end;
+ p := mem[p + 1].hh.lh;
+ repeat
+ r := p;
+ p := mem[p].hh.rh
+ until mem[p + 2].hh.lh >= n;
+ if mem[p + 2].hh.lh <> n then
+ goto 10
+ end;
+ if discardsuffixes then
+ flushbelowvariable(p)
+ else begin
+ if mem[p].hh.b0 = 21 then
+ p := mem[p + 1].hh.lh;
+ recyclevalue(p)
+ end;
+ 10:
+
+ end; {:246} {248:}
+
+ function undtype(p: halfword): smallnumber;
+ begin
+ case mem[p].hh.b0 of
+ 0, 1:
+ undtype := 0;
+ 2, 3:
+ undtype := 3;
+ 4, 5:
+ undtype := 5;
+ 6, 7, 8:
+ undtype := 7;
+ 9, 10:
+ undtype := 10;
+ 11, 12:
+ undtype := 12;
+ 13, 14, 15:
+ undtype := mem[p].hh.b0;
+ 16, 17, 18, 19:
+ undtype := 15
+ end
+ end; {:248}
+ {249:}
+
+ procedure clearsymbol(p: halfword; saving: boolean);
+ var
+ q: halfword;
+ begin
+ q := eqtb[p].rh;
+ if eqtb[p].lh mod 83 in
+ [10, 53, 44, 49, 41] then
+ case eqtb[p].lh mod 83 of
+ 10, 53, 44, 49:
+ if not saving then
+ deletemacref(q);
+ 41:
+ if q <> (-30000) then
+ if saving then
+ mem[q].hh.b1 := 1
+ else begin
+ flushbelowvariable(q);
+ freenode(q, 2)
+ end
+ end
+ else
+ ;
+ eqtb[p] := eqtb[2241]
+ end; {:249} {252:}
+
+ procedure savevariable(q: halfword);
+ var
+ p: halfword;
+ begin
+ if saveptr <> (-30000) then begin
+ p := getnode(2);
+ mem[p].hh.lh := q;
+ mem[p].hh.rh := saveptr;
+ mem[p + 1].hh := eqtb[q];
+ saveptr := p
+ end;
+ clearsymbol(q, saveptr <> (-30000))
+ end; {:252} {253:}
+
+ procedure saveinternal(q: halfword);
+ var
+ p: halfword;
+ begin
+ if saveptr <> (-30000) then begin
+ p := getnode(2);
+ mem[p].hh.lh := 2241 + q;
+ mem[p].hh.rh := saveptr;
+ mem[p + 1].int := internal[q];
+ saveptr := p
+ end
+ end; { saveinternal }
+ {:253}
+ {254:}
+
+ procedure unsave;
+ var
+ q: halfword;
+ p: halfword;
+ begin
+ while mem[saveptr].hh.lh <> 0 do begin
+ q := mem[saveptr].hh.lh;
+ if q > 2241 then begin
+ if internal[8] > 0 then begin
+ begindiagnostic;
+ printnl(383);
+ print(intname[q - 2241]);
+ printchar(61);
+ printscaled(mem[saveptr + 1].int);
+ printchar(125);
+ enddiagnostic(false)
+ end;
+ internal[q - 2241] := mem[saveptr + 1].int
+ end else begin
+ if internal[8] > 0 then begin
+ begindiagnostic;
+ printnl(383);
+ print(hash[q].rh);
+ printchar(125);
+ enddiagnostic(false)
+ end;
+ clearsymbol(q, false);
+ eqtb[q] := mem[saveptr + 1].hh;
+ if (eqtb[q].lh mod 83) = 41 then begin
+ p := eqtb[q].rh;
+ if p <> (-30000) then
+ mem[p].hh.b1 := 0
+ end
+ end;
+ p := mem[saveptr].hh.rh;
+ freenode(saveptr, 2);
+ saveptr := p
+ end;
+ p := mem[saveptr].hh.rh;
+ begin
+ mem[saveptr].hh.rh := avail;
+ avail := saveptr
+ end {dynused:=dynused-1;};
+ saveptr := p
+ end; {:254} {264:}
+
+ function copyknot(p: halfword): halfword;
+ var
+ q: halfword;
+ k: 0..6;
+ begin
+ q := getnode(7);
+ for k := 0 to 6 do
+ mem[q + k] := mem[p + k];
+ copyknot := q
+ end; {:264} {265:}
+
+ function copypath(p: halfword): halfword;
+ label
+ 10;
+ var
+ q, pp, qq: halfword;
+ begin
+ q := getnode(7);
+ qq := q;
+ pp := p;
+ while true do begin
+ mem[qq].hh.b0 := mem[pp].hh.b0;
+ mem[qq].hh.b1 := mem[pp].hh.b1;
+ mem[qq + 1].int := mem[pp + 1].int;
+ mem[qq + 2].int := mem[pp + 2].int;
+ mem[qq + 3].int := mem[pp + 3].int;
+ mem[qq + 4].int := mem[pp + 4].int;
+ mem[qq + 5].int := mem[pp + 5].int;
+ mem[qq + 6].int := mem[pp + 6].int;
+ if mem[pp].hh.rh = p then begin
+ mem[qq].hh.rh := q;
+ copypath := q;
+ goto 10
+ end;
+ mem[qq].hh.rh := getnode(7);
+ qq := mem[qq].hh.rh;
+ pp := mem[pp].hh.rh
+ end;
+ 10:
+
+ end; {:265} {266:}
+
+ function htapypoc(p: halfword): halfword;
+ label
+ 10;
+ var
+ q, pp, qq, rr: halfword;
+ begin
+ q := getnode(7);
+ qq := q;
+ pp := p;
+ while true do begin
+ mem[qq].hh.b1 := mem[pp].hh.b0;
+ mem[qq].hh.b0 := mem[pp].hh.b1;
+ mem[qq + 1].int := mem[pp + 1].int;
+ mem[qq + 2].int := mem[pp + 2].int;
+ mem[qq + 5].int := mem[pp + 3].int;
+ mem[qq + 6].int := mem[pp + 4].int;
+ mem[qq + 3].int := mem[pp + 5].int;
+ mem[qq + 4].int := mem[pp + 6].int;
+ if mem[pp].hh.rh = p then begin
+ mem[q].hh.rh := qq;
+ pathtail := pp;
+ htapypoc := q;
+ goto 10
+ end;
+ rr := getnode(7);
+ mem[rr].hh.rh := qq;
+ qq := rr;
+ pp := mem[pp].hh.rh
+ end;
+ 10:
+
+ end; {:266} {269:} {284:} {296:}
+
+ function curlratio(gamma, atension, btension: scaled): fraction;
+ var
+ alpha, beta, num, denom, ff: fraction;
+ begin
+ alpha := makefraction(65536, atension);
+ beta := makefraction(65536, btension);
+ if alpha <= beta then begin
+ ff := makefraction(alpha, beta);
+ ff := takefraction(ff, ff);
+ gamma := takefraction(gamma, ff);
+ beta := beta div 4096;
+ denom := (takefraction(gamma, alpha) + 196608) - beta;
+ num := takefraction(gamma, 805306368 - alpha) + beta
+ end else begin
+ ff := makefraction(beta, alpha);
+ ff := takefraction(ff, ff);
+ beta := takefraction(beta, ff) div 4096;
+ denom := (takefraction(gamma, alpha) + (ff div 1365)) - beta;
+ num := takefraction(gamma, 805306368 - alpha) + beta
+ end;
+ if num >= (((denom + denom) + denom) + denom) then
+ curlratio := 1073741824
+ else
+ curlratio := makefraction(num, denom)
+ end; {:296} {299:}
+
+ procedure setcontrols(p, q: halfword; k: integer);
+ var
+ rr, ss: fraction;
+ lt, rt: scaled;
+ sine: fraction;
+ begin
+ lt := abs(mem[q + 4].int);
+ rt := abs(mem[p + 6].int);
+ rr := velocity(st, ct, sf, cf, rt);
+ ss := velocity(sf, cf, st, ct, lt);
+ if (mem[p + 6].int < 0) or (mem[q + 4].int < 0) then {300:}
+ if ((st >= 0) and (sf >= 0)) or ((st <= 0) and (sf <= 0)) then begin
+ sine := takefraction(abs(st), cf) + takefraction(abs(sf), ct);
+ if sine > 0 then begin
+ sine := takefraction(sine, 268500992);
+ if mem[p + 6].int < 0 then
+ if abvscd(abs(sf), 268435456, rr, sine) < 0 then
+ rr := makefraction(abs(sf), sine);
+ if mem[q + 4].int < 0 then
+ if abvscd(abs(st), 268435456, ss, sine) < 0 then
+ ss := makefraction(abs(st), sine)
+ end
+ end {:300};
+ mem[p + 5].int := mem[p + 1].int + takefraction(takefraction(deltax[k], ct) - takefraction(deltay[k], st), rr);
+ mem[p + 6].int := mem[p + 2].int + takefraction(takefraction(deltay[k], ct) + takefraction(deltax[k], st), rr);
+ mem[q + 3].int := mem[q + 1].int - takefraction(takefraction(deltax[k], cf) + takefraction(deltay[k], sf), ss);
+ mem[q + 4].int := mem[q + 2].int - takefraction(takefraction(deltay[k], cf) - takefraction(deltax[k], sf), ss);
+ mem[p].hh.b1 := 1;
+ mem[q].hh.b0 := 1
+ end; { setcontrols }
+ {:299}
+
+ procedure solvechoices(p, q: halfword; n: halfword);
+ label
+ 40, 10;
+ var
+ k: 0..pathsize;
+ r, s, t: halfword;
+ sine, cosine: fraction; {286:}
+ aa, bb, cc, ff, acc: fraction;
+ dd, ee: scaled;
+ lt, rt: scaled; {:286}
+ begin
+ k := 0;
+ s := p;
+ while true do begin
+ t := mem[s].hh.rh;
+ if k = 0 then {285:}
+ case mem[s].hh.b1 of
+ 2:
+ if mem[t].hh.b0 = 2 then begin {301:}
+ aa := narg(deltax[0], deltay[0]);
+ nsincos(mem[p + 5].int - aa);
+ ct := ncos;
+ st := nsin;
+ nsincos(mem[q + 3].int - aa);
+ cf := ncos;
+ sf := -nsin;
+ setcontrols(p, q, 0);
+ goto 10
+ end else begin {:301} {293:}
+ vv[0] := mem[s + 5].int - narg(deltax[0], deltay[0]);
+ if abs(vv[0]) > 188743680 then
+ if vv[0] > 0 then
+ vv[0] := vv[0] - 377487360
+ else
+ vv[0] := vv[0] + 377487360;
+ uu[0] := 0;
+ ww[0] := 0
+ end {:293};
+ 3:
+ if mem[t].hh.b0 = 3 then begin {302:}
+ mem[p].hh.b1 := 1;
+ mem[q].hh.b0 := 1;
+ lt := abs(mem[q + 4].int);
+ rt := abs(mem[p + 6].int);
+ if rt = 65536 then begin
+ if deltax[0] >= 0 then
+ mem[p + 5].int := mem[p + 1].int + ((deltax[0] + 1) div 3)
+ else
+ mem[p + 5].int := mem[p + 1].int + ((deltax[0] - 1) div 3);
+ if deltay[0] >= 0 then
+ mem[p + 6].int := mem[p + 2].int + ((deltay[0] + 1) div 3)
+ else
+ mem[p + 6].int := mem[p + 2].int + ((deltay[0] - 1) div 3)
+ end else begin
+ ff := makefraction(65536, 3 * rt);
+ mem[p + 5].int := mem[p + 1].int + takefraction(deltax[0], ff);
+ mem[p + 6].int := mem[p + 2].int + takefraction(deltay[0], ff)
+ end;
+ if lt = 65536 then begin
+ if deltax[0] >= 0 then
+ mem[q + 3].int := mem[q + 1].int - ((deltax[0] + 1) div 3)
+ else
+ mem[q + 3].int := mem[q + 1].int - ((deltax[0] - 1) div 3);
+ if deltay[0] >= 0 then
+ mem[q + 4].int := mem[q + 2].int - ((deltay[0] + 1) div 3)
+ else
+ mem[q + 4].int := mem[q + 2].int - ((deltay[0] - 1) div 3)
+ end else begin
+ ff := makefraction(65536, 3 * lt);
+ mem[q + 3].int := mem[q + 1].int - takefraction(deltax[0], ff);
+ mem[q + 4].int := mem[q + 2].int - takefraction(deltay[0], ff)
+ end;
+ goto 10
+ end else begin {:302} {294:}
+ cc := mem[s + 5].int;
+ lt := abs(mem[t + 4].int);
+ rt := abs(mem[s + 6].int);
+ if (rt = 65536) and (lt = 65536) then
+ uu[0] := makefraction((cc + cc) + 65536, cc + 131072)
+ else
+ uu[0] := curlratio(cc, rt, lt);
+ vv[0] := -takefraction(psi[1], uu[0]);
+ ww[0] := 0
+ end {:294};
+ 4:
+ begin
+ uu[0] := 0;
+ vv[0] := 0;
+ ww[0] := 268435456
+ end
+ end {:285}
+ else
+ case mem[s].hh.b0 of
+ 5, 4:
+ begin {287:} {288:}
+ if abs(mem[r + 6].int) = 65536 then begin
+ aa := 134217728;
+ dd := 2 * delta[k]
+ end else begin
+ aa := makefraction(65536, (3 * abs(mem[r + 6].int)) - 65536);
+ dd := takefraction(delta[k], 805306368 - makefraction(65536, abs(mem[r + 6].int)))
+ end;
+ if abs(mem[t + 4].int) = 65536 then begin
+ bb := 134217728;
+ ee := 2 * delta[k - 1]
+ end else begin
+ bb := makefraction(65536, (3 * abs(mem[t + 4].int)) - 65536);
+ ee := takefraction(delta[k - 1], 805306368 - makefraction(65536, abs(mem[t + 4].int)))
+ end;
+ cc := 268435456 - takefraction(uu[k - 1], aa) {:288}; {289:}
+ dd := takefraction(dd, cc);
+ lt := abs(mem[s + 4].int);
+ rt := abs(mem[s + 6].int);
+ if lt <> rt then
+ if lt < rt then begin
+ ff := makefraction(lt, rt);
+ ff := takefraction(ff, ff);
+ dd := takefraction(dd, ff)
+ end else begin
+ ff := makefraction(rt, lt);
+ ff := takefraction(ff, ff);
+ ee := takefraction(ee, ff)
+ end;
+ ff := makefraction(ee, ee + dd) {:289};
+ uu[k] := takefraction(ff, bb); {290:}
+ acc := -takefraction(psi[k + 1], uu[k]);
+ if mem[r].hh.b1 = 3 then begin
+ ww[k] := 0;
+ vv[k] := acc - takefraction(psi[1], 268435456 - ff)
+ end else begin
+ ff := makefraction(268435456 - ff, cc);
+ acc := acc - takefraction(psi[k], ff);
+ ff := takefraction(ff, aa);
+ vv[k] := acc - takefraction(vv[k - 1], ff);
+ if ww[k - 1] = 0 then
+ ww[k] := 0
+ else
+ ww[k] := -takefraction(ww[k - 1], ff)
+ end {:290};
+ if mem[s].hh.b0 = 5 then begin {291:}
+ aa := 0;
+ bb := 268435456;
+ repeat
+ k := k - 1;
+ if k = 0 then
+ k := n;
+ aa := vv[k] - takefraction(aa, uu[k]);
+ bb := ww[k] - takefraction(bb, uu[k])
+ until k = n;
+ aa := makefraction(aa, 268435456 - bb);
+ theta[n] := aa;
+ vv[0] := aa;
+ for k := 1 to n - 1 do
+ vv[k] := vv[k] + takefraction(aa, ww[k]);
+ goto 40
+ end {:291}
+ end; {:287}
+ 3:
+ begin {295:}
+ cc := mem[s + 3].int;
+ lt := abs(mem[s + 4].int);
+ rt := abs(mem[r + 6].int);
+ if (rt = 65536) and (lt = 65536) then
+ ff := makefraction((cc + cc) + 65536, cc + 131072)
+ else
+ ff := curlratio(cc, lt, rt);
+ theta[n] := -makefraction(takefraction(vv[n - 1], ff), 268435456 - takefraction(ff, uu[n - 1]));
+ goto 40
+ end; {:295}
+ 2:
+ begin {292:}
+ theta[n] := mem[s + 3].int - narg(deltax[n - 1], deltay[n - 1]);
+ if abs(theta[n]) > 188743680 then
+ if theta[n] > 0 then
+ theta[n] := theta[n] - 377487360
+ else
+ theta[n] := theta[n] + 377487360;
+ goto 40
+ end
+ end {:292};
+ r := s;
+ s := t;
+ k := k + 1
+ end;
+ 40: {297:}
+ for k := n - 1 downto 0 do
+ theta[k] := vv[k] - takefraction(theta[k + 1], uu[k]);
+ s := p;
+ k := 0;
+ repeat
+ t := mem[s].hh.rh;
+ nsincos(theta[k]);
+ st := nsin;
+ ct := ncos;
+ nsincos((-psi[k + 1]) - theta[k + 1]);
+ sf := nsin;
+ cf := ncos;
+ setcontrols(s, t, k);
+ k := k + 1;
+ s := t
+ until k = n {:297};
+ 10:
+
+ end; {:284}
+
+ procedure makechoices(knots: halfword);
+ label
+ 30;
+ var
+ h: halfword;
+ p, q: halfword; {280:}
+ k, n: 0..pathsize;
+ r, s, t: halfword;
+ delx, dely: scaled;
+ sine, cosine: fraction; {:280}
+ begin
+ begin
+ if aritherror then
+ cleararith
+ end;
+ if internal[4] > 0 then
+ printpath(knots, 393, true); {271:}
+ p := knots;
+ repeat
+ q := mem[p].hh.rh;
+ if mem[p + 1].int = mem[q + 1].int then
+ if mem[p + 2].int = mem[q + 2].int then
+ if mem[p].hh.b1 > 1 then begin
+ mem[p].hh.b1 := 1;
+ if mem[p].hh.b0 = 4 then begin
+ mem[p].hh.b0 := 3;
+ mem[p + 3].int := 65536
+ end;
+ mem[q].hh.b0 := 1;
+ if mem[q].hh.b1 = 4 then begin
+ mem[q].hh.b1 := 3;
+ mem[q + 5].int := 65536
+ end;
+ mem[p + 5].int := mem[p + 1].int;
+ mem[q + 3].int := mem[p + 1].int;
+ mem[p + 6].int := mem[p + 2].int;
+ mem[q + 4].int := mem[p + 2].int
+ end;
+ p := q
+ until p = knots {:271}; {272:}
+ h := knots;
+ while true do begin
+ if mem[h].hh.b0 <> 4 then
+ goto 30;
+ if mem[h].hh.b1 <> 4 then
+ goto 30;
+ h := mem[h].hh.rh;
+ if h = knots then begin
+ mem[h].hh.b0 := 5;
+ goto 30
+ end
+ end;
+ 30: {:272}
+ ;
+ p := h; {273:}
+ repeat
+ q := mem[p].hh.rh;
+ if mem[p].hh.b1 >= 2 then begin
+ while (mem[q].hh.b0 = 4) and (mem[q].hh.b1 = 4) do
+ q := mem[q].hh.rh; {278:} {281:}
+ k := 0;
+ s := p;
+ n := pathsize;
+ repeat
+ t := mem[s].hh.rh;
+ deltax[k] := mem[t + 1].int - mem[s + 1].int;
+ deltay[k] := mem[t + 2].int - mem[s + 2].int;
+ delta[k] := pythadd(deltax[k], deltay[k]);
+ if k > 0 then begin
+ sine := makefraction(deltay[k - 1], delta[k - 1]);
+ cosine := makefraction(deltax[k - 1], delta[k - 1]);
+ psi[k] := narg(takefraction(deltax[k], cosine) + takefraction(deltay[k], sine), takefraction(deltay[k], cosine) - takefraction(deltax[k], sine))
+ end;
+ k := k + 1;
+ s := t;
+ if k = pathsize then
+ overflow(398, pathsize);
+ if s = q then
+ n := k
+ until (k >= n) and (mem[s].hh.b0 <> 5);
+ if k = n then
+ psi[n] := 0
+ else
+ psi[k] := psi[1] {:281}; {282:}
+ if mem[q].hh.b0 = 4 then begin
+ delx := mem[q + 5].int - mem[q + 1].int;
+ dely := mem[q + 6].int - mem[q + 2].int;
+ if (delx = 0) and (dely = 0) then begin
+ mem[q].hh.b0 := 3;
+ mem[q + 3].int := 65536
+ end else begin
+ mem[q].hh.b0 := 2;
+ mem[q + 3].int := narg(delx, dely)
+ end
+ end;
+ if (mem[p].hh.b1 = 4) and (mem[p].hh.b0 = 1) then begin
+ delx := mem[p + 1].int - mem[p + 3].int;
+ dely := mem[p + 2].int - mem[p + 4].int;
+ if (delx = 0) and (dely = 0) then begin
+ mem[p].hh.b1 := 3;
+ mem[p + 5].int := 65536
+ end else begin
+ mem[p].hh.b1 := 2;
+ mem[p + 5].int := narg(delx, dely)
+ end
+ end {:282};
+ solvechoices(p, q, n) {:278}
+ end;
+ p := q {:273}
+ until p = h;
+ if internal[4] > 0 then
+ printpath(knots, 394, true);
+ if aritherror then begin {270:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(395)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 396;
+ helpline[0] := 397
+ end;
+ putgeterror;
+ aritherror := false
+ end {:270}
+ end; {:269} {311:}
+
+ {-------------------------------------------------------------------
+ procedure makemoves(xx0, xx1, xx2, xx3, yy0, yy1, yy2, yy3: scaled; xicorr, etacorr: smallnumber);
+
+ moved to mf2ps3.p
+ -------------------------------------------------------------------}
+
+ procedure smoothmoves(b, t: integer);
+ var
+ k: 1..movesize;
+ a, aa, aaa: integer;
+ begin
+ if (t - b) >= 3 then begin
+ k := b + 2;
+ aa := move[k - 1];
+ aaa := move[k - 2];
+ repeat
+ a := move[k];
+ if abs(a - aa) > 1 then {322:}
+ if a > aa then begin
+ if aaa >= aa then
+ if a >= move[k + 1] then begin
+ move[k - 1] := move[k - 1] + 1;
+ move[k] := a - 1
+ end
+ end else begin
+ if aaa <= aa then
+ if a <= move[k + 1] then begin
+ move[k - 1] := move[k - 1] - 1;
+ move[k] := a + 1
+ end
+ end {:322};
+ k := k + 1;
+ aaa := aa;
+ aa := a
+ until k = t
+ end
+ end; {:321} {326:}
+
+ procedure initedges(h: halfword);
+ begin
+ mem[h].hh.lh := h;
+ mem[h].hh.rh := h;
+ mem[h + 1].hh.lh := 8191;
+ mem[h + 1].hh.rh := 1;
+ mem[h + 2].hh.lh := 8191;
+ mem[h + 2].hh.rh := 1;
+ mem[h + 3].hh.lh := 4096;
+ mem[h + 3].hh.rh := 0;
+ mem[h + 4].int := 0;
+ mem[h + 5].hh.rh := h;
+ mem[h + 5].hh.lh := 0
+ end; {:326} {328:}
+
+ procedure fixoffset;
+ var
+ p, q: halfword;
+ delta: integer;
+ begin
+ delta := 8 * (mem[curedges + 3].hh.lh - 4096);
+ mem[curedges + 3].hh.lh := 4096;
+ q := mem[curedges].hh.rh;
+ while q <> curedges do begin
+ p := mem[q + 1].hh.rh;
+ while p <> 30000 do begin
+ mem[p].hh.lh := mem[p].hh.lh - delta;
+ p := mem[p].hh.rh
+ end;
+ p := mem[q + 1].hh.lh;
+ while p > (-29999) do begin
+ mem[p].hh.lh := mem[p].hh.lh - delta;
+ p := mem[p].hh.rh
+ end;
+ q := mem[q].hh.rh
+ end
+ end; {:328} {329:}
+
+ procedure edgeprep(ml, mr, nl, nr: integer);
+ var
+ delta: halfword;
+ p, q: halfword;
+ begin
+ ml := ml + 4096;
+ mr := mr + 4096;
+ nl := nl + 4096;
+ nr := nr + 4095;
+ if ml < mem[curedges + 2].hh.lh then
+ mem[curedges + 2].hh.lh := ml;
+ if mr > mem[curedges + 2].hh.rh then
+ mem[curedges + 2].hh.rh := mr;
+ if (not (abs((mem[curedges + 2].hh.lh + mem[curedges + 3].hh.lh) - 8192) < 4096)) or (not (abs((mem[curedges + 2].hh.rh + mem[curedges + 3].hh.lh) - 8192) < 4096)) then
+ fixoffset;
+ if mem[curedges].hh.rh = curedges then begin
+ mem[curedges + 1].hh.lh := nr + 1;
+ mem[curedges + 1].hh.rh := nr
+ end;
+ if nl < mem[curedges + 1].hh.lh then begin {330:}
+ delta := mem[curedges + 1].hh.lh - nl;
+ mem[curedges + 1].hh.lh := nl;
+ p := mem[curedges].hh.rh;
+ repeat
+ q := getnode(2);
+ mem[q + 1].hh.rh := 30000;
+ mem[q + 1].hh.lh := -29999;
+ mem[p].hh.lh := q;
+ mem[q].hh.rh := p;
+ p := q;
+ delta := delta - 1
+ until delta = 0;
+ mem[p].hh.lh := curedges;
+ mem[curedges].hh.rh := p;
+ if mem[curedges + 5].hh.rh = curedges then
+ mem[curedges + 5].hh.lh := nl - 1
+ end {:330};
+ if nr > mem[curedges + 1].hh.rh then begin {331:}
+ delta := nr - mem[curedges + 1].hh.rh;
+ mem[curedges + 1].hh.rh := nr;
+ p := mem[curedges].hh.lh;
+ repeat
+ q := getnode(2);
+ mem[q + 1].hh.rh := 30000;
+ mem[q + 1].hh.lh := -29999;
+ mem[p].hh.rh := q;
+ mem[q].hh.lh := p;
+ p := q;
+ delta := delta - 1
+ until delta = 0;
+ mem[p].hh.rh := curedges;
+ mem[curedges].hh.lh := p;
+ if mem[curedges + 5].hh.rh = curedges then
+ mem[curedges + 5].hh.lh := nr + 1
+ end {:331}
+ end; {:329} {334:}
+
+ function copyedges(h: halfword): halfword;
+ var
+ p, r: halfword;
+ hh, pp, qq, rr, ss: halfword;
+ begin
+ hh := getnode(6);
+ mem[hh + 1] := mem[h + 1];
+ mem[hh + 2] := mem[h + 2];
+ mem[hh + 3] := mem[h + 3];
+ mem[hh + 4] := mem[h + 4];
+ mem[hh + 5].hh.lh := mem[hh + 1].hh.rh + 1;
+ mem[hh + 5].hh.rh := hh;
+ p := mem[h].hh.rh;
+ qq := hh;
+ while p <> h do begin
+ pp := getnode(2);
+ mem[qq].hh.rh := pp;
+ mem[pp].hh.lh := qq;
+ {335:}
+ r := mem[p + 1].hh.rh;
+ rr := pp + 1;
+ while r <> 30000 do begin
+ ss := getavail;
+ mem[rr].hh.rh := ss;
+ rr := ss;
+ mem[rr].hh.lh := mem[r].hh.lh;
+ r := mem[r].hh.rh
+ end;
+ mem[rr].hh.rh := 30000;
+ r := mem[p + 1].hh.lh;
+ rr := 29999;
+ while r > (-29999) do begin
+ ss := getavail;
+ mem[rr].hh.rh := ss;
+ rr := ss;
+ mem[rr].hh.lh := mem[r].hh.lh;
+ r := mem[r].hh.rh
+ end;
+ mem[rr].hh.rh := r;
+ mem[pp + 1].hh.lh := mem[29999].hh.rh {:335};
+ p := mem[p].hh.rh;
+ qq := pp
+ end;
+ mem[qq].hh.rh := hh;
+ mem[hh].hh.lh := qq;
+ copyedges := hh
+ end; {:334} {336:}
+
+ procedure yreflectedges;
+ var
+ p, q, r: halfword;
+ begin
+ p := mem[curedges + 1].hh.lh;
+ mem[curedges + 1].hh.lh := 8191 - mem[curedges + 1].hh.rh;
+ mem[curedges + 1].hh.rh := 8191 - p;
+ mem[curedges + 5].hh.lh := 8191 - mem[curedges + 5].hh.lh;
+ p := mem[curedges].hh.rh;
+ q := curedges;
+ repeat
+ r := mem[p].hh.rh;
+ mem[p].hh.rh := q;
+ mem[q].hh.lh := p;
+ q := p;
+ p := r
+ until q = curedges;
+ mem[curedges + 4].int := 0
+ end; {:336} {337:}
+
+ procedure xreflectedges;
+ var
+ p, q, r, s: halfword;
+ m: integer;
+ begin
+ p := mem[curedges + 2].hh.lh;
+ mem[curedges + 2].hh.lh := 8192 - mem[curedges + 2].hh.rh;
+ mem[curedges + 2].hh.rh := 8192 - p;
+ m := ((4096 + mem[curedges + 3].hh.lh) * 8) - 65528;
+ mem[curedges + 3].hh.lh := 4096;
+ p := mem[curedges].hh.rh; {339:}
+ repeat
+ q := mem[p + 1].hh.rh;
+ r := 30000;
+ while q <> 30000 do begin
+ s := mem[q].hh.rh;
+ mem[q].hh.rh := r;
+ r := q;
+ mem[r].hh.lh := m - mem[q].hh.lh;
+ q := s
+ end;
+ mem[p + 1].hh.rh := r {:339}; {338:}
+ q := mem[p + 1].hh.lh;
+ while q > (-29999) do begin
+ mem[q].hh.lh := m - mem[q].hh.lh;
+ q := mem[q].hh.rh
+ end {:338};
+ p := mem[p].hh.rh
+ until p = curedges;
+ mem[curedges + 4].int := 0
+ end; { xreflectedges }
+ {:337}
+ {340:}
+
+ procedure yscaleedges(s: integer);
+ var
+ p, q, pp, r, rr, ss: halfword;
+ t: integer;
+ begin
+ if ((s * (mem[curedges + 1].hh.rh - 4095)) >= 4096) or ((s * (mem[curedges + 1].hh.lh - 4096)) <= (-4096)) then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(402)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 403;
+ helpline[1] := 404;
+ helpline[0] := 405
+ end;
+ putgeterror
+ end else begin
+ mem[curedges + 1].hh.rh := (s * (mem[curedges + 1].hh.rh - 4095)) + 4095;
+ mem[curedges + 1].hh.lh := (s * (mem[curedges + 1].hh.lh - 4096)) + 4096; {341:}
+ p := curedges;
+ repeat
+ q := p;
+ p := mem[p].hh.rh;
+ for t := 2 to s do begin
+ pp := getnode(2);
+ mem[q].hh.rh := pp;
+ mem[p].hh.lh := pp;
+ mem[pp].hh.rh := p;
+ mem[pp].hh.lh := q;
+ q := pp; {335:}
+ r := mem[p + 1].hh.rh;
+ rr := pp + 1;
+ while r <> 30000 do begin
+ ss := getavail;
+ mem[rr].hh.rh := ss;
+ rr := ss;
+ mem[rr].hh.lh := mem[r].hh.lh;
+ r := mem[r].hh.rh
+ end;
+ mem[rr].hh.rh := 30000;
+ r := mem[p + 1].hh.lh;
+ rr := 29999;
+ while r > (-29999) do begin
+ ss := getavail;
+ mem[rr].hh.rh := ss;
+ rr := ss;
+ mem[rr].hh.lh := mem[r].hh.lh;
+ r := mem[r].hh.rh
+ end;
+ mem[rr].hh.rh := r;
+ mem[pp + 1].hh.lh := mem[29999].hh.rh {:335}
+ end
+ until mem[p].hh.rh = curedges {:341};
+ mem[curedges + 4].int := 0
+ end
+ end; {:340}
+ {342:}
+
+ procedure xscaleedges(s: integer);
+ var
+ p, q: halfword;
+ t: 0..65535;
+ w: 0..7;
+ delta: integer;
+ begin
+ if ((s * (mem[curedges + 2].hh.rh - 4096)) >= 4096) or ((s * (mem[curedges + 2].hh.lh - 4096)) <= (-4096)) then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(402)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 406;
+ helpline[1] := 404;
+ helpline[0] := 405
+ end;
+ putgeterror
+ end else if (mem[curedges + 2].hh.rh <> 4096) or (mem[curedges + 2].hh.lh <> 4096) then begin
+ mem[curedges + 2].hh.rh := (s * (mem[curedges + 2].hh.rh - 4096)) + 4096;
+ mem[curedges + 2].hh.lh := (s * (mem[curedges + 2].hh.lh - 4096)) + 4096;
+ delta := (8 * (4096 - (s * mem[curedges + 3].hh.lh))) - 32768;
+ mem[curedges + 3].hh.lh := 4096; {343:}
+ q := mem[curedges].hh.rh;
+ repeat
+ p := mem[q + 1].hh.rh;
+ while p <> 30000 do begin
+ t := mem[p].hh.lh + 32768;
+ w := t mod 8;
+ mem[p].hh.lh := (((t - w) * s) + w) + delta;
+ p := mem[p].hh.rh
+ end;
+ p := mem[q + 1].hh.lh;
+ while p > (-29999) do begin
+ t := mem[p].hh.lh + 32768;
+ w := t mod 8;
+ mem[p].hh.lh := (((t - w) * s) + w) + delta;
+ p := mem[p].hh.rh
+ end;
+ q := mem[q].hh.rh
+ until q = curedges {:343};
+ mem[curedges + 4].int := 0
+ end
+ end; { xscaleedges }
+ {:342}
+ {344:}
+
+ procedure negateedges(h: halfword);
+ label
+ 30;
+ var
+ p, q, r, s, t, u: halfword;
+ begin
+ p := mem[h].hh.rh;
+ while p <> h do begin
+ q := mem[p + 1].hh.lh;
+ while q > (-29999) do begin
+ mem[q].hh.lh := (8 - (2 * ((mem[q].hh.lh + 32768) mod 8))) + mem[q].hh.lh;
+ q := mem[q].hh.rh
+ end;
+ q := mem[p + 1].hh.rh;
+ if q <> 30000 then begin
+ repeat
+ mem[q].hh.lh := (8 - (2 * ((mem[q].hh.lh + 32768) mod 8))) + mem[q].hh.lh;
+ q := mem[q].hh.rh
+ until q = 30000; {345:}
+ u := p + 1;
+ q := mem[u].hh.rh;
+ r := q;
+ s := mem[r].hh.rh;
+ while true do
+ if mem[s].hh.lh > mem[r].hh.lh then begin
+ mem[u].hh.rh := q;
+ if s = 30000 then
+ goto 30;
+ u := r;
+ q := s;
+ r := q;
+ s := mem[r].hh.rh
+ end else begin
+ t := s;
+ s := mem[t].hh.rh;
+ mem[t].hh.rh := q;
+ q := t
+ end;
+ 30:
+ mem[r].hh.rh := 30000 {:345}
+ end;
+ p := mem[p].hh.rh
+ end;
+ mem[h + 4].int := 0
+ end; {:344} {346:}
+
+ procedure sortedges(h: halfword);
+ label
+ 30;
+ var
+ k: halfword;
+ p, q, r, s: halfword;
+ begin
+ r := mem[h + 1].hh.lh;
+ mem[h + 1].hh.lh := -30000;
+ p := mem[r].hh.rh;
+ mem[r].hh.rh := 30000;
+ mem[29999].hh.rh := r;
+ while p > (-29999) do begin
+ k := mem[p].hh.lh;
+ q := 29999;
+ repeat
+ r := q;
+ q := mem[r].hh.rh
+ until k <= mem[q].hh.lh;
+ mem[r].hh.rh := p;
+ r := mem[p].hh.rh;
+ mem[p].hh.rh := q;
+ p := r
+ end; {347:}
+ begin
+ r := h + 1;
+ q := mem[r].hh.rh;
+ p := mem[29999].hh.rh;
+ while true do begin
+ k := mem[p].hh.lh;
+ while k > mem[q].hh.lh do begin
+ r := q;
+ q := mem[r].hh.rh
+ end;
+ mem[r].hh.rh := p;
+ s := mem[p].hh.rh;
+ mem[p].hh.rh := q;
+ if s = 30000 then
+ goto 30;
+ r := p;
+ p := s
+ end;
+ 30: {:347}
+
+ end
+ end; {:346} {348:}
+
+ procedure culledges(wlo, whi, wout, win: integer);
+ label
+ 30;
+ var
+ p, q, r, s: halfword;
+ w: integer;
+ d: integer;
+ m: integer;
+ mm: integer;
+ ww: integer;
+ prevw: integer;
+ n, minn, maxn: halfword;
+ mind, maxd: halfword;
+ begin
+ mind := 32767;
+ maxd := -32768;
+ minn := 32767;
+ maxn := -32768;
+ p := mem[curedges].hh.rh;
+ n := mem[curedges + 1].hh.lh;
+ while p <> curedges do begin
+ if mem[p + 1].hh.lh > (-29999) then
+ sortedges(p);
+ if mem[p + 1].hh.rh <> 30000 then begin {349:}
+ r := 29999;
+ q := mem[p + 1].hh.rh;
+ ww := 0;
+ m := 1000000;
+ prevw := 0;
+ while true do begin
+ if q = 30000 then
+ mm := 1000000
+ else begin
+ d := mem[q].hh.lh + 32768;
+ mm := d div 8;
+ ww := (ww + (d mod 8)) - 4
+ end;
+ if mm > m then begin {350:}
+ if w <> prevw then begin
+ s := getavail;
+ mem[r].hh.rh := s;
+ mem[s].hh.lh := (((8 * m) - 32764) + w) - prevw;
+ r := s;
+ prevw := w
+ end {:350};
+ if q = 30000 then
+ goto 30
+ end;
+ m := mm;
+ if ww >= wlo then
+ if ww <= whi then
+ w := win
+ else
+ w := wout
+ else
+ w := wout;
+ s := mem[q].hh.rh;
+ begin
+ mem[q].hh.rh := avail;
+ avail := q
+ end {dynused:=dynused-1;};
+ q := s
+ end;
+ 30:
+ mem[r].hh.rh := 30000;
+ mem[p + 1].hh.rh := mem[29999].hh.rh;
+ if r <> 29999 then begin {351:}
+ if minn = 32767 then
+ minn := n;
+ maxn := n;
+ if mind > mem[mem[29999].hh.rh].hh.lh then
+ mind := mem[mem[29999].hh.rh].hh.lh;
+ if maxd < mem[r].hh.lh then
+ maxd := mem[r].hh.lh
+ end {:351}
+ end {:349};
+ p := mem[p].hh.rh;
+ n := n + 1
+ end; {352:}
+ if minn > maxn then begin {353:}
+ p := mem[curedges].hh.rh;
+ while p <> curedges do begin
+ q := mem[p].hh.rh;
+ freenode(p, 2);
+ p := q
+ end;
+ initedges(curedges)
+ end else begin {:353}
+ n := mem[curedges + 1].hh.lh;
+ mem[curedges + 1].hh.lh := minn;
+ while minn > n do begin
+ p := mem[curedges].hh.rh;
+ mem[curedges].hh.rh := mem[p].hh.rh;
+ mem[mem[p].hh.rh].hh.lh := curedges;
+ freenode(p, 2);
+ n := n + 1
+ end;
+ n := mem[curedges + 1].hh.rh;
+ mem[curedges + 1].hh.rh := maxn;
+ mem[curedges + 5].hh.lh := maxn + 1;
+ mem[curedges + 5].hh.rh := curedges;
+ while maxn < n do begin
+ p := mem[curedges].hh.lh;
+ mem[curedges].hh.lh := mem[p].hh.lh;
+ mem[mem[p].hh.lh].hh.rh := curedges;
+ freenode(p, 2);
+ n := n - 1
+ end;
+ mem[curedges + 2].hh.lh := (((mind + 32768) div 8) - mem[curedges + 3].hh.lh) + 4096;
+ mem[curedges + 2].hh.rh := (((maxd + 32768) div 8) - mem[curedges + 3].hh.lh) + 4096
+ end {:352};
+ mem[curedges + 4].int := 0
+ end; {:348} {354:}
+
+ procedure xyswapedges;
+ label
+ 30;
+ var
+ mmagic, nmagic: integer;
+ p, q, r, s: halfword; {357:}
+ mspread: integer;
+ j, jj: 0..movesize;
+ m, mm: integer;
+ pd, rd: integer;
+ pm, rm: integer;
+ w: integer;
+ ww: integer;
+ dw: integer; {:357} {363:}
+ extras: integer;
+ xw: -3..3;
+ k: integer; {:363} {356:}
+ begin
+ mspread := mem[curedges + 2].hh.rh - mem[curedges + 2].hh.lh;
+ if mspread > movesize then
+ overflow(407, movesize);
+ for j := 0 to mspread do
+ move[j] := 30000 {:356}; {355:}
+ p := getnode(2);
+ mem[p + 1].hh.rh := 30000;
+ mem[p + 1].hh.lh := -30000;
+ mem[p].hh.lh := curedges;
+ mem[mem[curedges].hh.rh].hh.lh := p;
+ p := getnode(2);
+ mem[p + 1].hh.rh := 30000;
+ mem[p].hh.lh := mem[curedges].hh.lh; {:355} {365:}
+ mmagic := (mem[curedges + 2].hh.lh + mem[curedges + 3].hh.lh) - 4096;
+ nmagic := (8 * mem[curedges + 1].hh.rh) - 32756 {:365};
+ repeat
+ q := mem[p].hh.lh;
+ if mem[q + 1].hh.lh > (-29999) then
+ sortedges(q); {358:}
+ r := mem[p + 1].hh.rh;
+ freenode(p, 2);
+ p := r;
+ pd := mem[p].hh.lh + 32768;
+ pm := pd div 8;
+ r := mem[q + 1].hh.rh;
+ rd := mem[r].hh.lh + 32768;
+ rm := rd div 8;
+ w := 0;
+ while true do begin
+ if pm < rm then
+ mm := pm
+ else
+ mm := rm;
+ if w <> 0 then {362:}
+ if m <> mm then begin
+ if (mm - mmagic) >= movesize then
+ confusion(377);
+ extras := (abs(w) - 1) div 3;
+ if extras > 0 then begin
+ if w > 0 then
+ xw := +3
+ else
+ xw := -3;
+ ww := w - (extras * xw)
+ end else
+ ww := w;
+ repeat
+ j := m - mmagic;
+ for k := 1 to extras do begin
+ s := getavail;
+ mem[s].hh.lh := nmagic + xw;
+ mem[s].hh.rh := move[j];
+ move[j] := s
+ end;
+ s := getavail;
+ mem[s].hh.lh := nmagic + ww;
+ mem[s].hh.rh := move[j];
+ move[j] := s;
+ m := m + 1
+ until m = mm
+ end {:362};
+ if pd < rd then begin
+ dw := (pd mod 8) - 4; {360:}
+ s := mem[p].hh.rh;
+ begin
+ mem[p].hh.rh := avail;
+ avail := p
+ end {dynused:=dynused-1;};
+ p := s;
+ pd := mem[p].hh.lh + 32768;
+ pm := pd div 8 {:360}
+ end else begin
+ if r = 30000 then
+ goto 30;
+ dw := -((rd mod 8) - 4); {359:}
+ r := mem[r].hh.rh;
+ rd := mem[r].hh.lh + 32768;
+ rm := rd div 8 {:359}
+ end;
+ m := mm;
+ w := w + dw
+ end;
+ 30: {:358}
+ ;
+ p := q;
+ nmagic := nmagic - 8
+ until mem[p].hh.lh = curedges;
+ freenode(p, 2); {364:}
+ move[mspread] := 0;
+ j := 0;
+ while move[j] = 30000 do
+ j := j + 1;
+ if j = mspread then
+ initedges(curedges)
+ else begin
+ mm := mem[curedges + 2].hh.lh;
+ mem[curedges + 2].hh.lh := mem[curedges + 1].hh.lh;
+ mem[curedges + 2].hh.rh := mem[curedges + 1].hh.rh + 1;
+ mem[curedges + 3].hh.lh := 4096;
+ jj := mspread - 1;
+ while move[jj] = 30000 do
+ jj := jj - 1;
+ mem[curedges + 1].hh.lh := j + mm;
+ mem[curedges + 1].hh.rh := jj + mm;
+ q := curedges;
+ repeat
+ p := getnode(2);
+ mem[q].hh.rh := p;
+ mem[p].hh.lh := q;
+ mem[p + 1].hh.rh := move[j];
+ mem[p + 1].hh.lh := -30000;
+ j := j + 1;
+ q := p
+ until j > jj;
+ mem[q].hh.rh := curedges;
+ mem[curedges].hh.lh := q;
+ mem[curedges + 5].hh.lh := mem[curedges + 1].hh.rh + 1;
+ mem[curedges + 5].hh.rh := curedges;
+ mem[curedges + 4].int := 0
+ end
+ end; {:364}
+ {:354}
+ {366:}
+
+ procedure mergeedges(h: halfword);
+ label
+ 30;
+ var
+ p, q, r, pp, qq, rr: halfword;
+ n: integer;
+ k: halfword;
+ delta: integer;
+ begin
+ if mem[h].hh.rh <> h then begin
+ if (((mem[h + 2].hh.lh < mem[curedges + 2].hh.lh) or (mem[h + 2].hh.rh > mem[curedges + 2].hh.rh)) or (mem[h + 1].hh.lh < mem[curedges + 1].hh.lh)) or (mem[h + 1].hh.rh > mem[curedges + 1].hh.rh) then
+ edgeprep(mem[h + 2].hh.lh - 4096, mem[h + 2].hh.rh - 4096, mem[h + 1].hh.lh - 4096, mem[h + 1].hh.rh - 4095);
+ if mem[h + 3].hh.lh <> mem[curedges + 3].hh.lh then begin {367:}
+ pp := mem[h].hh.rh;
+ delta := 8 * (mem[curedges + 3].hh.lh - mem[h + 3].hh.lh);
+ repeat
+ qq := mem[pp + 1].hh.rh;
+ while qq <> 30000 do begin
+ mem[qq].hh.lh := mem[qq].hh.lh + delta;
+ qq := mem[qq].hh.rh
+ end;
+ qq := mem[pp + 1].hh.lh;
+ while qq > (-29999) do begin
+ mem[qq].hh.lh := mem[qq].hh.lh + delta;
+ qq := mem[qq].hh.rh
+ end;
+ pp := mem[pp].hh.rh
+ until pp = h
+ end {:367};
+ n := mem[curedges + 1].hh.lh;
+ p := mem[curedges].hh.rh;
+ pp := mem[h].hh.rh;
+ while n < mem[h + 1].hh.lh do begin
+ n := n + 1;
+ p := mem[p].hh.rh
+ end; {368:}
+ repeat
+ qq := mem[pp + 1].hh.lh;
+ if qq > (-29999) then
+ if mem[p + 1].hh.lh <= (-29999) then
+ mem[p + 1].hh.lh := qq
+ else begin
+ while mem[qq].hh.rh > (-29999) do
+ qq := mem[qq].hh.rh;
+ mem[qq].hh.rh := mem[p + 1].hh.lh;
+ mem[p + 1].hh.lh := mem[pp + 1].hh.lh
+ end;
+ mem[pp + 1].hh.lh := -30000;
+ qq := mem[pp + 1].hh.rh;
+ if qq <> 30000 then begin
+ if mem[p + 1].hh.lh = (-29999) then
+ mem[p + 1].hh.lh := -30000;
+ mem[pp + 1].hh.rh := 30000;
+ r := p + 1;
+ q := mem[r].hh.rh;
+ if q = 30000 then
+ mem[p + 1].hh.rh := qq
+ else
+ while true do begin
+ k := mem[qq].hh.lh;
+ while k > mem[q].hh.lh do begin
+ r := q;
+ q := mem[r].hh.rh
+ end;
+ mem[r].hh.rh := qq;
+ rr := mem[qq].hh.rh;
+ mem[qq].hh.rh := q;
+ if rr = 30000 then
+ goto 30;
+ r := qq;
+ qq := rr
+ end
+ end;
+ 30: {:368}
+ ;
+ pp := mem[pp].hh.rh;
+ p := mem[p].hh.rh
+ until pp = h
+ end
+ end; {:366} {369:}
+
+ function totalweight(h: halfword): integer;
+ var
+ p, q: halfword;
+ n: integer;
+ m: 0..65535;
+ begin
+ n := 0;
+ p := mem[h].hh.rh;
+ while p <> h do begin
+ q := mem[p + 1].hh.rh;
+ while q <> 30000 do begin {370:}
+ m := mem[q].hh.lh + 32768;
+ n := n - (((m mod 8) - 4) * (m div 8));
+ q := mem[q].hh.rh
+ end {:370};
+ q := mem[p + 1].hh.lh;
+ while q > (-29999) do begin {370:}
+ m := mem[q].hh.lh + 32768;
+ n := n - (((m mod 8) - 4) * (m div 8));
+ q := mem[q].hh.rh
+ end {:370};
+ p := mem[p].hh.rh
+ end;
+ totalweight := n
+ end; {:369}
+ {372:}
+
+ procedure beginedgetracing;
+ begin
+ printdiagnostic(408, 155, true);
+ print(409);
+ printint(curwt);
+ printchar(41);
+ tracex := -4096
+ end; { beginedgetracing }
+
+ procedure traceacorner;
+ begin
+ if fileoffset > (maxprintline - 13) then
+ printnl(155);
+ printchar(40);
+ printint(tracex);
+ printchar(44);
+ printint(traceyy);
+ printchar(41);
+ tracey := traceyy
+ end;
+
+ procedure endedgetracing;
+ begin
+ if tracex = (-4096) then
+ printnl(410)
+ else begin
+ traceacorner;
+ printchar(46)
+ end;
+ enddiagnostic(true)
+ end; {:372} {373:}
+
+ procedure tracenewedge(r: halfword; n: integer);
+ var
+ d: integer;
+ w: -3..3;
+ m, n0, n1: integer;
+ begin
+ d := mem[r].hh.lh + 32768;
+ w := (d mod 8) - 4;
+ m := (d div 8) - mem[curedges + 3].hh.lh;
+ if w = curwt then begin
+ n0 := n + 1;
+ n1 := n
+ end else begin
+ n0 := n;
+ n1 := n + 1
+ end;
+ if m <> tracex then begin
+ if tracex = (-4096) then begin
+ printnl(155);
+ traceyy := n0
+ end else if traceyy <> n0 then
+ printchar(63)
+ else
+ traceacorner;
+ tracex := m;
+ traceacorner
+ end else begin
+ if n0 <> traceyy then
+ printchar(33);
+ if ((n0 < n1) and (tracey > traceyy)) or ((n0 > n1) and (tracey < traceyy)) then
+ traceacorner
+ end;
+ traceyy := n1
+ end; {:373} {374:}
+
+ procedure lineedges(x0, y0, x1, y1: scaled);
+ label
+ 30, 31;
+ var
+ m0, n0, m1, n1: integer;
+ delx, dely: scaled;
+ yt: scaled;
+ tx: scaled;
+ p, r: halfword;
+ base: integer;
+ n: integer;
+ begin
+ n0 := roundunscaled(y0);
+ n1 := roundunscaled(y1);
+ if n0 <> n1 then begin
+ m0 := roundunscaled(x0);
+ m1 := roundunscaled(x1);
+ delx := x1 - x0;
+ dely := y1 - y0;
+ yt := (n0 * 65536) - 32768;
+ y0 := y0 - yt;
+ y1 := y1 - yt;
+ if n0 < n1 then begin {375:}
+ base := ((8 * mem[curedges + 3].hh.lh) - 32764) - curwt;
+ if m0 <= m1 then
+ edgeprep(m0, m1, n0, n1)
+ else
+ edgeprep(m1, m0, n0, n1); {377:}
+ n := mem[curedges + 5].hh.lh - 4096;
+ p := mem[curedges + 5].hh.rh;
+ if n <> n0 then
+ if n < n0 then
+ repeat
+ n := n + 1;
+ p := mem[p].hh.rh
+ until n = n0
+ else
+ repeat
+ n := n - 1;
+ p := mem[p].hh.lh
+ until n = n0 {:377};
+ y0 := 65536 - y0;
+ while true do begin
+ r := getavail;
+ mem[r].hh.rh := mem[p + 1].hh.lh;
+ mem[p + 1].hh.lh := r;
+ tx := takefraction(delx, makefraction(y0, dely));
+ if abvscd(delx, y0, dely, tx) < 0 then
+ tx := tx - 1;
+ mem[r].hh.lh := (8 * roundunscaled(x0 + tx)) + base;
+ y1 := y1 - 65536;
+ if internal[10] > 0 then
+ tracenewedge(r, n);
+ if y1 < 65536 then
+ goto 30;
+ p := mem[p].hh.rh;
+ y0 := y0 + 65536;
+ n := n + 1
+ end;
+ 30: {:375}
+
+ end else begin {376:}
+ base := ((8 * mem[curedges + 3].hh.lh) - 32764) + curwt;
+ if m0 <= m1 then
+ edgeprep(m0, m1, n1, n0)
+ else
+ edgeprep(m1, m0, n1, n0);
+ n0 := n0 - 1;
+ {377:}
+ n := mem[curedges + 5].hh.lh - 4096;
+ p := mem[curedges + 5].hh.rh;
+ if n <> n0 then
+ if n < n0 then
+ repeat
+ n := n + 1;
+ p := mem[p].hh.rh
+ until n = n0
+ else
+ repeat
+ n := n - 1;
+ p := mem[p].hh.lh
+ until n = n0 {:377};
+ while true do begin
+ r := getavail;
+ mem[r].hh.rh := mem[p + 1].hh.lh;
+ mem[p + 1].hh.lh := r;
+ tx := takefraction(delx, makefraction(y0, dely));
+ if abvscd(delx, y0, dely, tx) < 0 then
+ tx := tx + 1;
+ mem[r].hh.lh := (8 * roundunscaled(x0 - tx)) + base;
+ y1 := y1 + 65536;
+ if internal[10] > 0 then
+ tracenewedge(r, n);
+ if y1 >= 0 then
+ goto 31;
+ p := mem[p].hh.lh;
+ y0 := y0 + 65536;
+ n := n - 1
+ end;
+ 31: {:376}
+
+ end;
+ mem[curedges + 5].hh.rh := p;
+ mem[curedges + 5].hh.lh := n + 4096
+ end
+ end; {:374}
+ {378:}
+
+ procedure movetoedges(m0, n0, m1, n1: integer);
+ label
+ 60, 61, 62, 63, 30;
+ var
+ delta: 0..movesize;
+ k: 0..movesize;
+ p, r: halfword;
+ dx: integer;
+ edgeandweight: integer;
+ j: integer;
+ n: integer; {sum:integer;}
+ {sum:=move[0];
+ for k:=1 to delta do sum:=sum+abs(move[k]);
+ if sum<>m1-m0 then confusion(48);}
+ begin
+ delta := n1 - n0;
+ {380:}
+ case octant of
+ 1:
+ begin
+ dx := 8;
+ edgeprep(m0, m1, n0, n1);
+ goto 60
+ end;
+ 5:
+ begin
+ dx := 8;
+ edgeprep(n0, n1, m0, m1);
+ goto 62
+ end;
+ 6:
+ begin
+ dx := -8;
+ edgeprep(-n1, -n0, m0, m1);
+ n0 := -n0;
+ goto 62
+ end;
+ 2:
+ begin
+ dx := -8;
+ edgeprep(-m1, -m0, n0, n1);
+ m0 := -m0;
+ goto 60
+ end;
+ 4:
+ begin
+ dx := -8;
+ edgeprep(-m1, -m0, -n1, -n0);
+ m0 := -m0;
+ goto 61
+ end;
+ 8:
+ begin
+ dx := -8;
+ edgeprep(-n1, -n0, -m1, -m0);
+ n0 := -n0;
+ goto 63
+ end;
+ 7:
+ begin
+ dx := 8;
+ edgeprep(n0, n1, -m1, -m0);
+ goto 63
+ end;
+ 3:
+ begin
+ dx := 8;
+ edgeprep(m0, m1, -n1, -n0);
+ goto 61
+ end
+ end; {:380}
+ 60: {381:} {377:}
+ n := mem[curedges + 5].hh.lh - 4096;
+ p := mem[curedges + 5].hh.rh;
+ if n <> n0 then
+ if n < n0 then
+ repeat
+ n := n + 1;
+ p := mem[p].hh.rh
+ until n = n0
+ else
+ repeat
+ n := n - 1;
+ p := mem[p].hh.lh
+ until n = n0 {:377};
+ if delta > 0 then begin
+ k := 0;
+ edgeandweight := ((8 * (m0 + mem[curedges + 3].hh.lh)) - 32764) - curwt;
+ repeat
+ edgeandweight := edgeandweight + (dx * move[k]);
+ begin
+ r := avail;
+ if r = (-30000) then
+ r := getavail
+ else begin
+ avail := mem[r].hh.rh;
+ mem[r].hh.rh := -30000
+ end {dynused:=dynused+1;}
+ end;
+ mem[r].hh.rh := mem[p + 1].hh.lh;
+ mem[r].hh.lh := edgeandweight;
+ if internal[10] > 0 then
+ tracenewedge(r, n);
+ mem[p + 1].hh.lh := r;
+ p := mem[p].hh.rh;
+ k := k + 1;
+ n := n + 1
+ until k = delta
+ end;
+ goto 30 {:381};
+ 61: {382:}
+ n0 := (-n0) - 1; {377:}
+ n := mem[curedges + 5].hh.lh - 4096;
+ p := mem[curedges + 5].hh.rh;
+ if n <> n0 then
+ if n < n0 then
+ repeat
+ n := n + 1;
+ p := mem[p].hh.rh
+ until n = n0
+ else
+ repeat
+ n := n - 1;
+ p := mem[p].hh.lh
+ until n = n0 {:377};
+ if delta > 0 then begin
+ k := 0;
+ edgeandweight := ((8 * (m0 + mem[curedges + 3].hh.lh)) - 32764) + curwt;
+ repeat
+ edgeandweight := edgeandweight + (dx * move[k]);
+ begin
+ r := avail;
+ if r = (-30000) then
+ r := getavail
+ else begin
+ avail := mem[r].hh.rh;
+ mem[r].hh.rh := -30000
+ end {dynused:=dynused+1;}
+ end;
+ mem[r].hh.rh := mem[p + 1].hh.lh;
+ mem[r].hh.lh := edgeandweight;
+ if internal[10] > 0 then
+ tracenewedge(r, n);
+ mem[p + 1].hh.lh := r;
+ p := mem[p].hh.lh;
+ k := k + 1;
+ n := n - 1
+ until k = delta
+ end;
+ goto 30 {:382};
+ 62: {383:}
+ edgeandweight := ((8 * (n0 + mem[curedges + 3].hh.lh)) - 32764) - curwt;
+ n0 := m0;
+ k := 0;
+ {377:}
+ n := mem[curedges + 5].hh.lh - 4096;
+ p := mem[curedges + 5].hh.rh;
+ if n <> n0 then
+ if n < n0 then
+ repeat
+ n := n + 1;
+ p := mem[p].hh.rh
+ until n = n0
+ else
+ repeat
+ n := n - 1;
+ p := mem[p].hh.lh
+ until n = n0 {:377};
+ repeat
+ j := move[k];
+ while j > 0 do begin
+ begin
+ r := avail;
+ if r = (-30000) then
+ r := getavail
+ else begin
+ avail := mem[r].hh.rh;
+ mem[r].hh.rh := -30000
+ end {dynused:=dynused+1;}
+ end;
+ mem[r].hh.rh := mem[p + 1].hh.lh;
+ mem[r].hh.lh := edgeandweight;
+ if internal[10] > 0 then
+ tracenewedge(r, n);
+ mem[p + 1].hh.lh := r;
+ p := mem[p].hh.rh;
+ j := j - 1;
+ n := n + 1
+ end;
+ edgeandweight := edgeandweight + dx;
+ k := k + 1
+ until k > delta;
+ goto 30 {:383};
+ 63: {384:}
+ edgeandweight := ((8 * (n0 + mem[curedges + 3].hh.lh)) - 32764) + curwt;
+ n0 := (-m0) - 1;
+ k := 0;
+ {377:}
+ n := mem[curedges + 5].hh.lh - 4096;
+ p := mem[curedges + 5].hh.rh;
+ if n <> n0 then
+ if n < n0 then
+ repeat
+ n := n + 1;
+ p := mem[p].hh.rh
+ until n = n0
+ else
+ repeat
+ n := n - 1;
+ p := mem[p].hh.lh
+ until n = n0 {:377};
+ repeat
+ j := move[k];
+ while j > 0 do begin
+ begin
+ r := avail;
+ if r = (-30000) then
+ r := getavail
+ else begin
+ avail := mem[r].hh.rh;
+ mem[r].hh.rh := -30000
+ end {dynused:=dynused+1;}
+ end;
+ mem[r].hh.rh := mem[p + 1].hh.lh;
+ mem[r].hh.lh := edgeandweight;
+ if internal[10] > 0 then
+ tracenewedge(r, n);
+ mem[p + 1].hh.lh := r;
+ p := mem[p].hh.lh;
+ j := j - 1;
+ n := n - 1
+ end;
+ edgeandweight := edgeandweight + dx;
+ k := k + 1
+ until k > delta;
+ goto 30 {:384};
+ 30:
+ mem[curedges + 5].hh.lh := n + 4096;
+ mem[curedges + 5].hh.rh := p
+ end; {:378} {387:}
+
+ procedure skew(x, y: scaled; octant: smallnumber);
+ begin
+ case octant of
+ 1:
+ begin
+ curx := x - y;
+ cury := y
+ end;
+ 5:
+ begin
+ curx := y - x;
+ cury := x
+ end;
+ 6:
+ begin
+ curx := y + x;
+ cury := -x
+ end;
+ 2:
+ begin
+ curx := (-x) - y;
+ cury := y
+ end;
+ 4:
+ begin
+ curx := (-x) + y;
+ cury := -y
+ end;
+ 8:
+ begin
+ curx := (-y) + x;
+ cury := -x
+ end;
+ 7:
+ begin
+ curx := (-y) - x;
+ cury := x
+ end;
+ 3:
+ begin
+ curx := x + y;
+ cury := -y
+ end
+ end
+ end; {:387} {390:}
+
+ procedure abnegate(x, y: scaled; octantbefore, octantafter: smallnumber);
+ begin
+ if odd(octantbefore) = odd(octantafter) then
+ curx := x
+ else
+ curx := -x;
+ if (octantbefore > 2) = (octantafter > 2) then
+ cury := y
+ else
+ cury := -y
+ end; {:390}
+ {391:}
+
+ function crossingpoint(a, b, c: integer): fraction;
+ label
+ 10;
+ var
+ d: integer;
+ x, xx, x0, x1, x2: integer;
+ begin
+ if a < 0 then begin
+ crossingpoint := 0;
+ goto 10
+ end;
+ if c >= 0 then begin
+ if b >= 0 then
+ if c > 0 then begin
+ crossingpoint := 268435457;
+ goto 10
+ end else if (a = 0) and (b = 0) then begin
+ crossingpoint := 268435457;
+ goto 10
+ end else begin
+ crossingpoint := 268435456;
+ goto 10
+ end;
+ if a = 0 then begin
+ crossingpoint := 0;
+ goto 10
+ end
+ end else if a = 0 then
+ if b <= 0 then begin
+ crossingpoint := 0;
+ goto 10
+ end;
+ {392:}
+ d := 1;
+ x0 := a;
+ x1 := a - b;
+ x2 := b - c;
+ repeat
+ x := (x1 + x2) div 2;
+ if (x1 - x0) > x0 then begin
+ x2 := x;
+ x0 := x0 + x0;
+ d := d + d
+ end else begin
+ xx := (x1 + x) - x0;
+ if xx > x0 then begin
+ x2 := x;
+ x0 := x0 + x0;
+ d := d + d
+ end else begin
+ x0 := x0 - xx;
+ if x <= x0 then
+ if (x + x2) <= x0 then begin
+ crossingpoint := 268435457;
+ goto 10
+ end;
+ x1 := x;
+ d := (d + d) + 1
+ end
+ end
+ until d >= 268435456;
+ crossingpoint := d - 268435456 {:392};
+ 10:
+
+ end; {:391} {394:}
+
+ procedure printspec(s: strnumber);
+ label
+ 45, 30;
+ var
+ p, q: halfword;
+ octant: smallnumber;
+ begin
+ printdiagnostic(411, s, true);
+ p := curspec;
+ octant := mem[p + 3].int;
+ println;
+ unskew(mem[curspec + 1].int, mem[curspec + 2].int, octant);
+ printtwo(curx, cury);
+ print(412);
+ while true do begin
+ print(octantdir[octant]);
+ printchar(39);
+ while true do begin
+ q := mem[p].hh.rh;
+ if mem[p].hh.b1 = 0 then
+ goto 45;
+ {397:}
+ begin
+ printnl(423);
+ unskew(mem[p + 5].int, mem[p + 6].int, octant);
+ printtwo(curx, cury);
+ print(390);
+ unskew(mem[q + 3].int, mem[q + 4].int, octant);
+ printtwo(curx, cury);
+ printnl(387);
+ unskew(mem[q + 1].int, mem[q + 2].int, octant);
+ printtwo(curx, cury);
+ print(424);
+ printint(mem[q].hh.b0 - 1)
+ end {:397};
+ p := q
+ end;
+ 45:
+ if q = curspec then
+ goto 30;
+ p := q;
+ octant := mem[p + 3].int;
+ printnl(413)
+ end;
+ 30:
+ printnl(414);
+ enddiagnostic(true)
+ end; {:394} {398:}
+
+ procedure printstrange(s: strnumber);
+ var
+ p: halfword;
+ f: halfword;
+ q: halfword;
+ t: integer;
+ begin
+ if interaction = 3 then
+ ;
+ printnl(62); {399:}
+ p := curspec;
+ t := 128;
+ repeat
+ p := mem[p].hh.rh;
+ if mem[p].hh.b0 <> 0 then begin
+ if mem[p].hh.b0 < t then
+ f := p;
+ t := mem[p].hh.b0
+ end
+ until p = curspec {:399}; {400:}
+ p := curspec;
+ q := p;
+ repeat
+ p := mem[p].hh.rh;
+ if mem[p].hh.b0 = 0 then
+ q := p
+ until p = f {:400};
+ t := 0;
+ repeat
+ if mem[p].hh.b0 <> 0 then begin
+ if mem[p].hh.b0 <> t then begin
+ t := mem[p].hh.b0;
+ printchar(32);
+ printint(t - 1)
+ end;
+ if q <> (-30000) then begin {401:}
+ if mem[mem[q].hh.rh].hh.b0 = 0 then begin
+ print(425);
+ print(octantdir[mem[q + 3].int]);
+ q := mem[q].hh.rh;
+ while mem[mem[q].hh.rh].hh.b0 = 0 do begin
+ printchar(32);
+ print(octantdir[mem[q + 3].int]);
+ q := mem[q].hh.rh
+ end;
+ printchar(41)
+ end {:401};
+ printchar(32);
+ print(octantdir[mem[q + 3].int]);
+ q := -30000
+ end
+ end else if q = (-30000) then
+ q := p;
+ p := mem[p].hh.rh
+ until p = f;
+ printchar(32);
+ printint(mem[p].hh.b0 - 1);
+ if q <> (-30000) then {401:}
+ if mem[mem[q].hh.rh].hh.b0 = 0 then begin
+ print(425);
+ print(octantdir[mem[q + 3].int]);
+ q := mem[q].hh.rh;
+ while mem[mem[q].hh.rh].hh.b0 = 0 do begin
+ printchar(32);
+ print(octantdir[mem[q + 3].int]);
+ q := mem[q].hh.rh
+ end;
+ printchar(41)
+ end {:401};
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(s)
+ end
+ end; { printstrange }
+ {:398}
+ {402:}
+ {405:}
+
+ procedure removecubic(p: halfword);
+ var
+ q: halfword;
+ begin
+ q := mem[p].hh.rh;
+ mem[p].hh.b1 := mem[q].hh.b1;
+ mem[p].hh.rh := mem[q].hh.rh;
+ mem[p + 1].int := mem[q + 1].int;
+ mem[p + 2].int := mem[q + 2].int;
+ mem[p + 5].int := mem[q + 5].int;
+ mem[p + 6].int := mem[q + 6].int;
+ freenode(q, 7)
+ end; {:405} {406:} {410:}
+
+ procedure splitcubic(p: halfword; t: fraction; xq, yq: scaled);
+ var
+ v: scaled;
+ q, r: halfword;
+ begin
+ q := mem[p].hh.rh;
+ r := getnode(7);
+ mem[p].hh.rh := r;
+ mem[r].hh.rh := q;
+ mem[r].hh.b0 := mem[q].hh.b0;
+ mem[r].hh.b1 := mem[p].hh.b1;
+ v := mem[p + 5].int - takefraction(mem[p + 5].int - mem[q + 3].int, t);
+ mem[p + 5].int := mem[p + 1].int - takefraction(mem[p + 1].int - mem[p + 5].int, t);
+ mem[q + 3].int := mem[q + 3].int - takefraction(mem[q + 3].int - xq, t);
+ mem[r + 3].int := mem[p + 5].int - takefraction(mem[p + 5].int - v, t);
+ mem[r + 5].int := v - takefraction(v - mem[q + 3].int, t);
+ mem[r + 1].int := mem[r + 3].int - takefraction(mem[r + 3].int - mem[r + 5].int, t);
+ v := mem[p + 6].int - takefraction(mem[p + 6].int - mem[q + 4].int, t);
+ mem[p + 6].int := mem[p + 2].int - takefraction(mem[p + 2].int - mem[p + 6].int, t);
+ mem[q + 4].int := mem[q + 4].int - takefraction(mem[q + 4].int - yq, t);
+ mem[r + 4].int := mem[p + 6].int - takefraction(mem[p + 6].int - v, t);
+ mem[r + 6].int := v - takefraction(v - mem[q + 4].int, t);
+ mem[r + 2].int := mem[r + 4].int - takefraction(mem[r + 4].int - mem[r + 6].int, t)
+ end; {:410}
+
+ procedure quadrantsubdivide;
+ label
+ 22, 10;
+ var
+ p, q, r, s, pp, qq: halfword;
+ firstx, firsty: scaled;
+ del1, del2, del3, del, dmax: scaled;
+ t: fraction;
+ destx, desty: scaled;
+ constantx: boolean;
+ begin
+ p := curspec;
+ firstx := mem[curspec + 1].int;
+ firsty := mem[curspec + 2].int;
+ repeat
+ 22:
+ q := mem[p].hh.rh; {407:}
+ if q = curspec then begin
+ destx := firstx;
+ desty := firsty
+ end else begin
+ destx := mem[q + 1].int;
+ desty := mem[q + 2].int
+ end;
+ del1 := mem[p + 5].int - mem[p + 1].int;
+ del2 := mem[q + 3].int - mem[p + 5].int;
+ del3 := destx - mem[q + 3].int; {408:}
+ if del1 <> 0 then
+ del := del1
+ else if del2 <> 0 then
+ del := del2
+ else
+ del := del3;
+ if del <> 0 then begin
+ dmax := abs(del1);
+ if abs(del2) > dmax then
+ dmax := abs(del2);
+ if abs(del3) > dmax then
+ dmax := abs(del3);
+ while dmax < 134217728 do begin
+ dmax := dmax + dmax;
+ del1 := del1 + del1;
+ del2 := del2 + del2;
+ del3 := del3 + del3
+ end
+ end {:408};
+ if del = 0 then
+ constantx := true
+ else begin
+ constantx := false;
+ if del < 0 then begin {409:}
+ mem[p + 1].int := -mem[p + 1].int;
+ mem[p + 5].int := -mem[p + 5].int;
+ mem[q + 3].int := -mem[q + 3].int;
+ del1 := -del1;
+ del2 := -del2;
+ del3 := -del3;
+ destx := -destx;
+ mem[p].hh.b1 := 2
+ end {:409};
+ t := crossingpoint(del1, del2, del3);
+ if t < 268435456 then begin {411:}
+ splitcubic(p, t, destx, desty);
+ r := mem[p].hh.rh;
+ if mem[r].hh.b1 > 1 then
+ mem[r].hh.b1 := 1
+ else
+ mem[r].hh.b1 := 2;
+ if mem[r + 1].int < mem[p + 1].int then
+ mem[r + 1].int := mem[p + 1].int;
+ mem[r + 3].int := mem[r + 1].int;
+ mem[r + 1].int := -mem[r + 1].int;
+ mem[r + 5].int := mem[r + 1].int;
+ mem[q + 3].int := -mem[q + 3].int;
+ destx := -destx;
+ del2 := del2 - takefraction(del2 - del3, t);
+ if del2 > 0 then
+ del2 := 0;
+ t := crossingpoint(0, -del2, -del3);
+ if t < 268435456 then begin {412:}
+ splitcubic(r, t, destx, desty);
+ s := mem[r].hh.rh;
+ if mem[s + 1].int < destx then
+ mem[s + 1].int := destx;
+ if mem[s + 1].int < mem[r + 1].int then
+ mem[s + 1].int := mem[r + 1].int;
+ mem[s].hh.b1 := mem[p].hh.b1;
+ mem[s + 3].int := mem[s + 1].int;
+ mem[s + 1].int := -mem[s + 1].int;
+ mem[s + 5].int := mem[s + 1].int;
+ mem[q + 3].int := -mem[q + 3].int
+ end else if mem[r + 1].int > destx then {:412}
+ mem[r + 1].int := destx
+ end {:411}
+ end {:407};
+ {413:}
+ pp := p;
+ repeat
+ qq := mem[pp].hh.rh;
+ abnegate(mem[qq + 1].int, mem[qq + 2].int, mem[qq].hh.b1, mem[pp].hh.b1);
+ destx := curx;
+ desty := cury;
+ del1 := mem[pp + 6].int - mem[pp + 2].int;
+ del2 := mem[qq + 4].int - mem[pp + 6].int;
+ del3 := desty - mem[qq + 4].int; {408:}
+ if del1 <> 0 then
+ del := del1
+ else if del2 <> 0 then
+ del := del2
+ else
+ del := del3;
+ if del <> 0 then begin
+ dmax := abs(del1);
+ if abs(del2) > dmax then
+ dmax := abs(del2);
+ if abs(del3) > dmax then
+ dmax := abs(del3);
+ while dmax < 134217728 do begin
+ dmax := dmax + dmax;
+ del1 := del1 + del1;
+ del2 := del2 + del2;
+ del3 := del3 + del3
+ end
+ end {:408};
+ if del <> 0 then begin
+ if del < 0 then begin {414:}
+ mem[pp + 2].int := -mem[pp + 2].int;
+ mem[pp + 6].int := -mem[pp + 6].int;
+ mem[qq + 4].int := -mem[qq + 4].int;
+ del1 := -del1;
+ del2 := -del2;
+ del3 := -del3;
+ desty := -desty;
+ mem[pp].hh.b1 := mem[pp].hh.b1 + 2
+ end {:414};
+ t := crossingpoint(del1, del2, del3);
+ if t < 268435456 then begin {415:}
+ splitcubic(pp, t, destx, desty);
+ r := mem[pp].hh.rh;
+ if mem[r].hh.b1 > 2 then
+ mem[r].hh.b1 := mem[r].hh.b1 - 2
+ else
+ mem[r].hh.b1 := mem[r].hh.b1 + 2;
+ if mem[r + 1].int > destx then
+ mem[r + 1].int := destx
+ else if mem[r + 1].int < mem[pp + 1].int then
+ mem[r + 1].int := mem[pp + 1].int;
+ if mem[r + 2].int < mem[pp + 2].int then
+ mem[r + 2].int := mem[pp + 2].int;
+ mem[r + 4].int := mem[r + 2].int;
+ mem[r + 2].int := -mem[r + 2].int;
+ mem[r + 6].int := mem[r + 2].int;
+ mem[qq + 4].int := -mem[qq + 4].int;
+ desty := -desty;
+ del2 := del2 - takefraction(del2 - del3, t);
+ if del2 > 0 then
+ del2 := 0;
+ t := crossingpoint(0, -del2, -del3);
+ if t < 268435456 then begin {416:}
+ splitcubic(r, t, destx, desty);
+ s := mem[r].hh.rh;
+ if mem[s + 1].int > destx then
+ mem[s + 1].int := destx
+ else if mem[s + 1].int < mem[r + 1].int then
+ mem[s + 1].int := mem[r + 1].int;
+ if mem[s + 2].int < desty then
+ mem[s + 2].int := desty;
+ if mem[s + 2].int < mem[r + 2].int then
+ mem[s + 2].int := mem[r + 2].int;
+ mem[s].hh.b1 := mem[pp].hh.b1;
+ mem[s + 4].int := mem[s + 2].int;
+ mem[s + 2].int := -mem[s + 2].int;
+ mem[s + 6].int := mem[s + 2].int;
+ mem[qq + 4].int := -mem[qq + 4].int
+ end else if mem[r + 2].int > desty then {:416}
+ mem[r + 2].int := desty
+ end {:415}
+ end else if constantx then begin {417:}
+ if q <> p then begin
+ removecubic(p);
+ if curspec <> q then
+ goto 22
+ else begin
+ curspec := p;
+ goto 10
+ end
+ end
+ end else if not odd(mem[pp].hh.b1) then begin {414:}
+ mem[pp + 2].int := -mem[pp + 2].int;
+ mem[pp + 6].int := -mem[pp + 6].int;
+ mem[qq + 4].int := -mem[qq + 4].int;
+ del1 := -del1;
+ del2 := -del2;
+ del3 := -del3;
+ desty := -desty;
+ mem[pp].hh.b1 := mem[pp].hh.b1 + 2
+ end {:414} {:417};
+ pp := qq
+ until pp = q;
+ if constantx then begin {418:}
+ pp := p;
+ repeat
+ qq := mem[pp].hh.rh;
+ if mem[pp].hh.b1 > 2 then begin
+ mem[pp].hh.b1 := mem[pp].hh.b1 + 1;
+ mem[pp + 1].int := -mem[pp + 1].int;
+ mem[pp + 5].int := -mem[pp + 5].int;
+ mem[qq + 3].int := -mem[qq + 3].int
+ end;
+ pp := qq
+ until pp = q
+ end {:418} {:413};
+ p := q
+ until p = curspec;
+ 10:
+
+ end; {:406} {419:}
+
+ procedure octantsubdivide;
+ var
+ p, q, r, s: halfword;
+ del1, del2, del3, del, dmax: scaled;
+ t: fraction;
+ destx, desty: scaled;
+ begin
+ p := curspec;
+ repeat
+ q := mem[p].hh.rh;
+ mem[p + 1].int := mem[p + 1].int - mem[p + 2].int;
+ mem[p + 5].int := mem[p + 5].int - mem[p + 6].int;
+ mem[q + 3].int := mem[q + 3].int - mem[q + 4].int; {420:} {421:}
+ if q = curspec then begin
+ unskew(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1);
+ skew(curx, cury, mem[p].hh.b1);
+ destx := curx;
+ desty := cury
+ end else begin
+ abnegate(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1, mem[p].hh.b1);
+ destx := curx - cury;
+ desty := cury
+ end;
+ del1 := mem[p + 5].int - mem[p + 1].int;
+ del2 := mem[q + 3].int - mem[p + 5].int;
+ del3 := destx - mem[q + 3].int {:421}; {408:}
+ if del1 <> 0 then
+ del := del1
+ else if del2 <> 0 then
+ del := del2
+ else
+ del := del3;
+ if del <> 0 then begin
+ dmax := abs(del1);
+ if abs(del2) > dmax then
+ dmax := abs(del2);
+ if abs(del3) > dmax then
+ dmax := abs(del3);
+ while dmax < 134217728 do begin
+ dmax := dmax + dmax;
+ del1 := del1 + del1;
+ del2 := del2 + del2;
+ del3 := del3 + del3
+ end
+ end {:408};
+ if del <> 0 then begin
+ if del < 0 then begin {423:}
+ mem[p + 2].int := mem[p + 1].int + mem[p + 2].int;
+ mem[p + 1].int := -mem[p + 1].int;
+ mem[p + 6].int := mem[p + 5].int + mem[p + 6].int;
+ mem[p + 5].int := -mem[p + 5].int;
+ mem[q + 4].int := mem[q + 3].int + mem[q + 4].int;
+ mem[q + 3].int := -mem[q + 3].int;
+ del1 := -del1;
+ del2 := -del2;
+ del3 := -del3;
+ desty := destx + desty;
+ destx := -destx;
+ mem[p].hh.b1 := mem[p].hh.b1 + 4
+ end {:423};
+ t := crossingpoint(del1, del2, del3);
+ if t < 268435456 then begin {424:}
+ splitcubic(p, t, destx, desty);
+ r := mem[p].hh.rh;
+ if mem[r].hh.b1 > 4 then
+ mem[r].hh.b1 := mem[r].hh.b1 - 4
+ else
+ mem[r].hh.b1 := mem[r].hh.b1 + 4;
+ if mem[r + 2].int > desty then
+ mem[r + 2].int := desty
+ else if mem[r + 2].int < mem[p + 2].int then
+ mem[r + 2].int := mem[p + 2].int;
+ if mem[r + 1].int < mem[p + 1].int then
+ mem[r + 1].int := mem[p + 1].int;
+ mem[r + 3].int := mem[r + 1].int;
+ mem[r + 2].int := mem[r + 2].int + mem[r + 1].int;
+ mem[r + 1].int := -mem[r + 1].int;
+ mem[r + 5].int := mem[r + 1].int;
+ mem[r + 6].int := mem[r + 6].int - mem[r + 5].int;
+ mem[q + 4].int := mem[q + 4].int + mem[q + 3].int;
+ mem[q + 3].int := -mem[q + 3].int;
+ desty := desty + destx;
+ destx := -destx;
+ del2 := del2 - takefraction(del2 - del3, t);
+ if del2 > 0 then
+ del2 := 0;
+ t := crossingpoint(0, -del2, -del3);
+ if t < 268435456 then begin {425:}
+ splitcubic(r, t, destx, desty);
+ s := mem[r].hh.rh;
+ if mem[s + 2].int > desty then
+ mem[s + 2].int := desty
+ else if mem[s + 2].int < mem[r + 2].int then
+ mem[s + 2].int := mem[r + 2].int;
+ if mem[s + 1].int < destx then
+ mem[s + 1].int := destx;
+ if mem[s + 1].int < mem[r + 1].int then
+ mem[s + 1].int := mem[r + 1].int;
+ mem[s].hh.b1 := mem[p].hh.b1;
+ mem[s + 3].int := mem[s + 1].int;
+ mem[s + 2].int := mem[s + 2].int + mem[s + 1].int;
+ mem[s + 1].int := -mem[s + 1].int;
+ mem[s + 6].int := mem[s + 6].int - mem[s + 1].int;
+ mem[s + 5].int := mem[s + 1].int;
+ mem[q + 4].int := mem[q + 4].int + mem[q + 3].int;
+ mem[q + 3].int := -mem[q + 3].int
+ end else if mem[r + 1].int > destx then {:425}
+ mem[r + 1].int := destx {:424}
+ end
+ end {:420};
+ p := q
+ until p = curspec
+ end; {:419} {426:}
+
+ procedure makesafe;
+ var
+ k: 0..maxwiggle;
+ allsafe: boolean;
+ nexta: scaled;
+ deltaa, deltab: scaled;
+ begin
+ before[curroundingptr] := before[0];
+ nodetoround[curroundingptr] := nodetoround[0];
+ repeat
+ after[curroundingptr] := after[0];
+ allsafe := true;
+ nexta := after[0];
+ for k := 0 to curroundingptr - 1 do begin
+ deltab := before[k + 1] - before[k];
+ if deltab >= 0 then
+ deltaa := after[k + 1] - nexta
+ else
+ deltaa := nexta - after[k + 1];
+ nexta := after[k + 1];
+ if (deltaa < 0) or (deltaa > abs(deltab + deltab)) then begin
+ allsafe := false;
+ after[k] := before[k];
+ if k = (curroundingptr - 1) then
+ after[0] := before[0]
+ else
+ after[k + 1] := before[k + 1]
+ end
+ end
+ until allsafe
+ end; {:426} {429:}
+
+ procedure beforeandafter(b, a: scaled; p: halfword);
+ begin
+ if curroundingptr = maxroundingptr then
+ if maxroundingptr < maxwiggle then
+ maxroundingptr := maxroundingptr + 1
+ else
+ overflow(435, maxwiggle);
+ after[curroundingptr] := a;
+ before[curroundingptr] := b;
+ nodetoround[curroundingptr] := p;
+ curroundingptr := curroundingptr + 1
+ end; { beforeandafter }
+ {:429}
+ {431:}
+
+ function goodval(b, o: scaled): scaled;
+ var
+ a: scaled;
+ begin
+ a := b + o;
+ if a >= 0 then
+ a := (a - (a mod curgran)) - o
+ else
+ a := (((a + ((-(a + 1)) mod curgran)) - curgran) + 1) - o;
+ if (b - a) < ((a + curgran) - b) then
+ goodval := a
+ else
+ goodval := a + curgran
+ end; {:431} {432:}
+
+ function compromise(u, v: scaled): scaled;
+ begin
+ compromise := goodval(u + u, (-u) - v) div 2
+ end; {:432} {433:}
+
+ procedure xyround;
+ var
+ p, q: halfword;
+ b, a: scaled;
+ penedge: scaled;
+ alpha: fraction;
+ begin
+ curgran := abs(internal[37]);
+ if curgran = 0 then
+ curgran := 65536;
+ p := curspec;
+ curroundingptr := 0;
+ repeat
+ q := mem[p].hh.rh; {434:}
+ if odd(mem[p].hh.b1) <> odd(mem[q].hh.b1) then begin
+ if odd(mem[q].hh.b1) then
+ b := mem[q + 1].int
+ else
+ b := -mem[q + 1].int;
+ if (abs(mem[q + 1].int - mem[q + 5].int) < 655) or (abs(mem[q + 1].int + mem[q + 3].int) < 655) then begin {435:}
+ if curpen = (-29997) then
+ penedge := 0
+ else if curpathtype = 0 then
+ penedge := compromise(mem[mem[curpen + 5].hh.rh + 2].int, mem[mem[curpen + 7].hh.rh + 2].int)
+ else if odd(mem[q].hh.b1) then
+ penedge := mem[mem[curpen + 7].hh.rh + 2].int
+ else
+ penedge := mem[mem[curpen + 5].hh.rh + 2].int;
+ a := goodval(b, penedge)
+ end else {:435}
+ a := b;
+ if abs(a) > maxallowed then
+ if a > 0 then
+ a := maxallowed
+ else
+ a := -maxallowed;
+ beforeandafter(b, a, q)
+ end {:434};
+ p := q
+ until p = curspec;
+ if curroundingptr > 0 then begin {436:}
+ makesafe;
+ repeat
+ curroundingptr := curroundingptr - 1;
+ if (after[curroundingptr] <> before[curroundingptr]) or (after[curroundingptr + 1] <> before[curroundingptr + 1]) then begin
+ p := nodetoround[curroundingptr];
+ if odd(mem[p].hh.b1) then begin
+ b := before[curroundingptr];
+ a := after[curroundingptr]
+ end else begin
+ b := -before[curroundingptr];
+ a := -after[curroundingptr]
+ end;
+ if before[curroundingptr] = before[curroundingptr + 1] then
+ alpha := 268435456
+ else
+ alpha := makefraction(after[curroundingptr + 1] - after[curroundingptr], before[curroundingptr + 1] - before[curroundingptr]);
+ repeat
+ mem[p + 1].int := takefraction(alpha, mem[p + 1].int - b) + a;
+ mem[p + 5].int := takefraction(alpha, mem[p + 5].int - b) + a;
+ p := mem[p].hh.rh;
+ mem[p + 3].int := takefraction(alpha, mem[p + 3].int - b) + a
+ until p = nodetoround[curroundingptr + 1]
+ end
+ until curroundingptr = 0
+ end {:436};
+ p := curspec;
+ curroundingptr := 0;
+ repeat
+ q := mem[p].hh.rh; {437:}
+ if (mem[p].hh.b1 > 2) <> (mem[q].hh.b1 > 2) then begin
+ if mem[q].hh.b1 <= 2 then
+ b := mem[q + 2].int
+ else
+ b := -mem[q + 2].int;
+ if (abs(mem[q + 2].int - mem[q + 6].int) < 655) or (abs(mem[q + 2].int + mem[q + 4].int) < 655) then begin {438:}
+ if curpen = (-29997) then
+ penedge := 0
+ else if curpathtype = 0 then
+ penedge := compromise(mem[mem[curpen + 2].hh.rh + 2].int, mem[mem[curpen + 1].hh.rh + 2].int)
+ else if mem[q].hh.b1 <= 2 then
+ penedge := mem[mem[curpen + 1].hh.rh + 2].int
+ else
+ penedge := mem[mem[curpen + 2].hh.rh + 2].int;
+ a := goodval(b, penedge)
+ end else {:438}
+ a := b;
+ if abs(a) > maxallowed then
+ if a > 0 then
+ a := maxallowed
+ else
+ a := -maxallowed;
+ beforeandafter(b, a, q)
+ end {:437};
+ p := q
+ until p = curspec;
+ if curroundingptr > 0 then begin {439:}
+ makesafe;
+ repeat
+ curroundingptr := curroundingptr - 1;
+ if (after[curroundingptr] <> before[curroundingptr]) or (after[curroundingptr + 1] <> before[curroundingptr + 1]) then begin
+ p := nodetoround[curroundingptr];
+ if mem[p].hh.b1 <= 2 then begin
+ b := before[curroundingptr];
+ a := after[curroundingptr]
+ end else begin
+ b := -before[curroundingptr];
+ a := -after[curroundingptr]
+ end;
+ if before[curroundingptr] = before[curroundingptr + 1] then
+ alpha := 268435456
+ else
+ alpha := makefraction(after[curroundingptr + 1] - after[curroundingptr], before[curroundingptr + 1] - before[curroundingptr]);
+ repeat
+ mem[p + 2].int := takefraction(alpha, mem[p + 2].int - b) + a;
+ mem[p + 6].int := takefraction(alpha, mem[p + 6].int - b) + a;
+ p := mem[p].hh.rh;
+ mem[p + 4].int := takefraction(alpha, mem[p + 4].int - b) + a
+ until p = nodetoround[curroundingptr + 1]
+ end
+ until curroundingptr = 0
+ end {:439}
+ end; {:433} {440:}
+
+ procedure diaground;
+ var
+ p, q, pp: halfword;
+ b, a, bb, aa, d, c, dd, cc: scaled;
+ penedge: scaled;
+ alpha, beta: fraction;
+ nexta: scaled;
+ allsafe: boolean;
+ k: 0..maxwiggle;
+ firstx, firsty: scaled;
+ begin
+ p := curspec;
+ curroundingptr := 0;
+ repeat
+ q := mem[p].hh.rh; {441:}
+ if mem[p].hh.b1 <> mem[q].hh.b1 then begin
+ if mem[q].hh.b1 > 4 then
+ b := -mem[q + 1].int
+ else
+ b := mem[q + 1].int;
+ if abs(mem[q].hh.b1 - mem[p].hh.b1) = 4 then
+ if (abs(mem[q + 1].int - mem[q + 5].int) < 655) or (abs(mem[q + 1].int + mem[q + 3].int) < 655) then begin {442:}
+ if curpen = (-29997) then
+ penedge := 0
+ else if curpathtype = 0 then {443:}
+ case mem[q].hh.b1 of
+ 1, 5:
+ penedge := compromise(mem[mem[mem[curpen + 1].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 4].hh.rh].hh.lh + 1].int);
+ 4, 8:
+ penedge := -compromise(mem[mem[mem[curpen + 1].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 4].hh.rh].hh.lh + 1].int);
+ 6, 2:
+ penedge := compromise(mem[mem[mem[curpen + 2].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 3].hh.rh].hh.lh + 1].int);
+ 7, 3:
+ penedge := -compromise(mem[mem[mem[curpen + 2].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 3].hh.rh].hh.lh + 1].int)
+ end {:443}
+ else if mem[q].hh.b1 <= 4 then
+ penedge := mem[mem[mem[curpen + mem[q].hh.b1].hh.rh].hh.lh + 1].int
+ else
+ penedge := -mem[mem[mem[curpen + mem[q].hh.b1].hh.rh].hh.lh + 1].int;
+ if odd(mem[q].hh.b1) then
+ a := goodval(b, penedge + (curgran div 2))
+ else
+ a := goodval(b - 1, penedge + (curgran div 2))
+ end else {:442}
+ a := b
+ else
+ a := b;
+ beforeandafter(b, a, q)
+ end {:441};
+ p := q
+ until p = curspec;
+ if curroundingptr > 0 then begin {444:}
+ p := nodetoround[0];
+ firstx := mem[p + 1].int;
+ firsty := mem[p + 2].int; {446:}
+ before[curroundingptr] := before[0];
+ nodetoround[curroundingptr] := nodetoround[0];
+ repeat
+ after[curroundingptr] := after[0];
+ allsafe := true;
+ nexta := after[0];
+ for k := 0 to curroundingptr - 1 do begin
+ a := nexta;
+ b := before[k];
+ nexta := after[k + 1];
+ aa := nexta;
+ bb := before[k + 1];
+ if (a <> b) or (aa <> bb) then begin
+ p := nodetoround[k];
+ pp := nodetoround[k + 1];
+ {445:}
+ if aa = bb then begin
+ if pp = nodetoround[0] then
+ unskew(firstx, firsty, mem[pp].hh.b1)
+ else
+ unskew(mem[pp + 1].int, mem[pp + 2].int, mem[pp].hh.b1);
+ skew(curx, cury, mem[p].hh.b1);
+ bb := curx;
+ aa := bb;
+ dd := cury;
+ cc := dd;
+ if mem[p].hh.b1 > 4 then begin
+ b := -b;
+ a := -a
+ end
+ end else begin
+ if mem[p].hh.b1 > 4 then begin
+ bb := -bb;
+ aa := -aa;
+ b := -b;
+ a := -a
+ end;
+ if pp = nodetoround[0] then
+ dd := firsty - bb
+ else
+ dd := mem[pp + 2].int - bb;
+ if odd(aa - bb) then
+ if mem[p].hh.b1 > 4 then
+ cc := dd - (((aa - bb) + 1) div 2)
+ else
+ cc := dd - (((aa - bb) - 1) div 2)
+ else
+ cc := dd - ((aa - bb) div 2)
+ end;
+ d := mem[p + 2].int;
+ if odd(a - b) then
+ if mem[p].hh.b1 > 4 then
+ c := d - (((a - b) - 1) div 2)
+ else
+ c := d - (((a - b) + 1) div 2)
+ else
+ c := d - ((a - b) div 2) {:445};
+ if (((aa < a) or (cc < c)) or ((aa - a) > (2 * (bb - b)))) or ((cc - c) > (2 * (dd - d))) then begin
+ allsafe := false;
+ after[k] := before[k];
+ if k = (curroundingptr - 1) then
+ after[0] := before[0]
+ else
+ after[k + 1] := before[k + 1]
+ end
+ end
+ end
+ until allsafe {:446};
+ for k := 0 to curroundingptr - 1 do begin
+ a := after[k];
+ b := before[k];
+ aa := after[k + 1];
+ bb := before[k + 1];
+ if (a <> b) or (aa <> bb) then begin
+ p := nodetoround[k];
+ pp := nodetoround[k + 1];
+ {445:}
+ if aa = bb then begin
+ if pp = nodetoround[0] then
+ unskew(firstx, firsty, mem[pp].hh.b1)
+ else
+ unskew(mem[pp + 1].int, mem[pp + 2].int, mem[pp].hh.b1);
+ skew(curx, cury, mem[p].hh.b1);
+ bb := curx;
+ aa := bb;
+ dd := cury;
+ cc := dd;
+ if mem[p].hh.b1 > 4 then begin
+ b := -b;
+ a := -a
+ end
+ end else begin
+ if mem[p].hh.b1 > 4 then begin
+ bb := -bb;
+ aa := -aa;
+ b := -b;
+ a := -a
+ end;
+ if pp = nodetoround[0] then
+ dd := firsty - bb
+ else
+ dd := mem[pp + 2].int - bb;
+ if odd(aa - bb) then
+ if mem[p].hh.b1 > 4 then
+ cc := dd - (((aa - bb) + 1) div 2)
+ else
+ cc := dd - (((aa - bb) - 1) div 2)
+ else
+ cc := dd - ((aa - bb) div 2)
+ end;
+ d := mem[p + 2].int;
+ if odd(a - b) then
+ if mem[p].hh.b1 > 4 then
+ c := d - (((a - b) - 1) div 2)
+ else
+ c := d - (((a - b) + 1) div 2)
+ else
+ c := d - ((a - b) div 2) {:445};
+ if b = bb then
+ alpha := 268435456
+ else
+ alpha := makefraction(aa - a, bb - b);
+ if d = dd then
+ beta := 268435456
+ else
+ beta := makefraction(cc - c, dd - d);
+ repeat
+ mem[p + 1].int := takefraction(alpha, mem[p + 1].int - b) + a;
+ mem[p + 2].int := takefraction(beta, mem[p + 2].int - d) + c;
+ mem[p + 5].int := takefraction(alpha, mem[p + 5].int - b) + a;
+ mem[p + 6].int := takefraction(beta, mem[p + 6].int - d) + c;
+ p := mem[p].hh.rh;
+ mem[p + 3].int := takefraction(alpha, mem[p + 3].int - b) + a;
+ mem[p + 4].int := takefraction(beta, mem[p + 4].int - d) + c
+ until p = pp
+ end
+ end
+ end {:444}
+ end; {:440} {451:}
+
+ procedure newboundary(p: halfword; octant: smallnumber);
+ var
+ q, r: halfword;
+ begin
+ q := mem[p].hh.rh;
+ r := getnode(7);
+ mem[r].hh.rh := q;
+ mem[p].hh.rh := r;
+ mem[r].hh.b0 := mem[q].hh.b0;
+ mem[r + 3].int := mem[q + 3].int;
+ mem[r + 4].int := mem[q + 4].int;
+ mem[r].hh.b1 := 0;
+ mem[q].hh.b0 := 0;
+ mem[r + 5].int := octant;
+ mem[q + 3].int := mem[q].hh.b1;
+ unskew(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1);
+ skew(curx, cury, octant);
+ mem[r + 1].int := curx;
+ mem[r + 2].int := cury
+ end; {:451}
+
+ function makespec(h: halfword; safetymargin: scaled; tracing: integer): halfword;
+ label
+ 22, 30;
+ var
+ p, q, r, s: halfword;
+ k: integer;
+ chopped: boolean; {453:}
+ o1, o2: smallnumber;
+ clockwise: boolean;
+ dx1, dy1, dx2, dy2: integer;
+ dmax, del: integer; {:453}
+ begin
+ curspec := h;
+ if tracing > 0 then
+ printpath(curspec, 426, true);
+ maxallowed := 268402687 - safetymargin; {404:}
+ p := curspec;
+ k := 1;
+ chopped := false;
+ repeat
+ if abs(mem[p + 3].int) > maxallowed then begin
+ chopped := true;
+ if mem[p + 3].int > 0 then
+ mem[p + 3].int := maxallowed
+ else
+ mem[p + 3].int := -maxallowed
+ end;
+ if abs(mem[p + 4].int) > maxallowed then begin
+ chopped := true;
+ if mem[p + 4].int > 0 then
+ mem[p + 4].int := maxallowed
+ else
+ mem[p + 4].int := -maxallowed
+ end;
+ if abs(mem[p + 1].int) > maxallowed then begin
+ chopped := true;
+ if mem[p + 1].int > 0 then
+ mem[p + 1].int := maxallowed
+ else
+ mem[p + 1].int := -maxallowed
+ end;
+ if abs(mem[p + 2].int) > maxallowed then begin
+ chopped := true;
+ if mem[p + 2].int > 0 then
+ mem[p + 2].int := maxallowed
+ else
+ mem[p + 2].int := -maxallowed
+ end;
+ if abs(mem[p + 5].int) > maxallowed then begin
+ chopped := true;
+ if mem[p + 5].int > 0 then
+ mem[p + 5].int := maxallowed
+ else
+ mem[p + 5].int := -maxallowed
+ end;
+ if abs(mem[p + 6].int) > maxallowed then begin
+ chopped := true;
+ if mem[p + 6].int > 0 then
+ mem[p + 6].int := maxallowed
+ else
+ mem[p + 6].int := -maxallowed
+ end;
+ p := mem[p].hh.rh;
+ mem[p].hh.b0 := k;
+ if k < 127 then
+ k := k + 1
+ else
+ k := 1
+ until p = curspec;
+ if chopped then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(430)
+ end;
+ begin
+ helpptr := 4;
+ helpline[3] := 431;
+ helpline[2] := 432;
+ helpline[1] := 433;
+ helpline[0] := 434
+ end;
+ putgeterror
+ end {:404};
+ quadrantsubdivide;
+ if internal[36] > 0 then
+ xyround;
+ octantsubdivide;
+ if internal[36] > 65536 then
+ diaground; {447:}
+ p := curspec;
+ repeat
+ 22:
+ q := mem[p].hh.rh;
+ if p <> q then begin
+ if mem[p + 1].int = mem[p + 5].int then
+ if mem[p + 2].int = mem[p + 6].int then
+ if mem[p + 1].int = mem[q + 3].int then
+ if mem[p + 2].int = mem[q + 4].int then begin
+ unskew(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1);
+ skew(curx, cury, mem[p].hh.b1);
+ if mem[p + 1].int = curx then
+ if mem[p + 2].int = cury then begin
+ removecubic(p);
+ if q <> curspec then
+ goto 22;
+ curspec := p;
+ q := p
+ end
+ end
+ end;
+ p := q
+ until p = curspec; {:447} {450:}
+ turningnumber := 0;
+ p := curspec;
+ q := mem[p].hh.rh;
+ repeat
+ r := mem[q].hh.rh;
+ if (mem[p].hh.b1 <> mem[q].hh.b1) or (q = r) then begin {452:}
+ newboundary(p, mem[p].hh.b1);
+ s := mem[p].hh.rh;
+ o1 := octantnumber[mem[p].hh.b1];
+ o2 := octantnumber[mem[q].hh.b1];
+ case o2 - o1 of
+ 1, -7, 7, -1:
+ goto 30;
+ 2, -6:
+ clockwise := false;
+ 3, -5, 4, -4, 5, -3:
+ begin {454:} {457:}
+ dx1 := mem[s + 1].int - mem[s + 3].int;
+ dy1 := mem[s + 2].int - mem[s + 4].int;
+ if dx1 = 0 then
+ if dy1 = 0 then begin
+ dx1 := mem[s + 1].int - mem[p + 5].int;
+ dy1 := mem[s + 2].int - mem[p + 6].int;
+ if dx1 = 0 then
+ if dy1 = 0 then begin
+ dx1 := mem[s + 1].int - mem[p + 1].int;
+ dy1 := mem[s + 2].int - mem[p + 2].int
+ end
+ end;
+ dmax := abs(dx1);
+ if abs(dy1) > dmax then
+ dmax := abs(dy1);
+ while dmax < 268435456 do begin
+ dmax := dmax + dmax;
+ dx1 := dx1 + dx1;
+ dy1 := dy1 + dy1
+ end;
+ dx2 := mem[q + 5].int - mem[q + 1].int;
+ dy2 := mem[q + 6].int - mem[q + 2].int;
+ if dx2 = 0 then
+ if dy2 = 0 then begin
+ dx2 := mem[r + 3].int - mem[q + 1].int;
+ dy2 := mem[r + 4].int - mem[q + 2].int;
+ if dx2 = 0 then
+ if dy2 = 0 then begin
+ if mem[r].hh.b1 = 0 then begin
+ curx := mem[r + 1].int;
+ cury := mem[r + 2].int
+ end else begin
+ unskew(mem[r + 1].int, mem[r + 2].int, mem[r].hh.b1);
+ skew(curx, cury, mem[q].hh.b1)
+ end;
+ dx2 := curx - mem[q + 1].int;
+ dy2 := cury - mem[q + 2].int
+ end
+ end;
+ dmax := abs(dx2);
+ if abs(dy2) > dmax then
+ dmax := abs(dy2);
+ while dmax < 268435456 do begin
+ dmax := dmax + dmax;
+ dx2 := dx2 + dx2;
+ dy2 := dy2 + dy2
+ end {:457};
+ unskew(dx1, dy1, mem[p].hh.b1);
+ del := pythadd(curx, cury);
+ dx1 := makefraction(curx, del);
+ dy1 := makefraction(cury, del);
+ unskew(dx2, dy2, mem[q].hh.b1);
+ del := pythadd(curx, cury);
+ dx2 := makefraction(curx, del);
+ dy2 := makefraction(cury, del);
+ del := takefraction(dx1, dy2) - takefraction(dx2, dy1);
+ if del > 4684844 then
+ clockwise := false
+ else if del < (-4684844) then
+ clockwise := true
+ else
+ clockwise := revturns
+ end; {:454}
+ 6, -2:
+ clockwise := true;
+ 0:
+ clockwise := revturns
+ end; {458:}
+ while true do begin
+ if clockwise then
+ if o1 = 1 then
+ o1 := 8
+ else
+ o1 := o1 - 1
+ else if o1 = 8 then
+ o1 := 1
+ else
+ o1 := o1 + 1;
+ if o1 = o2 then
+ goto 30;
+ newboundary(s, octantcode[o1]);
+ s := mem[s].hh.rh;
+ mem[s + 3].int := mem[s + 5].int
+ end {:458};
+ 30:
+ if q = r then begin
+ q := mem[q].hh.rh;
+ r := q;
+ p := s;
+ mem[s].hh.rh := q;
+ mem[q + 3].int := mem[q + 5].int;
+ mem[q].hh.b0 := 0;
+ freenode(curspec, 7);
+ curspec := q
+ end; {459:}
+ p := mem[p].hh.rh;
+ repeat
+ s := mem[p].hh.rh;
+ o1 := octantnumber[mem[p + 5].int];
+ o2 := octantnumber[mem[s + 3].int];
+ if abs(o1 - o2) = 1 then begin
+ if o2 < o1 then
+ o2 := o1;
+ if odd(o2) then
+ mem[p + 6].int := 0
+ else
+ mem[p + 6].int := 1
+ end else begin
+ if o1 = 8 then
+ turningnumber := turningnumber + 1
+ else
+ turningnumber := turningnumber - 1;
+ mem[p + 6].int := 0
+ end;
+ mem[s + 4].int := mem[p + 6].int;
+ p := s
+ until p = q {:459}
+ end {:452};
+ p := q;
+ q := r
+ until p = curspec; {:450}
+ while mem[curspec].hh.b0 <> 0 do
+ curspec := mem[curspec].hh.rh;
+ if tracing > 0 then
+ if internal[36] <= 0 then
+ printspec(427)
+ else if internal[36] > 65536 then
+ printspec(428)
+ else
+ printspec(429);
+ makespec := curspec
+ end; { makespec }
+ {:402}
+ {463:}
+
+ procedure endround(x, y: scaled);
+ begin
+ y := (y + 32768) - ycorr[octant];
+ x := (x + y) - xcorr[octant];
+ m1 := floorunscaled(x);
+ n1 := floorunscaled(y);
+ if (x - (65536 * m1)) >= ((y - (65536 * n1)) + zcorr[octant]) then
+ d1 := 1
+ else
+ d1 := 0
+ end; {:463}
+ {465:}
+
+ procedure fillspec(h: halfword);
+ var
+ p, q, r, s: halfword;
+ begin
+ if internal[10] > 0 then
+ beginedgetracing;
+ p := h;
+ {------------------------------------}
+ print_start(psfile); { Start cycle }
+ {------------------------------------}
+ repeat
+ octant := mem[p + 3].int; {466:}
+ q := p;
+ while mem[q].hh.b1 <> 0 do
+ q := mem[q].hh.rh {:466};
+ if q <> p then begin {467:}
+ endround(mem[p + 1].int, mem[p + 2].int);
+ m0 := m1;
+ n0 := n1;
+ d0 := d1;
+ endround(mem[q + 1].int, mem[q + 2].int) {:467}; {468:}
+ if (n1 - n0) >= movesize then
+ overflow(407, movesize);
+ move[0] := d0;
+ moveptr := 0;
+ r := p;
+ repeat
+ s := mem[r].hh.rh;
+ makemoves(mem[r + 1].int, mem[r + 5].int, mem[s + 3].int, mem[s + 1].int, mem[r + 2].int + 32768, mem[r + 6].int + 32768, mem[s + 4].int + 32768, mem[s + 2].int + 32768, xycorr[octant], ycorr[octant],465,octant);
+ r := s
+ until r = q;
+ move[moveptr] := move[moveptr] - d1;
+ if internal[35] > 0 then
+ smoothmoves(0, moveptr) {:468};
+ movetoedges(m0, n0, m1, n1)
+ end;
+ p := mem[q].hh.rh
+ until p = h;
+ {------------------------------------}
+ print_end(psfile); { End cycle }
+ {------------------------------------}
+ tossknotlist(h);
+ if internal[10] > 0 then
+ endedgetracing
+ end; {:465} {476:}
+
+ procedure dupoffset(w: halfword);
+ var
+ r: halfword;
+ begin
+ r := getnode(3);
+ mem[r + 1].int := mem[w + 1].int;
+ mem[r + 2].int := mem[w + 2].int;
+ mem[r].hh.rh := mem[w].hh.rh;
+ mem[mem[w].hh.rh].hh.lh := r;
+ mem[r].hh.lh := w;
+ mem[w].hh.rh := r
+ end; {:476} {477:}
+
+ function makepen(h: halfword): halfword;
+ label
+ 30, 31, 45, 40;
+ var
+ o, oo, k: smallnumber;
+ p: halfword;
+ q, r, s, w, hh: halfword;
+ n: integer;
+ dx, dy: scaled;
+ mc: scaled; {479:}
+ begin
+ q := h;
+ r := mem[q].hh.rh;
+ mc := abs(mem[h + 1].int);
+ if q = r then begin
+ hh := h;
+ mem[h].hh.b1 := 0;
+ if mc < abs(mem[h + 2].int) then
+ mc := abs(mem[h + 2].int)
+ end else begin
+ o := 0;
+ hh := -30000;
+ while true do begin
+ s := mem[r].hh.rh;
+ if mc < abs(mem[r + 1].int) then
+ mc := abs(mem[r + 1].int);
+ if mc < abs(mem[r + 2].int) then
+ mc := abs(mem[r + 2].int);
+ dx := mem[r + 1].int - mem[q + 1].int;
+ dy := mem[r + 2].int - mem[q + 2].int;
+ if dx = 0 then
+ if dy = 0 then
+ goto 45;
+ if abvscd(dx, mem[s + 2].int - mem[r + 2].int, dy, mem[s + 1].int - mem[r + 1].int) < 0 then
+ goto 45; {480:}
+ if dx > 0 then
+ octant := 1
+ else if dx = 0 then
+ if dy > 0 then
+ octant := 1
+ else
+ octant := 2
+ else begin
+ dx := -dx;
+ octant := 2
+ end;
+ if dy < 0 then begin
+ dy := -dy;
+ octant := octant + 2
+ end else if dy = 0 then
+ if octant > 1 then
+ octant := 4;
+ if dx < dy then
+ octant := octant + 4 {:480};
+ mem[q].hh.b1 := octant;
+ oo := octantnumber[octant];
+ if o > oo then begin
+ if hh <> (-30000) then
+ goto 45;
+ hh := q
+ end;
+ o := oo;
+ if (q = h) and (hh <> (-30000)) then
+ goto 30;
+ q := r;
+ r := s
+ end;
+ 30: {:479}
+
+ end;
+ if mc >= 268402688 then
+ goto 45;
+ p := getnode(10);
+ q := hh;
+ mem[p + 9].int := mc;
+ mem[p].hh.lh := -30000;
+ if mem[q].hh.rh <> q then
+ mem[p].hh.rh := -29999;
+ for k := 1 to 8 do begin {481:}
+ octant := octantcode[k];
+ n := 0;
+ h := p + octant;
+ while true do begin
+ r := getnode(3);
+ skew(mem[q + 1].int, mem[q + 2].int, octant);
+ mem[r + 1].int := curx;
+ mem[r + 2].int := cury;
+ if n = 0 then
+ mem[h].hh.rh := r {482:}
+ else if odd(k) then begin
+ mem[w].hh.rh := r;
+ mem[r].hh.lh := w
+ end else begin
+ mem[w].hh.lh := r;
+ mem[r].hh.rh := w
+ end {:482};
+ w := r;
+ if mem[q].hh.b1 <> octant then
+ goto 31;
+ q := mem[q].hh.rh;
+ n := n + 1
+ end;
+ 31: {483:}
+ r := mem[h].hh.rh;
+ if odd(k) then begin
+ mem[w].hh.rh := r;
+ mem[r].hh.lh := w
+ end else begin
+ mem[w].hh.lh := r;
+ mem[r].hh.rh := w;
+ mem[h].hh.rh := w;
+ r := w
+ end;
+ if (mem[r + 2].int <> mem[mem[r].hh.rh + 2].int) or (n = 0) then begin
+ dupoffset(r);
+ n := n + 1
+ end;
+ r := mem[r].hh.lh;
+ {:
+ 483}
+ if mem[r + 1].int <> mem[mem[r].hh.lh + 1].int then
+ dupoffset(r)
+ else
+ n := n - 1;
+ if n >= 127 then
+ overflow(446, 127);
+ mem[h].hh.lh := n
+ end {:481};
+ goto 40;
+ 45:
+ p := -29997; {478:}
+ if mc >= 268402688 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(440)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 441;
+ helpline[0] := 442
+ end
+ end else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(443)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 444;
+ helpline[1] := 445;
+ helpline[0] := 442
+ end
+ end; {:478}
+ putgeterror;
+ 40:
+ if internal[6] > 0 then
+ printpen(p, 439, true);
+ makepen := p
+ end; {:477} {484:} {486:}
+
+ function trivialknot(x, y: scaled): halfword;
+ var
+ p: halfword;
+ begin
+ p := getnode(7);
+ mem[p].hh.b0 := 1;
+ mem[p].hh.b1 := 1;
+ mem[p + 1].int := x;
+ mem[p + 3].int := x;
+ mem[p + 5].int := x;
+ mem[p + 2].int := y;
+ mem[p + 4].int := y;
+ mem[p + 6].int := y;
+ trivialknot := p
+ end; {:486}
+
+ function makepath(penhead: halfword): halfword;
+ var
+ p: halfword;
+ k: 1..8;
+ h: halfword;
+ m, n: integer;
+ w, ww: halfword;
+ begin
+ p := 29999;
+ for k := 1 to 8 do begin
+ octant := octantcode[k];
+ h := penhead + octant;
+ n := mem[h].hh.lh;
+ w := mem[h].hh.rh;
+ if not odd(k) then
+ w := mem[w].hh.lh;
+ for m := 1 to n + 1 do begin
+ if odd(k) then
+ ww := mem[w].hh.rh
+ else
+ ww := mem[w].hh.lh;
+ if (mem[ww + 1].int <> mem[w + 1].int) or (mem[ww + 2].int <> mem[w + 2].int) then begin {485:}
+ unskew(mem[ww + 1].int, mem[ww + 2].int, octant);
+ mem[p].hh.rh := trivialknot(curx, cury);
+ p := mem[p].hh.rh
+ end {:485};
+ w := ww
+ end
+ end;
+ if p = 29999 then begin
+ w := mem[penhead + 1].hh.rh;
+ p := trivialknot(mem[w + 1].int + mem[w + 2].int, mem[w + 2].int);
+ mem[29999].hh.rh := p
+ end;
+ mem[p].hh.rh := mem[29999].hh.rh;
+ makepath := mem[29999].hh.rh
+ end; {:484} {488:}
+
+ procedure findoffset(x, y: scaled; p: halfword);
+ label
+ 30, 10;
+ var
+ octant: 1..8;
+ s: -1..+1;
+ n: integer;
+ h, w, ww: halfword; {489:}
+ begin
+ if x > 0 then
+ octant := 1
+ else if x = 0 then
+ if y <= 0 then
+ if y = 0 then begin
+ curx := 0;
+ cury := 0;
+ goto 10
+ end else
+ octant := 2
+ else
+ octant := 1
+ else begin
+ x := -x;
+ if y = 0 then
+ octant := 4
+ else
+ octant := 2
+ end;
+ if y < 0 then begin
+ octant := octant + 2;
+ y := -y
+ end;
+ if x >= y then
+ x := x - y
+ else begin
+ octant := octant + 4;
+ x := y - x;
+ y := y - x
+ end {:489};
+ if odd(octantnumber[octant]) then
+ s := -1
+ else
+ s := +1;
+ h := p + octant;
+ w := mem[mem[h].hh.rh].hh.rh;
+ ww := mem[w].hh.rh;
+ n := mem[h].hh.lh;
+ while n > 1 do begin
+ if abvscd(x, mem[ww + 2].int - mem[w + 2].int, y, mem[ww + 1].int - mem[w + 1].int) <> s then
+ goto 30;
+ w := ww;
+ ww := mem[w].hh.rh;
+ n := n - 1
+ end;
+ 30:
+ unskew(mem[w + 1].int, mem[w + 2].int, octant);
+ 10:
+
+ end; {:488} {491:} {493:}
+
+ procedure splitforoffset(p: halfword; t: fraction);
+ var
+ q: halfword;
+ r: halfword;
+ begin
+ q := mem[p].hh.rh;
+ splitcubic(p, t, mem[q + 1].int, mem[q + 2].int);
+ r := mem[p].hh.rh;
+ if mem[r + 2].int < mem[p + 2].int then
+ mem[r + 2].int := mem[p + 2].int
+ else if mem[r + 2].int > mem[q + 2].int then
+ mem[r + 2].int := mem[q + 2].int;
+ if mem[r + 1].int < mem[p + 1].int then
+ mem[r + 1].int := mem[p + 1].int
+ else if mem[r + 1].int > mem[q + 1].int then
+ mem[r + 1].int := mem[q + 1].int
+ end; {:493} {497:}
+
+ procedure finoffsetprep(p: halfword; k: halfword; w: halfword; x0, x1, x2, y0, y1, y2: integer; rising: boolean; n: integer);
+ label
+ 10;
+ var
+ q, ww: halfword;
+ du, dv: scaled;
+ t0, t1, t2: integer;
+ t: fraction;
+ s: fraction;
+ v: integer;
+ begin
+ while true do begin
+ q := mem[p].hh.rh;
+ mem[p].hh.b1 := k;
+ if rising then
+ if k = n then
+ goto 10
+ else
+ ww := mem[w].hh.rh
+ else if k = 1 then
+ goto 10
+ else
+ ww := mem[w].hh.lh; {498:}
+ du := mem[ww + 1].int - mem[w + 1].int;
+ dv := mem[ww + 2].int - mem[w + 2].int;
+ if abs(du) >= abs(dv) then begin
+ s := makefraction(dv, du);
+ t0 := takefraction(x0, s) - y0;
+ t1 := takefraction(x1, s) - y1;
+ t2 := takefraction(x2, s) - y2
+ end else begin
+ s := makefraction(du, dv);
+ t0 := x0 - takefraction(y0, s);
+ t1 := x1 - takefraction(y1, s);
+ t2 := x2 - takefraction(y2, s)
+ end {:498};
+ t := crossingpoint(t0, t1, t2);
+ if t >= 268435456 then
+ goto 10; {499:}
+ begin
+ splitforoffset(p, t);
+ mem[p].hh.b1 := k;
+ p := mem[p].hh.rh;
+ v := x0 - takefraction(x0 - x1, t);
+ x1 := x1 - takefraction(x1 - x2, t);
+ x0 := v - takefraction(v - x1, t);
+ v := y0 - takefraction(y0 - y1, t);
+ y1 := y1 - takefraction(y1 - y2, t);
+ y0 := v - takefraction(v - y1, t);
+ t1 := t1 - takefraction(t1 - t2, t);
+ if t1 > 0 then
+ t1 := 0;
+ t := crossingpoint(0, -t1, -t2);
+ if t < 268435456 then begin
+ splitforoffset(p, t);
+ mem[mem[p].hh.rh].hh.b1 := k;
+ v := x1 - takefraction(x1 - x2, t);
+ x1 := x0 - takefraction(x0 - x1, t);
+ x2 := x1 - takefraction(x1 - v, t);
+ v := y1 - takefraction(y1 - y2, t);
+ y1 := y0 - takefraction(y0 - y1, t);
+ y2 := y1 - takefraction(y1 - v, t)
+ end
+ end {:499};
+ if rising then
+ k := k + 1
+ else
+ k := k - 1;
+ w := ww
+ end;
+ 10:
+
+ end; {:497}
+
+ procedure offsetprep(c, h: halfword);
+ label
+ 30, 45;
+ var
+ n: halfword;
+ p, q, r, lh, ww: halfword;
+ k: halfword;
+ w: halfword; {495:}
+ x0, x1, x2, y0, y1, y2: integer;
+ t0, t1, t2: integer;
+ du, dv, dx, dy: integer;
+ maxcoef: integer;
+ x0a, x1a, x2a, y0a, y1a, y2a: integer;
+ t: fraction;
+ s: fraction;
+ {:495}
+ begin
+ p := c;
+ n := mem[h].hh.lh;
+ lh := mem[h].hh.rh;
+ while mem[p].hh.b1 <> 0 do begin
+ q := mem[p].hh.rh; {494:}
+ if n <= 1 then
+ mem[p].hh.b1 := 1
+ else begin {496:}
+ x0 := mem[p + 5].int - mem[p + 1].int;
+ x2 := mem[q + 1].int - mem[q + 3].int;
+ x1 := mem[q + 3].int - mem[p + 5].int;
+ y0 := mem[p + 6].int - mem[p + 2].int;
+ y2 := mem[q + 2].int - mem[q + 4].int;
+ y1 := mem[q + 4].int - mem[p + 6].int;
+ maxcoef := abs(x0);
+ if abs(x1) > maxcoef then
+ maxcoef := abs(x1);
+ if abs(x2) > maxcoef then
+ maxcoef := abs(x2);
+ if abs(y0) > maxcoef then
+ maxcoef := abs(y0);
+ if abs(y1) > maxcoef then
+ maxcoef := abs(y1);
+ if abs(y2) > maxcoef then
+ maxcoef := abs(y2);
+ if maxcoef = 0 then
+ goto 45;
+ while maxcoef < 268435456 do begin
+ maxcoef := maxcoef + maxcoef;
+ x0 := x0 + x0;
+ x1 := x1 + x1;
+ x2 := x2 + x2;
+ y0 := y0 + y0;
+ y1 := y1 + y1;
+ y2 := y2 + y2
+ end {:496}; {501:}
+ dx := x0;
+ dy := y0;
+ if dx = 0 then
+ if dy = 0 then begin
+ dx := x1;
+ dy := y1;
+ if dx = 0 then
+ if dy = 0 then begin
+ dx := x2;
+ dy := y2
+ end
+ end {:501};
+ if dx = 0 then {505:}
+ finoffsetprep(p, n, mem[mem[lh].hh.lh].hh.lh, -x0, -x1, -x2, -y0, -y1, -y2, false, n) {:505}
+ else begin {502:}
+ k := 1;
+ w := mem[lh].hh.rh;
+ while true do begin
+ if k = n then
+ goto 30;
+ ww := mem[w].hh.rh;
+ if abvscd(dy, abs(mem[ww + 1].int - mem[w + 1].int), dx, abs(mem[ww + 2].int - mem[w + 2].int)) >= 0 then begin
+ k := k + 1;
+ w := ww
+ end else
+ goto 30
+ end;
+ 30: {:502}
+ ;
+ {503:}
+ if k = 1 then
+ t := 268435457
+ else begin
+ ww := mem[w].hh.lh; {498:}
+ du := mem[ww + 1].int - mem[w + 1].int;
+ dv := mem[ww + 2].int - mem[w + 2].int;
+ if abs(du) >= abs(dv) then begin
+ s := makefraction(dv, du);
+ t0 := takefraction(x0, s) - y0;
+ t1 := takefraction(x1, s) - y1;
+ t2 := takefraction(x2, s) - y2
+ end else begin
+ s := makefraction(du, dv);
+ t0 := x0 - takefraction(y0, s);
+ t1 := x1 - takefraction(y1, s);
+ t2 := x2 - takefraction(y2, s)
+ end {:498};
+ t := crossingpoint(-t0, -t1, -t2)
+ end;
+ if t >= 268435456 then
+ finoffsetprep(p, k, w, x0, x1, x2, y0, y1, y2, true, n)
+ else begin
+ splitforoffset(p, t);
+ r := mem[p].hh.rh;
+ x1a := x0 - takefraction(x0 - x1, t);
+ x1 := x1 - takefraction(x1 - x2, t);
+ x2a := x1a - takefraction(x1a - x1, t);
+ y1a := y0 - takefraction(y0 - y1, t);
+ y1 := y1 - takefraction(y1 - y2, t);
+ y2a := y1a - takefraction(y1a - y1, t);
+ finoffsetprep(p, k, w, x0, x1a, x2a, y0, y1a, y2a, true, n);
+ x0 := x2a;
+ y0 := y2a;
+ t1 := t1 - takefraction(t1 - t2, t);
+ if t1 < 0 then
+ t1 := 0;
+ t := crossingpoint(0, t1, t2);
+ if t < 268435456 then begin {504:}
+ splitforoffset(r, t);
+ x1a := x1 - takefraction(x1 - x2, t);
+ x1 := x0 - takefraction(x0 - x1, t);
+ x0a := x1 - takefraction(x1 - x1a, t);
+ y1a := y1 - takefraction(y1 - y2, t);
+ y1 := y0 - takefraction(y0 - y1, t);
+ y0a := y1 - takefraction(y1 - y1a, t);
+ finoffsetprep(mem[r].hh.rh, k, w, x0a, x1a, x2, y0a, y1a, y2, true, n);
+ x2 := x0a;
+ y2 := y0a
+ end {:504};
+ finoffsetprep(r, k - 1, ww, -x0, -x1, -x2, -y0, -y1, -y2, false, n)
+ end {:503}
+ end;
+ 45: {:494}
+
+ end; {492:}
+ repeat
+ r := mem[p].hh.rh;
+ if mem[p + 1].int = mem[p + 5].int then
+ if mem[p + 2].int = mem[p + 6].int then
+ if mem[p + 1].int = mem[r + 3].int then
+ if mem[p + 2].int = mem[r + 4].int then
+ if mem[p + 1].int = mem[r + 1].int then
+ if mem[p + 2].int = mem[r + 2].int then begin
+ removecubic(p);
+ if r = q then
+ q := p;
+ r := p
+ end;
+ p := r
+ until p = q {:492}
+ end
+ end; { offsetprep }
+ {:491}
+ {506:}
+ {510:}
+
+ procedure skewlineedges(p, w, ww: halfword);
+ var
+ x0, y0, x1, y1: scaled;
+ begin
+ if (mem[w + 1].int <> mem[ww + 1].int) or (mem[w + 2].int <> mem[ww + 2].int) then begin
+ x0 := mem[p + 1].int + mem[w + 1].int;
+ y0 := mem[p + 2].int + mem[w + 2].int;
+ x1 := mem[p + 1].int + mem[ww + 1].int;
+ y1 := mem[p + 2].int + mem[ww + 2].int;
+ {-------------------------------------}
+ sendline(x0,y0,x1,y1,octant,510);
+ {-------------------------------------}
+ unskew(x0, y0, octant);
+ x0 := curx;
+ y0 := cury;
+ unskew(x1, y1, octant);
+ {if internal[10]>65536 then begin printnl(451);printtwo(x0,y0);
+ print(450);printtwo(curx,cury);printnl(155);end;}
+ lineedges(x0, y0, curx, cury)
+ end
+ end; {:510} {518:}
+
+ procedure dualmoves(h, p, q: halfword);
+ label
+ 30, 31;
+ var
+ r, s: halfword; {511:}
+ m, n: integer;
+ mm0, mm1: integer;
+ k: integer;
+ w, ww: halfword;
+ smoothbot, smoothtop: 0..movesize;
+ xx, yy, xp, yp, delx, dely, tx, ty: scaled;
+ {:511} {519:}
+ begin
+ k := mem[h].hh.lh + 1;
+ ww := mem[h].hh.rh;
+ w := mem[ww].hh.lh;
+ mm0 := floorunscaled((mem[p + 1].int + mem[w + 1].int) - xycorr[octant]);
+ mm1 := floorunscaled((mem[q + 1].int + mem[ww + 1].int) - xycorr[octant]);
+ for n := 1 to (n1 - n0) + 1 do
+ envmove[n] := mm1;
+ envmove[0] := mm0;
+ moveptr := 0;
+ m := mm0 {:519};
+ r := p;
+ while true do begin
+ if r = q then
+ smoothtop := moveptr;
+ while mem[r].hh.b1 <> k do begin {521:}
+ xx := mem[r + 1].int + mem[w + 1].int;
+ yy := (mem[r + 2].int + mem[w + 2].int) + 32768;
+ {if internal[10]>65536 then begin printnl(452);printint(k);print(453);
+ unskew(xx,yy-32768,octant);printtwo(curx,cury);end;}
+ {------------}
+ my_xx := xx;
+ my_yy := yy;
+ {------------}
+ if mem[r].hh.b1 < k then begin
+ k := k - 1;
+ w := mem[w].hh.lh;
+ xp := mem[r + 1].int + mem[w + 1].int;
+ yp := (mem[r + 2].int + mem[w + 2].int) + 32768;
+ if yp <> yy then begin {522:}
+ ty := floorscaled(yy - ycorr[octant]);
+ dely := yp - yy;
+ yy := yy - ty;
+ ty := (yp - ycorr[octant]) - ty;
+ if ty >= 65536 then begin
+ delx := xp - xx;
+ yy := 65536 - yy;
+ while true do begin
+ if m < envmove[moveptr] then
+ envmove[moveptr] := m;
+ tx := takefraction(delx, makefraction(yy, dely));
+ if (abvscd(tx, dely, delx, yy) + xycorr[octant]) > 0 then
+ tx := tx - 1;
+ m := floorunscaled(xx + tx);
+ ty := ty - 65536;
+ moveptr := moveptr + 1;
+ if ty < 65536 then
+ goto 31;
+ yy := yy + 65536
+ end;
+ 31:
+ if m < envmove[moveptr] then
+ envmove[moveptr] := m
+ end
+ end {:522}
+ end else begin
+ k := k + 1;
+ w := mem[w].hh.rh;
+ xp := mem[r + 1].int + mem[w + 1].int;
+ yp := (mem[r + 2].int + mem[w + 2].int) + 32768;
+ end;
+ {if internal[10]>65536 then begin print(450);unskew(xp,yp-32768,octant);
+ printtwo(curx,cury);printnl(155);end;}
+ {---------------------------------------------------}
+ sendline(my_xx,my_yy-32768,xp,yp-32768,octant,521);
+ {---------------------------------------------------}
+ m := floorunscaled(xp - xycorr[octant]);
+ moveptr := floorunscaled(yp - ycorr[octant]) - n0;
+ if m < envmove[moveptr] then
+ envmove[moveptr] := m
+ end {:521};
+ if r = p then
+ smoothbot := moveptr;
+ if r = q then
+ goto 30;
+ move[moveptr] := 1;
+ n := moveptr;
+ s := mem[r].hh.rh;
+ makemoves(mem[r + 1].int + mem[w + 1].int, mem[r + 5].int + mem[w + 1].int, mem[s + 3].int + mem[w + 1].int, mem[s + 1].int + mem[w + 1].int, (mem[r + 2].int + mem[w + 2].int) + 32768, (mem[r + 6].int + mem[w + 2].int) + 32768, (mem[s + 4].int + mem[w + 2].int) + 32768, (mem[s + 2].int + mem[w + 2].int) + 32768, xycorr[octant], ycorr[octant],518,octant); {520:}
+ repeat
+ if m < envmove[n] then
+ envmove[n] := m;
+ m := (m + move[n]) - 1;
+ n := n + 1
+ until n > moveptr {:520};
+ r := s
+ end;
+ 30: {523:}
+ {if(m<>mm1)or(moveptr<>n1-n0)then confusion(50);}
+ move[0] := (d0 + envmove[1]) - mm0;
+ for n := 1 to moveptr do
+ move[n] := (envmove[n + 1] - envmove[n]) + 1;
+ move[moveptr] := move[moveptr] - d1;
+ if internal[35] > 0 then
+ smoothmoves(smoothbot, smoothtop);
+ movetoedges(m0, n0, m1, n1);
+ if mem[q + 6].int = 1 then begin
+ w := mem[h].hh.rh;
+ skewlineedges(q, w, mem[w].hh.lh)
+ end {:523}
+ end; {:518}
+
+ procedure fillenvelope(spechead: halfword);
+ label
+ 30, 31;
+ var
+ p, q, r, s: halfword;
+ h: halfword;
+ www: halfword; {511:}
+ m, n: integer;
+ mm0, mm1: integer;
+ k: integer;
+ w, ww: halfword;
+ smoothbot, smoothtop: 0..movesize;
+ xx, yy, xp, yp, delx, dely, tx, ty: scaled; {:511}
+ begin
+ if internal[10] > 0 then
+ beginedgetracing;
+ {------------------------------------}
+ print_start(psfile); { Start cycle }
+ {------------------------------------}
+ p := spechead;
+ repeat
+ octant := mem[p + 3].int;
+ h := curpen + octant; {466:}
+ q := p;
+ while mem[q].hh.b1 <> 0 do
+ q := mem[q].hh.rh {:466}; {508:}
+ w := mem[h].hh.rh;
+ if mem[p + 4].int = 1 then
+ w := mem[w].hh.lh;
+ {if internal[10]>65536 then[509:]begin printnl(447);
+ print(octantdir[octant]);print(425);printint(mem[h].hh.lh);print(448);
+ if mem[h].hh.lh<>1 then printchar(115);print(449);
+ unskew(mem[p+1].int+mem[w+1].int,mem[p+2].int+mem[w+2].int,octant);
+ printtwo(curx,cury);ww:=mem[h].hh.rh;
+ if mem[q+6].int=1 then ww:=mem[ww].hh.lh;print(450);
+ unskew(mem[q+1].int+mem[ww+1].int,mem[q+2].int+mem[ww+2].int,octant);
+ printtwo(curx,cury);end[:509];}
+ ww := mem[h].hh.rh;
+ www := ww;
+ if odd(octantnumber[octant]) then
+ www := mem[www].hh.lh
+ else
+ ww := mem[ww].hh.lh;
+ if w <> ww then
+ skewlineedges(p, w, ww);
+ endround(mem[p + 1].int + mem[ww + 1].int, mem[p + 2].int + mem[ww + 2].int);
+ m0 := m1;
+ n0 := n1;
+ d0 := d1;
+ endround(mem[q + 1].int + mem[www + 1].int, mem[q + 2].int + mem[www + 2].int);
+ if (n1 - n0) >= movesize then
+ overflow(407, movesize) {:508};
+ offsetprep(p, h);
+ {466:}
+ q := p;
+ while mem[q].hh.b1 <> 0 do
+ q := mem[q].hh.rh {:466}; {512:}
+ if odd(octantnumber[octant]) then begin {513:}
+ k := 0;
+ w := mem[h].hh.rh;
+ ww := mem[w].hh.lh;
+ mm0 := floorunscaled((mem[p + 1].int + mem[w + 1].int) - xycorr[octant]);
+ mm1 := floorunscaled((mem[q + 1].int + mem[ww + 1].int) - xycorr[octant]);
+ for n := 0 to n1 - n0 do
+ envmove[n] := mm0;
+ envmove[n1 - n0] := mm1;
+ moveptr := 0;
+ m := mm0 {:513};
+ r := p;
+ mem[q].hh.b1 := mem[h].hh.lh + 1;
+ while true do begin
+ if r = q then
+ smoothtop := moveptr;
+ while mem[r].hh.b1 <> k do begin {515:}
+ xx := mem[r + 1].int + mem[w + 1].int;
+ yy := (mem[r + 2].int + mem[w + 2].int) + 32768;
+ {if internal[10]>65536 then begin printnl(452);printint(k);print(453);
+ unskew(xx,yy-32768,octant);printtwo(curx,cury);end;}
+ {------------}
+ my_xx := xx;
+ my_yy := yy;
+ {------------}
+ if mem[r].hh.b1 > k then begin
+ k := k + 1;
+ w := mem[w].hh.rh;
+ xp := mem[r + 1].int + mem[w + 1].int;
+ yp := (mem[r + 2].int + mem[w + 2].int) + 32768;
+ if yp <> yy then begin {516:}
+ ty := floorscaled(yy - ycorr[octant]);
+ dely := yp - yy;
+ yy := yy - ty;
+ ty := (yp - ycorr[octant]) - ty;
+ if ty >= 65536 then begin
+ delx := xp - xx;
+ yy := 65536 - yy;
+ while true do begin
+ tx := takefraction(delx, makefraction(yy, dely));
+ if (abvscd(tx, dely, delx, yy) + xycorr[octant]) > 0 then
+ tx := tx - 1;
+ m := floorunscaled(xx + tx);
+ if m > envmove[moveptr] then
+ envmove[moveptr] := m;
+ ty := ty - 65536;
+ if ty < 65536 then
+ goto 31;
+ yy := yy + 65536;
+ moveptr := moveptr + 1
+ end;
+ 31:
+
+ end
+ end {:516}
+ end else begin
+ k := k - 1;
+ w := mem[w].hh.lh;
+ xp := mem[r + 1].int + mem[w + 1].int;
+ yp := (mem[r + 2].int + mem[w + 2].int) + 32768;
+ end;
+ {if internal[10]>65536 then begin print(450);unskew(xp,yp-32768,octant);
+ printtwo(curx,cury);printnl(155);end;}
+ {---------------------------------------------------}
+ sendline(my_xx,my_yy-32768,xp,yp-32768,octant,515);
+ {---------------------------------------------------}
+ m := floorunscaled(xp - xycorr[octant]);
+ moveptr := floorunscaled(yp - ycorr[octant]) - n0;
+ if m > envmove[moveptr] then
+ envmove[moveptr] := m
+ end {:515};
+ if r = p then
+ smoothbot := moveptr;
+ if r = q then
+ goto 30;
+ move[moveptr] := 1;
+ n := moveptr;
+ s := mem[r].hh.rh;
+ makemoves(mem[r + 1].int + mem[w + 1].int, mem[r + 5].int + mem[w + 1].int, mem[s + 3].int + mem[w + 1].int, mem[s + 1].int + mem[w + 1].int, (mem[r + 2].int + mem[w + 2].int) + 32768, (mem[r + 6].int + mem[w + 2].int) + 32768, (mem[s + 4].int + mem[w + 2].int) + 32768, (mem[s + 2].int + mem[w + 2].int) + 32768, xycorr[octant], ycorr[octant],512,octant); {514:}
+ repeat
+ m := (m + move[n]) - 1;
+ if m > envmove[n] then
+ envmove[n] := m;
+ n := n + 1
+ until n > moveptr {:514};
+ r := s
+ end;
+ 30: {517:}
+ {if(m<>mm1)or(moveptr<>n1-n0)then confusion(49);}
+ move[0] := (d0 + envmove[0]) - mm0;
+ for n := 1 to moveptr do
+ move[n] := (envmove[n] - envmove[n - 1]) + 1;
+ move[moveptr] := move[moveptr] - d1;
+ if internal[35] > 0 then
+ smoothmoves(smoothbot, smoothtop);
+ movetoedges(m0, n0, m1, n1);
+ if mem[q + 6].int = 0 then begin
+ w := mem[h].hh.rh;
+ skewlineedges(q, mem[w].hh.lh, w)
+ end {:517}
+ end else
+ dualmoves(h, p, q);
+ mem[q].hh.b1 := 0 {:512};
+ p := mem[q].hh.rh
+ until p = spechead;
+ {------------------------------------}
+ print_end(psfile); { End cycle }
+ {------------------------------------}
+ if internal[10] > 0 then
+ endedgetracing;
+ tossknotlist(spechead)
+ end; {:506}
+ {527:}
+
+ function makeellipse(majoraxis, minoraxis: scaled; theta: angle): halfword;
+ label
+ 30, 31, 40;
+ var
+ p, q, r, s: halfword;
+ h: halfword;
+ alpha, beta, gamma, delta: integer;
+ c, d: integer;
+ u, v: integer;
+ symmetric: boolean; {528:}
+ begin {530:}
+ if (majoraxis = minoraxis) or ((theta mod 94371840) = 0) then begin
+ symmetric := true;
+ alpha := 0;
+ if odd(theta div 94371840) then begin
+ beta := majoraxis;
+ gamma := minoraxis;
+ nsin := 268435456;
+ ncos := 0
+ end else begin
+ beta := minoraxis;
+ gamma := majoraxis
+ end
+ end else begin
+ symmetric := false;
+ nsincos(theta);
+ gamma := takefraction(majoraxis, nsin);
+ delta := takefraction(minoraxis, ncos);
+ beta := pythadd(gamma, delta);
+ alpha := takefraction(takefraction(majoraxis, makefraction(gamma, beta)), ncos) - takefraction(takefraction(minoraxis, makefraction(delta, beta)), nsin);
+ alpha := (alpha + 32768) div 65536;
+ gamma := pythadd(takefraction(majoraxis, ncos), takefraction(minoraxis, nsin))
+ end;
+ beta := (beta + 32768) div 65536;
+ gamma := (gamma + 32768) div 65536 {:530};
+ p := getnode(7);
+ q := getnode(7);
+ r := getnode(7);
+ if symmetric then
+ s := -30000
+ else
+ s := getnode(7);
+ h := p;
+ mem[p].hh.rh := q;
+ mem[q].hh.rh := r;
+ mem[r].hh.rh := s; {529:}
+ if beta = 0 then
+ beta := 1;
+ if gamma = 0 then
+ gamma := 1;
+ if gamma <= abs(alpha) then
+ if alpha > 0 then
+ alpha := gamma - 1
+ else
+ alpha := 1 - gamma {:529};
+ mem[p + 1].int := -(alpha * 32768);
+ mem[p + 2].int := -(beta * 32768);
+ mem[q + 1].int := gamma * 32768;
+ mem[q + 2].int := mem[p + 2].int;
+ mem[r + 1].int := mem[q + 1].int;
+ mem[p + 5].int := 0;
+ mem[q + 3].int := -32768;
+ mem[q + 5].int := 32768;
+ mem[r + 3].int := 0;
+ mem[r + 5].int := 0;
+ mem[p + 6].int := beta;
+ mem[q + 6].int := gamma;
+ mem[r + 6].int := beta;
+ mem[q + 4].int := gamma + alpha;
+ if symmetric then begin
+ mem[r + 2].int := 0;
+ mem[r + 4].int := beta
+ end else begin
+ mem[r + 2].int := -mem[p + 2].int;
+ mem[r + 4].int := beta + beta;
+ mem[s + 1].int := -mem[p + 1].int;
+ mem[s + 2].int := mem[r + 2].int;
+ mem[s + 3].int := 32768;
+ mem[s + 4].int := gamma - alpha
+ end {:528}; {531:}
+ while true do begin
+ u := mem[p + 5].int + mem[q + 5].int;
+ v := mem[q + 3].int + mem[r + 3].int;
+ c := mem[p + 6].int + mem[q + 6].int; {533:}
+ delta := pythadd(u, v);
+ if majoraxis = minoraxis then
+ d := majoraxis
+ else begin
+ if theta = 0 then begin
+ alpha := u;
+ beta := v
+ end else begin
+ alpha := takefraction(u, ncos) + takefraction(v, nsin);
+ beta := takefraction(v, ncos) - takefraction(u, nsin)
+ end;
+ alpha := makefraction(alpha, delta);
+ beta := makefraction(beta, delta);
+ d := pythadd(takefraction(majoraxis, alpha), takefraction(minoraxis, beta))
+ end;
+ d := takefraction(d, delta);
+ alpha := abs(u);
+ beta := abs(v);
+ if alpha < beta then begin
+ delta := alpha;
+ alpha := beta;
+ beta := delta
+ end;
+ if internal[38] <> 0 then
+ d := d - takefraction(internal[38], beta + beta);
+ d := (d + 4) div 8;
+ alpha := alpha div 32768;
+ if d < alpha then
+ d := alpha {:533};
+ delta := c - d;
+ if delta > 0 then begin
+ if delta > mem[r + 4].int then
+ delta := mem[r + 4].int;
+ if delta >= mem[q + 4].int then begin {534:}
+ delta := mem[q + 4].int;
+ mem[p + 6].int := c - delta;
+ mem[p + 5].int := u;
+ mem[q + 3].int := v;
+ mem[q + 1].int := mem[q + 1].int - (delta * mem[r + 3].int);
+ mem[q + 2].int := mem[q + 2].int + (delta * mem[q + 5].int);
+ mem[r + 4].int := mem[r + 4].int - delta
+ end else begin {:534} {535:}
+ s := getnode(7);
+ mem[p].hh.rh := s;
+ mem[s].hh.rh := q;
+ mem[s + 1].int := mem[q + 1].int + (delta * mem[q + 3].int);
+ mem[s + 2].int := mem[q + 2].int - (delta * mem[p + 5].int);
+ mem[q + 1].int := mem[q + 1].int - (delta * mem[r + 3].int);
+ mem[q + 2].int := mem[q + 2].int + (delta * mem[q + 5].int);
+ mem[s + 3].int := mem[q + 3].int;
+ mem[s + 5].int := u;
+ mem[q + 3].int := v;
+ mem[s + 6].int := c - delta;
+ mem[s + 4].int := mem[q + 4].int - delta;
+ mem[q + 4].int := delta;
+ mem[r + 4].int := mem[r + 4].int - delta
+ end {:535}
+ end else
+ p := q; {532:}
+ while true do begin
+ q := mem[p].hh.rh;
+ if q = (-30000) then
+ goto 30;
+ if mem[q + 4].int = 0 then begin
+ mem[p].hh.rh := mem[q].hh.rh;
+ mem[p + 6].int := mem[q + 6].int;
+ mem[p + 5].int := mem[q + 5].int;
+ freenode(q, 7)
+ end else begin
+ r := mem[q].hh.rh;
+ if r = (-30000) then
+ goto 30;
+ if mem[r + 4].int = 0 then begin
+ mem[p].hh.rh := r;
+ freenode(q, 7);
+ p := r
+ end else
+ goto 40
+ end
+ end;
+ 40: {:532}
+
+ end;
+ 30: {:531}
+ ;
+ if symmetric then begin {536:}
+ s := -30000;
+ q := h;
+ while true do begin
+ r := getnode(7);
+ mem[r].hh.rh := s;
+ s := r;
+ mem[s + 1].int := mem[q + 1].int;
+ mem[s + 2].int := -mem[q + 2].int;
+ if q = p then
+ goto 31;
+ q := mem[q].hh.rh;
+ if mem[q + 2].int = 0 then
+ goto 31
+ end;
+ 31:
+ mem[p].hh.rh := s;
+ beta := -mem[h + 2].int;
+ while mem[p + 2].int <> beta do
+ p := mem[p].hh.rh;
+ q := mem[p].hh.rh
+ end {:536};
+ {537:}
+ if q <> (-30000) then begin
+ if mem[h + 5].int = 0 then begin
+ p := h;
+ h := mem[h].hh.rh;
+ freenode(p, 7);
+ mem[q + 1].int := -mem[h + 1].int
+ end;
+ p := q
+ end else
+ q := p;
+ r := mem[h].hh.rh;
+ repeat
+ s := getnode(7);
+ mem[p].hh.rh := s;
+ p := s;
+ mem[p + 1].int := -mem[r + 1].int;
+ mem[p + 2].int := -mem[r + 2].int;
+ r := mem[r].hh.rh
+ until r = q;
+ mem[p].hh.rh := h {:537};
+ makeellipse := h
+ end; {:527} {539:}
+
+ function finddirectiontime(x, y: scaled; h: halfword): scaled;
+ label
+ 10, 40, 45, 30;
+ var
+ max: scaled;
+ p, q: halfword;
+ n: scaled;
+ tt: scaled; {542:}
+ x1, x2, x3, y1, y2, y3: scaled;
+ theta, phi: angle;
+ t: fraction; {:542} {540:}
+ begin
+ if abs(x) < abs(y) then begin
+ x := makefraction(x, abs(y));
+ if y > 0 then
+ y := 268435456
+ else
+ y := -268435456
+ end else if x = 0 then begin
+ finddirectiontime := 0;
+ goto 10
+ end else begin
+ y := makefraction(y, abs(x));
+ if x > 0 then
+ x := 268435456
+ else
+ x := -268435456
+ end {:540};
+ n := 0;
+ p := h;
+ while true do begin
+ if mem[p].hh.b1 = 0 then
+ goto 45;
+ q := mem[p].hh.rh;
+ {541:}
+ tt := 0; {543:}
+ x1 := mem[p + 5].int - mem[p + 1].int;
+ x2 := mem[q + 3].int - mem[p + 5].int;
+ x3 := mem[q + 1].int - mem[q + 3].int;
+ y1 := mem[p + 6].int - mem[p + 2].int;
+ y2 := mem[q + 4].int - mem[p + 6].int;
+ y3 := mem[q + 2].int - mem[q + 4].int;
+ max := abs(x1);
+ if abs(x2) > max then
+ max := abs(x2);
+ if abs(x3) > max then
+ max := abs(x3);
+ if abs(y1) > max then
+ max := abs(y1);
+ if abs(y2) > max then
+ max := abs(y2);
+ if abs(y3) > max then
+ max := abs(y3);
+ if max = 0 then
+ goto 40;
+ while max < 134217728 do begin
+ max := max + max;
+ x1 := x1 + x1;
+ x2 := x2 + x2;
+ x3 := x3 + x3;
+ y1 := y1 + y1;
+ y2 := y2 + y2;
+ y3 := y3 + y3
+ end;
+ t := x1;
+ x1 := takefraction(x1, x) + takefraction(y1, y);
+ y1 := takefraction(y1, x) - takefraction(t, y);
+ t := x2;
+ x2 := takefraction(x2, x) + takefraction(y2, y);
+ y2 := takefraction(y2, x) - takefraction(t, y);
+ t := x3;
+ x3 := takefraction(x3, x) + takefraction(y3, y);
+ y3 := takefraction(y3, x) - takefraction(t, y) {:543};
+ if y1 = 0 then
+ if x1 >= 0 then
+ goto 40;
+ if n > 0 then begin {544:}
+ theta := narg(x1, y1);
+ if theta >= 0 then
+ if phi <= 0 then
+ if phi >= (theta - 188743680) then
+ goto 40;
+ {:
+ 544}
+ if theta <= 0 then
+ if phi >= 0 then
+ if phi <= (theta + 188743680) then
+ goto 40;
+ if p = h then
+ goto 45
+ end;
+ if (x3 <> 0) or (y3 <> 0) then
+ phi := narg(x3, y3);
+ {546:}
+ if x1 < 0 then
+ if x2 < 0 then
+ if x3 < 0 then
+ goto 30;
+ if abvscd(y1, y3, y2, y2) = 0 then begin {548:}
+ if abvscd(y1, y2, 0, 0) < 0 then begin
+ t := makefraction(y1, y1 - y2);
+ x1 := x1 - takefraction(x1 - x2, t);
+ x2 := x2 - takefraction(x2 - x3, t);
+ if (x1 - takefraction(x1 - x2, t)) >= 0 then begin
+ tt := (t + 2048) div 4096;
+ goto 40
+ end
+ end else if y3 = 0 then
+ if y1 = 0 then begin {549:}
+ t := crossingpoint(-x1, -x2, -x3);
+ if t <= 268435456 then begin
+ tt := (t + 2048) div 4096;
+ goto 40
+ end;
+ if abvscd(x1, x3, x2, x2) <= 0 then begin
+ t := makefraction(x1, x1 - x2);
+ begin
+ tt := (t + 2048) div 4096;
+ goto 40
+ end
+ end
+ end else if x3 >= 0 then begin {:549}
+ tt := 65536;
+ goto 40
+ end;
+ goto 30
+ end {:548};
+ if y1 <= 0 then
+ if y1 < 0 then begin
+ y1 := -y1;
+ y2 := -y2;
+ y3 := -y3
+ end else if y2 > 0 then begin
+ y2 := -y2;
+ y3 := -y3
+ end; {547:}
+ t := crossingpoint(y1, y2, y3);
+ if t > 268435456 then
+ goto 30;
+ y2 := y2 - takefraction(y2 - y3, t);
+ x1 := x1 - takefraction(x1 - x2, t);
+ x2 := x2 - takefraction(x2 - x3, t);
+ x1 := x1 - takefraction(x1 - x2, t);
+ if x1 >= 0 then begin
+ tt := (t + 2048) div 4096;
+ goto 40
+ end;
+ if y2 > 0 then
+ y2 := 0;
+ tt := t;
+ t := crossingpoint(0, -y2, -y3);
+ if t > 268435456 then
+ goto 30;
+ x1 := x1 - takefraction(x1 - x2, t);
+ x2 := x2 - takefraction(x2 - x3, t);
+ if (x1 - takefraction(x1 - x2, t)) >= 0 then begin
+ t := tt - takefraction(tt - 268435456, t);
+ begin
+ tt := (t + 2048) div 4096;
+ goto 40
+ end
+ end {:547};
+ 30: {:546}
+ {:541}
+ ;
+ p := q;
+ n := n + 65536
+ end;
+ 45:
+ finddirectiontime := -65536;
+ goto 10;
+ 40:
+ finddirectiontime := n + tt;
+ 10:
+
+ end; {:539} {556:}
+
+ procedure cubicintersection(p, pp: halfword);
+ label
+ 22, 45, 10;
+ var
+ q, qq: halfword;
+ begin
+ timetogo := 5000;
+ maxt := 2; {558:}
+ q := mem[p].hh.rh;
+ qq := mem[pp].hh.rh;
+ bisectptr := 20;
+ bisectstack[bisectptr - 5] := mem[p + 5].int - mem[p + 1].int;
+ bisectstack[bisectptr - 4] := mem[q + 3].int - mem[p + 5].int;
+ bisectstack[bisectptr - 3] := mem[q + 1].int - mem[q + 3].int;
+ if bisectstack[bisectptr - 5] < 0 then
+ if bisectstack[bisectptr - 3] >= 0 then begin
+ if bisectstack[bisectptr - 4] < 0 then
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]
+ else
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 1] < 0 then
+ bisectstack[bisectptr - 1] := 0
+ end else begin
+ bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 2] > bisectstack[bisectptr - 5] then
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4];
+ if bisectstack[bisectptr - 1] < 0 then
+ bisectstack[bisectptr - 1] := 0
+ end
+ else if bisectstack[bisectptr - 3] <= 0 then begin
+ if bisectstack[bisectptr - 4] > 0 then
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]
+ else
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 2] > 0 then
+ bisectstack[bisectptr - 2] := 0
+ end else begin
+ bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 1] < bisectstack[bisectptr - 5] then
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4];
+ if bisectstack[bisectptr - 2] > 0 then
+ bisectstack[bisectptr - 2] := 0
+ end;
+ bisectstack[bisectptr - 10] := mem[p + 6].int - mem[p + 2].int;
+ bisectstack[bisectptr - 9] := mem[q + 4].int - mem[p + 6].int;
+ bisectstack[bisectptr - 8] := mem[q + 2].int - mem[q + 4].int;
+ if bisectstack[bisectptr - 10] < 0 then
+ if bisectstack[bisectptr - 8] >= 0 then begin
+ if bisectstack[bisectptr - 9] < 0 then
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]
+ else
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 6] < 0 then
+ bisectstack[bisectptr - 6] := 0
+ end else begin
+ bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 7] > bisectstack[bisectptr - 10] then
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9];
+ if bisectstack[bisectptr - 6] < 0 then
+ bisectstack[bisectptr - 6] := 0
+ end
+ else if bisectstack[bisectptr - 8] <= 0 then begin
+ if bisectstack[bisectptr - 9] > 0 then
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]
+ else
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 7] > 0 then
+ bisectstack[bisectptr - 7] := 0
+ end else begin
+ bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 6] < bisectstack[bisectptr - 10] then
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9];
+ if bisectstack[bisectptr - 7] > 0 then
+ bisectstack[bisectptr - 7] := 0
+ end;
+ bisectstack[bisectptr - 15] := mem[pp + 5].int - mem[pp + 1].int;
+ bisectstack[bisectptr - 14] := mem[qq + 3].int - mem[pp + 5].int;
+ bisectstack[bisectptr - 13] := mem[qq + 1].int - mem[qq + 3].int;
+ if bisectstack[bisectptr - 15] < 0 then
+ if bisectstack[bisectptr - 13] >= 0 then begin
+ if bisectstack[bisectptr - 14] < 0 then
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]
+ else
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 11] < 0 then
+ bisectstack[bisectptr - 11] := 0
+ end else begin
+ bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 12] > bisectstack[bisectptr - 15] then
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14];
+ if bisectstack[bisectptr - 11] < 0 then
+ bisectstack[bisectptr - 11] := 0
+ end
+ else if bisectstack[bisectptr - 13] <= 0 then begin
+ if bisectstack[bisectptr - 14] > 0 then
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]
+ else
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 12] > 0 then
+ bisectstack[bisectptr - 12] := 0
+ end else begin
+ bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 11] < bisectstack[bisectptr - 15] then
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14];
+ if bisectstack[bisectptr - 12] > 0 then
+ bisectstack[bisectptr - 12] := 0
+ end;
+ bisectstack[bisectptr - 20] := mem[pp + 6].int - mem[pp + 2].int;
+ bisectstack[bisectptr - 19] := mem[qq + 4].int - mem[pp + 6].int;
+ bisectstack[bisectptr - 18] := mem[qq + 2].int - mem[qq + 4].int;
+ if bisectstack[bisectptr - 20] < 0 then
+ if bisectstack[bisectptr - 18] >= 0 then begin
+ if bisectstack[bisectptr - 19] < 0 then
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]
+ else
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 16] < 0 then
+ bisectstack[bisectptr - 16] := 0
+ end else begin
+ bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 17] > bisectstack[bisectptr - 20] then
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19];
+ if bisectstack[bisectptr - 16] < 0 then
+ bisectstack[bisectptr - 16] := 0
+ end
+ else if bisectstack[bisectptr - 18] <= 0 then begin
+ if bisectstack[bisectptr - 19] > 0 then
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]
+ else
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 17] > 0 then
+ bisectstack[bisectptr - 17] := 0
+ end else begin
+ bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 16] < bisectstack[bisectptr - 20] then
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19];
+ if bisectstack[bisectptr - 17] > 0 then
+ bisectstack[bisectptr - 17] := 0
+ end;
+ delx := mem[p + 1].int - mem[pp + 1].int;
+ dely := mem[p + 2].int - mem[pp + 2].int;
+ tol := 0;
+ uv := bisectptr;
+ xy := bisectptr;
+ threel := 0;
+ curt := 1;
+ curtt := 1 {:558};
+ while true do begin
+ 22:
+ if (delx - tol) <= (bisectstack[xy - 11] - bisectstack[uv - 2]) then
+ if (delx + tol) >= (bisectstack[xy - 12] - bisectstack[uv - 1]) then
+ if (dely - tol) <= (bisectstack[xy - 16] - bisectstack[uv - 7]) then
+ if (dely + tol) >= (bisectstack[xy - 17] - bisectstack[uv - 6]) then begin
+ if curt >= maxt then begin
+ if maxt = 131072 then begin
+ curt := (curt + 1) div 2;
+ curtt := (curtt + 1) div 2;
+ goto 10
+ end;
+ maxt := maxt + maxt;
+ apprt := curt;
+ apprtt := curtt
+ end; {559:}
+ bisectstack[bisectptr] := delx;
+ bisectstack[bisectptr + 1] := dely;
+ bisectstack[bisectptr + 2] := tol;
+ bisectstack[bisectptr + 3] := uv;
+ bisectstack[bisectptr + 4] := xy;
+ bisectptr := bisectptr + 45;
+ curt := curt + curt;
+ curtt := curtt + curtt;
+ bisectstack[bisectptr - 25] := bisectstack[uv - 5];
+ bisectstack[bisectptr - 3] := bisectstack[uv - 3];
+ bisectstack[bisectptr - 24] := (bisectstack[bisectptr - 25] + bisectstack[uv - 4]) div 2;
+ bisectstack[bisectptr - 4] := (bisectstack[bisectptr - 3] + bisectstack[uv - 4]) div 2;
+ bisectstack[bisectptr - 23] := (bisectstack[bisectptr - 24] + bisectstack[bisectptr - 4]) div 2;
+ bisectstack[bisectptr - 5] := bisectstack[bisectptr - 23];
+ if bisectstack[bisectptr - 25] < 0 then
+ if bisectstack[bisectptr - 23] >= 0 then begin
+ if bisectstack[bisectptr - 24] < 0 then
+ bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]
+ else
+ bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25];
+ bisectstack[bisectptr - 21] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23];
+ if bisectstack[bisectptr - 21] < 0 then
+ bisectstack[bisectptr - 21] := 0
+ end else begin
+ bisectstack[bisectptr - 22] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23];
+ if bisectstack[bisectptr - 22] > bisectstack[bisectptr - 25] then
+ bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25];
+ bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24];
+ if bisectstack[bisectptr - 21] < 0 then
+ bisectstack[bisectptr - 21] := 0
+ end
+ else if bisectstack[bisectptr - 23] <= 0 then begin
+ if bisectstack[bisectptr - 24] > 0 then
+ bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]
+ else
+ bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25];
+ bisectstack[bisectptr - 22] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23];
+ if bisectstack[bisectptr - 22] > 0 then
+ bisectstack[bisectptr - 22] := 0
+ end else begin
+ bisectstack[bisectptr - 21] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23];
+ if bisectstack[bisectptr - 21] < bisectstack[bisectptr - 25] then
+ bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25];
+ bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24];
+ if bisectstack[bisectptr - 22] > 0 then
+ bisectstack[bisectptr - 22] := 0
+ end;
+ if bisectstack[bisectptr - 5] < 0 then
+ if bisectstack[bisectptr - 3] >= 0 then begin
+ if bisectstack[bisectptr - 4] < 0 then
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]
+ else
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 1] < 0 then
+ bisectstack[bisectptr - 1] := 0
+ end else begin
+ bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 2] > bisectstack[bisectptr - 5] then
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4];
+ if bisectstack[bisectptr - 1] < 0 then
+ bisectstack[bisectptr - 1] := 0
+ end
+ else if bisectstack[bisectptr - 3] <= 0 then begin
+ if bisectstack[bisectptr - 4] > 0 then
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]
+ else
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 2] > 0 then
+ bisectstack[bisectptr - 2] := 0
+ end else begin
+ bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3];
+ if bisectstack[bisectptr - 1] < bisectstack[bisectptr - 5] then
+ bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5];
+ bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4];
+ if bisectstack[bisectptr - 2] > 0 then
+ bisectstack[bisectptr - 2] := 0
+ end;
+ bisectstack[bisectptr - 30] := bisectstack[uv - 10];
+ bisectstack[bisectptr - 8] := bisectstack[uv - 8];
+ bisectstack[bisectptr - 29] := (bisectstack[bisectptr - 30] + bisectstack[uv - 9]) div 2;
+ bisectstack[bisectptr - 9] := (bisectstack[bisectptr - 8] + bisectstack[uv - 9]) div 2;
+ bisectstack[bisectptr - 28] := (bisectstack[bisectptr - 29] + bisectstack[bisectptr - 9]) div 2;
+ bisectstack[bisectptr - 10] := bisectstack[bisectptr - 28];
+ if bisectstack[bisectptr - 30] < 0 then
+ if bisectstack[bisectptr - 28] >= 0 then begin
+ if bisectstack[bisectptr - 29] < 0 then
+ bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]
+ else
+ bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30];
+ bisectstack[bisectptr - 26] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28];
+ if bisectstack[bisectptr - 26] < 0 then
+ bisectstack[bisectptr - 26] := 0
+ end else begin
+ bisectstack[bisectptr - 27] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28];
+ if bisectstack[bisectptr - 27] > bisectstack[bisectptr - 30] then
+ bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30];
+ bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29];
+ if bisectstack[bisectptr - 26] < 0 then
+ bisectstack[bisectptr - 26] := 0
+ end
+ else if bisectstack[bisectptr - 28] <= 0 then begin
+ if bisectstack[bisectptr - 29] > 0 then
+ bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]
+ else
+ bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30];
+ bisectstack[bisectptr - 27] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28];
+ if bisectstack[bisectptr - 27] > 0 then
+ bisectstack[bisectptr - 27] := 0
+ end else begin
+ bisectstack[bisectptr - 26] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28];
+ if bisectstack[bisectptr - 26] < bisectstack[bisectptr - 30] then
+ bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30];
+ bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29];
+ if bisectstack[bisectptr - 27] > 0 then
+ bisectstack[bisectptr - 27] := 0
+ end;
+ if bisectstack[bisectptr - 10] < 0 then
+ if bisectstack[bisectptr - 8] >= 0 then begin
+ if bisectstack[bisectptr - 9] < 0 then
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]
+ else
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 6] < 0 then
+ bisectstack[bisectptr - 6] := 0
+ end else begin
+ bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 7] > bisectstack[bisectptr - 10] then
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9];
+ if bisectstack[bisectptr - 6] < 0 then
+ bisectstack[bisectptr - 6] := 0
+ end
+ else if bisectstack[bisectptr - 8] <= 0 then begin
+ if bisectstack[bisectptr - 9] > 0 then
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]
+ else
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 7] > 0 then
+ bisectstack[bisectptr - 7] := 0
+ end else begin
+ bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8];
+ if bisectstack[bisectptr - 6] < bisectstack[bisectptr - 10] then
+ bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10];
+ bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9];
+ if bisectstack[bisectptr - 7] > 0 then
+ bisectstack[bisectptr - 7] := 0
+ end;
+ bisectstack[bisectptr - 35] := bisectstack[xy - 15];
+ bisectstack[bisectptr - 13] := bisectstack[xy - 13];
+ bisectstack[bisectptr - 34] := (bisectstack[bisectptr - 35] + bisectstack[xy - 14]) div 2;
+ bisectstack[bisectptr - 14] := (bisectstack[bisectptr - 13] + bisectstack[xy - 14]) div 2;
+ bisectstack[bisectptr - 33] := (bisectstack[bisectptr - 34] + bisectstack[bisectptr - 14]) div 2;
+ bisectstack[bisectptr - 15] := bisectstack[bisectptr - 33];
+ if bisectstack[bisectptr - 35] < 0 then
+ if bisectstack[bisectptr - 33] >= 0 then begin
+ if bisectstack[bisectptr - 34] < 0 then
+ bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]
+ else
+ bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35];
+ bisectstack[bisectptr - 31] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33];
+ if bisectstack[bisectptr - 31] < 0 then
+ bisectstack[bisectptr - 31] := 0
+ end else begin
+ bisectstack[bisectptr - 32] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33];
+ if bisectstack[bisectptr - 32] > bisectstack[bisectptr - 35] then
+ bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35];
+ bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34];
+ if bisectstack[bisectptr - 31] < 0 then
+ bisectstack[bisectptr - 31] := 0
+ end
+ else if bisectstack[bisectptr - 33] <= 0 then begin
+ if bisectstack[bisectptr - 34] > 0 then
+ bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]
+ else
+ bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35];
+ bisectstack[bisectptr - 32] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33];
+ if bisectstack[bisectptr - 32] > 0 then
+ bisectstack[bisectptr - 32] := 0
+ end else begin
+ bisectstack[bisectptr - 31] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33];
+ if bisectstack[bisectptr - 31] < bisectstack[bisectptr - 35] then
+ bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35];
+ bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34];
+ if bisectstack[bisectptr - 32] > 0 then
+ bisectstack[bisectptr - 32] := 0
+ end;
+ if bisectstack[bisectptr - 15] < 0 then
+ if bisectstack[bisectptr - 13] >= 0 then begin
+ if bisectstack[bisectptr - 14] < 0 then
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]
+ else
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 11] < 0 then
+ bisectstack[bisectptr - 11] := 0
+ end else begin
+ bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 12] > bisectstack[bisectptr - 15] then
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14];
+ if bisectstack[bisectptr - 11] < 0 then
+ bisectstack[bisectptr - 11] := 0
+ end
+ else if bisectstack[bisectptr - 13] <= 0 then begin
+ if bisectstack[bisectptr - 14] > 0 then
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]
+ else
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 12] > 0 then
+ bisectstack[bisectptr - 12] := 0
+ end else begin
+ bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13];
+ if bisectstack[bisectptr - 11] < bisectstack[bisectptr - 15] then
+ bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15];
+ bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14];
+ if bisectstack[bisectptr - 12] > 0 then
+ bisectstack[bisectptr - 12] := 0
+ end;
+ bisectstack[bisectptr - 40] := bisectstack[xy - 20];
+ bisectstack[bisectptr - 18] := bisectstack[xy - 18];
+ bisectstack[bisectptr - 39] := (bisectstack[bisectptr - 40] + bisectstack[xy - 19]) div 2;
+ bisectstack[bisectptr - 19] := (bisectstack[bisectptr - 18] + bisectstack[xy - 19]) div 2;
+ bisectstack[bisectptr - 38] := (bisectstack[bisectptr - 39] + bisectstack[bisectptr - 19]) div 2;
+ bisectstack[bisectptr - 20] := bisectstack[bisectptr - 38];
+ if bisectstack[bisectptr - 40] < 0 then
+ if bisectstack[bisectptr - 38] >= 0 then begin
+ if bisectstack[bisectptr - 39] < 0 then
+ bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]
+ else
+ bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40];
+ bisectstack[bisectptr - 36] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38];
+ if bisectstack[bisectptr - 36] < 0 then
+ bisectstack[bisectptr - 36] := 0
+ end else begin
+ bisectstack[bisectptr - 37] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38];
+ if bisectstack[bisectptr - 37] > bisectstack[bisectptr - 40] then
+ bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40];
+ bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39];
+ if bisectstack[bisectptr - 36] < 0 then
+ bisectstack[bisectptr - 36] := 0
+ end
+ else if bisectstack[bisectptr - 38] <= 0 then begin
+ if bisectstack[bisectptr - 39] > 0 then
+ bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]
+ else
+ bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40];
+ bisectstack[bisectptr - 37] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38];
+ if bisectstack[bisectptr - 37] > 0 then
+ bisectstack[bisectptr - 37] := 0
+ end else begin
+ bisectstack[bisectptr - 36] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38];
+ if bisectstack[bisectptr - 36] < bisectstack[bisectptr - 40] then
+ bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40];
+ bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39];
+ if bisectstack[bisectptr - 37] > 0 then
+ bisectstack[bisectptr - 37] := 0
+ end;
+ if bisectstack[bisectptr - 20] < 0 then
+ if bisectstack[bisectptr - 18] >= 0 then begin
+ if bisectstack[bisectptr - 19] < 0 then
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]
+ else
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 16] < 0 then
+ bisectstack[bisectptr - 16] := 0
+ end else begin
+ bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 17] > bisectstack[bisectptr - 20] then
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19];
+ if bisectstack[bisectptr - 16] < 0 then
+ bisectstack[bisectptr - 16] := 0
+ end
+ else if bisectstack[bisectptr - 18] <= 0 then begin
+ if bisectstack[bisectptr - 19] > 0 then
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]
+ else
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 17] > 0 then
+ bisectstack[bisectptr - 17] := 0
+ end else begin
+ bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18];
+ if bisectstack[bisectptr - 16] < bisectstack[bisectptr - 20] then
+ bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20];
+ bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19];
+ if bisectstack[bisectptr - 17] > 0 then
+ bisectstack[bisectptr - 17] := 0
+ end;
+ uv := bisectptr - 20;
+ xy := bisectptr - 20;
+ delx := delx + delx;
+ dely := dely + dely;
+ tol := (tol - threel) + tolstep;
+ tol := tol + tol;
+ threel := threel + tolstep {:559};
+ goto 22
+ end;
+ if timetogo > 0 then
+ timetogo := timetogo - 1
+ else begin
+ while apprt < 65536 do begin
+ apprt := apprt + apprt;
+ apprtt := apprtt + apprtt
+ end;
+ curt := apprt;
+ curtt := apprtt;
+ goto 10
+ end; {560:}
+ 45:
+ if odd(curtt) then
+ if odd(curt) then begin {561:}
+ curt := curt div 2;
+ curtt := curtt div 2;
+ if curt = 0 then
+ goto 10;
+ bisectptr := bisectptr - 45;
+ threel := threel - tolstep;
+ delx := bisectstack[bisectptr];
+ dely := bisectstack[bisectptr + 1];
+ tol := bisectstack[bisectptr + 2];
+ uv := bisectstack[bisectptr + 3];
+ xy := bisectstack[bisectptr + 4];
+ goto 45
+ end else begin {:561}
+ curt := curt + 1;
+ delx := ((delx + bisectstack[uv - 5]) + bisectstack[uv - 4]) + bisectstack[uv - 3];
+ dely := ((dely + bisectstack[uv - 10]) + bisectstack[uv - 9]) + bisectstack[uv - 8];
+ uv := uv + 20;
+ curtt := curtt - 1;
+ xy := xy - 20;
+ delx := ((delx + bisectstack[xy - 15]) + bisectstack[xy - 14]) + bisectstack[xy - 13];
+ dely := ((dely + bisectstack[xy - 20]) + bisectstack[xy - 19]) + bisectstack[xy - 18]
+ end
+ else begin
+ curtt := curtt + 1;
+ tol := tol + threel;
+ delx := ((delx - bisectstack[xy - 15]) - bisectstack[xy - 14]) - bisectstack[xy - 13];
+ dely := ((dely - bisectstack[xy - 20]) - bisectstack[xy - 19]) - bisectstack[xy - 18];
+ xy := xy + 20
+ end {:560}
+ end;
+ 10:
+
+ end; {:556} {562:}
+
+ procedure pathintersection(h, hh: halfword);
+ label
+ 10;
+ var
+ p, pp: halfword;
+ n, nn: integer; {563:}
+ begin
+ if mem[h].hh.b1 = 0 then begin
+ mem[h + 5].int := mem[h + 1].int;
+ mem[h + 3].int := mem[h + 1].int;
+ mem[h + 6].int := mem[h + 2].int;
+ mem[h + 4].int := mem[h + 2].int;
+ mem[h].hh.b1 := 1
+ end;
+ if mem[hh].hh.b1 = 0 then begin
+ mem[hh + 5].int := mem[hh + 1].int;
+ mem[hh + 3].int := mem[hh + 1].int;
+ mem[hh + 6].int := mem[hh + 2].int;
+ mem[hh + 4].int := mem[hh + 2].int;
+ mem[hh].hh.b1 := 1
+ end; {:563}
+ tolstep := 0;
+ repeat
+ n := -65536;
+ p := h;
+ repeat
+ if mem[p].hh.b1 <> 0 then begin
+ nn := -65536;
+ pp := hh;
+ repeat
+ if mem[pp].hh.b1 <> 0 then begin
+ cubicintersection(p, pp);
+ if curt > 0 then begin
+ curt := curt + n;
+ curtt := curtt + nn;
+ goto 10
+ end
+ end;
+ nn := nn + 65536;
+ pp := mem[pp].hh.rh
+ until pp = hh
+ end;
+ n := n + 65536;
+ p := mem[p].hh.rh
+ until p = h;
+ tolstep := tolstep + 3
+ until tolstep > 3;
+ curt := -65536;
+ curtt := -65536;
+ 10:
+
+ end; {:562} {574:}
+
+ procedure openawindow(k: windownumber; r0, c0, r1, c1: scaled; x, y: scaled);
+ var
+ m, n: integer; {575:}
+ begin
+ if r0 < 0 then
+ r0 := 0
+ else
+ r0 := roundunscaled(r0);
+ r1 := roundunscaled(r1);
+ if r1 > screendepth then
+ r1 := screendepth;
+ if r1 < r0 then
+ if r0 > screendepth then
+ r0 := r1
+ else
+ r1 := r0;
+ if c0 < 0 then
+ c0 := 0
+ else
+ c0 := roundunscaled(c0);
+ c1 := roundunscaled(c1);
+ if c1 > screenwidth then
+ c1 := screenwidth;
+ if c1 < c0 then
+ if c0 > screenwidth then
+ c0 := c1
+ else
+ c1 := c0 {:575};
+ windowopen[k] := true;
+ windowtime[k] := windowtime[k] + 1;
+ leftcol[k] := c0;
+ rightcol[k] := c1;
+ toprow[k] := r0;
+ botrow[k] := r1; {576:}
+ m := roundunscaled(x);
+ n := roundunscaled(y) - 1;
+ mwindow[k] := c0 - m;
+ nwindow[k] := r0 + n {:576};
+ begin
+ if not screenstarted then begin
+ screenOK := initscreen;
+ screenstarted := true
+ end
+ end;
+ if screenOK then begin
+ blankrectangle(c0, c1, r0, r1);
+ updatescreen
+ end
+ end; { openawindow }
+ {:574}
+ {577:}
+
+ procedure dispedges(k: windownumber);
+ label
+ 30, 40;
+ var
+ p, q: halfword;
+ alreadythere: boolean;
+ r: integer; {580:}
+ n: screencol;
+ w, ww: integer;
+ b: pixelcolor;
+ m, mm: integer;
+ d: integer;
+ madjustment: integer;
+ rightedge: integer;
+ mincol: screencol; {:580}
+ begin
+ if screenOK then
+ if leftcol[k] < rightcol[k] then
+ if toprow[k] < botrow[k] then begin
+ alreadythere := false;
+ if mem[curedges + 3].hh.rh = k then
+ if mem[curedges + 4].int = windowtime[k] then
+ alreadythere := true;
+ if not alreadythere then
+ blankrectangle(leftcol[k], rightcol[k], toprow[k], botrow[k]); {581:}
+ madjustment := mwindow[k] - mem[curedges + 3].hh.lh;
+ rightedge := 8 * (rightcol[k] - madjustment);
+ mincol := leftcol[k] {:581};
+ p := mem[curedges].hh.rh;
+ r := nwindow[k] - (mem[curedges + 1].hh.lh - 4096);
+ while (p <> curedges) and (r >= toprow[k]) do begin
+ if r < botrow[k] then begin {578:}
+ if mem[p + 1].hh.lh > (-29999) then
+ sortedges(p)
+ else if mem[p + 1].hh.lh = (-29999) then
+ if alreadythere then
+ goto 30;
+ mem[p + 1].hh.lh := -29999; {582:}
+ n := 0;
+ ww := 0;
+ m := -1;
+ w := 0;
+ q := mem[p + 1].hh.rh;
+ rowtransition[0] := mincol;
+ while true do begin
+ if q = 30000 then
+ d := rightedge
+ else
+ d := mem[q].hh.lh + 32768;
+ mm := (d div 8) + madjustment;
+ if mm <> m then begin {583:}
+ if w <= 0 then begin
+ if ww > 0 then
+ if m > mincol then begin
+ if n = 0 then
+ if alreadythere then begin
+ b := 0;
+ n := n + 1
+ end else
+ b := 1
+ else
+ n := n + 1;
+ rowtransition[n] := m
+ end
+ end else if ww <= 0 then
+ if m > mincol then begin
+ if n = 0 then
+ b := 1;
+ n := n + 1;
+ rowtransition[n] := m
+ end {:583};
+ m := mm;
+ w := ww
+ end;
+ if d >= rightedge then
+ goto 40;
+ ww := (ww + (d mod 8)) - 4;
+ q := mem[q].hh.rh
+ end;
+ 40: {584:}
+ if alreadythere or (ww > 0) then begin
+ if n = 0 then
+ if ww > 0 then
+ b := 1
+ else
+ b := 0;
+ n := n + 1;
+ rowtransition[n] := rightcol[k]
+ end else if n = 0 then
+ goto 30 {:584}; {:582}
+ paintrow(r, b, rowtransition, n);
+ 30: {:578}
+
+ end;
+ p := mem[p].hh.rh;
+ r := r - 1
+ end;
+ updatescreen;
+ windowtime[k] := windowtime[k] + 1;
+ mem[curedges + 3].hh.rh := k;
+ mem[curedges + 4].int := windowtime[k]
+ end
+ end; {:577} {591:}
+
+ function maxcoef(p: halfword): fraction;
+ var
+ x: fraction;
+ begin
+ x := 0;
+ while mem[p].hh.lh <> (-30000) do begin
+ if abs(mem[p + 1].int) > x then
+ x := abs(mem[p + 1].int);
+ p := mem[p].hh.rh
+ end;
+ maxcoef := x
+ end; {:591} {597:}
+
+ function pplusq(p: halfword; q: halfword; t: smallnumber): halfword;
+ label
+ 30;
+ var
+ pp, qq: halfword;
+ r, s: halfword;
+ threshold: integer;
+ v: integer;
+ begin
+ if t = 17 then
+ threshold := 2685
+ else
+ threshold := 8;
+ r := 29999;
+ pp := mem[p].hh.lh;
+ qq := mem[q].hh.lh;
+ while true do
+ if pp = qq then
+ if pp = (-30000) then
+ goto 30 {598:}
+ else begin
+ v := mem[p + 1].int + mem[q + 1].int;
+ mem[p + 1].int := v;
+ s := p;
+ p := mem[p].hh.rh;
+ pp := mem[p].hh.lh;
+ if abs(v) < threshold then
+ freenode(s, 2)
+ else begin
+ if abs(v) >= 626349397 then
+ if watchcoefs then begin
+ mem[qq].hh.b0 := 0;
+ fixneeded := true
+ end;
+ mem[r].hh.rh := s;
+ r := s
+ end;
+ q := mem[q].hh.rh;
+ qq := mem[q].hh.lh
+ end {:598}
+ else if mem[pp + 1].int < mem[qq + 1].int then begin
+ s := getnode(2);
+ mem[s].hh.lh := qq;
+ mem[s + 1].int := mem[q + 1].int;
+ q := mem[q].hh.rh;
+ qq := mem[q].hh.lh;
+ mem[r].hh.rh := s;
+ r := s
+ end else begin
+ mem[r].hh.rh := p;
+ r := p;
+ p := mem[p].hh.rh;
+ pp := mem[p].hh.lh
+ end;
+ 30:
+ mem[p + 1].int := slowadd(mem[p + 1].int, mem[q + 1].int);
+ mem[r].hh.rh := p;
+ depfinal := p;
+ pplusq := mem[29999].hh.rh
+ end; {:597} {599:}
+
+ function ptimesv(p: halfword; v: integer; t0, t1: smallnumber; visscaled: boolean): halfword;
+ var
+ r, s: halfword;
+ w: integer;
+ threshold: integer;
+ scalingdown: boolean;
+ begin
+ if t0 <> t1 then
+ scalingdown := true
+ else
+ scalingdown := not visscaled;
+ if t1 = 17 then
+ threshold := 1342
+ else
+ threshold := 4;
+ r := 29999;
+ while mem[p].hh.lh <> (-30000) do begin
+ if scalingdown then
+ w := takefraction(v, mem[p + 1].int)
+ else
+ w := takescaled(v, mem[p + 1].int);
+ if abs(w) <= threshold then begin
+ s := mem[p].hh.rh;
+ freenode(p, 2);
+ p := s
+ end else begin
+ if abs(w) >= 626349397 then begin
+ fixneeded := true;
+ mem[mem[p].hh.lh].hh.b0 := 0
+ end;
+ mem[r].hh.rh := p;
+ r := p;
+ mem[p + 1].int := w;
+ p := mem[p].hh.rh
+ end
+ end;
+ mem[r].hh.rh := p;
+ if visscaled then
+ mem[p + 1].int := takescaled(mem[p + 1].int, v)
+ else
+ mem[p + 1].int := takefraction(mem[p + 1].int, v);
+ ptimesv := mem[29999].hh.rh
+ end; {:599}
+ {601:}
+
+ function pwithxbecomingq(p, x, q: halfword; t: smallnumber): halfword;
+ var
+ r, s: halfword;
+ v: integer;
+ sx: integer;
+ begin
+ s := p;
+ r := 29999;
+ sx := mem[x + 1].int;
+ while mem[mem[s].hh.lh + 1].int > sx do begin
+ r := s;
+ s := mem[s].hh.rh
+ end;
+ if mem[s].hh.lh <> x then
+ pwithxbecomingq := p
+ else begin
+ mem[29999].hh.rh := p;
+ mem[r].hh.rh := mem[s].hh.rh;
+ v := mem[s + 1].int;
+ freenode(s, 2);
+ pwithxbecomingq := pplusfq(mem[29999].hh.rh, v, q, t, 17)
+ end
+ end; {:601} {606:}
+
+ procedure newdep(q, p: halfword);
+ var
+ r: halfword;
+ begin
+ mem[q + 1].hh.rh := p;
+ mem[q + 1].hh.lh := -29987;
+ r := mem[-29987].hh.rh;
+ mem[depfinal].hh.rh := r;
+ mem[r + 1].hh.lh := depfinal;
+ mem[-29987].hh.rh := q
+ end; {:606} {607:}
+
+ function constdependency(v: scaled): halfword;
+ begin
+ depfinal := getnode(2);
+ mem[depfinal + 1].int := v;
+ mem[depfinal].hh.lh := -30000;
+ constdependency := depfinal
+ end; {:607} {608:}
+
+ function singledependency(p: halfword): halfword;
+ var
+ q: halfword;
+ m: integer;
+ begin
+ m := mem[p + 1].int mod 64;
+ if m > 28 then
+ singledependency := constdependency(0)
+ else begin
+ q := getnode(2);
+ mem[q + 1].int := twotothe[28 - m];
+ mem[q].hh.lh := p;
+ mem[q].hh.rh := constdependency(0);
+ singledependency := q
+ end
+ end; {:608}
+ {609:}
+
+ function copydeplist(p: halfword): halfword;
+ label
+ 30;
+ var
+ q: halfword;
+ begin
+ q := getnode(2);
+ depfinal := q;
+ while true do begin
+ mem[depfinal].hh.lh := mem[p].hh.lh;
+ mem[depfinal + 1].int := mem[p + 1].int;
+ if mem[depfinal].hh.lh = (-30000) then
+ goto 30;
+ mem[depfinal].hh.rh := getnode(2);
+ depfinal := mem[depfinal].hh.rh;
+ p := mem[p].hh.rh
+ end;
+ 30:
+ copydeplist := q
+ end; {:609} {610:}
+
+ procedure lineareq(p: halfword; t: smallnumber);
+ var
+ q, r, s: halfword;
+ x: halfword;
+ n: integer;
+ v: integer;
+ prevr: halfword;
+ finalnode: halfword;
+ w: integer; {611:}
+ begin
+ q := p;
+ r := mem[p].hh.rh;
+ v := mem[q + 1].int;
+ while mem[r].hh.lh <> (-30000) do begin
+ if abs(mem[r + 1].int) > abs(v) then begin
+ q := r;
+ v := mem[r + 1].int
+ end;
+ r := mem[r].hh.rh
+ end {:611};
+ x := mem[q].hh.lh;
+ n := mem[x + 1].int mod 64; {612:}
+ s := 29999;
+ mem[s].hh.rh := p;
+ r := p;
+ repeat
+ if r = q then begin
+ mem[s].hh.rh := mem[r].hh.rh;
+ freenode(r, 2)
+ end else begin
+ w := makefraction(mem[r + 1].int, v);
+ if abs(w) <= 1342 then begin
+ mem[s].hh.rh := mem[r].hh.rh;
+ freenode(r, 2)
+ end else begin
+ mem[r + 1].int := -w;
+ s := r
+ end
+ end;
+ r := mem[s].hh.rh
+ until mem[r].hh.lh = (-30000);
+ if t = 18 then
+ mem[r + 1].int := -makescaled(mem[r + 1].int, v)
+ else if v <> (-268435456) then
+ mem[r + 1].int := -makefraction(mem[r + 1].int, v);
+ finalnode := r;
+ p := mem[29999].hh.rh {:612};
+ if internal[2] > 0 then {613:}
+ if interesting(x) then begin
+ begindiagnostic;
+ printnl(462);
+ printvariablename(x);
+ w := n;
+ while w > 0 do begin
+ print(455);
+ w := w - 2
+ end;
+ printchar(61);
+ printdependency(p, 17);
+ enddiagnostic(false)
+ end {:613};
+ {614:}
+ prevr := -29987;
+ r := mem[-29987].hh.rh;
+ while r <> (-29987) do begin
+ s := mem[r + 1].hh.rh;
+ q := pwithxbecomingq(s, x, p, mem[r].hh.b0);
+ if mem[q].hh.lh = (-30000) then
+ makeknown(r, q)
+ else begin
+ mem[r + 1].hh.rh := q;
+ repeat
+ q := mem[q].hh.rh
+ until mem[q].hh.lh = (-30000);
+ prevr := q
+ end;
+ r := mem[prevr].hh.rh
+ end {:614}; {615:}
+ if n > 0 then begin {616:}
+ s := 29999;
+ mem[29999].hh.rh := p;
+ r := p;
+ repeat
+ if n > 30 then
+ w := 0
+ else
+ w := mem[r + 1].int div twotothe[n];
+ if (abs(w) <= 1342) and (mem[r].hh.lh <> (-30000)) then begin
+ mem[s].hh.rh := mem[r].hh.rh;
+ freenode(r, 2)
+ end else begin
+ mem[r + 1].int := w;
+ s := r
+ end;
+ r := mem[s].hh.rh
+ until mem[s].hh.lh = (-30000);
+ p := mem[29999].hh.rh
+ end {:616};
+ if mem[p].hh.lh = (-30000) then begin
+ mem[x].hh.b0 := 16;
+ mem[x + 1].int := mem[p + 1].int;
+ if abs(mem[x + 1].int) >= 268435456 then
+ valtoobig(mem[x + 1].int);
+ freenode(p, 2);
+ if curexp = x then
+ if curtype = 19 then begin
+ curexp := mem[x + 1].int;
+ curtype := 16;
+ freenode(x, 2)
+ end
+ end else begin
+ mem[x].hh.b0 := 17;
+ depfinal := finalnode;
+ newdep(x, p);
+ if curexp = x then
+ if curtype = 19 then
+ curtype := 17
+ end {:615};
+ if fixneeded then
+ fixdependencies
+ end; {:610} {619:}
+
+ function newringentry(p: halfword): halfword;
+ var
+ q: halfword;
+ begin
+ q := getnode(2);
+ mem[q].hh.b1 := 11;
+ mem[q].hh.b0 := mem[p].hh.b0;
+ if mem[p + 1].int = (-30000) then
+ mem[q + 1].int := p
+ else
+ mem[q + 1].int := mem[p + 1].int;
+ mem[p + 1].int := q;
+ newringentry := q
+ end; {:619} {621:}
+
+ procedure nonlineareq(v: integer; p: halfword; flushp: boolean);
+ var
+ t: smallnumber;
+ q, r: halfword;
+ begin
+ t := mem[p].hh.b0 - 1;
+ q := mem[p + 1].int;
+ if flushp then
+ mem[p].hh.b0 := 1
+ else
+ p := q;
+ repeat
+ r := mem[q + 1].int;
+ mem[q].hh.b0 := t;
+ case t of
+ 2:
+ mem[q + 1].int := v;
+ 4:
+ begin
+ mem[q + 1].int := v;
+ begin
+ if strref[v] < 127 then
+ strref[v] := strref[v] + 1
+ end
+ end;
+ 6:
+ begin
+ mem[q + 1].int := v;
+ mem[v].hh.lh := mem[v].hh.lh + 1
+ end;
+ 9:
+ mem[q + 1].int := copypath(v);
+ 11:
+ mem[q + 1].int := copyedges(v)
+ end;
+ q := r
+ until q = p
+ end; {:621} {622:}
+
+ procedure ringmerge(p, q: halfword);
+ label
+ 10;
+ var
+ r: halfword;
+ begin
+ r := mem[p + 1].int;
+ while r <> p do begin
+ if r = q then begin {623:}
+ begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(465)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 466;
+ helpline[0] := 467
+ end;
+ putgeterror
+ end {:623};
+ goto 10
+ end;
+ r := mem[r + 1].int
+ end;
+ r := mem[p + 1].int;
+ mem[p + 1].int := mem[q + 1].int;
+ mem[q + 1].int := r;
+ 10:
+
+ end; {:622} {626:}
+
+ procedure showcmdmod(c, m: integer);
+ begin
+ begindiagnostic;
+ printnl(123);
+ printcmdmod(c, m);
+ printchar(125);
+ enddiagnostic(false)
+ end; {:626} {635:}
+
+ procedure showcontext;
+ label
+ 30;
+ var
+ oldsetting: 0..5; {641:}
+ i: 0..bufsize;
+ l: integer;
+ m: integer;
+ n: 0..errorline;
+ p: integer;
+ q: integer; {:641}
+ begin
+ fileptr := inputptr;
+ inputstack[fileptr] := curinput;
+ while true do begin
+ curinput := inputstack[fileptr]; {636:}
+ if (((fileptr = inputptr) or (curinput.indexfield <= 6)) or (curinput.indexfield <> 10)) or (curinput.locfield <> (-30000)) then begin
+ tally := 0;
+ oldsetting := selector;
+ if curinput.indexfield <= 6 then begin {637:}
+ if curinput.namefield <= 1 then
+ if (curinput.namefield = 0) and (fileptr = 0) then
+ printnl(469)
+ else
+ printnl(470)
+ else if curinput.namefield = 2 then
+ printnl(471)
+ else begin
+ printnl(472);
+ printint(line)
+ end;
+ printchar(32) {:637};
+ {644:}
+ begin
+ l := tally;
+ tally := 0;
+ selector := 4;
+ trickcount := 1000000
+ end;
+ if curinput.limitfield > 0 then
+ for i := curinput.startfield to curinput.limitfield - 1 do begin
+ if i = curinput.locfield then begin
+ firstcount := tally;
+ trickcount := ((tally + 1) + errorline) - halferrorline;
+ if trickcount < errorline then
+ trickcount := errorline
+ end;
+ print(buffer[i])
+ end {:644}
+ end else begin {638:}
+ if curinput.indexfield in
+ [7, 8, 9, 10, 11, 12] then
+ case curinput.indexfield of
+ 7:
+ printnl(473);
+ 8:
+ begin {639:}
+ printnl(478);
+ p := paramstack[curinput.limitfield];
+ if p <> (-30000) then
+ if mem[p].hh.rh = (-29999) then
+ printexp(p, 0)
+ else
+ showtokenlist(p, -30000, 20, tally);
+ print(479)
+ end; {:639}
+ 9:
+ printnl(474);
+ 10:
+ if curinput.locfield = (-30000) then
+ printnl(475)
+ else
+ printnl(476);
+ 11:
+ printnl(477);
+ 12:
+ begin
+ println;
+ if curinput.namefield <> (-30000) then
+ print(hash[curinput.namefield].rh) {640:}
+ else begin
+ p := paramstack[curinput.limitfield];
+ if p = (-30000) then
+ showtokenlist(paramstack[curinput.limitfield + 1], -30000, 20, tally)
+ else begin
+ q := p;
+ while mem[q].hh.rh <> (-30000) do
+ q := mem[q].hh.rh;
+ mem[q].hh.rh := paramstack[curinput.limitfield + 1];
+ showtokenlist(p, -30000, 20, tally);
+ mem[q].hh.rh := -30000
+ end
+ end {:640};
+ print(368)
+ end
+ end
+ else
+ printnl(63) {:638}; {645:}
+ begin
+ l := tally;
+ tally := 0;
+ selector := 4;
+ trickcount := 1000000
+ end;
+ if curinput.indexfield <> 12 then
+ showtokenlist(curinput.startfield, curinput.locfield, 100000, 0)
+ else
+ showmacro(curinput.startfield, curinput.locfield, 100000) {:645}
+ end;
+ selector := oldsetting; {643:}
+ if trickcount = 1000000 then begin
+ firstcount := tally;
+ trickcount := ((tally + 1) + errorline) - halferrorline;
+ if trickcount < errorline then
+ trickcount := errorline
+ end;
+ if tally < trickcount then
+ m := tally - firstcount
+ else
+ m := trickcount - firstcount;
+ if (l + firstcount) <= halferrorline then begin
+ p := 0;
+ n := l + firstcount
+ end else begin
+ print(146);
+ p := ((l + firstcount) - halferrorline) + 3;
+ n := halferrorline
+ end;
+ for q := p to firstcount - 1 do
+ printchar(trickbuf[q mod errorline]);
+ println;
+ for q := 1 to n do
+ printchar(32);
+ if (m + n) <= errorline then
+ p := firstcount + m
+ else
+ p := firstcount + ((errorline - n) - 3);
+ for q := firstcount to p - 1 do
+ printchar(trickbuf[q mod errorline]);
+ if (m + n) > errorline then
+ print(146) {:643}
+ end {:636};
+ if curinput.indexfield <= 6 then
+ if (curinput.namefield > 2) or (fileptr = 0) then
+ goto 30;
+ fileptr := fileptr - 1
+ end;
+ 30:
+ curinput := inputstack[inputptr]
+ end; { showcontext }
+ {:635}
+ {649:}
+
+ procedure begintokenlist(p: halfword; t: quarterword);
+ begin
+ begin
+ if inputptr > maxinstack then begin
+ maxinstack := inputptr;
+ if inputptr = stacksize then
+ overflow(480, stacksize)
+ end;
+ inputstack[inputptr] := curinput;
+ inputptr := inputptr + 1
+ end;
+ curinput.startfield := p;
+ curinput.indexfield := t;
+ curinput.limitfield := paramptr;
+ curinput.locfield := p
+ end; {:649} {650:}
+
+ procedure endtokenlist;
+ label
+ 30;
+ var
+ p: halfword;
+ begin
+ if curinput.indexfield >= 10 then
+ if curinput.indexfield <= 11 then begin
+ flushtokenlist(curinput.startfield);
+ goto 30
+ end else
+ deletemacref(curinput.startfield);
+ while paramptr > curinput.limitfield do begin
+ paramptr := paramptr - 1;
+ p := paramstack[paramptr];
+ if p <> (-30000) then
+ if mem[p].hh.rh = (-29999) then begin
+ recyclevalue(p);
+ freenode(p, 2)
+ end else
+ flushtokenlist(p)
+ end;
+ 30:
+ begin
+ inputptr := inputptr - 1;
+ curinput := inputstack[inputptr]
+ end;
+ begin
+ if interrupt <> 0 then
+ pauseforinstructions
+ end
+ end; {:650} {651:}
+ {855:}
+ {856:}
+
+ procedure encapsulate(p: halfword);
+ begin
+ curexp := getnode(2);
+ mem[curexp].hh.b0 := curtype;
+ mem[curexp].hh.b1 := 11;
+ newdep(curexp, p)
+ end; { encapsulate }
+ {:856}
+ {858:}
+
+ procedure install(r, q: halfword);
+ var
+ p: halfword;
+ begin
+ if mem[q].hh.b0 = 16 then begin
+ mem[r + 1].int := mem[q + 1].int;
+ mem[r].hh.b0 := 16
+ end else if mem[q].hh.b0 = 19 then begin
+ p := singledependency(q);
+ if p = depfinal then begin
+ mem[r].hh.b0 := 16;
+ mem[r + 1].int := 0;
+ freenode(p, 2)
+ end else begin
+ mem[r].hh.b0 := 17;
+ newdep(r, p)
+ end
+ end else begin
+ mem[r].hh.b0 := mem[q].hh.b0;
+ newdep(r, copydeplist(mem[q + 1].hh.rh))
+ end
+ end; {:858}
+
+ procedure makeexpcopy(p: halfword);
+ label
+ 20;
+ var
+ q, r, t: halfword;
+ begin
+ 20:
+ curtype := mem[p].hh.b0;
+ if curtype in
+ [1, 2, 16, 3, 5, 7, 12, 10,
+ 4, 6, 11, 9, 8, 13, 14, 17,
+ 18, 15, 19] then
+ case curtype of
+ 1, 2, 16:
+ curexp := mem[p + 1].int;
+ 3, 5, 7, 12, 10:
+ curexp := newringentry(p);
+ 4:
+ begin
+ curexp := mem[p + 1].int;
+ begin
+ if strref[curexp] < 127 then
+ strref[curexp] := strref[curexp] + 1
+ end
+ end;
+ 6:
+ begin
+ curexp := mem[p + 1].int;
+ mem[curexp].hh.lh := mem[curexp].hh.lh + 1
+ end;
+ 11:
+ curexp := copyedges(mem[p + 1].int);
+ 9, 8:
+ curexp := copypath(mem[p + 1].int);
+ 13, 14:
+ begin {857:}
+ if mem[p + 1].int = (-30000) then
+ initbignode(p);
+ t := getnode(2);
+ mem[t].hh.b1 := 11;
+ mem[t].hh.b0 := curtype;
+ initbignode(t);
+ q := mem[p + 1].int + bignodesize[curtype];
+ r := mem[t + 1].int + bignodesize[curtype];
+ repeat
+ q := q - 2;
+ r := r - 2;
+ install(r, q)
+ until q = mem[p + 1].int;
+ curexp := t
+ end; {:857}
+ 17, 18:
+ encapsulate(copydeplist(mem[p + 1].hh.rh));
+ 15:
+ begin
+ begin
+ mem[p].hh.b0 := 19;
+ serialno := serialno + 64;
+ mem[p + 1].int := serialno
+ end;
+ goto 20
+ end;
+ 19:
+ begin
+ q := singledependency(p);
+ if q = depfinal then begin
+ curtype := 16;
+ curexp := 0;
+ freenode(q, 2)
+ end else begin
+ curtype := 17;
+ encapsulate(q)
+ end
+ end
+ end
+ else
+ confusion(664)
+ end; {:855}
+
+ function curtok: halfword;
+ var
+ p: halfword;
+ savetype: smallnumber;
+ saveexp: integer;
+ begin
+ if cursym = 0 then
+ if curcmd = 38 then begin
+ savetype := curtype;
+ saveexp := curexp;
+ makeexpcopy(curmod);
+ p := stashcurexp;
+ mem[p].hh.rh := -30000;
+ curtype := savetype;
+ curexp := saveexp
+ end else begin
+ p := getnode(2);
+ mem[p + 1].int := curmod;
+ mem[p].hh.b1 := 12;
+ if curcmd = 42 then
+ mem[p].hh.b0 := 16
+ else
+ mem[p].hh.b0 := 4
+ end
+ else begin
+ begin
+ p := avail;
+ if p = (-30000) then
+ p := getavail
+ else begin
+ avail := mem[p].hh.rh;
+ mem[p].hh.rh := -30000
+ end {dynused:=dynused+1;}
+ end;
+ mem[p].hh.lh := cursym
+ end;
+ curtok := p
+ end; {:651} {652:}
+
+ procedure backinput;
+ var
+ p: halfword;
+ s: 0..150;
+ begin
+ p := curtok;
+ while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do
+ endtokenlist;
+ begintokenlist(p, 10)
+ end; {:652} {653:}
+
+ procedure backerror;
+ begin
+ OKtointerrupt := false;
+ backinput;
+ OKtointerrupt := true;
+ error
+ end; { backerror }
+
+ procedure inserror;
+ begin
+ OKtointerrupt := false;
+ backinput;
+ curinput.indexfield := 11;
+ OKtointerrupt := true;
+ error
+ end; {:653} {654:}
+
+ procedure beginfilereading;
+ begin
+ if inopen = 6 then
+ overflow(481, 6);
+ if first = bufsize then
+ overflow(128, bufsize);
+ inopen := inopen + 1;
+ begin
+ if inputptr > maxinstack then begin
+ maxinstack := inputptr;
+ if inputptr = stacksize then
+ overflow(480, stacksize)
+ end;
+ inputstack[inputptr] := curinput;
+ inputptr := inputptr + 1
+ end;
+ curinput.indexfield := inopen;
+ linestack[curinput.indexfield] := line;
+ curinput.startfield := first;
+ curinput.namefield := 0
+ end; {:654} {655:}
+
+ procedure endfilereading;
+ begin
+ first := curinput.startfield;
+ line := linestack[curinput.indexfield];
+ if curinput.indexfield <> inopen then
+ confusion(482);
+ if curinput.namefield > 2 then
+ aclose(inputfile[curinput.indexfield]);
+ begin
+ inputptr := inputptr - 1;
+ curinput := inputstack[inputptr]
+ end;
+ inopen := inopen - 1
+ end; {:655} {656:}
+
+ procedure clearforerrorprompt;
+ begin
+ while (((curinput.indexfield <= 6) and (curinput.namefield = 0)) and (inputptr > 0)) and (curinput.locfield = curinput.limitfield) do
+ endfilereading;
+ println
+ end; {:656} {661:}
+
+ function checkoutervalidity: boolean;
+ var
+ p: halfword;
+ begin
+ if scannerstatus = 0 then
+ checkoutervalidity := true
+ else begin
+ deletionsallowed := false; {662:}
+ if cursym <> 0 then begin
+ p := getavail;
+ mem[p].hh.lh := cursym;
+ begintokenlist(p, 10)
+ end {:662};
+ if scannerstatus > 1 then begin {663:}
+ runaway;
+ if cursym = 0 then begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(488)
+ end else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(489)
+ end
+ end;
+ print(490);
+ begin
+ helpptr := 4;
+ helpline[3] := 491;
+ helpline[2] := 492;
+ helpline[1] := 493;
+ helpline[0] := 494
+ end;
+ case scannerstatus of {664:}
+ 2:
+ begin
+ print(495);
+ helpline[3] := 496;
+ cursym := 2235
+ end;
+ 3:
+ begin
+ print(497);
+ helpline[3] := 498;
+ if warninginfo = 0 then
+ cursym := 2239
+ else begin
+ cursym := 2231;
+ eqtb[2231].rh := warninginfo
+ end
+ end;
+ 4, 5:
+ begin
+ print(499);
+ if scannerstatus = 5 then
+ print(hash[warninginfo].rh)
+ else
+ printvariablename(warninginfo);
+ cursym := 2237
+ end;
+ 6:
+ begin
+ print(500);
+ print(hash[warninginfo].rh);
+ print(501);
+ helpline[3] := 502;
+ cursym := 2236
+ end
+ end {:664};
+ inserror
+ end else begin {:663}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(483)
+ end;
+ printint(warninginfo);
+ begin
+ helpptr := 3;
+ helpline[2] := 484;
+ helpline[1] := 485;
+ helpline[0] := 486
+ end;
+ if cursym = 0 then
+ helpline[2] := 487;
+ cursym := 2238;
+ inserror
+ end;
+ deletionsallowed := true;
+ checkoutervalidity := false
+ end
+ end; {:661} {666:}
+
+ procedure firmuptheline;
+ forward; {:666} {667:}
+
+ procedure getnext;
+ label
+ 20, 10, 40, 25, 85, 86, 87, 30;
+ var
+ k: 0..bufsize;
+ c: ASCIIcode;
+ class: ASCIIcode;
+ n, f: integer;
+ begin
+ 20:
+ cursym := 0;
+ if curinput.indexfield <= 6 then begin {669:}
+ 25:
+ c := buffer[curinput.locfield];
+ curinput.locfield := curinput.locfield + 1;
+ class := charclass[c];
+ if class in
+ [0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 20] then
+ case class of
+ 0:
+ goto 85;
+ 1:
+ begin
+ class := charclass[buffer[curinput.locfield]];
+ if class > 1 then
+ goto 25
+ else if class < 1 then begin
+ n := 0;
+ goto 86
+ end
+ end;
+ 2:
+ goto 25;
+ 3:
+ begin {679:}
+ if curinput.namefield > 2 then begin {681:}
+ line := line + 1;
+ first := curinput.startfield;
+ if not forceeof then begin
+ if inputln(inputfile[curinput.indexfield], true) then
+ firmuptheline
+ else
+ forceeof := true
+ end;
+ if forceeof then begin
+ printchar(41);
+ forceeof := false;
+ flush(output);
+ endfilereading;
+ if checkoutervalidity then
+ goto 20
+ else
+ goto 20
+ end;
+ buffer[curinput.limitfield] := 37;
+ first := curinput.limitfield + 1;
+ curinput.locfield := curinput.startfield
+ end else begin {:681}
+ if inputptr > 0 then begin
+ endfilereading;
+ goto 20
+ end;
+ if selector < 2 then
+ openlogfile;
+ if interaction > 1 then begin
+ if curinput.limitfield = curinput.startfield then
+ printnl(517);
+ println;
+ first := curinput.startfield;
+ begin
+ print(42);
+ terminput
+ end;
+ curinput.limitfield := last;
+ buffer[curinput.limitfield] := 37;
+ first := curinput.limitfield + 1;
+ curinput.locfield := curinput.startfield
+ end else
+ fatalerror(518)
+ end {:679};
+ begin
+ if interrupt <> 0 then
+ pauseforinstructions
+ end;
+ goto 25
+ end;
+ 4:
+ begin {671:}
+ if buffer[curinput.locfield] = 34 then
+ curmod := 155
+ else begin
+ k := curinput.locfield;
+ buffer[curinput.limitfield + 1] := 34;
+ repeat
+ curinput.locfield := curinput.locfield + 1
+ until buffer[curinput.locfield] = 34;
+ if curinput.locfield > curinput.limitfield then begin {672:}
+ curinput.locfield := curinput.limitfield;
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(510)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 511;
+ helpline[1] := 512;
+ helpline[0] := 513
+ end;
+ deletionsallowed := false;
+ error;
+ deletionsallowed := true;
+ goto 20
+ end {:672};
+ if curinput.locfield = (k + 1) then
+ curmod := buffer[k]
+ else begin
+ begin
+ if ((poolptr + curinput.locfield) - k) > maxpoolptr then begin
+ if ((poolptr + curinput.locfield) - k) > poolsize then
+ overflow(129, poolsize - initpoolptr);
+ maxpoolptr := (poolptr + curinput.locfield) - k
+ end
+ end;
+ repeat
+ begin
+ strpool[poolptr] := buffer[k];
+ poolptr := poolptr + 1
+ end;
+ k := k + 1
+ until k = curinput.locfield;
+ curmod := makestring
+ end
+ end;
+ curinput.locfield := curinput.locfield + 1;
+ curcmd := 39;
+ goto 10
+ end; {:671}
+ 5, 6, 7, 8:
+ begin
+ k := curinput.locfield - 1;
+ goto 40
+ end;
+ 20:
+ begin {670:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(507)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 508;
+ helpline[0] := 509
+ end;
+ deletionsallowed := false;
+ error;
+ deletionsallowed := true;
+ goto 20
+ end
+ end
+ else
+ {:670};
+ k := curinput.locfield - 1;
+ while charclass[buffer[curinput.locfield]] = class do
+ curinput.locfield := curinput.locfield + 1;
+ goto 40;
+ 85: {673:}
+ n := c - 48;
+ while charclass[buffer[curinput.locfield]] = 0 do begin
+ if n < 4096 then
+ n := ((10 * n) + buffer[curinput.locfield]) - 48;
+ curinput.locfield := curinput.locfield + 1
+ end;
+ if buffer[curinput.locfield] = 46 then
+ if charclass[buffer[curinput.locfield + 1]] = 0 then
+ goto 30;
+ f := 0;
+ goto 87;
+ 30:
+ curinput.locfield := curinput.locfield + 1 {:673};
+ 86: {674:}
+ k := 0;
+ repeat
+ if k < 17 then begin
+ dig[k] := buffer[curinput.locfield] - 48;
+ k := k + 1
+ end;
+ curinput.locfield := curinput.locfield + 1
+ until charclass[buffer[curinput.locfield]] <> 0;
+ f := rounddecimals(k);
+ if f = 65536 then begin
+ n := n + 1;
+ f := 0
+ end {:674};
+ 87: {675:}
+ if n < 4096 then
+ curmod := (n * 65536) + f
+ else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(514)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 515;
+ helpline[0] := 516
+ end;
+ deletionsallowed := false;
+ error;
+ deletionsallowed := true;
+ curmod := 268435455
+ end;
+ curcmd := 42;
+ goto 10 {:675};
+ 40:
+ cursym := idlookup(k, curinput.locfield - k)
+ end else if curinput.locfield >= himemmin then begin {:669} {676:}
+ cursym := mem[curinput.locfield].hh.lh;
+ curinput.locfield := mem[curinput.locfield].hh.rh;
+ if cursym >= 2242 then
+ if cursym >= 2392 then begin {677:}
+ if cursym >= 2542 then
+ cursym := cursym - 150;
+ begintokenlist(paramstack[(curinput.limitfield + cursym) - 2392], 9);
+ goto 20
+ end else begin {:677}
+ curcmd := 38;
+ curmod := paramstack[(curinput.limitfield + cursym) - 2242];
+ cursym := 0;
+ goto 10
+ end
+ end else if curinput.locfield > (-30000) then begin {678:}
+ if mem[curinput.locfield].hh.b1 = 12 then begin
+ curmod := mem[curinput.locfield + 1].int;
+ if mem[curinput.locfield].hh.b0 = 16 then
+ curcmd := 42
+ else begin
+ curcmd := 39;
+ begin
+ if strref[curmod] < 127 then
+ strref[curmod] := strref[curmod] + 1
+ end
+ end
+ end else begin
+ curmod := curinput.locfield;
+ curcmd := 38
+ end;
+ curinput.locfield := mem[curinput.locfield].hh.rh;
+ goto 10
+ end else begin {:678}
+ endtokenlist;
+ goto 20
+ end {:676}; {668:}
+ curcmd := eqtb[cursym].lh;
+ curmod := eqtb[cursym].rh;
+ if curcmd >= 83 then
+ if checkoutervalidity then
+ curcmd := curcmd - 83
+ else
+ goto 20 {:668};
+ 10:
+
+ end; {:667} {682:}
+
+ procedure firmuptheline;
+ var
+ k: 0..bufsize;
+ begin
+ curinput.limitfield := last;
+ if internal[31] > 0 then
+ if interaction > 1 then begin
+ println;
+ if curinput.startfield < curinput.limitfield then
+ for k := curinput.startfield to curinput.limitfield - 1 do
+ print(buffer[k]);
+ first := curinput.limitfield;
+ begin
+ print(519);
+ terminput
+ end;
+ if last > first then begin
+ for k := first to last - 1 do
+ buffer[(k + curinput.startfield) - first] := buffer[k];
+ curinput.limitfield := (curinput.startfield + last) - first
+ end
+ end
+ end; {:682}
+ {685:}
+
+ function scantoks(terminator: commandcode; substlist, tailend: halfword; suffixcount: smallnumber): halfword;
+ label
+ 30, 40;
+ var
+ p: halfword;
+ q: halfword;
+ balance: integer;
+ begin
+ p := 29998;
+ balance := 1;
+ mem[29998].hh.rh := -30000;
+ while true do begin
+ getnext;
+ if cursym > 0 then begin {686:}
+ begin
+ q := substlist;
+ while q <> (-30000) do begin
+ if mem[q].hh.lh = cursym then begin
+ cursym := mem[q + 1].int;
+ curcmd := 7;
+ goto 40
+ end;
+ q := mem[q].hh.rh
+ end;
+ 40: {:686}
+
+ end;
+ if curcmd = terminator then {687:}
+ if curmod > 0 then
+ balance := balance + 1
+ else begin
+ balance := balance - 1;
+ if balance = 0 then
+ goto 30
+ end {:687}
+ else if curcmd = 61 then begin {690:}
+ if curmod = 0 then
+ getnext
+ else if curmod <= suffixcount then
+ cursym := 2391 + curmod
+ end {:690}
+ end;
+ mem[p].hh.rh := curtok;
+ p := mem[p].hh.rh
+ end;
+ 30:
+ mem[p].hh.rh := tailend;
+ flushnodelist(substlist);
+ scantoks := mem[29998].hh.rh
+ end; {:685} {691:}
+
+ procedure getsymbol;
+ label
+ 20;
+ begin
+ 20:
+ getnext;
+ if (cursym = 0) or (cursym > 2229) then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(531)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 532;
+ helpline[1] := 533;
+ helpline[0] := 534
+ end;
+ if cursym > 0 then
+ helpline[2] := 535
+ else if curcmd = 39 then begin
+ if strref[curmod] < 127 then
+ if strref[curmod] > 1 then
+ strref[curmod] := strref[curmod] - 1
+ else
+ flushstring(curmod)
+ end;
+ cursym := 2229;
+ inserror;
+ goto 20
+ end
+ end; { getsymbol }
+ {:691}
+ {692:}
+
+ procedure getclearsymbol;
+ begin
+ getsymbol;
+ clearsymbol(cursym, false)
+ end; {:692} {693:}
+
+ procedure checkequals;
+ begin
+ if curcmd <> 51 then
+ if curcmd <> 77 then begin
+ missingerr(61);
+ begin
+ helpptr := 5;
+ helpline[4] := 536;
+ helpline[3] := 537;
+ helpline[2] := 538;
+ helpline[1] := 539;
+ helpline[0] := 540
+ end;
+ backerror
+ end
+ end; {:693} {694:}
+
+ procedure makeopdef;
+ var
+ m: commandcode;
+ p, q, r: halfword;
+ begin
+ m := curmod;
+ getsymbol;
+ q := getnode(2);
+ mem[q].hh.lh := cursym;
+ mem[q + 1].int := 2242;
+ getclearsymbol;
+ warninginfo := cursym;
+ getsymbol;
+ p := getnode(2);
+ mem[p].hh.lh := cursym;
+ mem[p + 1].int := 2243;
+ mem[p].hh.rh := q;
+ getnext;
+ checkequals;
+ scannerstatus := 5;
+ q := getavail;
+ mem[q].hh.lh := -30000;
+ r := getavail;
+ mem[q].hh.rh := r;
+ mem[r].hh.lh := 0;
+ mem[r].hh.rh := scantoks(16, p, -30000, 0);
+ scannerstatus := 0;
+ eqtb[warninginfo].lh := m;
+ eqtb[warninginfo].rh := q;
+ getxnext
+ end; {:694}
+ {697:}
+ {1032:}
+
+ procedure checkdelimiter(ldelim, rdelim: halfword);
+ label
+ 10;
+ begin
+ if curcmd = 62 then
+ if curmod = ldelim then
+ goto 10;
+ if cursym <> rdelim then begin
+ missingerr(hash[rdelim].rh);
+ begin
+ helpptr := 2;
+ helpline[1] := 786;
+ helpline[0] := 787
+ end;
+ backerror
+ end else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(788)
+ end;
+ print(hash[rdelim].rh);
+ print(789);
+ begin
+ helpptr := 3;
+ helpline[2] := 790;
+ helpline[1] := 791;
+ helpline[0] := 792
+ end;
+ error
+ end;
+ 10:
+
+ end; {:1032} {1011:}
+
+ function scandeclaredvariable: halfword;
+ label
+ 30;
+ var
+ x: halfword;
+ h, t: halfword;
+ l: halfword;
+ begin
+ getsymbol;
+ x := cursym;
+ if curcmd <> 41 then
+ clearsymbol(x, false);
+ if eqtb[x].rh = (-30000) then
+ newroot(x);
+ h := getavail;
+ mem[h].hh.lh := x;
+ t := h;
+ while true do begin
+ getxnext;
+ if cursym = 0 then
+ goto 30;
+ if curcmd <> 41 then
+ if curcmd <> 40 then
+ if curcmd = 63 then begin {1012:}
+ l := cursym;
+ getxnext;
+ if curcmd <> 64 then begin
+ backinput;
+ cursym := l;
+ curcmd := 63;
+ goto 30
+ end else
+ cursym := 0
+ end else {:1012}
+ goto 30;
+ mem[t].hh.rh := getavail;
+ t := mem[t].hh.rh;
+ mem[t].hh.lh := cursym
+ end;
+ 30:
+ scandeclaredvariable := h
+ end; {:1011}
+
+ procedure scandef;
+ var
+ m: 1..2;
+ n: 0..3;
+ k: 0..150;
+ c: 0..7;
+ r: halfword;
+ q: halfword;
+ p: halfword;
+ base: halfword;
+ ldelim, rdelim: halfword;
+ begin
+ m := curmod;
+ c := 0;
+ mem[29998].hh.rh := -30000;
+ q := getavail;
+ mem[q].hh.lh := -30000;
+ r := -30000; {700:}
+ if m = 1 then begin
+ getclearsymbol;
+ warninginfo := cursym;
+ getnext;
+ scannerstatus := 5;
+ n := 0;
+ eqtb[warninginfo].lh := 10;
+ eqtb[warninginfo].rh := q
+ end else begin
+ p := scandeclaredvariable;
+ flushvariable(eqtb[mem[p].hh.lh].rh, mem[p].hh.rh, true);
+ warninginfo := findvariable(p);
+ flushlist(p);
+ if warninginfo = (-30000) then begin {701:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(547)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 548;
+ helpline[0] := 549
+ end;
+ error;
+ warninginfo := -29979
+ end {:701};
+ scannerstatus := 4;
+ n := 2;
+ if curcmd = 61 then
+ if curmod = 3 then begin
+ n := 3;
+ getnext
+ end;
+ mem[warninginfo].hh.b0 := 20 + n;
+ mem[warninginfo + 1].int := q
+ end {:700};
+ k := n;
+ if curcmd = 31 then {703:}
+ repeat
+ ldelim := cursym;
+ rdelim := curmod;
+ getnext;
+ if (curcmd = 56) and (curmod >= 2242) then
+ base := curmod
+ else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(550)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := 551
+ end;
+ backerror;
+ base := 2242
+ end; {704:}
+ repeat
+ mem[q].hh.rh := getavail;
+ q := mem[q].hh.rh;
+ mem[q].hh.lh := base + k;
+ getsymbol;
+ p := getnode(2);
+ mem[p + 1].int := base + k;
+ mem[p].hh.lh := cursym;
+ if k = 150 then
+ overflow(552, 150);
+ k := k + 1;
+ mem[p].hh.rh := r;
+ r := p;
+ getnext
+ until curcmd <> 79 {:704};
+ checkdelimiter(ldelim, rdelim);
+ getnext
+ until curcmd <> 31 {:703};
+ if curcmd = 56 then begin {705:}
+ p := getnode(2);
+ if curmod < 2242 then begin
+ c := curmod;
+ mem[p + 1].int := 2242 + k
+ end else begin
+ mem[p + 1].int := curmod + k;
+ if curmod = 2242 then
+ c := 4
+ else if curmod = 2392 then
+ c := 6
+ else
+ c := 7
+ end;
+ if k = 150 then
+ overflow(552, 150);
+ k := k + 1;
+ getsymbol;
+ mem[p].hh.lh := cursym;
+ mem[p].hh.rh := r;
+ r := p;
+ getnext;
+ if c = 4 then
+ if curcmd = 69 then begin
+ c := 5;
+ p := getnode(2);
+ if k = 150 then
+ overflow(552, 150);
+ mem[p + 1].int := 2242 + k;
+ getsymbol;
+ mem[p].hh.lh := cursym;
+ mem[p].hh.rh := r;
+ r := p;
+ getnext
+ end
+ end {:705};
+ checkequals;
+ p := getavail;
+ mem[p].hh.lh := c;
+ mem[q].hh.rh := p; {698:}
+ if m = 1 then
+ mem[p].hh.rh := scantoks(16, r, -30000, n)
+ else begin
+ q := getavail;
+ mem[q].hh.lh := bgloc;
+ mem[p].hh.rh := q;
+ p := getavail;
+ mem[p].hh.lh := egloc;
+ mem[q].hh.rh := scantoks(16, r, p, n)
+ end;
+ if warninginfo = (-29979) then
+ flushtokenlist(mem[-29978].int) {:698};
+ scannerstatus := 0;
+ getxnext
+ end; {:697} {706:}
+
+ procedure scanprimary;
+ forward;
+
+ procedure scansecondary;
+ forward;
+
+ procedure scantertiary;
+ forward;
+
+ procedure scanexpression;
+ forward;
+
+ procedure scansuffix;
+ forward; {720:}
+ {722:}
+
+ procedure printmacroname(a, n: halfword);
+ var
+ p, q: halfword;
+ begin
+ if n <> (-30000) then
+ print(hash[n].rh)
+ else begin
+ p := mem[a].hh.lh;
+ if p = (-30000) then
+ print(hash[mem[mem[mem[a].hh.rh].hh.lh].hh.lh].rh)
+ else begin
+ q := p;
+ while mem[q].hh.rh <> (-30000) do
+ q := mem[q].hh.rh;
+ mem[q].hh.rh := mem[mem[a].hh.rh].hh.lh;
+ showtokenlist(p, -30000, 1000, 0);
+ mem[q].hh.rh := -30000
+ end
+ end
+ end; {:722} {723:}
+
+ procedure printarg(q: halfword; n: integer; b: halfword);
+ begin
+ if mem[q].hh.rh = (-29999) then
+ printnl(365)
+ else if (b < 2542) and (b <> 7) then
+ printnl(366)
+ else
+ printnl(367);
+ printint(n);
+ print(568);
+ if mem[q].hh.rh = (-29999) then
+ printexp(q, 1)
+ else
+ showtokenlist(q, -30000, 1000, 0)
+ end; {:723} {730:}
+
+ procedure scantextarg(ldelim, rdelim: halfword);
+ label
+ 30;
+ var
+ balance: integer;
+ p: halfword;
+ begin
+ warninginfo := ldelim;
+ scannerstatus := 3;
+ p := 29998;
+ balance := 1;
+ mem[29998].hh.rh := -30000;
+ while true do begin
+ getnext;
+ if ldelim = 0 then begin {732:}
+ if curcmd > 79 then begin
+ if balance = 1 then
+ goto 30
+ else if curcmd = 81 then
+ balance := balance - 1
+ end else if curcmd = 32 then
+ balance := balance + 1
+ end else begin {:732} {731:}
+ if curcmd = 62 then begin
+ if curmod = ldelim then begin
+ balance := balance - 1;
+ if balance = 0 then
+ goto 30
+ end
+ end else if curcmd = 31 then
+ if curmod = rdelim then
+ balance := balance + 1
+ end {:731};
+ mem[p].hh.rh := curtok;
+ p := mem[p].hh.rh
+ end;
+ 30:
+ curexp := mem[29998].hh.rh;
+ curtype := 20;
+ scannerstatus := 0
+ end; {:730}
+
+ procedure macrocall(defref, arglist, macroname: halfword);
+ label
+ 40;
+ var
+ r: halfword;
+ p, q: halfword;
+ n: integer;
+ ldelim, rdelim: halfword;
+ tail: halfword;
+ begin
+ r := mem[defref].hh.rh;
+ mem[defref].hh.lh := mem[defref].hh.lh + 1;
+ if arglist = (-30000) then
+ n := 0 {724:}
+ else begin
+ n := 1;
+ tail := arglist;
+ while mem[tail].hh.rh <> (-30000) do begin
+ n := n + 1;
+ tail := mem[tail].hh.rh
+ end
+ end {:724};
+ if internal[9] > 0 then begin {721:}
+ begindiagnostic;
+ println;
+ printmacroname(arglist, macroname);
+ if n = 3 then
+ print(530);
+ showmacro(defref, -30000, 100000);
+ if arglist <> (-30000) then begin
+ n := 0;
+ p := arglist;
+ repeat
+ q := mem[p].hh.lh;
+ printarg(q, n, 0);
+ n := n + 1;
+ p := mem[p].hh.rh
+ until p = (-30000)
+ end;
+ enddiagnostic(false)
+ end {:721}; {725:}
+ curcmd := 80;
+ while mem[r].hh.lh >= 2242 do begin {726:}
+ if curcmd <> 79 then begin
+ getxnext;
+ if curcmd <> 31 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(574)
+ end;
+ printmacroname(arglist, macroname);
+ begin
+ helpptr := 3;
+ helpline[2] := 575;
+ helpline[1] := 576;
+ helpline[0] := 577
+ end;
+ if mem[r].hh.lh >= 2392 then begin
+ curexp := -30000;
+ curtype := 20
+ end else begin
+ curexp := 0;
+ curtype := 16
+ end;
+ backerror;
+ curcmd := 62;
+ goto 40
+ end;
+ ldelim := cursym;
+ rdelim := curmod
+ end; {729:}
+ if mem[r].hh.lh >= 2542 then
+ scantextarg(ldelim, rdelim)
+ else begin
+ getxnext;
+ if mem[r].hh.lh >= 2392 then
+ scansuffix
+ else
+ scanexpression
+ end {:729};
+ if curcmd <> 79 then {727:}
+ if (curcmd <> 62) or (curmod <> ldelim) then
+ if mem[mem[r].hh.rh].hh.lh >= 2242 then begin
+ missingerr(44);
+ begin
+ helpptr := 3;
+ helpline[2] := 578;
+ helpline[1] := 579;
+ helpline[0] := 573
+ end;
+ backerror;
+ curcmd := 79
+ end else begin
+ missingerr(hash[rdelim].rh);
+ begin
+ helpptr := 2;
+ helpline[1] := 580;
+ helpline[0] := 573
+ end;
+ backerror
+ end {:727};
+ 40: {728:}
+ begin
+ p := getavail;
+ if curtype = 20 then
+ mem[p].hh.lh := curexp
+ else
+ mem[p].hh.lh := stashcurexp;
+ if internal[9] > 0 then begin
+ begindiagnostic;
+ printarg(mem[p].hh.lh, n, mem[r].hh.lh);
+ enddiagnostic(false)
+ end;
+ if arglist = (-30000) then
+ arglist := p
+ else
+ mem[tail].hh.rh := p;
+ tail := p;
+ n := n + 1
+ end {:728} {:726};
+ r := mem[r].hh.rh
+ end;
+ if curcmd = 79 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(569)
+ end;
+ printmacroname(arglist, macroname);
+ printchar(59);
+ printnl(570);
+ print(hash[rdelim].rh);
+ print(170);
+ begin
+ helpptr := 3;
+ helpline[2] := 571;
+ helpline[1] := 572;
+ helpline[0] := 573
+ end;
+ error
+ end;
+ if mem[r].hh.lh <> 0 then begin {733:}
+ if mem[r].hh.lh < 7 then begin
+ getxnext;
+ if mem[r].hh.lh <> 6 then
+ if (curcmd = 51) or (curcmd = 77) then
+ getxnext
+ end;
+ case mem[r].hh.lh of
+ 1:
+ scanprimary;
+ 2:
+ scansecondary;
+ 3:
+ scantertiary;
+ 4:
+ scanexpression;
+ 5:
+ begin {734:}
+ scanexpression;
+ p := getavail;
+ mem[p].hh.lh := stashcurexp;
+ if internal[9] > 0 then begin
+ begindiagnostic;
+ printarg(mem[p].hh.lh, n, 0);
+ enddiagnostic(false)
+ end;
+ if arglist = (-30000) then
+ arglist := p
+ else
+ mem[tail].hh.rh := p;
+ tail := p;
+ n := n + 1;
+ if curcmd <> 69 then begin
+ missingerr(347);
+ print(581);
+ printmacroname(arglist, macroname);
+ begin
+ helpptr := 1;
+ helpline[0] := 582
+ end;
+ backerror
+ end;
+ getxnext;
+ scanprimary
+ end; {:734}
+ 6:
+ begin {735:}
+ if curcmd <> 31 then
+ ldelim := -30000
+ else begin
+ ldelim := cursym;
+ rdelim := curmod;
+ getxnext
+ end;
+ scansuffix;
+ if ldelim <> (-30000) then begin
+ if (curcmd <> 62) or (curmod <> ldelim) then begin
+ missingerr(hash[rdelim].rh);
+ begin
+ helpptr := 2;
+ helpline[1] := 580;
+ helpline[0] := 573
+ end;
+ backerror
+ end;
+ getxnext
+ end
+ end; {:735}
+ 7:
+ scantextarg(0, 0)
+ end;
+ backinput; {728:}
+ begin
+ p := getavail;
+ if curtype = 20 then
+ mem[p].hh.lh := curexp
+ else
+ mem[p].hh.lh := stashcurexp;
+ if internal[9] > 0 then begin
+ begindiagnostic;
+ printarg(mem[p].hh.lh, n, mem[r].hh.lh);
+ enddiagnostic(false)
+ end;
+ if arglist = (-30000) then
+ arglist := p
+ else
+ mem[tail].hh.rh := p;
+ tail := p;
+ n := n + 1
+ end {:728}
+ end {:733};
+ r := mem[r].hh.rh {:725}; {736:}
+ while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do
+ endtokenlist;
+ if (paramptr + n) > maxparamstack then begin
+ maxparamstack := paramptr + n;
+ if maxparamstack > 150 then
+ overflow(552, 150)
+ end;
+ begintokenlist(defref, 12);
+ curinput.namefield := macroname;
+ curinput.locfield := r;
+ if n > 0 then begin
+ p := arglist;
+ repeat
+ paramstack[paramptr] := mem[p].hh.lh;
+ paramptr := paramptr + 1;
+ p := mem[p].hh.rh
+ until p = (-30000);
+ flushlist(arglist)
+ end {:736}
+ end; {:720}
+
+ procedure getboolean;
+ forward;
+
+ procedure passtext;
+ forward;
+
+ procedure conditional;
+ forward;
+
+ procedure startinput;
+ forward;
+
+ procedure beginiteration;
+ forward;
+
+ procedure resumeiteration;
+ forward;
+
+ procedure stopiteration;
+ forward; {:706} {707:}
+
+ procedure expand;
+ var
+ p: halfword;
+ k: integer;
+ j: poolpointer;
+ begin
+ if internal[7] > 65536 then
+ if curcmd <> 10 then
+ showcmdmod(curcmd, curmod);
+ case curcmd of
+ 1:
+ conditional;
+ 2: {751:}
+ if curmod > iflimit then
+ if iflimit = 1 then begin
+ missingerr(58);
+ backinput;
+ cursym := 2234;
+ inserror
+ end else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(589)
+ end;
+ printcmdmod(2, curmod);
+ begin
+ helpptr := 1;
+ helpline[0] := 590
+ end;
+ error
+ end
+ else begin
+ while curmod <> 2 do
+ passtext;
+ {745:}
+ begin
+ p := condptr;
+ ifline := mem[p + 1].int;
+ curif := mem[p].hh.b1;
+ iflimit := mem[p].hh.b0;
+ condptr := mem[p].hh.rh;
+ freenode(p, 2)
+ end {:745}
+ end {:751};
+ 3: {711:}
+ if curmod > 0 then
+ forceeof := true
+ else {:711}
+ startinput;
+ 4:
+ if curmod = 0 then begin {708:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(553)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 554;
+ helpline[0] := 555
+ end;
+ error
+ end else {:708}
+ beginiteration;
+ 5:
+ begin {712:}
+ while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do
+ endtokenlist;
+ if loopptr = (-30000) then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(557)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 558;
+ helpline[0] := 559
+ end;
+ error
+ end else
+ resumeiteration
+ end; {:712}
+ 6:
+ begin {713:}
+ getboolean;
+ if internal[7] > 65536 then
+ showcmdmod(33, curexp);
+ if curexp = 30 then
+ if loopptr = (-30000) then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(560)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := 561
+ end;
+ if curcmd = 80 then
+ error
+ else
+ backerror
+ end else begin {714:}
+ p := -30000;
+ repeat
+ if curinput.indexfield <= 6 then
+ endfilereading
+ else begin
+ if curinput.indexfield <= 8 then
+ p := curinput.startfield;
+ endtokenlist
+ end
+ until p <> (-30000);
+ if p <> mem[loopptr].hh.lh then
+ fatalerror(564);
+ stopiteration
+ end {:714}
+ else if curcmd <> 80 then begin
+ missingerr(59);
+ begin
+ helpptr := 2;
+ helpline[1] := 562;
+ helpline[0] := 563
+ end;
+ backerror
+ end
+ end; {:713}
+ 7:
+ ;
+ 9:
+ begin {715:}
+ getnext;
+ p := curtok;
+ getnext;
+ if curcmd < 11 then
+ expand
+ else
+ backinput;
+ begintokenlist(p, 10)
+ end; {:715}
+ 8:
+ begin {716:}
+ getxnext;
+ scanprimary;
+ if curtype <> 4 then begin
+ disperr(-30000, 565);
+ begin
+ helpptr := 2;
+ helpline[1] := 566;
+ helpline[0] := 567
+ end;
+ putgetflusherror(0)
+ end else begin
+ backinput;
+ if (strstart[curexp + 1] - strstart[curexp]) > 0 then begin {717:}
+ beginfilereading;
+ curinput.namefield := 2;
+ k := first + (strstart[curexp + 1] - strstart[curexp]);
+ if k >= maxbufstack then begin
+ if k >= bufsize then begin
+ maxbufstack := bufsize;
+ overflow(128, bufsize)
+ end;
+ maxbufstack := k + 1
+ end;
+ j := strstart[curexp];
+ curinput.limitfield := k;
+ while first < curinput.limitfield do begin
+ buffer[first] := strpool[j];
+ j := j + 1;
+ first := first + 1
+ end;
+ buffer[curinput.limitfield] := 37;
+ first := curinput.limitfield + 1;
+ curinput.locfield := curinput.startfield;
+ flushcurexp(0)
+ end {:717}
+ end
+ end; {:716}
+ 10:
+ macrocall(curmod, -30000, cursym)
+ end
+ end; {:707} {718:}
+
+ procedure getxnext;
+ var
+ saveexp: halfword;
+ begin
+ getnext;
+ if curcmd < 11 then begin
+ saveexp := stashcurexp;
+ repeat
+ if curcmd = 10 then
+ macrocall(curmod, -30000, cursym)
+ else
+ expand;
+ getnext
+ until curcmd >= 11;
+ unstashcurexp(saveexp)
+ end
+ end; {:718} {737:}
+
+ procedure stackargument(p: halfword);
+ begin
+ if paramptr = maxparamstack then begin
+ maxparamstack := maxparamstack + 1;
+ if maxparamstack > 150 then
+ overflow(552, 150)
+ end;
+ paramstack[paramptr] := p;
+ paramptr := paramptr + 1
+ end; {:737} {742:}
+
+ procedure passtext;
+ label
+ 30;
+ var
+ l: integer;
+ begin
+ scannerstatus := 1;
+ l := 0;
+ warninginfo := line;
+ while true do begin
+ getnext;
+ if curcmd <= 2 then
+ if curcmd < 2 then
+ l := l + 1
+ else begin
+ if l = 0 then
+ goto 30;
+ if curmod = 2 then
+ l := l - 1
+ end {743:}
+ else if curcmd = 39 then begin
+ if strref[curmod] < 127 then
+ if strref[curmod] > 1 then
+ strref[curmod] := strref[curmod] - 1
+ else
+ flushstring(curmod)
+ end {:743}
+ end;
+ 30:
+ scannerstatus := 0
+ end; {:742} {746:}
+
+ procedure changeiflimit(l: smallnumber; p: halfword);
+ label
+ 10;
+ var
+ q: halfword;
+ begin
+ if p = condptr then
+ iflimit := l
+ else begin
+ q := condptr;
+ while true do begin
+ if q = (-30000) then
+ confusion(583);
+ if mem[q].hh.rh = p then begin
+ mem[q].hh.b0 := l;
+ goto 10
+ end;
+ q := mem[q].hh.rh
+ end
+ end;
+ 10:
+
+ end; {:746} {747:}
+
+ procedure checkcolon;
+ begin
+ if curcmd <> 78 then begin
+ missingerr(58);
+ begin
+ helpptr := 2;
+ helpline[1] := 586;
+ helpline[0] := 563
+ end;
+ backerror
+ end
+ end; {:747} {748:}
+
+ procedure conditional;
+ label
+ 10, 30, 21, 40;
+ var
+ savecondptr: halfword;
+ newiflimit: 2..4;
+ p: halfword; {744:}
+ begin
+ begin
+ p := getnode(2);
+ mem[p].hh.rh := condptr;
+ mem[p].hh.b0 := iflimit;
+ mem[p].hh.b1 := curif;
+ mem[p + 1].int := ifline;
+ condptr := p;
+ iflimit := 1;
+ ifline := line;
+ curif := 1
+ end {:744};
+ savecondptr := condptr;
+ 21:
+ getboolean;
+ newiflimit := 4;
+ if internal[7] > 65536 then begin {750:}
+ begindiagnostic;
+ if curexp = 30 then
+ print(587)
+ else
+ print(588);
+ enddiagnostic(false)
+ end {:750};
+ 40:
+ checkcolon;
+ if curexp = 30 then begin
+ changeiflimit(newiflimit, savecondptr);
+ goto 10
+ end; {749:}
+ while true do begin
+ passtext;
+ if condptr = savecondptr then
+ goto 30
+ else if curmod = 2 then begin {745:}
+ p := condptr;
+ ifline := mem[p + 1].int;
+ curif := mem[p].hh.b1;
+ iflimit := mem[p].hh.b0;
+ condptr := mem[p].hh.rh;
+ freenode(p, 2)
+ end {:745}
+ end {:749};
+ 30:
+ curif := curmod;
+ ifline := line;
+ if curmod = 2 then begin {745:}
+ p := condptr;
+ ifline := mem[p + 1].int;
+ curif := mem[p].hh.b1;
+ iflimit := mem[p].hh.b0;
+ condptr := mem[p].hh.rh;
+ freenode(p, 2)
+ end else if curmod = 4 then {:745}
+ goto 21
+ else begin
+ curexp := 30;
+ newiflimit := 2;
+ getxnext;
+ goto 40
+ end;
+ 10:
+
+ end; {:748} {754:}
+
+ procedure badfor(s: strnumber);
+ begin
+ disperr(-30000, 591);
+ print(s);
+ print(177);
+ begin
+ helpptr := 4;
+ helpline[3] := 592;
+ helpline[2] := 593;
+ helpline[1] := 594;
+ helpline[0] := 179
+ end;
+ putgetflusherror(0)
+ end; {:754} {755:}
+
+ procedure beginiteration;
+ label
+ 22, 30, 40;
+ var
+ m: halfword;
+ n: halfword;
+ p, q, s, pp: halfword;
+ begin
+ m := curmod;
+ n := cursym;
+ s := getnode(2);
+ if m = 1 then begin
+ mem[s + 1].hh.lh := -29999;
+ p := -30000;
+ getxnext;
+ goto 40
+ end;
+ getsymbol;
+ p := getnode(2);
+ mem[p].hh.lh := cursym;
+ mem[p + 1].int := m;
+ getxnext;
+ if (curcmd <> 51) and (curcmd <> 77) then begin
+ missingerr(61);
+ begin
+ helpptr := 3;
+ helpline[2] := 595;
+ helpline[1] := 538;
+ helpline[0] := 596
+ end;
+ backerror
+ end;
+ {764:}
+ mem[s + 1].hh.lh := -30000;
+ q := s + 1;
+ mem[q].hh.rh := -30000;
+ repeat
+ getxnext;
+ if m <> 2242 then
+ scansuffix
+ else begin
+ if curcmd >= 78 then
+ if curcmd <= 79 then
+ goto 22;
+ scanexpression;
+ if curcmd = 74 then
+ if q = (s + 1) then begin {765:}
+ if curtype <> 16 then
+ badfor(602);
+ pp := getnode(4);
+ mem[pp + 1].int := curexp;
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then
+ badfor(603);
+ mem[pp + 2].int := curexp;
+ if curcmd <> 75 then begin
+ missingerr(357);
+ begin
+ helpptr := 2;
+ helpline[1] := 604;
+ helpline[0] := 605
+ end;
+ backerror
+ end;
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then
+ badfor(606);
+ mem[pp + 3].int := curexp;
+ mem[s + 1].hh.lh := pp;
+ goto 30
+ end {:765};
+ curexp := stashcurexp
+ end;
+ mem[q].hh.rh := getavail;
+ q := mem[q].hh.rh;
+ mem[q].hh.lh := curexp;
+ curtype := 1;
+ 22:
+
+ until curcmd <> 79;
+ 30: {:764}
+ ;
+ 40: {756:}
+ if curcmd <> 78 then begin
+ missingerr(58);
+ begin
+ helpptr := 3;
+ helpline[2] := 597;
+ helpline[1] := 598;
+ helpline[0] := 599
+ end;
+ backerror
+ end {:756}; {758:}
+ q := getavail;
+ mem[q].hh.lh := 2230;
+ scannerstatus := 6;
+ warninginfo := n;
+ mem[s].hh.lh := scantoks(4, p, q, 0);
+ scannerstatus := 0;
+ mem[s].hh.rh := loopptr;
+ loopptr := s {:758};
+ resumeiteration
+ end; {:755} {760:}
+
+ procedure resumeiteration;
+ label
+ 45, 10;
+ var
+ p, q: halfword;
+ begin
+ p := mem[loopptr + 1].hh.lh;
+ if p > (-29999) then begin
+ curexp := mem[p + 1].int; {761:}
+ if ((mem[p + 2].int > 0) and (curexp > mem[p + 3].int)) or ((mem[p + 2].int < 0) and (curexp < mem[p + 3].int)) then {:761}
+ goto 45;
+ curtype := 16;
+ q := stashcurexp;
+ mem[p + 1].int := curexp + mem[p + 2].int
+ end else if p < (-29999) then begin
+ p := mem[loopptr + 1].hh.rh;
+ if p = (-30000) then
+ goto 45;
+ mem[loopptr + 1].hh.rh := mem[p].hh.rh;
+ q := mem[p].hh.lh;
+ begin
+ mem[p].hh.rh := avail;
+ avail := p
+ end {dynused:=dynused-1;}
+ end else begin
+ begintokenlist(mem[loopptr].hh.lh, 7);
+ goto 10
+ end;
+ begintokenlist(mem[loopptr].hh.lh, 8);
+ stackargument(q);
+ if internal[7] > 65536 then begin {762:}
+ begindiagnostic;
+ printnl(601);
+ if (q <> (-30000)) and (mem[q].hh.rh = (-29999)) then
+ printexp(q, 1)
+ else
+ showtokenlist(q, -30000, 50, 0);
+ printchar(125);
+ enddiagnostic(false)
+ end {:762};
+ goto 10;
+ 45:
+ stopiteration;
+ 10:
+
+ end; {:760} {763:}
+
+ procedure stopiteration;
+ var
+ p, q: halfword;
+ begin
+ p := mem[loopptr + 1].hh.lh;
+ if p > (-29999) then
+ freenode(p, 4)
+ else if p < (-29999) then begin
+ q := mem[loopptr + 1].hh.rh;
+ while q <> (-30000) do begin
+ p := mem[q].hh.lh;
+ if p <> (-30000) then
+ if mem[p].hh.rh = (-29999) then begin
+ recyclevalue(p);
+ freenode(p, 2)
+ end else
+ flushtokenlist(p);
+ p := q;
+ q := mem[q].hh.rh;
+ begin
+ mem[p].hh.rh := avail;
+ avail := p
+ end {dynused:=dynused-1;}
+ end
+ end;
+ p := loopptr;
+ loopptr := mem[p].hh.rh;
+ flushtokenlist(mem[p].hh.lh);
+ freenode(p, 2)
+ end; {:763} {770:}
+
+ procedure beginname;
+ begin
+ areadelimiter := 0;
+ extdelimiter := 0
+ end; {:770} {771:}
+
+ function morename(c: ASCIIcode): boolean;
+ begin
+ if (c = 32) or (c = 9) then
+ morename := false
+ else begin
+ if c = 47 then begin
+ areadelimiter := poolptr;
+ extdelimiter := 0
+ end else if (c = 46) and (extdelimiter = 0) then
+ extdelimiter := poolptr;
+ begin
+ if (poolptr + 1) > maxpoolptr then begin
+ if (poolptr + 1) > poolsize then
+ overflow(129, poolsize - initpoolptr);
+ maxpoolptr := poolptr + 1
+ end
+ end;
+ begin
+ strpool[poolptr] := c;
+ poolptr := poolptr + 1
+ end;
+ morename := true
+ end
+ end; { morename }
+ {:771}
+ {772:}
+
+ procedure endname;
+ begin
+ if (strptr + 3) > maxstrptr then begin
+ if (strptr + 3) > maxstrings then
+ overflow(130, maxstrings - initstrptr);
+ maxstrptr := strptr + 3
+ end;
+ if areadelimiter = 0 then
+ curarea := 155
+ else begin
+ curarea := strptr;
+ strptr := strptr + 1;
+ strstart[strptr] := areadelimiter + 1
+ end;
+ if extdelimiter = 0 then begin
+ curext := 155;
+ curname := makestring
+ end else begin
+ curname := strptr;
+ strptr := strptr + 1;
+ strstart[strptr] := extdelimiter;
+ curext := makestring
+ end
+ end; {:772} {774:}
+
+ procedure packfilename(n, a, e: strnumber);
+ var
+ k: integer;
+ c: ASCIIcode;
+ j: poolpointer;
+ begin
+ k := 0;
+ for j := strstart[a] to strstart[a + 1] - 1 do begin
+ c := strpool[j];
+ k := k + 1;
+ if k <= filenamesize then
+ nameoffile[k] := xchr[c]
+ end;
+ for j := strstart[n] to strstart[n + 1] - 1 do begin
+ c := strpool[j];
+ k := k + 1;
+ if k <= filenamesize then
+ nameoffile[k] := xchr[c]
+ end;
+ for j := strstart[e] to strstart[e + 1] - 1 do begin
+ c := strpool[j];
+ k := k + 1;
+ if k <= filenamesize then
+ nameoffile[k] := xchr[c]
+ end;
+ if k <= filenamesize then
+ namelength := k
+ else
+ namelength := filenamesize;
+ for k := namelength + 1 to filenamesize do
+ nameoffile[k] := ' '
+ end; {:774}
+ {778:}
+
+ procedure packbufferedname(n: smallnumber; a, b: integer);
+ var
+ k: integer;
+ c: ASCIIcode;
+ j: integer;
+ begin
+ if (((n + b) - a) + 6) > filenamesize then
+ b := ((a + filenamesize) - n) - 6;
+ k := 0;
+ for j := 1 to n do begin
+ c := xord[MFbasedefault[j]];
+ k := k + 1;
+ if k <= filenamesize then
+ nameoffile[k] := xchr[c]
+ end;
+ for j := a to b do begin
+ c := buffer[j];
+ k := k + 1;
+ if k <= filenamesize then
+ nameoffile[k] := xchr[c]
+ end;
+ for j := 6 to 10 do begin
+ c := xord[MFbasedefault[j]];
+ k := k + 1;
+ if k <= filenamesize then
+ nameoffile[k] := xchr[c]
+ end;
+ if k <= filenamesize then
+ namelength := k
+ else
+ namelength := filenamesize;
+ for k := namelength + 1 to filenamesize do
+ nameoffile[k] := ' '
+ end; {:778}
+ {780:}
+
+ function makenamestring: strnumber;
+ var
+ k, kstart: 1..filenamesize;
+ begin
+ k := 1;
+ while (k < filenamesize) and (xord[realnameoffile[k]] <> 32) do
+ k := k + 1;
+ namelength := k - 1;
+ if ((poolptr + namelength) > poolsize) or (strptr = maxstrings) then
+ makenamestring := 63
+ else begin
+ if (xord[realnameoffile[1]] = 46) and (xord[realnameoffile[2]] = 47) then
+ kstart := 3
+ else
+ kstart := 1;
+ for k := kstart to namelength do begin
+ strpool[poolptr] := xord[realnameoffile[k]];
+ poolptr := poolptr + 1
+ end;
+ makenamestring := makestring
+ end
+ end;
+
+ function amakenamestring(var f: alphafile): strnumber;
+ begin
+ amakenamestring := makenamestring
+ end; { amakenamestring }
+
+ function bmakenamestring(var f: bytefile): strnumber;
+ begin
+ bgetname(f, realnameoffile);
+ bmakenamestring := makenamestring
+ end; { bmakenamestring }
+
+ function wmakenamestring(var f: wordfile): strnumber;
+ begin
+ wmakenamestring := makenamestring
+ end; {:780} {781:}
+
+ procedure scanfilename;
+ label
+ 30;
+ begin
+ beginname;
+ while (buffer[curinput.locfield] = 32) or (buffer[curinput.locfield] = 9) do
+ curinput.locfield := curinput.locfield + 1;
+ while true do begin
+ if (buffer[curinput.locfield] = 59) or (buffer[curinput.locfield] = 37) then
+ goto 30;
+ if not morename(buffer[curinput.locfield]) then
+ goto 30;
+ curinput.locfield := curinput.locfield + 1
+ end;
+ 30:
+ endname
+ end; {:781} {784:}
+
+ procedure packjobname(s: strnumber);
+ begin
+ curarea := 155;
+ curext := s;
+ curname := jobname;
+ packfilename(curname, curarea, curext)
+ end; {:784} {786:}
+
+ procedure promptfilename(s, e: strnumber);
+ label
+ 30;
+ var
+ k: 0..bufsize;
+ begin
+ if interaction = 2 then
+ ;
+ if s = 607 then begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(608)
+ end else begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(609)
+ end;
+ printfilename(curname, curarea, curext);
+ print(610);
+ if e = 611 then
+ showcontext;
+ printnl(612);
+ print(s);
+ if interaction < 2 then
+ fatalerror(613);
+ begin
+ print(614);
+ terminput
+ end;
+ {787:}
+ begin
+ beginname;
+ k := first;
+ while ((buffer[k] = 32) or (buffer[k] = 9)) and (k < last) do
+ k := k + 1;
+ while true do begin
+ if k = last then
+ goto 30;
+ if not morename(buffer[k]) then
+ goto 30;
+ k := k + 1
+ end;
+ 30:
+ endname
+ end {:787};
+ if curext = 155 then
+ curext := e;
+ packfilename(curname, curarea, curext)
+ end; { promptfilename }
+ {:786}
+ {788:}
+
+ procedure openlogfile;
+ var
+ oldsetting: 0..5;
+ k: 0..bufsize;
+ l: 0..bufsize;
+ m: integer;
+ months: packed array [1..36] of char;
+ begin
+ oldsetting := selector;
+ if jobname = 0 then
+ jobname := 615;
+ packjobname(616);
+ while not aopenout(logfile) do begin {789:}
+ if interaction < 2 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(609)
+ end;
+ printfilename(curname, curarea, curext);
+ print(610);
+ jobname := 0;
+ history := 3;
+ jumpout
+ end;
+ promptfilename(618, 616)
+ end {:789};
+ logname := amakenamestring(logfile);
+ selector := 2; {790:}
+ begin
+ write(logfile, 'This is METAFONT, Version 1.0 for Berkeley UNIX');
+ print(baseident);
+ print(619);
+ printint(roundunscaled(internal[16]));
+ printchar(32);
+ months := 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
+ m := roundunscaled(internal[15]);
+ for k := (3 * m) - 2 to 3 * m do
+ write(logfile, months[k]);
+ printchar(32);
+ printint(roundunscaled(internal[14]));
+ printchar(32);
+ m := roundunscaled(internal[17]);
+ printdd(m div 60);
+ printchar(58);
+ printdd(m mod 60)
+ end {:790};
+ inputstack[inputptr] := curinput;
+ printnl(617);
+ l := inputstack[0].limitfield - 1;
+ for k := 1 to l do
+ print(buffer[k]);
+ println;
+ selector := oldsetting + 2
+ end; {:788} {793:}
+
+ procedure startinput;
+ label
+ 30; {795:}
+ begin
+ while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do
+ endtokenlist;
+ if curinput.indexfield > 6 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(621)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 622;
+ helpline[1] := 623;
+ helpline[0] := 624
+ end;
+ error
+ end;
+ if curinput.indexfield <= 6 then
+ scanfilename
+ else begin
+ curname := 155;
+ curext := 155;
+ curarea := 155
+ end {:795};
+ if curext = 155 then
+ curext := 611;
+ packfilename(curname, curarea, curext);
+ while true do begin
+ beginfilereading;
+ if aopenin(inputfile[curinput.indexfield], 6) then
+ goto 30;
+ endfilereading;
+ promptfilename(607, 611)
+ end;
+ 30:
+ curinput.namefield := amakenamestring(inputfile[curinput.indexfield]);
+ strref[curname] := 127;
+ if jobname = 0 then begin
+ jobname := curname;
+ openlogfile
+ end;
+ if (termoffset + (strstart[curinput.namefield + 1] - strstart[curinput.namefield])) > (maxprintline - 2) then
+ println
+ else if (termoffset > 0) or (fileoffset > 0) then
+ printchar(32);
+ printchar(40);
+ print(curinput.namefield);
+ flush(output); {794:}
+ begin
+ if not inputln(inputfile[curinput.indexfield], false) then
+ ;
+ firmuptheline;
+ buffer[curinput.limitfield] := 37;
+ first := curinput.limitfield + 1;
+ curinput.locfield := curinput.startfield;
+ line := 1
+ end {:794}
+ end; {:793} {824:}
+
+ procedure badexp(s: strnumber);
+ var
+ saveflag: 0..82;
+ begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(s)
+ end;
+ print(634);
+ printcmdmod(curcmd, curmod);
+ printchar(39);
+ begin
+ helpptr := 4;
+ helpline[3] := 635;
+ helpline[2] := 636;
+ helpline[1] := 637;
+ helpline[0] := 638
+ end;
+ backinput;
+ cursym := 0;
+ curcmd := 42;
+ curmod := 0;
+ inserror;
+ saveflag := varflag;
+ varflag := 0;
+ getxnext;
+ varflag := saveflag
+ end; {:824} {827:}
+
+ procedure stashin(p: halfword);
+ var
+ q: halfword;
+ begin
+ mem[p].hh.b0 := curtype;
+ {
+ 829:}
+ if curtype = 16 then
+ mem[p + 1].int := curexp
+ else begin
+ if curtype = 19 then begin
+ q := singledependency(curexp);
+ if q = depfinal then begin
+ mem[p].hh.b0 := 16;
+ mem[p + 1].int := 0;
+ freenode(q, 2)
+ end else begin
+ mem[p].hh.b0 := 17;
+ newdep(p, q)
+ end;
+ recyclevalue(curexp)
+ end else begin {:829}
+ mem[p + 1] := mem[curexp + 1];
+ mem[mem[p + 1].hh.lh].hh.rh := p
+ end;
+ freenode(curexp, 2)
+ end;
+ curtype := 1
+ end; { stashin }
+ {:827}
+ {848:}
+
+ procedure backexpr;
+ var
+ p: halfword;
+ begin
+ p := stashcurexp;
+ mem[p].hh.rh := -30000;
+ begintokenlist(p, 10)
+ end; {:848} {849:}
+
+ procedure badsubscript;
+ begin
+ disperr(-30000, 650);
+ begin
+ helpptr := 3;
+ helpline[2] := 651;
+ helpline[1] := 652;
+ helpline[0] := 653
+ end;
+ flusherror(0)
+ end; {:849} {851:}
+
+ procedure obliterated(q: halfword);
+ begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(654)
+ end;
+ showtokenlist(q, -30000, 1000, 0);
+ print(655);
+ begin
+ helpptr := 5;
+ helpline[4] := 656;
+ helpline[3] := 657;
+ helpline[2] := 658;
+ helpline[1] := 659;
+ helpline[0] := 660
+ end
+ end; {:851} {863:}
+
+ procedure binarymac(p, c, n: halfword);
+ var
+ q, r: halfword;
+ begin
+ q := getavail;
+ r := getavail;
+ mem[q].hh.rh := r;
+ mem[q].hh.lh := p;
+ mem[r].hh.lh := stashcurexp;
+ macrocall(c, q, n)
+ end; {:863} {865:}
+
+ procedure materializepen;
+ label
+ 50;
+ var
+ aminusb, aplusb, majoraxis, minoraxis: scaled;
+ theta: angle;
+ p: halfword;
+ q: halfword;
+ begin
+ q := curexp;
+ if mem[q].hh.b0 = 0 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(670)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 671;
+ helpline[0] := 442
+ end;
+ putgeterror;
+ curexp := -29997;
+ goto 50
+ end else if mem[q].hh.b0 = 4 then begin {866:}
+ tx := mem[q + 1].int;
+ ty := mem[q + 2].int;
+ txx := mem[q + 3].int - tx;
+ tyx := mem[q + 4].int - ty;
+ txy := mem[q + 5].int - tx;
+ tyy := mem[q + 6].int - ty;
+ aminusb := pythadd(txx - tyy, tyx + txy);
+ aplusb := pythadd(txx + tyy, tyx - txy);
+ majoraxis := (aminusb + aplusb) div 2;
+ minoraxis := abs(aplusb - aminusb) div 2;
+ if majoraxis = minoraxis then
+ theta := 0
+ else
+ theta := (narg(txx - tyy, tyx + txy) + narg(txx + tyy, tyx - txy)) div 2;
+ freenode(q, 7);
+ q := makeellipse(majoraxis, minoraxis, theta);
+ if (tx <> 0) or (ty <> 0) then begin {867:}
+ p := q;
+ repeat
+ mem[p + 1].int := mem[p + 1].int + tx;
+ mem[p + 2].int := mem[p + 2].int + ty;
+ p := mem[p].hh.rh
+ until p = q
+ end {:867}
+ end {:866};
+ curexp := makepen(q);
+ 50:
+ tossknotlist(q);
+ curtype := 6
+ end; {:865}
+ {871:}
+ {872:}
+
+ procedure knownpair;
+ var
+ p: halfword;
+ begin
+ if curtype <> 14 then begin
+ disperr(-30000, 673);
+ begin
+ helpptr := 5;
+ helpline[4] := 674;
+ helpline[3] := 675;
+ helpline[2] := 676;
+ helpline[1] := 677;
+ helpline[0] := 678
+ end;
+ putgetflusherror(0);
+ curx := 0;
+ cury := 0
+ end else begin
+ p := mem[curexp + 1].int; {873:}
+ if mem[p].hh.b0 = 16 then
+ curx := mem[p + 1].int
+ else begin
+ disperr(p, 679);
+ begin
+ helpptr := 5;
+ helpline[4] := 680;
+ helpline[3] := 675;
+ helpline[2] := 676;
+ helpline[1] := 677;
+ helpline[0] := 678
+ end;
+ putgeterror;
+ recyclevalue(p);
+ curx := 0
+ end;
+ if mem[p + 2].hh.b0 = 16 then
+ cury := mem[p + 3].int
+ else begin
+ disperr(p + 2, 681);
+ begin
+ helpptr := 5;
+ helpline[4] := 682;
+ helpline[3] := 675;
+ helpline[2] := 676;
+ helpline[1] := 677;
+ helpline[0] := 678
+ end;
+ putgeterror;
+ recyclevalue(p + 2);
+ cury := 0
+ end {:873};
+ flushcurexp(0)
+ end
+ end; {:872}
+
+ function newknot: halfword;
+ var
+ q: halfword;
+ begin
+ q := getnode(7);
+ mem[q].hh.b0 := 0;
+ mem[q].hh.b1 := 0;
+ mem[q].hh.rh := q;
+ knownpair;
+ mem[q + 1].int := curx;
+ mem[q + 2].int := cury;
+ newknot := q
+ end; {:871} {875:}
+
+ function scandirection: smallnumber;
+ var
+ t: 2..4;
+ x: scaled;
+ begin
+ getxnext;
+ if curcmd = 60 then begin {876:}
+ getxnext;
+ scanexpression;
+ if (curtype <> 16) or (curexp < 0) then begin
+ disperr(-30000, 685);
+ begin
+ helpptr := 1;
+ helpline[0] := 686
+ end;
+ putgetflusherror(65536)
+ end;
+ t := 3
+ end else begin {:876} {877:}
+ scanexpression;
+ if curtype > 14 then begin {878:}
+ if curtype <> 16 then begin
+ disperr(-30000, 679);
+ begin
+ helpptr := 5;
+ helpline[4] := 680;
+ helpline[3] := 675;
+ helpline[2] := 676;
+ helpline[1] := 677;
+ helpline[0] := 678
+ end;
+ putgetflusherror(0)
+ end;
+ x := curexp;
+ if curcmd <> 79 then begin
+ missingerr(44);
+ begin
+ helpptr := 2;
+ helpline[1] := 687;
+ helpline[0] := 688
+ end;
+ backerror
+ end;
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then begin
+ disperr(-30000, 681);
+ begin
+ helpptr := 5;
+ helpline[4] := 682;
+ helpline[3] := 675;
+ helpline[2] := 676;
+ helpline[1] := 677;
+ helpline[0] := 678
+ end;
+ putgetflusherror(0)
+ end;
+ cury := curexp;
+ curx := x
+ end else {:878}
+ knownpair;
+ if (curx = 0) and (cury = 0) then
+ t := 4
+ else begin
+ t := 2;
+ curexp := narg(curx, cury)
+ end
+ end {:877};
+ if curcmd <> 65 then begin
+ missingerr(125);
+ begin
+ helpptr := 3;
+ helpline[2] := 683;
+ helpline[1] := 684;
+ helpline[0] := 563
+ end;
+ backerror
+ end;
+ getxnext;
+ scandirection := t
+ end; {:875} {895:}
+
+ procedure donullary(c: quarterword);
+ var
+ k: integer;
+ begin
+ begin
+ if aritherror then
+ cleararith
+ end;
+ if internal[7] > 131072 then
+ showcmdmod(33, c);
+ case c of
+ 30, 31:
+ begin
+ curtype := 2;
+ curexp := c
+ end;
+ 32:
+ begin
+ curtype := 11;
+ curexp := getnode(6);
+ initedges(curexp)
+ end;
+ 33:
+ begin
+ curtype := 6;
+ curexp := -29997
+ end;
+ 37:
+ begin
+ curtype := 16;
+ curexp := normrand
+ end;
+ 36:
+ begin {896:}
+ curtype := 8;
+ curexp := getnode(7);
+ mem[curexp].hh.b0 := 4;
+ mem[curexp].hh.b1 := 4;
+ mem[curexp].hh.rh := curexp;
+ mem[curexp + 1].int := 0;
+ mem[curexp + 2].int := 0;
+ mem[curexp + 3].int := 65536;
+ mem[curexp + 4].int := 0;
+ mem[curexp + 5].int := 0;
+ mem[curexp + 6].int := 65536
+ end; {:896}
+ 34:
+ begin
+ if jobname = 0 then
+ openlogfile;
+ curtype := 4;
+ curexp := jobname
+ end;
+ 35:
+ begin {897:}
+ if interaction <= 1 then
+ fatalerror(699);
+ beginfilereading;
+ curinput.namefield := 1;
+ begin
+ print(155);
+ terminput
+ end;
+ begin
+ if ((poolptr + last) - curinput.startfield) > maxpoolptr then begin
+ if ((poolptr + last) - curinput.startfield) > poolsize then
+ overflow(129, poolsize - initpoolptr);
+ maxpoolptr := (poolptr + last) - curinput.startfield
+ end
+ end;
+ for k := curinput.startfield to last - 1 do begin
+ strpool[poolptr] := buffer[k];
+ poolptr := poolptr + 1
+ end;
+ endfilereading;
+ curtype := 4;
+ curexp := makestring
+ end
+ end {:897};
+ begin
+ if aritherror then
+ cleararith
+ end
+ end; {:895} {898:}
+ {899:}
+
+ function nicepair(p: integer; t: quarterword): boolean;
+ label
+ 10;
+ begin
+ if t = 14 then begin
+ p := mem[p + 1].int;
+ if mem[p].hh.b0 = 16 then
+ if mem[p + 2].hh.b0 = 16 then begin
+ nicepair := true;
+ goto 10
+ end
+ end;
+ nicepair := false;
+ 10:
+
+ end; {:899} {900:}
+
+ procedure printknownorunknownt(t: smallnumber; v: integer);
+ begin
+ printchar(40);
+ if t < 17 then
+ if t <> 14 then
+ printtype(t)
+ else if nicepair(v, 14) then
+ print(207)
+ else
+ print(700)
+ else
+ print(701);
+ printchar(41)
+ end; {:900} {901:}
+
+ procedure badunary(c: quarterword);
+ begin
+ disperr(-30000, 702);
+ printop(c);
+ printknownorunknownt(curtype, curexp);
+ begin
+ helpptr := 3;
+ helpline[2] := 703;
+ helpline[1] := 704;
+ helpline[0] := 705
+ end;
+ putgeterror
+ end; {:901} {904:}
+
+ procedure negatedeplist(p: halfword);
+ label
+ 10;
+ begin
+ while true do begin
+ mem[p + 1].int := -mem[p + 1].int;
+ if mem[p].hh.lh = (-30000) then
+ goto 10;
+ p := mem[p].hh.rh
+ end;
+ 10:
+
+ end; {:904}
+ {908:}
+
+ procedure pairtopath;
+ begin
+ curexp := newknot;
+ curtype := 9
+ end; {:908}
+ {910:}
+
+ procedure takepart(c: quarterword);
+ var
+ p: halfword;
+ begin
+ p := mem[curexp + 1].int;
+ mem[-29982].int := p;
+ mem[-29983].hh.b0 := curtype;
+ mem[p].hh.rh := -29983;
+ freenode(curexp, 2);
+ makeexpcopy(p + (2 * (c - 53)));
+ recyclevalue(-29983)
+ end; {:910} {913:}
+
+ procedure strtonum(c: quarterword);
+ var
+ n: integer;
+ m: ASCIIcode;
+ k: poolpointer;
+ b: 8..16;
+ badchar: boolean;
+ begin
+ if c = 49 then
+ if (strstart[curexp + 1] - strstart[curexp]) = 0 then
+ n := -1
+ else
+ n := strpool[strstart[curexp]]
+ else begin
+ if c = 47 then
+ b := 8
+ else
+ b := 16;
+ n := 0;
+ badchar := false;
+ for k := strstart[curexp] to strstart[curexp + 1] - 1 do begin
+ m := strpool[k];
+ if (m >= 48) and (m <= 57) then
+ m := m - 48
+ else if (m >= 65) and (m <= 70) then
+ m := m - 55
+ else if (m >= 97) and (m <= 102) then
+ m := m - 87
+ else begin
+ badchar := true;
+ m := 0
+ end;
+ if m >= b then begin
+ badchar := true;
+ m := 0
+ end;
+ if n < (32768 div b) then
+ n := (n * b) + m
+ else
+ n := 32767
+ end; {914:}
+ if badchar then begin
+ disperr(-30000, 707);
+ if c = 47 then begin
+ helpptr := 1;
+ helpline[0] := 708
+ end else begin
+ helpptr := 1;
+ helpline[0] := 709
+ end;
+ putgeterror
+ end;
+ if n > 4095 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(710)
+ end;
+ printint(n);
+ printchar(41);
+ begin
+ helpptr := 1;
+ helpline[0] := 711
+ end;
+ putgeterror
+ end {:914}
+ end;
+ flushcurexp(n * 65536)
+ end; { strtonum }
+ {:913}
+ {916:}
+
+ function pathlength: scaled;
+ var
+ n: scaled;
+ p: halfword;
+ begin
+ p := curexp;
+ if mem[p].hh.b0 = 0 then
+ n := -65536
+ else
+ n := 0;
+ repeat
+ p := mem[p].hh.rh;
+ n := n + 65536
+ until p = curexp;
+ pathlength := n
+ end; { pathlength }
+ {:916}
+ {919:}
+
+ procedure testknown(c: quarterword);
+ label
+ 30;
+ var
+ b: 30..31;
+ p, q: halfword;
+ begin
+ b := 31;
+ if curtype in
+ [1, 2, 4, 6, 8, 9, 11, 16,
+ 13, 14] then
+ case curtype of
+ 1, 2, 4, 6, 8, 9, 11,
+ 16:
+ b := 30;
+ 13, 14:
+ begin
+ p := mem[curexp + 1].int;
+ q := p + bignodesize[curtype];
+ repeat
+ q := q - 2;
+ if mem[q].hh.b0 <> 16 then
+ goto 30
+ until q = p;
+ b := 30;
+ 30:
+
+ end
+ end
+ else
+ ;
+ if c = 39 then
+ flushcurexp(b)
+ else
+ flushcurexp(61 - b);
+ curtype := 2
+ end; {:919}
+
+ procedure dounary(c: quarterword);
+ var
+ p, q: halfword;
+ x: integer;
+ begin
+ begin
+ if aritherror then
+ cleararith
+ end;
+ if internal[7] > 131072 then begin {902:}
+ begindiagnostic;
+ printnl(123);
+ printop(c);
+ printchar(40);
+ printexp(-30000, 0);
+ print(706);
+ enddiagnostic(false)
+ end {:902};
+ case c of
+ 69:
+ if curtype < 14 then
+ if curtype <> 11 then
+ badunary(69);
+ 70: {903:}
+ if curtype in
+ [14, 19, 17, 18, 16, 11] then
+ case curtype of
+ 14, 19:
+ begin
+ q := curexp;
+ makeexpcopy(q);
+ if curtype = 17 then
+ negatedeplist(mem[curexp + 1].hh.rh)
+ else if curtype = 14 then begin
+ p := mem[curexp + 1].int;
+ if mem[p].hh.b0 = 16 then
+ mem[p + 1].int := -mem[p + 1].int
+ else
+ negatedeplist(mem[p + 1].hh.rh);
+ if mem[p + 2].hh.b0 = 16 then
+ mem[p + 3].int := -mem[p + 3].int
+ else
+ negatedeplist(mem[p + 3].hh.rh)
+ end;
+ recyclevalue(q);
+ freenode(q, 2)
+ end;
+ 17, 18:
+ negatedeplist(mem[curexp + 1].hh.rh);
+ 16:
+ curexp := -curexp;
+ 11:
+ negateedges(curexp)
+ end
+ else
+ badunary(70) {:903}; {905:}
+ 41:
+ if curtype <> 2 then
+ badunary(41)
+ else
+ curexp := 61 - curexp; {:905} {906:}
+ 59, 60, 61, 62, 63, 64, 65,
+ 38, 66:
+ if curtype <> 16 then
+ badunary(c)
+ else
+ case c of
+ 59:
+ curexp := squarert(curexp);
+ 60:
+ curexp := mexp(curexp);
+ 61:
+ curexp := mlog(curexp);
+ 62, 63:
+ begin
+ nsincos((curexp mod 23592960) * 16);
+ if c = 62 then
+ curexp := roundfraction(nsin)
+ else
+ curexp := roundfraction(ncos)
+ end;
+ 64:
+ curexp := floorscaled(curexp);
+ 65:
+ curexp := unifrand(curexp);
+ 38:
+ begin
+ if odd(roundunscaled(curexp)) then
+ curexp := 30
+ else
+ curexp := 31;
+ curtype := 2
+ end;
+ 66:
+ begin {1181:}
+ curexp := roundunscaled(curexp) mod 256;
+ if curexp < 0 then
+ curexp := curexp + 256;
+ if charexists[curexp] then
+ curexp := 30
+ else
+ curexp := 31;
+ curtype := 2
+ end
+ end {:1181}; {:906} {907:}
+ 67:
+ if nicepair(curexp, curtype) then begin
+ p := mem[curexp + 1].int;
+ x := narg(mem[p + 1].int, mem[p + 3].int);
+ if x >= 0 then
+ flushcurexp((x + 8) div 16)
+ else
+ flushcurexp(-(((-x) + 8) div 16))
+ end else
+ badunary(67); {:907} {909:}
+ 53, 54:
+ if (curtype <= 14) and (curtype >= 13) then
+ takepart(c)
+ else
+ badunary(c);
+ 55, 56, 57, 58:
+ if curtype = 13 then
+ takepart(c)
+ else
+ badunary(c); {:909} {912:}
+ 50:
+ if curtype <> 16 then
+ badunary(50)
+ else begin
+ curexp := roundunscaled(curexp) mod 128;
+ curtype := 4;
+ if curexp < 0 then
+ curexp := curexp + 128;
+ if (strstart[curexp + 1] - strstart[curexp]) <> 1 then begin
+ begin
+ if (poolptr + 1) > maxpoolptr then begin
+ if (poolptr + 1) > poolsize then
+ overflow(129, poolsize - initpoolptr);
+ maxpoolptr := poolptr + 1
+ end
+ end;
+ begin
+ strpool[poolptr] := curexp;
+ poolptr := poolptr + 1
+ end;
+ curexp := makestring
+ end
+ end;
+ 42:
+ if curtype <> 16 then
+ badunary(42)
+ else begin
+ oldsetting := selector;
+ selector := 5;
+ printscaled(curexp);
+ curexp := makestring;
+ selector := oldsetting;
+ curtype := 4
+ end;
+ 47, 48, 49:
+ if curtype <> 4 then
+ badunary(c)
+ else
+ strtonum(c);
+ {:912}
+ {915:}
+ 51:
+ if curtype = 4 then
+ flushcurexp((strstart[curexp + 1] - strstart[curexp]) * 65536)
+ else if curtype = 9 then
+ flushcurexp(pathlength)
+ else if curtype = 16 then
+ curexp := abs(curexp)
+ else if nicepair(curexp, curtype) then
+ flushcurexp(pythadd(mem[mem[curexp + 1].int + 1].int, mem[mem[curexp + 1].int + 3].int))
+ else
+ badunary(c); {:915} {917:}
+ 52:
+ if curtype = 14 then
+ flushcurexp(0)
+ else if curtype <> 9 then
+ badunary(52)
+ else if mem[curexp].hh.b0 = 0 then
+ flushcurexp(0)
+ else begin
+ curpen := -29997;
+ curpathtype := 1;
+ curexp := makespec(curexp, -1879080960, 0);
+ flushcurexp(turningnumber * 65536)
+ end; {:917} {918:}
+ 2:
+ begin
+ if (curtype >= 2) and (curtype <= 3) then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end;
+ 4:
+ begin
+ if (curtype >= 4) and (curtype <= 5) then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end;
+ 6:
+ begin
+ if (curtype >= 6) and (curtype <= 8) then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end;
+ 9:
+ begin
+ if (curtype >= 9) and (curtype <= 10) then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end;
+ 11:
+ begin
+ if (curtype >= 11) and (curtype <= 12) then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end;
+ 13, 14:
+ begin
+ if curtype = c then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end;
+ 15:
+ begin
+ if (curtype >= 16) and (curtype <= 19) then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end;
+ 39, 40:
+ testknown(c); {:918} {920:}
+ 68:
+ begin
+ if curtype <> 9 then
+ flushcurexp(31)
+ else if mem[curexp].hh.b0 <> 0 then
+ flushcurexp(30)
+ else
+ flushcurexp(31);
+ curtype := 2
+ end; {:920} {921:}
+ 45:
+ begin
+ if curtype = 14 then
+ pairtopath;
+ if curtype = 9 then
+ curtype := 8
+ else
+ badunary(45)
+ end;
+ 44:
+ begin
+ if curtype = 8 then
+ materializepen;
+ if curtype <> 6 then
+ badunary(44)
+ else begin
+ flushcurexp(makepath(curexp));
+ curtype := 9
+ end
+ end;
+ 46:
+ if curtype <> 11 then
+ badunary(46)
+ else
+ flushcurexp(totalweight(curexp));
+ 43:
+ if curtype = 9 then begin
+ p := htapypoc(curexp);
+ if mem[p].hh.b1 = 0 then
+ p := mem[p].hh.rh;
+ tossknotlist(curexp);
+ curexp := p
+ end else if curtype = 14 then
+ pairtopath
+ else
+ badunary(43)
+ end {:921};
+ begin
+ if aritherror then
+ cleararith
+ end
+ end; {:898} {922:} {923:}
+
+ procedure badbinary(p: halfword; c: quarterword);
+ begin
+ disperr(p, 155);
+ disperr(-30000, 702);
+ if c >= 94 then
+ printop(c);
+ printknownorunknownt(mem[p].hh.b0, p);
+ if c >= 94 then
+ print(347)
+ else
+ printop(c);
+ printknownorunknownt(curtype, curexp);
+ begin
+ helpptr := 3;
+ helpline[2] := 703;
+ helpline[1] := 712;
+ helpline[0] := 713
+ end;
+ putgeterror
+ end; {:923} {928:}
+
+ function tarnished(p: halfword): halfword;
+ label
+ 10;
+ var
+ q: halfword;
+ r: halfword;
+ begin
+ q := mem[p + 1].int;
+ r := q + bignodesize[mem[p].hh.b0];
+ repeat
+ r := r - 2;
+ if mem[r].hh.b0 = 19 then begin
+ tarnished := -29999;
+ goto 10
+ end
+ until r = q;
+ tarnished := -30000;
+ 10:
+
+ end; {:928} {930:} {935:}
+
+ procedure depfinish(v, q: halfword; t: smallnumber);
+ var
+ p: halfword;
+ vv: scaled;
+ begin
+ if q = (-30000) then
+ p := curexp
+ else
+ p := q;
+ mem[p + 1].hh.rh := v;
+ mem[p].hh.b0 := t;
+ if mem[v].hh.lh = (-30000) then begin
+ vv := mem[v + 1].int;
+ if q = (-30000) then
+ flushcurexp(vv)
+ else begin
+ recyclevalue(p);
+ mem[q].hh.b0 := 16;
+ mem[q + 1].int := vv
+ end
+ end else if q = (-30000) then
+ curtype := t;
+ if fixneeded then
+ fixdependencies
+ end; {:935}
+
+ procedure addorsubtract(p, q: halfword; c: quarterword);
+ label
+ 30, 10;
+ var
+ s, t: smallnumber;
+ r: halfword;
+ v: integer;
+ begin
+ if q = (-30000) then begin
+ t := curtype;
+ if t < 17 then
+ v := curexp
+ else
+ v := mem[curexp + 1].hh.rh
+ end else begin
+ t := mem[q].hh.b0;
+ if t < 17 then
+ v := mem[q + 1].int
+ else
+ v := mem[q + 1].hh.rh
+ end;
+ if t = 16 then begin
+ if c = 70 then
+ v := -v;
+ if mem[p].hh.b0 = 16 then begin
+ v := slowadd(mem[p + 1].int, v);
+ if q = (-30000) then
+ curexp := v
+ else
+ mem[q + 1].int := v;
+ goto 10
+ end; {931:}
+ r := mem[p + 1].hh.rh;
+ while mem[r].hh.lh <> (-30000) do
+ r := mem[r].hh.rh;
+ mem[r + 1].int := slowadd(mem[r + 1].int, v);
+ if q = (-30000) then begin
+ q := getnode(2);
+ curexp := q;
+ curtype := mem[p].hh.b0;
+ mem[q].hh.b1 := 11
+ end;
+ mem[q + 1].hh.rh := mem[p + 1].hh.rh;
+ mem[q].hh.b0 := mem[p].hh.b0;
+ mem[q + 1].hh.lh := mem[p + 1].hh.lh;
+ mem[mem[p + 1].hh.lh].hh.rh := q;
+ mem[p].hh.b0 := 16
+ end else begin {:931}
+ if c = 70 then
+ negatedeplist(v); {932:}
+ if mem[p].hh.b0 = 16 then begin {933:}
+ while mem[v].hh.lh <> (-30000) do
+ v := mem[v].hh.rh;
+ mem[v + 1].int := slowadd(mem[p + 1].int, mem[v + 1].int)
+ end else begin {:933}
+ s := mem[p].hh.b0;
+ r := mem[p + 1].hh.rh;
+ if t = 17 then begin
+ if s = 17 then
+ if (maxcoef(r) + maxcoef(v)) < 626349397 then begin
+ v := pplusq(v, r, 17);
+ goto 30
+ end;
+ t := 18;
+ v := poverv(v, 65536, 17, 18)
+ end;
+ if s = 18 then
+ v := pplusq(v, r, 18)
+ else
+ v := pplusfq(v, 65536, r, 18, 17);
+ 30: {934:}
+ if q <> (-30000) then
+ depfinish(v, q, t)
+ else begin
+ curtype := t;
+ depfinish(v, -30000, t)
+ end {:934}
+ end {:932}
+ end;
+ 10:
+
+ end; {:930} {943:}
+
+ procedure depmult(p: halfword; v: integer; visscaled: boolean);
+ label
+ 10;
+ var
+ q: halfword;
+ s, t: smallnumber;
+ begin
+ if p = (-30000) then
+ q := curexp
+ else if mem[p].hh.b0 <> 16 then
+ q := p
+ else begin
+ if visscaled then
+ mem[p + 1].int := takescaled(mem[p + 1].int, v)
+ else
+ mem[p + 1].int := takefraction(mem[p + 1].int, v);
+ goto 10
+ end;
+ t := mem[q].hh.b0;
+ q := mem[q + 1].hh.rh;
+ s := t;
+ if t = 17 then
+ if visscaled then
+ if abvscd(maxcoef(q), abs(v), 626349396, 65536) >= 0 then
+ t := 18;
+ q := ptimesv(q, v, s, t, visscaled);
+ depfinish(q, p, t);
+ 10:
+
+ end; {:943} {946:}
+
+ procedure hardtimes(p: halfword);
+ var
+ q: halfword;
+ r: halfword;
+ u, v: scaled;
+ begin
+ if mem[p].hh.b0 = 14 then begin
+ q := stashcurexp;
+ unstashcurexp(p);
+ p := q
+ end;
+ r := mem[curexp + 1].int;
+ u := mem[r + 1].int;
+ v := mem[r + 3].int; {947:}
+ mem[r + 2].hh.b0 := mem[p].hh.b0;
+ newdep(r + 2, copydeplist(mem[p + 1].hh.rh));
+ mem[r].hh.b0 := mem[p].hh.b0;
+ mem[r + 1] := mem[p + 1];
+ mem[mem[p + 1].hh.lh].hh.rh := r;
+ freenode(p, 2) {:947};
+ depmult(r, u, true);
+ depmult(r + 2, v, true)
+ end; {:946} {949:}
+
+ procedure depdiv(p: halfword; v: scaled);
+ label
+ 10;
+ var
+ q: halfword;
+ s, t: smallnumber;
+ begin
+ if p = (-30000) then
+ q := curexp
+ else if mem[p].hh.b0 <> 16 then
+ q := p
+ else begin
+ mem[p + 1].int := makescaled(mem[p + 1].int, v);
+ goto 10
+ end;
+ t := mem[q].hh.b0;
+ q := mem[q + 1].hh.rh;
+ s := t;
+ if t = 17 then
+ if abvscd(maxcoef(q), 65536, 626349396, abs(v)) >= 0 then
+ t := 18;
+ q := poverv(q, v, s, t);
+ depfinish(q, p, t);
+ 10:
+
+ end; {:949} {953:}
+
+ procedure setuptrans(c: quarterword);
+ label
+ 30, 10;
+ var
+ p, q, r: halfword;
+ begin
+ if (c <> 88) or (curtype <> 13) then begin {955:}
+ p := stashcurexp;
+ curexp := idtransform;
+ curtype := 13;
+ q := mem[curexp + 1].int;
+ case c of {957:}
+ 84:
+ if mem[p].hh.b0 = 16 then begin {958:}
+ nsincos((mem[p + 1].int mod 23592960) * 16);
+ mem[q + 5].int := roundfraction(ncos);
+ mem[q + 9].int := roundfraction(nsin);
+ mem[q + 7].int := -mem[q + 9].int;
+ mem[q + 11].int := mem[q + 5].int;
+ goto 30
+ end {:958};
+ 85:
+ if mem[p].hh.b0 > 14 then begin
+ install(q + 6, p);
+ goto 30
+ end;
+ 86:
+ if mem[p].hh.b0 > 14 then begin
+ install(q + 4, p);
+ install(q + 10, p);
+ goto 30
+ end;
+ 87:
+ if mem[p].hh.b0 = 14 then begin
+ r := mem[p + 1].int;
+ install(q, r);
+ install(q + 2, r + 2);
+ goto 30
+ end;
+ 89:
+ if mem[p].hh.b0 > 14 then begin
+ install(q + 4, p);
+ goto 30
+ end;
+ 90:
+ if mem[p].hh.b0 > 14 then begin
+ install(q + 10, p);
+ goto 30
+ end;
+ 91:
+ if mem[p].hh.b0 = 14 then begin {959:}
+ r := mem[p + 1].int;
+ install(q + 4, r);
+ install(q + 10, r);
+ install(q + 8, r + 2);
+ if mem[r + 2].hh.b0 = 16 then
+ mem[r + 3].int := -mem[r + 3].int
+ else
+ negatedeplist(mem[r + 3].hh.rh);
+ install(q + 6, r + 2);
+ goto 30
+ end {:959};
+ 88:
+
+ end {:957};
+ disperr(p, 722);
+ begin
+ helpptr := 3;
+ helpline[2] := 723;
+ helpline[1] := 724;
+ helpline[0] := 405
+ end;
+ putgeterror;
+ 30:
+ recyclevalue(p);
+ freenode(p, 2)
+ end {:955}; {956:}
+ q := mem[curexp + 1].int;
+ r := q + 12;
+ repeat
+ r := r - 2;
+ if mem[r].hh.b0 <> 16 then
+ goto 10
+ until r = q;
+ txx := mem[q + 5].int;
+ txy := mem[q + 7].int;
+ tyx := mem[q + 9].int;
+ tyy := mem[q + 11].int;
+ tx := mem[q + 1].int;
+ ty := mem[q + 3].int;
+ flushcurexp(0) {:956};
+ 10:
+
+ end; {:953} {960:}
+
+ procedure setupknowntrans(c: quarterword);
+ begin
+ setuptrans(c);
+ if curtype <> 16 then begin
+ disperr(-30000, 725);
+ begin
+ helpptr := 3;
+ helpline[2] := 726;
+ helpline[1] := 727;
+ helpline[0] := 405
+ end;
+ putgetflusherror(0);
+ txx := 65536;
+ txy := 0;
+ tyx := 0;
+ tyy := 65536;
+ tx := 0;
+ ty := 0
+ end
+ end; {:960} {961:}
+
+ procedure trans(p, q: halfword);
+ var
+ v: scaled;
+ begin
+ v := (takescaled(mem[p].int, txx) + takescaled(mem[q].int, txy)) + tx;
+ mem[q].int := (takescaled(mem[p].int, tyx) + takescaled(mem[q].int, tyy)) + ty;
+ mem[p].int := v
+ end; {:961} {962:}
+
+ procedure pathtrans(p: halfword; c: quarterword);
+ label
+ 10;
+ var
+ q: halfword;
+ begin
+ setupknowntrans(c);
+ unstashcurexp(p);
+ if curtype = 6 then begin
+ if mem[curexp + 9].int = 0 then
+ if tx = 0 then
+ if ty = 0 then
+ goto 10;
+ flushcurexp(makepath(curexp));
+ curtype := 8
+ end;
+ q := curexp;
+ repeat
+ if mem[q].hh.b0 <> 0 then
+ trans(q + 3, q + 4);
+ trans(q + 1, q + 2);
+ if mem[q].hh.b1 <> 0 then
+ trans(q + 5, q + 6);
+ q := mem[q].hh.rh
+ until q = curexp;
+ 10:
+
+ end; {:962} {963:}
+
+ procedure edgestrans(p: halfword; c: quarterword);
+ label
+ 10;
+ begin
+ setupknowntrans(c);
+ unstashcurexp(p);
+ curedges := curexp;
+ if mem[curedges].hh.rh = curedges then
+ goto 10;
+ if txx = 0 then
+ if tyy = 0 then
+ if (txy mod 65536) = 0 then
+ if (tyx mod 65536) = 0 then begin
+ xyswapedges;
+ txx := txy;
+ tyy := tyx;
+ txy := 0;
+ tyx := 0;
+ if mem[curedges].hh.rh = curedges then
+ goto 10
+ end;
+ if txy = 0 then
+ if tyx = 0 then
+ if (txy mod 65536) = 0 then
+ if (tyy mod 65536) = 0 then begin {964:}
+ if (txx = 0) or (tyy = 0) then begin
+ tossedges(curedges);
+ curexp := getnode(6);
+ initedges(curexp)
+ end else begin
+ if txx < 0 then begin
+ xreflectedges;
+ txx := -txx
+ end;
+ if tyy < 0 then begin
+ yreflectedges;
+ tyy := -tyy
+ end;
+ if txx <> 65536 then
+ xscaleedges(txx div 65536);
+ if tyy <> 65536 then
+ yscaleedges(tyy div 65536); {965:}
+ tx := roundunscaled(tx);
+ ty := roundunscaled(ty);
+ if ((((((mem[curedges + 2].hh.lh + tx) <= 0) or ((mem[curedges + 2].hh.rh + tx) >= 8192)) or ((mem[curedges + 1].hh.lh + ty) <= 0)) or ((mem[curedges + 1].hh.rh + ty) >= 8191)) or (abs(tx) >= 4096)) or (abs(ty) >= 4096) then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(731)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 732;
+ helpline[1] := 404;
+ helpline[0] := 405
+ end;
+ putgeterror
+ end else begin
+ if tx <> 0 then begin
+ if not (abs((mem[curedges + 3].hh.lh - tx) - 4096) < 4096) then
+ fixoffset;
+ mem[curedges + 2].hh.lh := mem[curedges + 2].hh.lh + tx;
+ mem[curedges + 2].hh.rh := mem[curedges + 2].hh.rh + tx;
+ mem[curedges + 3].hh.lh := mem[curedges + 3].hh.lh - tx;
+ mem[curedges + 4].int := 0
+ end;
+ if ty <> 0 then begin
+ mem[curedges + 1].hh.lh := mem[curedges + 1].hh.lh + ty;
+ mem[curedges + 1].hh.rh := mem[curedges + 1].hh.rh + ty;
+ mem[curedges + 5].hh.lh := mem[curedges + 5].hh.lh + ty;
+ mem[curedges + 4].int := 0
+ end
+ end {:965}
+ end;
+ goto 10
+ end {:964};
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(728)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 729;
+ helpline[1] := 730;
+ helpline[0] := 405
+ end;
+ putgeterror;
+ 10:
+
+ end; {:963} {966:}
+ {968:}
+
+ procedure bilin1(p: halfword; t: scaled; q: halfword; u, delta: scaled);
+ var
+ r: halfword;
+ begin
+ if t <> 65536 then
+ depmult(p, t, true);
+ if u <> 0 then
+ if mem[q].hh.b0 = 16 then
+ delta := delta + takescaled(mem[q + 1].int, u)
+ else begin {969:}
+ if mem[p].hh.b0 <> 18 then begin
+ if mem[p].hh.b0 = 16 then
+ newdep(p, constdependency(mem[p + 1].int))
+ else
+ mem[p + 1].hh.rh := ptimesv(mem[p + 1].hh.rh, 65536, 17, 18, true);
+ mem[p].hh.b0 := 18
+ end {:969};
+ mem[p + 1].hh.rh := pplusfq(mem[p + 1].hh.rh, u, mem[q + 1].hh.rh, 18, mem[q].hh.b0)
+ end;
+ if mem[p].hh.b0 = 16 then
+ mem[p + 1].int := mem[p + 1].int + delta
+ else begin
+ r := mem[p + 1].hh.rh;
+ while mem[r].hh.lh <> (-30000) do
+ r := mem[r].hh.rh;
+ delta := mem[r + 1].int + delta;
+ if r <> mem[p + 1].hh.rh then
+ mem[r + 1].int := delta
+ else begin
+ recyclevalue(p);
+ mem[p].hh.b0 := 16;
+ mem[p + 1].int := delta
+ end
+ end;
+ if fixneeded then
+ fixdependencies
+ end; {:968} {971:}
+
+ procedure addmultdep(p: halfword; v: scaled; r: halfword);
+ begin
+ if mem[r].hh.b0 = 16 then
+ mem[depfinal + 1].int := mem[depfinal + 1].int + takescaled(mem[r + 1].int, v)
+ else begin
+ mem[p + 1].hh.rh := pplusfq(mem[p + 1].hh.rh, v, mem[r + 1].hh.rh, 18, mem[r].hh.b0);
+ if fixneeded then
+ fixdependencies
+ end
+ end; {:971} {972:}
+
+ procedure bilin2(p, t: halfword; v: scaled; u, q: halfword);
+ var
+ vv: scaled;
+ begin
+ vv := mem[p + 1].int;
+ mem[p].hh.b0 := 18;
+ newdep(p, constdependency(0));
+ if vv <> 0 then
+ addmultdep(p, vv, t);
+ if v <> 0 then
+ addmultdep(p, v, u);
+ if q <> (-30000) then
+ addmultdep(p, 65536, q);
+ if mem[p + 1].hh.rh = depfinal then begin
+ vv := mem[depfinal + 1].int;
+ recyclevalue(p);
+ mem[p].hh.b0 := 16;
+ mem[p + 1].int := vv
+ end
+ end; {:972} {974:}
+
+ procedure bilin3(p: halfword; t, v, u, delta: scaled);
+ begin
+ if t <> 65536 then
+ delta := delta + takescaled(mem[p + 1].int, t)
+ else
+ delta := delta + mem[p + 1].int;
+ if u <> 0 then
+ mem[p + 1].int := delta + takescaled(v, u)
+ else
+ mem[p + 1].int := delta
+ end; {:974}
+
+ procedure bigtrans(p: halfword; c: quarterword);
+ label
+ 10;
+ var
+ q, r, pp, qq: halfword;
+ s: smallnumber;
+ begin
+ s := bignodesize[mem[p].hh.b0];
+ q := mem[p + 1].int;
+ r := q + s;
+ repeat
+ r := r - 2;
+ if mem[r].hh.b0 <> 16 then begin {967:}
+ setupknowntrans(c);
+ makeexpcopy(p);
+ r := mem[curexp + 1].int;
+ if curtype = 13 then begin
+ bilin1(r + 10, tyy, q + 6, tyx, 0);
+ bilin1(r + 8, tyy, q + 4, tyx, 0);
+ bilin1(r + 6, txx, q + 10, txy, 0);
+ bilin1(r + 4, txx, q + 8, txy, 0)
+ end;
+ bilin1(r + 2, tyy, q, tyx, ty);
+ bilin1(r, txx, q + 2, txy, tx);
+ goto 10
+ end {:967}
+ until r = q; {970:}
+ setuptrans(c);
+ if curtype = 16 then begin {973:}
+ makeexpcopy(p);
+ r := mem[curexp + 1].int;
+ if curtype = 13 then begin
+ bilin3(r + 10, tyy, mem[q + 7].int, tyx, 0);
+ bilin3(r + 8, tyy, mem[q + 5].int, tyx, 0);
+ bilin3(r + 6, txx, mem[q + 11].int, txy, 0);
+ bilin3(r + 4, txx, mem[q + 9].int, txy, 0)
+ end;
+ bilin3(r + 2, tyy, mem[q + 1].int, tyx, ty);
+ bilin3(r, txx, mem[q + 3].int, txy, tx)
+ end else begin {:973}
+ pp := stashcurexp;
+ qq := mem[pp + 1].int;
+ makeexpcopy(p);
+ r := mem[curexp + 1].int;
+ if curtype = 13 then begin
+ bilin2(r + 10, qq + 10, mem[q + 7].int, qq + 8, -30000);
+ bilin2(r + 8, qq + 10, mem[q + 5].int, qq + 8, -30000);
+ bilin2(r + 6, qq + 4, mem[q + 11].int, qq + 6, -30000);
+ bilin2(r + 4, qq + 4, mem[q + 9].int, qq + 6, -30000)
+ end;
+ bilin2(r + 2, qq + 10, mem[q + 1].int, qq + 8, qq + 2);
+ bilin2(r, qq + 4, mem[q + 3].int, qq + 6, qq);
+ recyclevalue(pp);
+ freenode(pp, 2)
+ end;
+ {:970}
+ 10:
+
+ end; {:966} {976:}
+
+ procedure cat(p: halfword);
+ var
+ a, b: strnumber;
+ k: poolpointer;
+ begin
+ a := mem[p + 1].int;
+ b := curexp;
+ begin
+ if ((poolptr + (strstart[a + 1] - strstart[a])) + (strstart[b + 1] - strstart[b])) > maxpoolptr then begin
+ if ((poolptr + (strstart[a + 1] - strstart[a])) + (strstart[b + 1] - strstart[b])) > poolsize then
+ overflow(129, poolsize - initpoolptr);
+ maxpoolptr := (poolptr + (strstart[a + 1] - strstart[a])) + (strstart[b + 1] - strstart[b])
+ end
+ end;
+ for k := strstart[a] to strstart[a + 1] - 1 do begin
+ strpool[poolptr] := strpool[k];
+ poolptr := poolptr + 1
+ end;
+ for k := strstart[b] to strstart[b + 1] - 1 do begin
+ strpool[poolptr] := strpool[k];
+ poolptr := poolptr + 1
+ end;
+ curexp := makestring;
+ begin
+ if strref[b] < 127 then
+ if strref[b] > 1 then
+ strref[b] := strref[b] - 1
+ else
+ flushstring(b)
+ end
+ end; {:976} {977:}
+
+ procedure chopstring(p: halfword);
+ var
+ a, b: integer;
+ l: integer;
+ k: integer;
+ s: strnumber;
+ reversed: boolean;
+ begin
+ a := roundunscaled(mem[p + 1].int);
+ b := roundunscaled(mem[p + 3].int);
+ if a <= b then
+ reversed := false
+ else begin
+ reversed := true;
+ k := a;
+ a := b;
+ b := k
+ end;
+ s := curexp;
+ l := strstart[s + 1] - strstart[s];
+ if a < 0 then begin
+ a := 0;
+ if b < 0 then
+ b := 0
+ end;
+ if b > l then begin
+ b := l;
+ if a > l then
+ a := l
+ end;
+ begin
+ if ((poolptr + b) - a) > maxpoolptr then begin
+ if ((poolptr + b) - a) > poolsize then
+ overflow(129, poolsize - initpoolptr);
+ maxpoolptr := (poolptr + b) - a
+ end
+ end;
+ if reversed then
+ for k := (strstart[s] + b) - 1 downto strstart[s] + a do begin
+ strpool[poolptr] := strpool[k];
+ poolptr := poolptr + 1
+ end
+ else
+ for k := strstart[s] + a to (strstart[s] + b) - 1 do begin
+ strpool[poolptr] := strpool[k];
+ poolptr := poolptr + 1
+ end;
+ curexp := makestring;
+ begin
+ if strref[s] < 127 then
+ if strref[s] > 1 then
+ strref[s] := strref[s] - 1
+ else
+ flushstring(s)
+ end
+ end; {:977} {978:}
+
+ procedure choppath(p: halfword);
+ var
+ q: halfword;
+ pp, qq, rr, ss: halfword;
+ a, b, k, l: scaled;
+ reversed: boolean;
+ begin
+ l := pathlength;
+ a := mem[p + 1].int;
+ b := mem[p + 3].int;
+ if a <= b then
+ reversed := false
+ else begin
+ reversed := true;
+ k := a;
+ a := b;
+ b := k
+ end; {979:}
+ if a < 0 then
+ if mem[curexp].hh.b0 = 0 then begin
+ a := 0;
+ if b < 0 then
+ b := 0
+ end else
+ repeat
+ a := a + l;
+ b := b + l
+ until a >= 0;
+ if b > l then
+ if mem[curexp].hh.b0 = 0 then begin
+ b := l;
+ if a > l then
+ a := l
+ end else
+ while a >= l do begin
+ a := a - l;
+ b := b - l
+ end {:979};
+ q := curexp;
+ while a >= 65536 do begin
+ q := mem[q].hh.rh;
+ a := a - 65536;
+ b := b - 65536
+ end;
+ if b = a then begin {981:}
+ if a > 0 then begin
+ qq := mem[q].hh.rh;
+ splitcubic(q, a * 4096, mem[qq + 1].int, mem[qq + 2].int);
+ q := mem[q].hh.rh
+ end;
+ pp := copyknot(q);
+ qq := pp
+ end else begin {:981} {980:}
+ pp := copyknot(q);
+ qq := pp;
+ repeat
+ q := mem[q].hh.rh;
+ rr := qq;
+ qq := copyknot(q);
+ mem[rr].hh.rh := qq;
+ b := b - 65536
+ until b <= 0;
+ if a > 0 then begin
+ ss := pp;
+ pp := mem[pp].hh.rh;
+ splitcubic(ss, a * 4096, mem[pp + 1].int, mem[pp + 2].int);
+ pp := mem[ss].hh.rh;
+ freenode(ss, 7);
+ if rr = ss then begin
+ b := makescaled(b, 65536 - a);
+ rr := pp
+ end
+ end;
+ if b < 0 then begin
+ splitcubic(rr, (b + 65536) * 4096, mem[qq + 1].int, mem[qq + 2].int);
+ freenode(qq, 7);
+ qq := mem[rr].hh.rh
+ end
+ end {:980};
+ mem[pp].hh.b0 := 0;
+ mem[qq].hh.b1 := 0;
+ mem[qq].hh.rh := pp;
+ tossknotlist(curexp);
+ if reversed then begin
+ curexp := mem[htapypoc(pp)].hh.rh;
+ tossknotlist(pp)
+ end else
+ curexp := pp
+ end; {:978} {982:}
+
+ procedure pairvalue(x, y: scaled);
+ var
+ p: halfword;
+ begin
+ p := getnode(2);
+ flushcurexp(p);
+ curtype := 14;
+ mem[p].hh.b0 := 14;
+ mem[p].hh.b1 := 11;
+ initbignode(p);
+ p := mem[p + 1].int;
+ mem[p].hh.b0 := 16;
+ mem[p + 1].int := x;
+ mem[p + 2].hh.b0 := 16;
+ mem[p + 3].int := y
+ end; { pairvalue }
+ {:982}
+ {984:}
+
+ procedure setupoffset(p: halfword);
+ begin
+ findoffset(mem[p + 1].int, mem[p + 3].int, curexp);
+ pairvalue(curx, cury)
+ end;
+
+ procedure setupdirectiontime(p: halfword);
+ begin
+ flushcurexp(finddirectiontime(mem[p + 1].int, mem[p + 3].int, curexp))
+ end; {:984} {985:}
+
+ procedure findpoint(v: scaled; c: quarterword);
+ var
+ p: halfword;
+ n: scaled;
+ vv: scaled;
+ q: halfword;
+ begin
+ vv := v;
+ p := curexp;
+ if mem[p].hh.b0 = 0 then
+ n := -65536
+ else
+ n := 0;
+ repeat
+ p := mem[p].hh.rh;
+ n := n + 65536
+ until p = curexp;
+ if n = 0 then
+ v := 0
+ else if v < 0 then
+ if mem[p].hh.b0 = 0 then
+ v := 0
+ else
+ v := (n - 1) - (((-v) - 1) mod n)
+ else if v > n then
+ if mem[p].hh.b0 = 0 then
+ v := n
+ else
+ v := v mod n;
+ p := curexp;
+ while v >= 65536 do begin
+ p := mem[p].hh.rh;
+ v := v - 65536
+ end;
+ if v <> 0 then begin {986:}
+ q := mem[p].hh.rh;
+ splitcubic(p, v * 4096, mem[q + 1].int, mem[q + 2].int);
+ p := mem[p].hh.rh
+ end {:986}; {987:}
+ case c of
+ 97:
+ pairvalue(mem[p + 1].int, mem[p + 2].int);
+ 98:
+ if mem[p].hh.b0 = 0 then
+ pairvalue(mem[p + 1].int, mem[p + 2].int)
+ else
+ pairvalue(mem[p + 3].int, mem[p + 4].int);
+ 99:
+ if mem[p].hh.b1 = 0 then
+ pairvalue(mem[p + 1].int, mem[p + 2].int)
+ else
+ pairvalue(mem[p + 5].int, mem[p + 6].int)
+ end {:987}
+ end; {:985}
+
+ procedure dobinary(p: halfword; c: quarterword);
+ label
+ 30, 31, 10;
+ var
+ q, r, rr: halfword;
+ oldp, oldexp: halfword;
+ v: integer;
+ begin
+ begin
+ if aritherror then
+ cleararith
+ end;
+ if internal[7] > 131072 then begin {924:}
+ begindiagnostic;
+ printnl(714);
+ printexp(p, 0);
+ printchar(41);
+ printop(c);
+ printchar(40);
+ printexp(-30000, 0);
+ print(706);
+ enddiagnostic(false)
+ end {:924}; {926:}
+ if mem[p].hh.b0 in
+ [13, 14, 19] then
+ case mem[p].hh.b0 of
+ 13, 14:
+ oldp := tarnished(p);
+ 19:
+ oldp := -29999
+ end
+ else
+ oldp := -30000;
+ if oldp <> (-30000) then begin
+ q := stashcurexp;
+ oldp := p;
+ makeexpcopy(oldp);
+ p := stashcurexp;
+ unstashcurexp(q)
+ end; {:926}
+ {927:}
+ if curtype in
+ [13, 14, 19] then
+ case curtype of
+ 13, 14:
+ oldexp := tarnished(curexp);
+ 19:
+ oldexp := -29999
+ end
+ else
+ oldexp := -30000;
+ if oldexp <> (-30000) then begin
+ oldexp := curexp;
+ makeexpcopy(oldexp)
+ end {:927};
+ case c of
+ 69, 70: {929:}
+ if (curtype < 14) or (mem[p].hh.b0 < 14) then
+ if (curtype = 11) and (mem[p].hh.b0 = 11) then begin
+ if c = 70 then
+ negateedges(curexp);
+ curedges := curexp;
+ mergeedges(mem[p + 1].int)
+ end else
+ badbinary(p, c)
+ else if curtype = 14 then
+ if mem[p].hh.b0 <> 14 then
+ badbinary(p, c)
+ else begin
+ q := mem[p + 1].int;
+ r := mem[curexp + 1].int;
+ addorsubtract(q, r, c);
+ addorsubtract(q + 2, r + 2, c)
+ end
+ else if mem[p].hh.b0 = 14 then
+ badbinary(p, c)
+ else
+ addorsubtract(p, -30000, c) {:929}; {936:}
+ 77, 78, 79, 80, 81, 82:
+ begin
+ if (curtype > 14) and (mem[p].hh.b0 > 14) then
+ addorsubtract(p, -30000, 70)
+ else if curtype <> mem[p].hh.b0 then begin
+ badbinary(p, c);
+ goto 30
+ end else if curtype = 4 then
+ flushcurexp(strvsstr(mem[p + 1].int, curexp))
+ else if (curtype = 5) or (curtype = 3) then begin {938:}
+ q := mem[curexp + 1].int;
+ while (q <> curexp) and (q <> p) do
+ q := mem[q + 1].int;
+ if q = p then
+ flushcurexp(0)
+ end else if (curtype = 14) or (curtype = 13) then begin {:938} {939:}
+ q := mem[p + 1].int;
+ r := mem[curexp + 1].int;
+ rr := (r + bignodesize[curtype]) - 2;
+ while true do begin
+ addorsubtract(q, r, 70);
+ if mem[r].hh.b0 <> 16 then
+ goto 31;
+ if mem[r + 1].int <> 0 then
+ goto 31;
+ if r = rr then
+ goto 31;
+ q := q + 2;
+ r := r + 2
+ end;
+ 31:
+ takepart(53 + ((r - mem[curexp + 1].int) div 2))
+ end else if curtype = 2 then {:939}
+ flushcurexp(curexp - mem[p + 1].int)
+ else begin
+ badbinary(p, c);
+ goto 30
+ end; {937:}
+ if curtype <> 16 then begin
+ if curtype < 16 then begin
+ disperr(p, 155);
+ begin
+ helpptr := 1;
+ helpline[0] := 715
+ end
+ end else begin
+ helpptr := 2;
+ helpline[1] := 716;
+ helpline[0] := 717
+ end;
+ disperr(-30000, 718);
+ putgetflusherror(31)
+ end else
+ case c of
+ 77:
+ if curexp < 0 then
+ curexp := 30
+ else
+ curexp := 31;
+ 78:
+ if curexp <= 0 then
+ curexp := 30
+ else
+ curexp := 31;
+ 79:
+ if curexp > 0 then
+ curexp := 30
+ else
+ curexp := 31;
+ 80:
+ if curexp >= 0 then
+ curexp := 30
+ else
+ curexp := 31;
+ 81:
+ if curexp = 0 then
+ curexp := 30
+ else
+ curexp := 31;
+ 82:
+ if curexp <> 0 then
+ curexp := 30
+ else
+ curexp := 31
+ end;
+ curtype := 2 {:937};
+ 30:
+
+ end; {:936} {940:}
+ 76, 75:
+ if (mem[p].hh.b0 <> 2) or (curtype <> 2) then
+ badbinary(p, c)
+ else if mem[p + 1].int = (c - 45) then
+ curexp := mem[p + 1].int; {:940} {941:}
+ 71:
+ if (curtype < 14) or (mem[p].hh.b0 < 14) then
+ badbinary(p, 71)
+ else if (curtype = 16) or (mem[p].hh.b0 = 16) then begin {942:}
+ if mem[p].hh.b0 = 16 then begin
+ v := mem[p + 1].int;
+ freenode(p, 2)
+ end else begin
+ v := curexp;
+ unstashcurexp(p)
+ end;
+ if curtype = 16 then
+ curexp := takescaled(curexp, v)
+ else if curtype = 14 then begin
+ p := mem[curexp + 1].int;
+ depmult(p, v, true);
+ depmult(p + 2, v, true)
+ end else
+ depmult(-30000, v, true);
+ goto 10
+ end else if (nicepair(p, mem[p].hh.b0) and (curtype > 14)) or (nicepair(curexp, curtype) and (mem[p].hh.b0 > 14)) then begin {:942}
+ hardtimes(p);
+ goto 10
+ end else
+ badbinary(p, 71); {:941} {948:}
+ 72:
+ if (curtype <> 16) or (mem[p].hh.b0 < 14) then
+ badbinary(p, 72)
+ else begin
+ v := curexp;
+ unstashcurexp(p);
+ if v = 0 then begin {950:}
+ disperr(-30000, 648);
+ begin
+ helpptr := 2;
+ helpline[1] := 720;
+ helpline[0] := 721
+ end;
+ putgeterror
+ end else begin {:950}
+ if curtype = 16 then
+ curexp := makescaled(curexp, v)
+ else if curtype = 14 then begin
+ p := mem[curexp + 1].int;
+ depdiv(p, v);
+ depdiv(p + 2, v)
+ end else
+ depdiv(-30000, v)
+ end;
+ goto 10
+ end; {:948} {951:}
+ 73, 74:
+ if (curtype = 16) and (mem[p].hh.b0 = 16) then
+ if c = 73 then
+ curexp := pythadd(mem[p + 1].int, curexp)
+ else
+ curexp := pythsub(mem[p + 1].int, curexp)
+ else
+ badbinary(p, c); {:951} {952:}
+ 84, 85, 86, 87, 88, 89, 90,
+ 91:
+ if ((mem[p].hh.b0 = 9) or (mem[p].hh.b0 = 8)) or (mem[p].hh.b0 = 6) then begin
+ pathtrans(p, c);
+ goto 10
+ end else if (mem[p].hh.b0 = 14) or (mem[p].hh.b0 = 13) then
+ bigtrans(p, c)
+ else if mem[p].hh.b0 = 11 then begin
+ edgestrans(p, c);
+ goto 10
+ end else
+ badbinary(p, c); {:952} {975:}
+ 83:
+ if (curtype = 4) and (mem[p].hh.b0 = 4) then
+ cat(p)
+ else
+ badbinary(p, 83);
+ 94:
+ if nicepair(p, mem[p].hh.b0) and (curtype = 4) then
+ chopstring(mem[p + 1].int)
+ else
+ badbinary(p, 94);
+ 95:
+ begin
+ if curtype = 14 then
+ pairtopath;
+ if nicepair(p, mem[p].hh.b0) and (curtype = 9) then
+ choppath(mem[p + 1].int)
+ else
+ badbinary(p, 95)
+ end; {:975} {983:}
+ 97, 98, 99:
+ begin
+ if curtype = 14 then
+ pairtopath;
+ if (curtype = 9) and (mem[p].hh.b0 = 16) then
+ findpoint(mem[p + 1].int, c)
+ else
+ badbinary(p, c)
+ end;
+ 100:
+ begin
+ if curtype = 8 then
+ materializepen;
+ if (curtype = 6) and nicepair(p, mem[p].hh.b0) then
+ setupoffset(mem[p + 1].int)
+ else
+ badbinary(p, 100)
+ end;
+ 96:
+ begin
+ if curtype = 14 then
+ pairtopath;
+ if (curtype = 9) and nicepair(p, mem[p].hh.b0) then
+ setupdirectiontime(mem[p + 1].int)
+ else
+ badbinary(p, 96)
+ end; {:983} {988:}
+ 92:
+ begin
+ if mem[p].hh.b0 = 14 then begin
+ q := stashcurexp;
+ unstashcurexp(p);
+ pairtopath;
+ p := stashcurexp;
+ unstashcurexp(q)
+ end;
+ if curtype = 14 then
+ pairtopath;
+ if (curtype = 9) and (mem[p].hh.b0 = 9) then begin
+ pathintersection(mem[p + 1].int, curexp);
+ pairvalue(curt, curtt)
+ end else
+ badbinary(p, 92)
+ end
+ end {:988};
+ recyclevalue(p);
+ freenode(p, 2);
+ 10:
+ begin
+ if aritherror then
+ cleararith
+ end; {925:}
+ if oldp <> (-30000) then begin
+ recyclevalue(oldp);
+ freenode(oldp, 2)
+ end;
+ if oldexp <> (-30000) then begin
+ recyclevalue(oldexp);
+ freenode(oldexp, 2)
+ end {:925}
+ end; {:922} {944:}
+
+ procedure fracmult(n, d: scaled);
+ var
+ p: halfword;
+ oldexp: halfword;
+ v: fraction;
+ begin
+ if internal[7] > 131072 then begin {945:}
+ begindiagnostic;
+ printnl(714);
+ printscaled(n);
+ printchar(47);
+ printscaled(d);
+ print(719);
+ printexp(-30000, 0);
+ print(706);
+ enddiagnostic(false)
+ end {:945};
+ if curtype in
+ [13, 14, 19] then
+ case curtype of
+ 13, 14:
+ oldexp := tarnished(curexp);
+ 19:
+ oldexp := -29999
+ end
+ else
+ oldexp := -30000;
+ if oldexp <> (-30000) then begin
+ oldexp := curexp;
+ makeexpcopy(oldexp)
+ end;
+ v := makefraction(n, d);
+ if curtype = 16 then
+ curexp := takefraction(curexp, v)
+ else if curtype = 14 then begin
+ p := mem[curexp + 1].int;
+ depmult(p, v, false);
+ depmult(p + 2, v, false)
+ end else
+ depmult(-30000, v, false);
+ if oldexp <> (-30000) then begin
+ recyclevalue(oldexp);
+ freenode(oldexp, 2)
+ end
+ end; {:944} {989:} {1155:}
+
+ procedure gfswap;
+ begin
+ if gflimit = gfbufsize then begin
+ bwritebuf(gffile, gfbuf, 0, halfbuf - 1);
+ gflimit := halfbuf;
+ gfoffset := gfoffset + gfbufsize;
+ gfptr := 0
+ end else begin
+ bwritebuf(gffile, gfbuf, halfbuf, gfbufsize - 1);
+ gflimit := gfbufsize
+ end
+ end; {:1155} {1157:}
+
+ procedure gffour(x: integer);
+ begin
+ if x >= 0 then begin
+ gfbuf[gfptr] := x div 16777216;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end else begin
+ x := x + 1073741824;
+ x := x + 1073741824;
+ begin
+ gfbuf[gfptr] := (x div 16777216) + 128;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end;
+ x := x mod 16777216;
+ begin
+ gfbuf[gfptr] := x div 65536;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ x := x mod 65536;
+ begin
+ gfbuf[gfptr] := x div 256;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := x mod 256;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end; {:1157} {1158:}
+
+ procedure gftwo(x: integer);
+ begin
+ begin
+ gfbuf[gfptr] := x div 256;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := x mod 256;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end;
+
+ procedure gfthree(x: integer);
+ begin
+ begin
+ gfbuf[gfptr] := x div 65536;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := (x mod 65536) div 256;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := x mod 256;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end; {:1158} {1159:}
+
+ procedure gfpaint(d: integer);
+ begin
+ if d < 64 then begin
+ gfbuf[gfptr] := 0 + d;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end else if d < 256 then begin
+ begin
+ gfbuf[gfptr] := 64;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := d;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end else begin
+ begin
+ gfbuf[gfptr] := 65;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gftwo(d)
+ end
+ end; {:1159}
+ {1160:}
+
+ procedure gfstring(s, t: strnumber);
+ var
+ k: poolpointer;
+ l: integer;
+ begin
+ if s <> 0 then begin
+ l := strstart[s + 1] - strstart[s];
+ if t <> 0 then
+ l := l + (strstart[t + 1] - strstart[t]);
+ if l <= 255 then begin
+ begin
+ gfbuf[gfptr] := 239;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := l;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end else begin
+ begin
+ gfbuf[gfptr] := 241;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gfthree(l)
+ end;
+ for k := strstart[s] to strstart[s + 1] - 1 do begin
+ gfbuf[gfptr] := strpool[k];
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end;
+ if t <> 0 then
+ for k := strstart[t] to strstart[t + 1] - 1 do begin
+ gfbuf[gfptr] := strpool[k];
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end; {:1160}
+ {1161:}
+
+ procedure gfboc(minm, maxm, minn, maxn: integer);
+ label
+ 10;
+ begin
+ if minm < gfminm then
+ gfminm := minm;
+ if maxn > gfmaxn then
+ gfmaxn := maxn;
+ if bocp = (-1) then
+ if bocc >= 0 then
+ if bocc < 256 then
+ if (maxm - minm) >= 0 then
+ if (maxm - minm) < 256 then
+ if maxm >= 0 then
+ if maxm < 256 then
+ if (maxn - minn) >= 0 then
+ if (maxn - minn) < 256 then
+ if maxn >= 0 then
+ if maxn < 256 then begin
+ begin
+ gfbuf[gfptr] := 68;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := bocc;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := maxm - minm;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := maxm;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := maxn - minn;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := maxn;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ goto 10
+ end;
+ begin
+ gfbuf[gfptr] := 67;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(bocc);
+ gffour(bocp);
+ gffour(minm);
+ gffour(maxm);
+ gffour(minn);
+ gffour(maxn);
+ 10:
+
+ end; {:1161} {1163:}
+
+ procedure initgf;
+ var
+ k: eightbits;
+ t: integer;
+ begin
+ gfminm := 4096;
+ gfmaxm := -4096;
+ gfminn := 4096;
+ gfmaxn := -4096;
+ for k := 0 to 255 do
+ charptr[k] := -1; {1164:}
+ if internal[27] <= 0 then
+ gfext := 908
+ else begin
+ oldsetting := selector;
+ selector := 5;
+ printchar(46);
+ printint(makescaled(internal[27], 59429463));
+ print(909);
+ gfext := makestring;
+ selector := oldsetting
+ end {:1164};
+ begin
+ if jobname = 0 then
+ openlogfile;
+ packjobname(gfext);
+ while not bopenout(gffile, nameoffile) do
+ promptfilename(620, gfext);
+ outputfilename := bmakenamestring(gffile)
+ end;
+ begin
+ gfbuf[gfptr] := 247;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := 131;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ oldsetting := selector;
+ selector := 5;
+ print(907);
+ printint(roundunscaled(internal[14]));
+ printchar(46);
+ printdd(roundunscaled(internal[15]));
+ printchar(46);
+ printdd(roundunscaled(internal[16]));
+ printchar(58);
+ t := roundunscaled(internal[17]);
+ printdd(t div 60);
+ printdd(t mod 60);
+ selector := oldsetting;
+ begin
+ gfbuf[gfptr] := poolptr - strstart[strptr];
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ strstart[strptr + 1] := poolptr;
+ gfstring(0, strptr);
+ poolptr := strstart[strptr];
+ gfprevptr := gfoffset + gfptr
+ end; {:1163} {1165:}
+
+ procedure shipout(c: eightbits);
+ label
+ 30;
+ var
+ f: integer;
+ prevm, m, mm: integer;
+ prevn, n: integer;
+ p, q: halfword;
+ prevw, w, ww: integer;
+ d: integer;
+ delta: integer;
+ curminm: integer;
+ xoff, yoff: integer;
+ begin
+ if outputfilename = 0 then
+ initgf;
+ f := roundunscaled(internal[19]);
+ xoff := roundunscaled(internal[29]);
+ yoff := roundunscaled(internal[30]);
+ if termoffset > (maxprintline - 9) then
+ println
+ else if (termoffset > 0) or (fileoffset > 0) then
+ printchar(32);
+ printchar(91);
+ printint(c);
+ if f <> 0 then begin
+ printchar(46);
+ printint(f)
+ end;
+ flush(output);
+ bocc := (256 * f) + c;
+ bocp := charptr[c];
+ charptr[c] := gfprevptr;
+ if internal[34] > 0 then begin {1166:}
+ if xoff <> 0 then begin
+ gfstring(308, 0);
+ begin
+ gfbuf[gfptr] := 243;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(xoff * 65536)
+ end;
+ if yoff <> 0 then begin
+ gfstring(309, 0);
+ begin
+ gfbuf[gfptr] := 243;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(yoff * 65536)
+ end
+ end {:1166}; {1167:}
+ prevn := 4096;
+ p := mem[curedges].hh.lh;
+ n := mem[curedges + 1].hh.rh - 4096;
+ while p <> curedges do begin {1169:}
+ if mem[p + 1].hh.lh > (-29999) then
+ sortedges(p);
+ q := mem[p + 1].hh.rh;
+ w := 0;
+ prevm := -268435456;
+ ww := 0;
+ prevw := 0;
+ m := prevm;
+ repeat
+ if q = 30000 then
+ mm := 268435456
+ else begin
+ d := mem[q].hh.lh + 32768;
+ mm := d div 8;
+ ww := (ww + (d mod 8)) - 4
+ end;
+ if mm <> m then begin
+ if prevw <= 0 then begin
+ if w > 0 then begin {1170:}
+ if prevm = (-268435456) then begin {1172:}
+ if prevn = 4096 then begin
+ gfboc((mem[curedges + 2].hh.lh + xoff) - 4096, (mem[curedges + 2].hh.rh + xoff) - 4096, (mem[curedges + 1].hh.lh + yoff) - 4096, n + yoff);
+ curminm := (mem[curedges + 2].hh.lh - 4096) + mem[curedges + 3].hh.lh
+ end else if prevn > (n + 1) then begin {1174:}
+ delta := (prevn - n) - 1;
+ if delta < 256 then
+ if delta = 0 then begin
+ gfbuf[gfptr] := 70;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end else begin
+ begin
+ gfbuf[gfptr] := 71;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := delta;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end
+ else begin
+ begin
+ gfbuf[gfptr] := 72;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gftwo(delta)
+ end
+ end else begin {:1174} {1173:}
+ delta := m - curminm;
+ if delta > 164 then begin
+ gfbuf[gfptr] := 70;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end else begin
+ begin
+ gfbuf[gfptr] := 74 + delta;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ goto 30
+ end
+ end {:1173};
+ gfpaint(m - curminm);
+ 30:
+ prevn := n
+ end else {:1172}
+ gfpaint(m - prevm);
+ prevm := m;
+ prevw := w
+ end {:1170}
+ end else if w <= 0 then begin {1171:}
+ gfpaint(m - prevm);
+ prevm := m;
+ prevw := w
+ end {:1171};
+ m := mm
+ end;
+ w := ww;
+ q := mem[q].hh.rh
+ until mm = 268435456;
+ if w <> 0 then
+ printnl(911);
+ if ((prevm - mem[curedges + 3].hh.lh) + xoff) > gfmaxm then
+ gfmaxm := (prevm - mem[curedges + 3].hh.lh) + xoff {:1169};
+ p := mem[p].hh.lh;
+ n := n - 1
+ end;
+ if prevn = 4096 then begin {1168:}
+ gfboc(0, 0, 0, 0);
+ if gfmaxm < 0 then
+ gfmaxm := 0;
+ if gfminn > 0 then
+ gfminn := 0
+ end else if (prevn + yoff) < gfminn then {:1168}
+ gfminn := prevn + yoff {:1167};
+ begin
+ gfbuf[gfptr] := 69;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gfprevptr := gfoffset + gfptr;
+ totalchars := totalchars + 1;
+ printchar(93);
+ flush(output);
+ if internal[11] > 0 then
+ printedges(910, true, xoff, yoff)
+ end; { shipout }
+ {:1165}
+ {995:}
+ {1006:}
+
+ procedure tryeq(l, r: halfword);
+ label
+ 30, 31;
+ var
+ p: halfword;
+ t: 16..19;
+ q: halfword;
+ pp: halfword;
+ tt: 17..19;
+ copied: boolean; {1007:}
+ begin
+ t := mem[l].hh.b0;
+ if t = 16 then begin
+ t := 17;
+ p := constdependency(-mem[l + 1].int);
+ q := p
+ end else if t = 19 then begin
+ t := 17;
+ p := singledependency(l);
+ mem[p + 1].int := -mem[p + 1].int;
+ q := depfinal
+ end else begin
+ p := mem[l + 1].hh.rh;
+ q := p;
+ while true do begin
+ mem[q + 1].int := -mem[q + 1].int;
+ if mem[q].hh.lh = (-30000) then
+ goto 30;
+ q := mem[q].hh.rh
+ end;
+ 30:
+ mem[mem[l + 1].hh.lh].hh.rh := mem[q].hh.rh;
+ mem[mem[q].hh.rh + 1].hh.lh := mem[l + 1].hh.lh;
+ mem[l].hh.b0 := 16
+ end {:1007};
+ {1009:}
+ if r = (-30000) then
+ if curtype = 16 then begin
+ mem[q + 1].int := mem[q + 1].int + curexp;
+ goto 31
+ end else begin
+ tt := curtype;
+ if tt = 19 then
+ pp := singledependency(curexp)
+ else
+ pp := mem[curexp + 1].hh.rh
+ end
+ else if mem[r].hh.b0 = 16 then begin
+ mem[q + 1].int := mem[q + 1].int + mem[r + 1].int;
+ goto 31
+ end else begin
+ tt := mem[r].hh.b0;
+ if tt = 19 then
+ pp := singledependency(r)
+ else
+ pp := mem[r + 1].hh.rh
+ end;
+ if tt <> 19 then
+ copied := false
+ else begin
+ copied := true;
+ tt := 17
+ end; {1010:}
+ watchcoefs := false;
+ if t = tt then
+ p := pplusq(p, pp, t)
+ else if t = 18 then
+ p := pplusfq(p, 65536, pp, 18, 17)
+ else begin
+ q := p;
+ while mem[q].hh.lh <> (-30000) do begin
+ mem[q + 1].int := roundfraction(mem[q + 1].int);
+ q := mem[q].hh.rh
+ end;
+ t := 18;
+ p := pplusq(p, pp, t)
+ end;
+ watchcoefs := true;
+ {:1010}
+ if copied then
+ flushnodelist(pp);
+ 31: {:1009}
+ ;
+ if mem[p].hh.lh = (-30000) then begin {1008:}
+ if abs(mem[p + 1].int) > 64 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(761)
+ end;
+ print(763);
+ printscaled(mem[p + 1].int);
+ printchar(41);
+ begin
+ helpptr := 2;
+ helpline[1] := 762;
+ helpline[0] := 760
+ end;
+ putgeterror
+ end else if r = (-30000) then begin {623:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(465)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 466;
+ helpline[0] := 467
+ end;
+ putgeterror
+ end {:623};
+ freenode(p, 2)
+ end else begin {:1008}
+ lineareq(p, t);
+ if r = (-30000) then
+ if curtype <> 16 then
+ if mem[curexp].hh.b0 = 16 then begin
+ pp := curexp;
+ curexp := mem[curexp + 1].int;
+ curtype := 16;
+ freenode(pp, 2)
+ end
+ end
+ end; {:1006} {1001:}
+
+ procedure makeeq(lhs: halfword);
+ label
+ 20, 30, 45;
+ var
+ t: smallnumber;
+ v: integer;
+ p, q: halfword;
+ begin
+ 20:
+ t := mem[lhs].hh.b0;
+ if t <= 14 then
+ v := mem[lhs + 1].int;
+ case t of {1003:}
+ 2, 4, 6, 9, 11:
+ if curtype = (t + 1) then begin
+ nonlineareq(v, curexp, false);
+ goto 30
+ end else if curtype = t then begin {1004:}
+ if curtype <= 4 then begin
+ if curtype = 4 then begin
+ if strvsstr(v, curexp) <> 0 then
+ goto 45
+ end else if v <> curexp then
+ goto 45; {623:}
+ begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(465)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 466;
+ helpline[0] := 467
+ end;
+ putgeterror
+ end {:623};
+ goto 30
+ end;
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(758)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 759;
+ helpline[0] := 760
+ end;
+ putgeterror;
+ goto 30;
+ 45:
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(761)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 762;
+ helpline[0] := 760
+ end;
+ putgeterror;
+ goto 30
+ end {:1004};
+ 3, 5, 7, 12, 10:
+ if curtype = (t - 1) then begin
+ nonlineareq(curexp, lhs, true);
+ goto 30
+ end else if curtype = t then begin
+ ringmerge(lhs, curexp);
+ goto 30
+ end else if curtype = 14 then
+ if t = 10 then begin
+ pairtopath;
+ goto 20
+ end;
+ 13, 14:
+ if curtype = t then begin {1005:}
+ p := v + bignodesize[t];
+ q := mem[curexp + 1].int + bignodesize[t];
+ repeat
+ p := p - 2;
+ q := q - 2;
+ tryeq(p, q)
+ until p = v;
+ goto 30
+ end {:1005};
+ 16, 17, 18, 19:
+ if curtype >= 16 then begin
+ tryeq(lhs, -30000);
+ goto 30
+ end;
+ 1:
+
+ end
+ {:1003}; {1002:}
+ disperr(lhs, 155);
+ disperr(-30000, 755);
+ if mem[lhs].hh.b0 <= 14 then
+ printtype(mem[lhs].hh.b0)
+ else
+ print(211);
+ printchar(61);
+ if curtype <= 14 then
+ printtype(curtype)
+ else
+ print(211);
+ printchar(41);
+ begin
+ helpptr := 2;
+ helpline[1] := 756;
+ helpline[0] := 757
+ end; {:1002}
+ putgeterror;
+ 30:
+ begin
+ if aritherror then
+ cleararith
+ end;
+ recyclevalue(lhs);
+ freenode(lhs, 2)
+ end; {:1001}
+
+ procedure doassignment;
+ forward;
+
+ procedure doequation;
+ var
+ lhs: halfword;
+ p: halfword;
+ begin
+ lhs := stashcurexp;
+ getxnext;
+ varflag := 77;
+ scanexpression;
+ if curcmd = 51 then
+ doequation
+ else if curcmd = 77 then
+ doassignment;
+ if internal[7] > 131072 then begin {997:}
+ begindiagnostic;
+ printnl(714);
+ printexp(lhs, 0);
+ print(750);
+ printexp(-30000, 0);
+ print(706);
+ enddiagnostic(false)
+ end {:997};
+ if curtype = 10 then
+ if mem[lhs].hh.b0 = 14 then begin
+ p := stashcurexp;
+ unstashcurexp(lhs);
+ lhs := p
+ end;
+ makeeq(lhs)
+ end; {:995} {996:}
+
+ procedure doassignment;
+ var
+ lhs: halfword;
+ p: halfword;
+ q: halfword;
+ begin
+ if curtype <> 20 then begin
+ disperr(-30000, 747);
+ begin
+ helpptr := 2;
+ helpline[1] := 748;
+ helpline[0] := 749
+ end;
+ error;
+ doequation
+ end else begin
+ lhs := curexp;
+ curtype := 1;
+ getxnext;
+ varflag := 77;
+ scanexpression;
+ if curcmd = 51 then
+ doequation
+ else if curcmd = 77 then
+ doassignment;
+ if internal[7] > 131072 then begin {998:}
+ begindiagnostic;
+ printnl(123);
+ if mem[lhs].hh.lh > 2241 then
+ print(intname[mem[lhs].hh.lh - 2241])
+ else
+ showtokenlist(lhs, -30000, 1000, 0);
+ print(329);
+ printexp(-30000, 0);
+ printchar(125);
+ enddiagnostic(false)
+ end {:998};
+ if mem[lhs].hh.lh > 2241 then {999:}
+ if curtype = 16 then
+ internal[mem[lhs].hh.lh - 2241] := curexp
+ else begin
+ disperr(-30000, 751);
+ print(intname[mem[lhs].hh.lh - 2241]);
+ print(752);
+ begin
+ helpptr := 2;
+ helpline[1] := 753;
+ helpline[0] := 754
+ end;
+ putgeterror
+ end {:999} {1000:}
+ else begin
+ p := findvariable(lhs);
+ if p <> (-30000) then begin
+ q := stashcurexp;
+ curtype := undtype(p);
+ recyclevalue(p);
+ mem[p].hh.b0 := curtype;
+ mem[p + 1].int := -30000;
+ makeexpcopy(p);
+ p := stashcurexp;
+ unstashcurexp(q);
+ makeeq(p)
+ end else begin
+ obliterated(lhs);
+ putgeterror
+ end
+ end {:1000};
+ flushnodelist(lhs)
+ end
+ end; {:996} {1015:}
+
+ procedure dotypedeclaration;
+ var
+ t: smallnumber;
+ p: halfword;
+ q: halfword;
+ begin
+ if curmod >= 13 then
+ t := curmod
+ else
+ t := curmod + 1;
+ repeat
+ p := scandeclaredvariable;
+ flushvariable(eqtb[mem[p].hh.lh].rh, mem[p].hh.rh, false);
+ q := findvariable(p);
+ if q <> (-30000) then begin
+ mem[q].hh.b0 := t;
+ mem[q + 1].int := -30000
+ end else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(764)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 765;
+ helpline[0] := 766
+ end;
+ putgeterror
+ end;
+ flushlist(p);
+ if curcmd < 79 then begin {1016:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(767)
+ end;
+ begin
+ helpptr := 5;
+ helpline[4] := 768;
+ helpline[3] := 769;
+ helpline[2] := 770;
+ helpline[1] := 771;
+ helpline[0] := 772
+ end;
+ if curcmd = 42 then
+ helpline[2] := 773;
+ putgeterror;
+ scannerstatus := 2;
+ repeat
+ getnext; {743:}
+ if curcmd = 39 then begin
+ if strref[curmod] < 127 then
+ if strref[curmod] > 1 then
+ strref[curmod] := strref[curmod] - 1
+ else
+ flushstring(curmod)
+ end {:743}
+ until curcmd >= 79;
+ scannerstatus := 0
+ end {:1016}
+ until curcmd > 79
+ end; { dotypedeclaration }
+ {:1015}
+ {1021:}
+
+ procedure dorandomseed;
+ begin
+ getxnext;
+ if curcmd <> 77 then begin
+ missingerr(329);
+ begin
+ helpptr := 1;
+ helpline[0] := 778
+ end;
+ backerror
+ end;
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then begin
+ disperr(-30000, 779);
+ begin
+ helpptr := 2;
+ helpline[1] := 780;
+ helpline[0] := 781
+ end;
+ putgetflusherror(0)
+ end else begin {1022:}
+ initrandoms(curexp);
+ if selector >= 2 then begin
+ oldsetting := selector;
+ selector := 2;
+ printnl(782);
+ printscaled(curexp);
+ printchar(125);
+ printnl(155);
+ selector := oldsetting
+ end
+ end {:1022}
+ end; {:1021} {1029:}
+
+ procedure doprotection;
+ var
+ m: 0..1;
+ t: halfword;
+ begin
+ m := curmod;
+ repeat
+ getsymbol;
+ t := eqtb[cursym].lh;
+ if m = 0 then begin
+ if t >= 83 then
+ eqtb[cursym].lh := t - 83
+ end else if t < 83 then
+ eqtb[cursym].lh := t + 83;
+ getxnext
+ until curcmd <> 79
+ end; {:1029} {1031:}
+
+ procedure defdelims;
+ var
+ ldelim, rdelim: halfword;
+ begin
+ getclearsymbol;
+ ldelim := cursym;
+ getclearsymbol;
+ rdelim := cursym;
+ eqtb[ldelim].lh := 31;
+ eqtb[ldelim].rh := rdelim;
+ eqtb[rdelim].lh := 62;
+ eqtb[rdelim].rh := ldelim;
+ getxnext
+ end; {:1031} {1034:}
+
+ procedure dostatement;
+ forward;
+
+ procedure dointerim;
+ begin
+ getxnext;
+ if curcmd <> 40 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(788)
+ end;
+ if cursym = 0 then
+ print(793)
+ else
+ print(hash[cursym].rh);
+ print(794);
+ begin
+ helpptr := 1;
+ helpline[0] := 795
+ end;
+ backerror
+ end else begin
+ saveinternal(curmod);
+ backinput
+ end;
+ dostatement
+ end; { dointerim }
+ {:1034}
+ {1035:}
+
+ procedure dolet;
+ var
+ l: halfword;
+ begin
+ getsymbol;
+ l := cursym;
+ getxnext;
+ if curcmd <> 51 then
+ if curcmd <> 77 then begin
+ missingerr(61);
+ begin
+ helpptr := 3;
+ helpline[2] := 796;
+ helpline[1] := 538;
+ helpline[0] := 797
+ end;
+ backerror
+ end;
+ getsymbol;
+ if curcmd in
+ [10, 53, 44, 49] then
+ case curcmd of
+ 10, 53, 44, 49:
+ mem[curmod].hh.lh := mem[curmod].hh.lh + 1
+ end
+ else
+ ;
+ clearsymbol(l, false);
+ eqtb[l].lh := curcmd;
+ if curcmd = 41 then
+ eqtb[l].rh := -30000
+ else
+ eqtb[l].rh := curmod;
+ getxnext
+ end; {:1035} {1036:}
+
+ procedure donewinternal;
+ begin
+ repeat
+ if intptr = maxinternal then
+ overflow(798, maxinternal);
+ getclearsymbol;
+ intptr := intptr + 1;
+ eqtb[cursym].lh := 40;
+ eqtb[cursym].rh := intptr;
+ intname[intptr] := hash[cursym].rh;
+ internal[intptr] := 0;
+ getxnext
+ until curcmd <> 79
+ end; {:1036} {1040:}
+
+ procedure doshow;
+ begin
+ repeat
+ getxnext;
+ scanexpression;
+ printnl(629);
+ printexp(-30000, 2);
+ flushcurexp(0)
+ until curcmd <> 79
+ end; {:1040} {1041:}
+
+ procedure disptoken;
+ begin
+ printnl(804);
+ if cursym = 0 then begin {1042:}
+ if curcmd = 42 then
+ printscaled(curmod)
+ else if curcmd = 38 then begin
+ gpointer := curmod;
+ printcapsule
+ end else begin
+ printchar(34);
+ print(curmod);
+ printchar(34);
+ begin
+ if strref[curmod] < 127 then
+ if strref[curmod] > 1 then
+ strref[curmod] := strref[curmod] - 1
+ else
+ flushstring(curmod)
+ end
+ end
+ end else begin {:1042}
+ print(hash[cursym].rh);
+ printchar(61);
+ if eqtb[cursym].lh >= 83 then
+ print(805);
+ printcmdmod(curcmd, curmod);
+ if curcmd = 10 then begin
+ println;
+ showmacro(curmod, -30000, 100000)
+ end
+ end
+ end; {:1041} {1044:}
+
+ procedure doshowtoken;
+ begin
+ repeat
+ getnext;
+ disptoken;
+ getxnext
+ until curcmd <> 79
+ end; {:1044} {1045:}
+
+ procedure doshowstats;
+ {printint(varused);printchar(38);printint(dynused);
+ if false then}
+ begin
+ printnl(814);
+ print(228);
+ print(425);
+ printint((himemmin - lomemmax) - 1);
+ print(815);
+ println;
+ printnl(816);
+ printint(strptr - initstrptr);
+ printchar(38);
+ printint(poolptr - initpoolptr);
+ print(425);
+ printint(maxstrings - maxstrptr);
+ printchar(38);
+ printint(poolsize - maxpoolptr);
+ print(815);
+ println;
+ getxnext
+ end; {:1045}
+ {1046:}
+
+ procedure dispvar(p: halfword);
+ var
+ q: halfword;
+ n: 0..maxprintline;
+ begin
+ if mem[p].hh.b0 = 21 then begin {1047:}
+ q := mem[p + 1].hh.lh;
+ repeat
+ dispvar(q);
+ q := mem[q].hh.rh
+ until q = (-29983);
+ q := mem[p + 1].hh.rh;
+ while mem[q].hh.b1 = 3 do begin
+ dispvar(q);
+ q := mem[q].hh.rh
+ end
+ end else if mem[p].hh.b0 >= 22 then begin {:1047} {1048:}
+ printnl(155);
+ printvariablename(p);
+ if mem[p].hh.b0 > 22 then
+ print(530);
+ print(817);
+ if fileoffset >= (maxprintline - 20) then
+ n := 5
+ else
+ n := (maxprintline - fileoffset) - 15;
+ showmacro(mem[p + 1].int, -30000, n)
+ end else if mem[p].hh.b0 <> 0 then begin {:1048}
+ printnl(155);
+ printvariablename(p);
+ printchar(61);
+ printexp(p, 0)
+ end
+ end; {:1046} {1049:}
+
+ procedure doshowvar;
+ label
+ 30;
+ begin
+ repeat
+ getnext;
+ if cursym > 0 then
+ if cursym <= 2241 then
+ if curcmd = 41 then
+ if curmod <> (-30000) then begin
+ dispvar(curmod);
+ goto 30
+ end;
+ disptoken;
+ 30:
+ getxnext
+ until curcmd <> 79
+ end; {:1049} {1050:}
+
+ procedure doshowdependencies;
+ var
+ p: halfword;
+ begin
+ p := mem[-29987].hh.rh;
+ while p <> (-29987) do begin
+ if interesting(p) then begin
+ printnl(155);
+ printvariablename(p);
+ if mem[p].hh.b0 = 17 then
+ printchar(61)
+ else
+ print(632);
+ printdependency(mem[p + 1].hh.rh, mem[p].hh.b0)
+ end;
+ p := mem[p + 1].hh.rh;
+ while mem[p].hh.lh <> (-30000) do
+ p := mem[p].hh.rh;
+ p := mem[p].hh.rh
+ end;
+ getxnext
+ end; {:1050} {1051:}
+
+ procedure doshowwhatever;
+ begin
+ if interaction = 3 then
+ ;
+ case curmod of
+ 0:
+ doshowtoken;
+ 1:
+ doshowstats;
+ 2:
+ doshow;
+ 3:
+ doshowvar;
+ 4:
+ doshowdependencies
+ end;
+ if internal[32] > 0 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(818)
+ end;
+ if interaction < 3 then begin
+ helpptr := 0;
+ errorcount := errorcount - 1
+ end else begin
+ helpptr := 1;
+ helpline[0] := 819
+ end;
+ if curcmd = 80 then
+ error
+ else
+ putgeterror
+ end
+ end; {:1051} {1054:}
+
+ function scanwith: boolean;
+ var
+ t: smallnumber;
+ result: boolean;
+ begin
+ t := curmod;
+ curtype := 1;
+ getxnext;
+ scanexpression;
+ result := false;
+ if curtype <> t then begin {1055:}
+ disperr(-30000, 827);
+ begin
+ helpptr := 2;
+ helpline[1] := 828;
+ helpline[0] := 829
+ end;
+ if t = 6 then
+ helpline[1] := 830;
+ putgetflusherror(0)
+ end else if curtype = 6 then {:1055}
+ result := true {1056:}
+ else begin
+ curexp := roundunscaled(curexp);
+ if (abs(curexp) < 4) and (curexp <> 0) then
+ result := true
+ else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(831)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := 829
+ end;
+ putgetflusherror(0)
+ end
+ end {:1056};
+ scanwith := result
+ end; {:1054} {1057:}
+
+ procedure findedgesvar(t: halfword);
+ var
+ p: halfword;
+ begin
+ p := findvariable(t);
+ curedges := -30000;
+ if p = (-30000) then begin
+ obliterated(t);
+ putgeterror
+ end else if mem[p].hh.b0 <> 11 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(654)
+ end;
+ showtokenlist(t, -30000, 1000, 0);
+ print(832);
+ printtype(mem[p].hh.b0);
+ printchar(41);
+ begin
+ helpptr := 2;
+ helpline[1] := 833;
+ helpline[0] := 834
+ end;
+ putgeterror
+ end else
+ curedges := mem[p + 1].int;
+ flushnodelist(t)
+ end; {:1057} {1059:}
+
+ procedure doaddto;
+ label
+ 30, 45;
+ var
+ lhs, rhs: halfword;
+ t: smallnumber;
+ w: integer;
+ p: halfword;
+ q: halfword;
+ begin
+ getxnext;
+ varflag := 68;
+ scanprimary;
+ if curtype <> 20 then begin {1060:}
+ disperr(-30000, 835);
+ begin
+ helpptr := 4;
+ helpline[3] := 836;
+ helpline[2] := 837;
+ helpline[1] := 838;
+ helpline[0] := 834
+ end;
+ putgetflusherror(0)
+ end else begin {:1060}
+ lhs := curexp;
+ curpathtype := curmod;
+ curtype := 1;
+ getxnext;
+ scanexpression;
+ if curpathtype = 2 then begin {1061:}
+ findedgesvar(lhs);
+ if curedges = (-30000) then
+ flushcurexp(0)
+ else if curtype <> 11 then begin
+ disperr(-30000, 839);
+ begin
+ helpptr := 2;
+ helpline[1] := 840;
+ helpline[0] := 834
+ end;
+ putgetflusherror(0)
+ end else begin
+ mergeedges(curexp);
+ flushcurexp(0)
+ end
+ end else begin {:1061} {1062:}
+ if curtype = 14 then
+ pairtopath;
+ if curtype <> 9 then begin
+ disperr(-30000, 839);
+ begin
+ helpptr := 2;
+ helpline[1] := 841;
+ helpline[0] := 834
+ end;
+ putgetflusherror(0);
+ flushtokenlist(lhs)
+ end else begin
+ rhs := curexp;
+ w := 1;
+ curpen := -29997;
+ {
+ 1063:}
+ while curcmd = 66 do
+ if scanwith then
+ if curtype = 16 then
+ w := curexp
+ else begin
+ if mem[curpen].hh.lh = (-30000) then
+ tosspen(curpen)
+ else
+ mem[curpen].hh.lh := mem[curpen].hh.lh - 1;
+ curpen := curexp
+ end {:1063}; {1064:}
+ findedgesvar(lhs);
+ if curedges = (-30000) then
+ tossknotlist(rhs)
+ else begin
+ lhs := -30000;
+ if mem[rhs].hh.b0 = 0 then
+ if curpathtype = 0 then {1065:}
+ if mem[rhs].hh.rh = rhs then begin {1066:}
+ mem[rhs + 5].int := mem[rhs + 1].int;
+ mem[rhs + 6].int := mem[rhs + 2].int;
+ mem[rhs + 3].int := mem[rhs + 1].int;
+ mem[rhs + 4].int := mem[rhs + 2].int;
+ mem[rhs].hh.b0 := 1;
+ mem[rhs].hh.b1 := 1
+ end else begin {:1066}
+ p := htapypoc(rhs);
+ q := mem[p].hh.rh;
+ mem[pathtail + 5].int := mem[q + 5].int;
+ mem[pathtail + 6].int := mem[q + 6].int;
+ mem[pathtail].hh.b1 := mem[q].hh.b1;
+ mem[pathtail].hh.rh := mem[q].hh.rh;
+ freenode(q, 7);
+ mem[p + 5].int := mem[rhs + 5].int;
+ mem[p + 6].int := mem[rhs + 6].int;
+ mem[p].hh.b1 := mem[rhs].hh.b1;
+ mem[p].hh.rh := mem[rhs].hh.rh;
+ freenode(rhs, 7);
+ rhs := p
+ end {:1065} {1067:}
+ else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(842)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 843;
+ helpline[0] := 834
+ end;
+ putgeterror;
+ tossknotlist(rhs);
+ goto 45
+ end {:1067}
+ else if curpathtype = 0 then
+ lhs := htapypoc(rhs);
+ curwt := w;
+ rhs := makespec(rhs, mem[curpen + 9].int, internal[5]); {1068:}
+ if turningnumber <= 0 then
+ if curpathtype <> 0 then
+ if internal[39] > 0 then
+ if (turningnumber < 0) and (mem[curpen].hh.rh = (-30000)) then
+ curwt := -curwt
+ else begin
+ if turningnumber = 0 then
+ if (internal[39] <= 65536) and (mem[curpen].hh.rh = (-30000)) then
+ goto 30
+ else
+ printstrange(844)
+ else
+ printstrange(845);
+ begin
+ helpptr := 3;
+ helpline[2] := 846;
+ helpline[1] := 847;
+ helpline[0] := 848
+ end;
+ putgeterror
+ end;
+ 30: {:1068}
+ ;
+ if mem[curpen + 9].int = 0 then
+ fillspec(rhs)
+ else
+ fillenvelope(rhs);
+ if lhs <> (-30000) then begin
+ revturns := true;
+ lhs := makespec(lhs, mem[curpen + 9].int, internal[5]);
+ revturns := false;
+ if mem[curpen + 9].int = 0 then
+ fillspec(lhs)
+ else
+ fillenvelope(lhs)
+ end;
+ 45: {:1064}
+
+ end;
+ if mem[curpen].hh.lh = (-30000) then
+ tosspen(curpen)
+ else
+ mem[curpen].hh.lh := mem[curpen].hh.lh - 1
+ end
+ end {:1062}
+ end
+ end; {:1059} {1070:} {1098:}
+
+ function tfmcheck(m: smallnumber): scaled;
+ begin
+ if abs(internal[m]) >= 134217728 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(865)
+ end;
+ print(intname[m]);
+ print(866);
+ begin
+ helpptr := 1;
+ helpline[0] := 867
+ end;
+ putgeterror;
+ if internal[m] > 0 then
+ tfmcheck := 134217727
+ else
+ tfmcheck := -134217727
+ end else
+ tfmcheck := internal[m]
+ end; {:1098}
+
+ procedure doshipout;
+ label
+ 10;
+ var
+ c: integer;
+ begin
+ getxnext;
+ varflag := 80;
+ scanexpression;
+ {1060:
+ }
+ if curtype <> 20 then
+ if curtype = 11 then
+ curedges := curexp
+ else begin
+ begin
+ disperr(-30000, 835);
+ begin
+ helpptr := 4;
+ helpline[3] := 836;
+ helpline[2] := 837;
+ helpline[1] := 838;
+ helpline[0] := 834
+ end;
+ putgetflusherror(0)
+ end {:1060};
+ goto 10
+ end
+ else begin
+ findedgesvar(curexp);
+ curtype := 1
+ end;
+ if curedges <> (-30000) then begin
+ c := roundunscaled(internal[18]) mod 256;
+ if c < 0 then
+ c := c + 256; {1099:}
+ if c < bc then
+ bc := c;
+ if c > ec then
+ ec := c;
+ charexists[c] := true;
+ gfdx[c] := internal[24];
+ gfdy[c] := internal[25];
+ tfmwidth[c] := tfmcheck(20);
+ tfmheight[c] := tfmcheck(21);
+ tfmdepth[c] := tfmcheck(22);
+ tfmitalcorr[c] := tfmcheck(23) {:1099};
+ if internal[34] >= 0 then
+ shipout(c)
+ end;
+ flushcurexp(0);
+ 10:
+
+ end; {:1070}
+ {1071:}
+
+ procedure dodisplay;
+ label
+ 45, 50, 10;
+ var
+ e: halfword;
+ begin
+ getxnext;
+ varflag := 73;
+ scanprimary;
+ if curtype <> 20 then begin {1060:}
+ disperr(-30000, 835);
+ begin
+ helpptr := 4;
+ helpline[3] := 836;
+ helpline[2] := 837;
+ helpline[1] := 838;
+ helpline[0] := 834
+ end;
+ putgetflusherror(0)
+ end else begin {:1060}
+ e := curexp;
+ curtype := 1;
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then
+ goto 50;
+ curexp := roundunscaled(curexp);
+ if curexp < 0 then
+ goto 45;
+ if curexp > 15 then
+ goto 45;
+ if not windowopen[curexp] then
+ goto 45;
+ findedgesvar(e);
+ if curedges <> (-30000) then
+ dispedges(curexp);
+ goto 10;
+ 45:
+ curexp := curexp * 65536;
+ 50:
+ disperr(-30000, 849);
+ begin
+ helpptr := 1;
+ helpline[0] := 850
+ end;
+ putgetflusherror(0);
+ flushtokenlist(e)
+ end;
+ 10:
+
+ end; { dodisplay }
+ {:1071}
+ {1072:}
+
+ function getpair(c: commandcode): boolean;
+ var
+ p: halfword;
+ b: boolean;
+ begin
+ if curcmd <> c then
+ getpair := false
+ else begin
+ getxnext;
+ scanexpression;
+ if nicepair(curexp, curtype) then begin
+ p := mem[curexp + 1].int;
+ curx := mem[p + 1].int;
+ cury := mem[p + 3].int;
+ b := true
+ end else
+ b := false;
+ flushcurexp(0);
+ getpair := b
+ end
+ end; {:1072} {1073:}
+
+ procedure doopenwindow;
+ label
+ 45, 10;
+ var
+ k: integer;
+ r0, c0, r1, c1: scaled;
+ begin
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then
+ goto 45;
+ k := roundunscaled(curexp);
+ if k < 0 then
+ goto 45;
+ if k > 15 then
+ goto 45;
+ if not getpair(70) then
+ goto 45;
+ r0 := curx;
+ c0 := cury;
+ if not getpair(71) then
+ goto 45;
+ r1 := curx;
+ c1 := cury;
+ if not getpair(72) then
+ goto 45;
+ openawindow(k, r0, c0, r1, c1, curx, cury);
+ goto 10;
+ 45:
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(851)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 852;
+ helpline[0] := 853
+ end;
+ putgeterror;
+ 10:
+
+ end; {:1073} {1074:}
+
+ procedure docull;
+ label
+ 45, 10;
+ var
+ e: halfword;
+ keeping: 0..1;
+ w, win, wout: integer;
+ begin
+ w := 1;
+ getxnext;
+ varflag := 67;
+ scanprimary;
+ if curtype <> 20 then begin {1060:}
+ disperr(-30000, 835);
+ begin
+ helpptr := 4;
+ helpline[3] := 836;
+ helpline[2] := 837;
+ helpline[1] := 838;
+ helpline[0] := 834
+ end;
+ putgetflusherror(0)
+ end else begin {:1060}
+ e := curexp;
+ curtype := 1;
+ keeping := curmod;
+ if not getpair(67) then
+ goto 45;
+ while (curcmd = 66) and (curmod = 16) do
+ if scanwith then
+ w := curexp; {1075:}
+ if curx > cury then
+ goto 45;
+ if keeping = 0 then begin
+ if (curx > 0) or (cury < 0) then
+ goto 45;
+ wout := w;
+ win := 0
+ end else begin
+ if (curx <= 0) and (cury >= 0) then
+ goto 45;
+ wout := 0;
+ win := w
+ end {:1075};
+ findedgesvar(e);
+ if curedges <> (-30000) then
+ culledges(floorunscaled(curx + 65535), floorunscaled(cury), wout, win);
+ goto 10;
+ 45:
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(854)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := 855
+ end;
+ putgeterror;
+ flushtokenlist(e)
+ end;
+ 10:
+
+ end; {:1074} {1082:}
+
+ procedure domessage;
+ var
+ m: 0..2;
+ begin
+ m := curmod;
+ getxnext;
+ scanexpression;
+ if curtype <> 4 then begin
+ disperr(-30000, 565);
+ begin
+ helpptr := 1;
+ helpline[0] := 859
+ end;
+ putgeterror
+ end else
+ case m of
+ 0:
+ begin
+ printnl(155);
+ slowprint(curexp)
+ end;
+ 1:
+ begin {1086:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(155)
+ end;
+ slowprint(curexp);
+ if errhelp <> 0 then
+ useerrhelp := true
+ else if longhelpseen then begin
+ helpptr := 1;
+ helpline[0] := 860
+ end else begin
+ if interaction < 3 then
+ longhelpseen := true;
+ begin
+ helpptr := 4;
+ helpline[3] := 861;
+ helpline[2] := 862;
+ helpline[1] := 863;
+ helpline[0] := 864
+ end
+ end;
+ putgeterror;
+ useerrhelp := false
+ end; {:1086}
+ 2:
+ begin {1083:}
+ if errhelp <> 0 then begin
+ if strref[errhelp] < 127 then
+ if strref[errhelp] > 1 then
+ strref[errhelp] := strref[errhelp] - 1
+ else
+ flushstring(errhelp)
+ end;
+ if (strstart[curexp + 1] - strstart[curexp]) = 0 then
+ errhelp := 0
+ else begin
+ errhelp := curexp;
+ begin
+ if strref[errhelp] < 127 then
+ strref[errhelp] := strref[errhelp] + 1
+ end
+ end
+ end
+ end {:1083};
+ flushcurexp(0)
+ end; {:1082} {1103:}
+
+ function getcode: eightbits;
+ label
+ 40;
+ var
+ c: integer;
+ begin
+ getxnext;
+ scanexpression;
+ if curtype = 16 then begin
+ c := roundunscaled(curexp);
+ if c >= 0 then
+ if c < 256 then
+ goto 40
+ end else if curtype = 4 then
+ if (strstart[curexp + 1] - strstart[curexp]) = 1 then begin
+ c := strpool[strstart[curexp]];
+ goto 40
+ end;
+ disperr(-30000, 873);
+ begin
+ helpptr := 2;
+ helpline[1] := 874;
+ helpline[0] := 875
+ end;
+ putgetflusherror(0);
+ c := 0;
+ 40:
+ getcode := c
+ end; {:1103} {1104:}
+
+ procedure settag(c: eightbits; t: smallnumber; r: eightbits);
+ begin
+ if chartag[c] = 0 then begin
+ chartag[c] := t;
+ charremainder[c] := r
+ end else begin {1105:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(876)
+ end;
+ if (c > 32) and (c < 128) then
+ print(c)
+ else begin
+ print(877);
+ printint(c)
+ end;
+ print(878);
+ case chartag[c] of
+ 1:
+ print(879);
+ 2:
+ print(880);
+ 3:
+ print(870)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 881;
+ helpline[0] := 834
+ end;
+ putgeterror
+ end {:1105}
+ end; {:1104} {1106:}
+
+ procedure dotfmcommand;
+ label
+ 22;
+ var
+ c, cc: eightbits;
+ k: 0..256;
+ j: integer;
+ begin
+ case curmod of
+ 0:
+ begin {1107:}
+ c := getcode;
+ while curcmd = 78 do begin
+ cc := getcode;
+ settag(c, 2, cc);
+ c := cc
+ end
+ end; {:1107}
+ 1:
+ begin {1108:}
+ 22:
+ c := getcode;
+ if curcmd = 78 then begin {1111:}
+ if nl < 256 then
+ settag(c, 1, nl)
+ else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(891)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := 892
+ end;
+ error
+ end;
+ goto 22
+ end {:1111};
+ if curcmd = 76 then begin {1112:}
+ ligkern[nl].b1 := c - 128;
+ ligkern[nl].b2 := curmod - 128;
+ ligkern[nl].b0 := -128;
+ if curmod = 0 then
+ ligkern[nl].b3 := getcode - 128
+ else begin
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then begin
+ disperr(-30000, 893);
+ begin
+ helpptr := 2;
+ helpline[1] := 894;
+ helpline[0] := 179
+ end;
+ putgetflusherror(0)
+ end;
+ kern[nk] := curexp;
+ k := 0;
+ while kern[k] <> curexp do
+ k := k + 1;
+ if k = nk then begin
+ if nk = 256 then
+ overflow(890, 256);
+ nk := nk + 1
+ end;
+ ligkern[nl].b3 := k - 128
+ end {:1112};
+ if nl = ligtablesize then
+ overflow(886, ligtablesize);
+ nl := nl + 1;
+ if curcmd = 79 then
+ goto 22
+ end else begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(887)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := 888
+ end;
+ backerror
+ end;
+ if nl > 0 then
+ ligkern[nl - 1].b0 := 0
+ end; {:1108}
+ 2:
+ begin {1113:}
+ if ne = 256 then
+ overflow(870, 256);
+ c := getcode;
+ settag(c, 3, ne);
+ if curcmd <> 78 then begin
+ missingerr(58);
+ begin
+ helpptr := 1;
+ helpline[0] := 895
+ end;
+ backerror
+ end;
+ exten[ne].b0 := getcode - 128;
+ if curcmd <> 79 then begin
+ missingerr(44);
+ begin
+ helpptr := 1;
+ helpline[0] := 895
+ end;
+ backerror
+ end;
+ exten[ne].b1 := getcode - 128;
+ if curcmd <> 79 then begin
+ missingerr(44);
+ begin
+ helpptr := 1;
+ helpline[0] := 895
+ end;
+ backerror
+ end;
+ exten[ne].b2 := getcode - 128;
+ if curcmd <> 79 then begin
+ missingerr(44);
+ begin
+ helpptr := 1;
+ helpline[0] := 895
+ end;
+ backerror
+ end;
+ exten[ne].b3 := getcode - 128;
+ ne := ne + 1
+ end; {:1113}
+ 3, 4:
+ begin
+ c := curmod;
+ getxnext;
+ scanexpression;
+ if (curtype <> 16) or (curexp < 32768) then begin
+ disperr(-30000, 882);
+ begin
+ helpptr := 2;
+ helpline[1] := 883;
+ helpline[0] := 884
+ end;
+ putgeterror
+ end else begin
+ j := roundunscaled(curexp);
+ if curcmd <> 78 then begin
+ missingerr(58);
+ begin
+ helpptr := 1;
+ helpline[0] := 885
+ end;
+ backerror
+ end;
+ if c = 3 then {1114:}
+ repeat
+ if j > headersize then
+ overflow(871, headersize);
+ headerbyte[j] := getcode;
+ j := j + 1
+ until curcmd <> 79 {:1114} {1115:}
+ else
+ repeat
+ if j > maxfontdimen then
+ overflow(872, maxfontdimen);
+ while j > np do begin
+ np := np + 1;
+ param[np] := 0
+ end;
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then begin
+ disperr(-30000, 896);
+ begin
+ helpptr := 1;
+ helpline[0] := 179
+ end;
+ putgetflusherror(0)
+ end;
+ param[j] := curexp;
+ j := j + 1
+ until curcmd <> 79 {:1115}
+ end
+ end
+ end
+ end; {:1106} {1177:}
+
+ procedure dospecial;
+ var
+ m: smallnumber;
+ begin
+ m := curmod;
+ getxnext;
+ scanexpression;
+ if internal[34] >= 0 then
+ if curtype <> m then begin {1178:}
+ disperr(-30000, 914);
+ begin
+ helpptr := 1;
+ helpline[0] := 915
+ end;
+ putgeterror
+ end else begin {:1178}
+ if outputfilename = 0 then
+ initgf;
+ if m = 4 then
+ gfstring(curexp, 0)
+ else begin
+ begin
+ gfbuf[gfptr] := 243;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(curexp)
+ end
+ end;
+ flushcurexp(0)
+ end; {:1177} {1186:}
+ {procedure storebasefile;var k:integer;
+ p,q:halfword;x:integer;w:fourquarters;begin[1200:]selector:=5;
+ print(925);print(jobname);printchar(32);
+ printint(roundunscaled(internal[14])mod 100);printchar(46);
+ printint(roundunscaled(internal[15]));printchar(46);
+ printint(roundunscaled(internal[16]));printchar(41);
+ if interaction=0 then selector:=2 else selector:=3;
+ begin if poolptr+1>maxpoolptr then begin if poolptr+1>poolsize then
+ overflow(129,poolsize-initpoolptr);maxpoolptr:=poolptr+1;end;end;
+ baseident:=makestring;strref[baseident]:=127;packjobname(926);
+ while not wopenout(basefile)do promptfilename(927,926);printnl(928);
+ print(wmakenamestring(basefile));flushstring(strptr-1);
+ printnl(baseident)[:1200];[1190:]begin basefile^.int:=503742536;
+ put(basefile);end;begin basefile^.int:=-30000;put(basefile);end;
+ begin basefile^.int:=30000;put(basefile);end;begin basefile^.int:=2100;
+ put(basefile);end;begin basefile^.int:=1777;put(basefile);end;
+ begin basefile^.int:=6;put(basefile);end[:1190];
+ [1192:]begin basefile^.int:=poolptr;put(basefile);end;
+ begin basefile^.int:=strptr;put(basefile);end;
+ for k:=0 to strptr do begin basefile^.int:=strstart[k];put(basefile);
+ end;k:=0;while k+4<poolptr do begin w.b0:=strpool[k];w.b1:=strpool[k+1];
+ w.b2:=strpool[k+2];w.b3:=strpool[k+3];begin basefile^.qqqq:=w;
+ put(basefile);end;k:=k+4;end;k:=poolptr-4;w.b0:=strpool[k];
+ w.b1:=strpool[k+1];w.b2:=strpool[k+2];w.b3:=strpool[k+3];
+ begin basefile^.qqqq:=w;put(basefile);end;println;printint(strptr);
+ print(922);printint(poolptr)[:1192];[1194:]sortavail;varused:=0;
+ begin basefile^.int:=lomemmax;put(basefile);end;
+ begin basefile^.int:=rover;put(basefile);end;p:=-30000;q:=rover;x:=0;
+ repeat for k:=p to q+1 do begin basefile^:=mem[k];put(basefile);end;
+ x:=x+q+2-p;varused:=varused+q-p;p:=q+mem[q].hh.lh;q:=mem[q+1].hh.rh;
+ until q=rover;varused:=varused+lomemmax-p;dynused:=memend+1-himemmin;
+ for k:=p to lomemmax do begin basefile^:=mem[k];put(basefile);end;
+ x:=x+lomemmax+1-p;begin basefile^.int:=himemmin;put(basefile);end;
+ begin basefile^.int:=avail;put(basefile);end;
+ for k:=himemmin to memend do begin basefile^:=mem[k];put(basefile);end;
+ x:=x+memend+1-himemmin;p:=avail;
+ while p<>-30000 do begin dynused:=dynused-1;p:=mem[p].hh.rh;end;
+ begin basefile^.int:=varused;put(basefile);end;
+ begin basefile^.int:=dynused;put(basefile);end;println;printint(x);
+ print(923);printint(varused);printchar(38);printint(dynused)[:1194];
+ [1196:]begin basefile^.int:=hashused;put(basefile);end;
+ stcount:=2228-hashused;
+ for p:=1 to hashused do if hash[p].rh<>0 then begin begin basefile^.int
+ :=p;put(basefile);end;begin basefile^.hh:=hash[p];put(basefile);end;
+ begin basefile^.hh:=eqtb[p];put(basefile);end;stcount:=stcount+1;end;
+ for p:=hashused+1 to 2241 do begin begin basefile^.hh:=hash[p];
+ put(basefile);end;begin basefile^.hh:=eqtb[p];put(basefile);end;end;
+ begin basefile^.int:=stcount;put(basefile);end;println;
+ printint(stcount);print(924)[:1196];[1198:]begin basefile^.int:=intptr;
+ put(basefile);end;
+ for k:=1 to intptr do begin begin basefile^.int:=internal[k];
+ put(basefile);end;begin basefile^.int:=intname[k];put(basefile);end;end;
+ begin basefile^.int:=startsym;put(basefile);end;
+ begin basefile^.int:=interaction;put(basefile);end;
+ begin basefile^.int:=baseident;put(basefile);end;
+ begin basefile^.int:=bgloc;put(basefile);end;begin basefile^.int:=egloc;
+ put(basefile);end;begin basefile^.int:=serialno;put(basefile);end;
+ begin basefile^.int:=69069;put(basefile);end;internal[12]:=0[:1198];
+ [1201:]wclose(basefile)[:1201];end;}
+ {:1186}
+
+ procedure dostatement;
+ begin
+ curtype := 1;
+ getxnext;
+ if curcmd > 43 then begin {990:}
+ if curcmd < 80 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(733)
+ end;
+ printcmdmod(curcmd, curmod);
+ printchar(39);
+ begin
+ helpptr := 5;
+ helpline[4] := 734;
+ helpline[3] := 735;
+ helpline[2] := 736;
+ helpline[1] := 737;
+ helpline[0] := 738
+ end;
+ backerror;
+ getxnext
+ end
+ end else if curcmd > 30 then begin {:990} {993:}
+ varflag := 77;
+ scanexpression;
+ if curcmd < 81 then begin
+ if curcmd = 51 then
+ doequation
+ else if curcmd = 77 then
+ doassignment
+ else if curtype = 4 then begin {994:}
+ if internal[1] > 0 then begin
+ printnl(155);
+ slowprint(curexp);
+ {---------------------}
+ auxprintnl(155);
+ auxslowprint(curexp);
+ {---------------------}
+ flush(output)
+ end;
+ if internal[34] > 0 then begin {1179:}
+ if outputfilename = 0 then
+ initgf;
+ gfstring(916, curexp)
+ end {:1179}
+ end else if curtype <> 1 then begin {:994}
+ disperr(-30000, 743);
+ begin
+ helpptr := 3;
+ helpline[2] := 744;
+ helpline[1] := 745;
+ helpline[0] := 746
+ end;
+ putgeterror
+ end;
+ flushcurexp(0);
+ curtype := 1
+ end
+ end else begin {:993} {992:}
+ if internal[7] > 0 then
+ showcmdmod(curcmd, curmod);
+ case curcmd of
+ 30:
+ dotypedeclaration;
+ 16:
+ if curmod > 2 then
+ makeopdef
+ else if curmod > 0 then
+ scandef; {1020:}
+ 24:
+ dorandomseed; {:1020} {1023:}
+ 23:
+ begin
+ println;
+ interaction := curmod; {70:}
+ if interaction = 0 then
+ selector := 0
+ else
+ selector := 1 {:70};
+ if jobname <> 0 then
+ selector := selector + 2;
+ getxnext
+ end; {:1023} {1026:}
+ 21:
+ doprotection; {:1026} {1030:}
+ 27:
+ defdelims; {:1030} {1033:}
+ 12:
+ repeat
+ getsymbol;
+ savevariable(cursym);
+ getxnext
+ until curcmd <> 79;
+ 13:
+ dointerim;
+ 14:
+ dolet;
+ 15:
+ donewinternal; {:1033} {1039:}
+ 22:
+ doshowwhatever;
+ {:1039}
+ {1058:}
+ 18:
+ doaddto; {:1058} {1069:}
+ 17:
+ doshipout;
+ 11:
+ dodisplay;
+ 28:
+ doopenwindow;
+ 19:
+ docull; {:1069} {1076:}
+ 26:
+ begin
+ getsymbol;
+ startsym := cursym;
+ getxnext
+ end; {:1076} {1081:}
+ 25:
+ domessage; {:1081} {1100:}
+ 20:
+ dotfmcommand; {:1100} {1175:}
+ 29:
+ dospecial
+ end {:1175};
+ curtype := 1
+ end {:992};
+ if curcmd < 80 then begin {991:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(739)
+ end;
+ begin
+ helpptr := 6;
+ helpline[5] := 740;
+ helpline[4] := 741;
+ helpline[3] := 742;
+ helpline[2] := 736;
+ helpline[1] := 737;
+ helpline[0] := 738
+ end;
+ backerror;
+ scannerstatus := 2;
+ repeat
+ getnext; {743:}
+ if curcmd = 39 then begin
+ if strref[curmod] < 127 then
+ if strref[curmod] > 1 then
+ strref[curmod] := strref[curmod] - 1
+ else
+ flushstring(curmod)
+ end {:743}
+ until curcmd > 79;
+ scannerstatus := 0
+ end {:991};
+ errorcount := 0
+ end; {:989}
+ {1017:}
+
+ procedure maincontrol;
+ begin
+ repeat
+ dostatement;
+ if curcmd = 81 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(774)
+ end;
+ begin
+ helpptr := 2;
+ helpline[1] := 775;
+ helpline[0] := 555
+ end;
+ flusherror(0)
+ end
+ until curcmd = 82
+ end; {:1017} {1117:}
+
+ function sortin(v: scaled): halfword;
+ label
+ 40;
+ var
+ p, q, r: halfword;
+ begin
+ p := 29999;
+ while true do begin
+ q := mem[p].hh.rh;
+ if v <= mem[q + 1].int then
+ goto 40;
+ p := q
+ end;
+ 40:
+ if v < mem[q + 1].int then begin
+ r := getnode(2);
+ mem[r + 1].int := v;
+ mem[r].hh.rh := q;
+ mem[p].hh.rh := r
+ end;
+ sortin := mem[p].hh.rh
+ end; {:1117}
+ {1118:}
+
+ function mincover(d: scaled): integer;
+ var
+ p: halfword;
+ l: scaled;
+ m: integer;
+ begin
+ m := 0;
+ p := mem[29999].hh.rh;
+ perturbation := 2147483647;
+ while p <> (-29981) do begin
+ m := m + 1;
+ l := mem[p + 1].int;
+ repeat
+ p := mem[p].hh.rh
+ until mem[p + 1].int > (l + d);
+ if (mem[p + 1].int - l) < perturbation then
+ perturbation := mem[p + 1].int - l
+ end;
+ mincover := m
+ end; {:1118} {1120:}
+
+ function threshold(m: integer): scaled;
+ var
+ d: scaled;
+ begin
+ if mincover(0) <= m then
+ threshold := 0
+ else begin
+ repeat
+ d := perturbation
+ until mincover(d + d) <= m;
+ while mincover(d) > m do
+ d := perturbation;
+ threshold := d
+ end
+ end; {:1120}
+ {1121:}
+
+ function skimp(m: integer): integer;
+ var
+ d: scaled;
+ p, q, r: halfword;
+ l: scaled;
+ v: scaled;
+ begin
+ d := threshold(m);
+ perturbation := 0;
+ q := 29999;
+ m := 0;
+ p := mem[29999].hh.rh;
+ while p <> (-29981) do begin
+ m := m + 1;
+ l := mem[p + 1].int;
+ mem[p].hh.lh := m;
+ if mem[mem[p].hh.rh + 1].int <= (l + d) then begin {1122:}
+ repeat
+ p := mem[p].hh.rh;
+ mem[p].hh.lh := m
+ until mem[mem[p].hh.rh + 1].int > (l + d);
+ v := (l + mem[p + 1].int) div 2;
+ if (mem[p + 1].int - v) > perturbation then
+ perturbation := mem[p + 1].int - v;
+ r := q;
+ repeat
+ r := mem[r].hh.rh;
+ mem[r + 1].int := v
+ until r = p;
+ mem[q].hh.rh := p
+ end {:1122};
+ q := p;
+ p := mem[p].hh.rh
+ end;
+ skimp := m
+ end; {:1121} {1123:}
+
+ procedure tfmwarning(m: smallnumber);
+ begin
+ printnl(897);
+ print(intname[m]);
+ print(898);
+ printscaled(perturbation);
+ print(899)
+ end; { tfmwarning }
+ {:1123}
+ {1128:}
+
+ procedure fixdesignsize;
+ var
+ d: scaled;
+ begin
+ d := internal[26];
+ if (d < 65536) or (d >= 134217728) then begin
+ if d <> 0 then
+ printnl(900);
+ d := 8388608;
+ internal[26] := d
+ end;
+ if headerbyte[5] < 0 then
+ if headerbyte[6] < 0 then
+ if headerbyte[7] < 0 then
+ if headerbyte[8] < 0 then begin
+ headerbyte[5] := d div 1048576;
+ headerbyte[6] := (d div 4096) mod 256;
+ headerbyte[7] := (d div 16) mod 256;
+ headerbyte[8] := (d mod 16) * 16
+ end;
+ maxtfmdimen := (16 * internal[26]) - (internal[26] div 2097152);
+ if maxtfmdimen >= 134217728 then
+ maxtfmdimen := 134217727
+ end; {:1128} {1129:}
+
+ function dimenout(x: scaled): integer;
+ begin
+ if abs(x) > maxtfmdimen then begin
+ tfmchanged := tfmchanged + 1;
+ if x > 0 then
+ x := 16777215
+ else
+ x := -16777215
+ end else
+ x := makescaled(x * 16, internal[26]);
+ dimenout := x
+ end; {:1129} {1131:}
+
+ procedure fixchecksum;
+ label
+ 10;
+ var
+ k: eightbits;
+ b1, b2, b3, b4: eightbits;
+ x: integer;
+ begin
+ if headerbyte[1] < 0 then
+ if headerbyte[2] < 0 then
+ if headerbyte[3] < 0 then
+ if headerbyte[4] < 0 then begin {1132:}
+ b1 := bc;
+ b2 := ec;
+ b3 := bc;
+ b4 := ec;
+ tfmchanged := 0;
+ for k := bc to ec do
+ if charexists[k] then begin
+ x := dimenout(mem[tfmwidth[k] + 1].int) + ((k + 4) * 4194304);
+ b1 := ((b1 + b1) + x) mod 255;
+ b2 := ((b2 + b2) + x) mod 253;
+ b3 := ((b3 + b3) + x) mod 251;
+ b4 := ((b4 + b4) + x) mod 247
+ end {:1132};
+ headerbyte[1] := b1;
+ headerbyte[2] := b2;
+ headerbyte[3] := b3;
+ headerbyte[4] := b4;
+ goto 10
+ end;
+ for k := 1 to 4 do
+ if headerbyte[k] < 0 then
+ headerbyte[k] := 0;
+ 10:
+
+ end; {:1131}
+ {1133:}
+
+ procedure tfmqqqq(x: fourquarters);
+ begin
+ bwritebyte(tfmfile, x.b0 + 128);
+ bwritebyte(tfmfile, x.b1 + 128);
+ bwritebyte(tfmfile, x.b2 + 128);
+ bwritebyte(tfmfile, x.b3 + 128)
+ end; {:1133}
+ {1187:}
+ {779:}
+
+ function openbasefile: boolean;
+ label
+ 40, 10;
+ var
+ j: 0..bufsize;
+ begin
+ j := curinput.locfield;
+ if buffer[curinput.locfield] = 38 then begin
+ curinput.locfield := curinput.locfield + 1;
+ j := curinput.locfield;
+ buffer[last] := 32;
+ while buffer[j] <> 32 do
+ j := j + 1;
+ packbufferedname(0, curinput.locfield, j - 1);
+ if wopenin(basefile) then
+ goto 40;
+ writeln(output, 'Sorry, I can''t find that base;', ' will try PLAIN.');
+ flush(output)
+ end;
+ packbufferedname(5, 1, 0);
+ if not wopenin(basefile) then begin
+ writeln(output, 'I can''t find the PLAIN base file!');
+ openbasefile := false;
+ goto 10
+ end;
+ 40:
+ curinput.locfield := j;
+ openbasefile := true;
+ 10:
+
+ end; {:779}
+
+ function loadbasefile: boolean;
+ label
+ 6666, 10;
+ var
+ k: integer;
+ p, q: halfword;
+ x: integer;
+ w: fourquarters; {1191:}
+ begin
+ x := basefile^.int;
+ if x <> 503742536 then
+ goto 6666;
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if x <> (-30000) then
+ goto 6666;
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if x <> 30000 then
+ goto 6666;
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if x <> 2100 then
+ goto 6666;
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if x <> 1777 then
+ goto 6666;
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if x <> 6 then
+ goto 6666 {:1191};
+ {1193:}
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if x < 0 then
+ goto 6666;
+ if x > poolsize then begin
+ writeln(output, '---! Must increase the ', 'string pool size');
+ goto 6666
+ end else
+ poolptr := x
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if x < 0 then
+ goto 6666;
+ if x > maxstrings then begin
+ writeln(output, '---! Must increase the ', 'max strings');
+ goto 6666
+ end else
+ strptr := x
+ end;
+ for k := 0 to strptr do begin
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 0) or (x > poolptr) then
+ goto 6666
+ else
+ strstart[k] := x
+ end;
+ strref[k] := 127
+ end;
+ k := 0;
+ while (k + 4) < poolptr do begin
+ begin
+ get(basefile);
+ w := basefile^.qqqq
+ end;
+ strpool[k] := w.b0;
+ strpool[k + 1] := w.b1;
+ strpool[k + 2] := w.b2;
+ strpool[k + 3] := w.b3;
+ k := k + 4
+ end;
+ k := poolptr - 4;
+ begin
+ get(basefile);
+ w := basefile^.qqqq
+ end;
+ strpool[k] := w.b0;
+ strpool[k + 1] := w.b1;
+ strpool[k + 2] := w.b2;
+ strpool[k + 3] := w.b3 {:1193}; {1195:}
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < (-28978)) or (x > 29997) then
+ goto 6666
+ else
+ lomemmax := x
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < (-29977)) or (x > lomemmax) then
+ goto 6666
+ else
+ rover := x
+ end;
+ p := -30000;
+ q := rover;
+ x := 0;
+ repeat
+ for k := p to q + 1 do begin
+ get(basefile);
+ mem[k] := basefile^
+ end;
+ p := q + mem[q].hh.lh;
+ if (p > lomemmax) or ((q >= mem[q + 1].hh.rh) and (mem[q + 1].hh.rh <> rover)) then
+ goto 6666;
+ q := mem[q + 1].hh.rh
+ until q = rover;
+ for k := p to lomemmax do begin
+ get(basefile);
+ mem[k] := basefile^
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < (lomemmax + 1)) or (x > 29998) then
+ goto 6666
+ else
+ himemmin := x
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < (-30000)) or (x > 30000) then
+ goto 6666
+ else
+ avail := x
+ end;
+ memend := 30000;
+ for k := himemmin to memend do begin
+ get(basefile);
+ mem[k] := basefile^
+ end;
+ begin
+ get(basefile);
+ varused := basefile^.int
+ end;
+ begin
+ get(basefile);
+ dynused := basefile^.int
+ end {:1195}; {1197:}
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 1) or (x > 2229) then
+ goto 6666
+ else
+ hashused := x
+ end;
+ p := 0;
+ repeat
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < (p + 1)) or (x > hashused) then
+ goto 6666
+ else
+ p := x
+ end;
+ begin
+ get(basefile);
+ hash[p] := basefile^.hh
+ end;
+ begin
+ get(basefile);
+ eqtb[p] := basefile^.hh
+ end
+ until p = hashused;
+ for p := hashused + 1 to 2241 do begin
+ begin
+ get(basefile);
+ hash[p] := basefile^.hh
+ end;
+ begin
+ get(basefile);
+ eqtb[p] := basefile^.hh
+ end
+ end;
+ begin
+ get(basefile);
+ stcount := basefile^.int
+ end {:1197}; {1199:}
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 40) or (x > maxinternal) then
+ goto 6666
+ else
+ intptr := x
+ end;
+ for k := 1 to intptr do begin
+ begin
+ get(basefile);
+ internal[k] := basefile^.int
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 0) or (x > strptr) then
+ goto 6666
+ else
+ intname[k] := x
+ end
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 0) or (x > 2229) then
+ goto 6666
+ else
+ startsym := x
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 0) or (x > 3) then
+ goto 6666
+ else
+ interaction := x
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 0) or (x > strptr) then
+ goto 6666
+ else
+ baseident := x
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 1) or (x > 2241) then
+ goto 6666
+ else
+ bgloc := x
+ end;
+ begin
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x < 1) or (x > 2241) then
+ goto 6666
+ else
+ egloc := x
+ end;
+ begin
+ get(basefile);
+ serialno := basefile^.int
+ end;
+ begin
+ get(basefile);
+ x := basefile^.int
+ end;
+ if (x <> 69069) or eof(basefile) then
+ goto 6666 {:1199};
+ loadbasefile := true;
+ goto 10;
+ 6666:
+ ;
+ writeln(output, '(Fatal base file error; I''m stymied)');
+ loadbasefile := false;
+ 10:
+
+ end; {:1187} {1202:} {823:}
+
+ procedure scanprimary;
+ label
+ 20, 30, 31, 32;
+ var
+ p, q, r: halfword;
+ c: quarterword;
+ myvarflag: 0..82;
+ ldelim, rdelim: halfword; {831:}
+ groupline: integer; {:831} {836:}
+ num, denom: scaled; {:836} {843:}
+ prehead, posthead, tail: halfword;
+ tt: smallnumber;
+ t: halfword;
+ macroref: halfword; {:843}
+ begin
+ myvarflag := varflag;
+ varflag := 0;
+ 20:
+ begin
+ if aritherror then
+ cleararith
+ end; {825:}
+ {if panicking then checkmem(false);}
+ if interrupt <> 0 then
+ if OKtointerrupt then begin
+ backinput;
+ begin
+ if interrupt <> 0 then
+ pauseforinstructions
+ end;
+ getxnext
+ end {:825};
+ if curcmd in
+ [31, 32, 39, 42, 33, 34, 30, 36,
+ 43, 37, 35, 40, 38, 41] then
+ case curcmd of
+ 31:
+ begin {826:}
+ ldelim := cursym;
+ rdelim := curmod;
+ getxnext;
+ scanexpression;
+ if (curcmd = 79) and (curtype >= 16) then begin {830:}
+ p := getnode(2);
+ mem[p].hh.b0 := 14;
+ mem[p].hh.b1 := 11;
+ initbignode(p);
+ q := mem[p + 1].int;
+ stashin(q);
+ getxnext;
+ scanexpression;
+ if curtype < 16 then begin
+ disperr(-30000, 639);
+ begin
+ helpptr := 4;
+ helpline[3] := 640;
+ helpline[2] := 641;
+ helpline[1] := 642;
+ helpline[0] := 643
+ end;
+ putgetflusherror(0)
+ end;
+ stashin(q + 2);
+ checkdelimiter(ldelim, rdelim);
+ curtype := 14;
+ curexp := p
+ end else {:830}
+ checkdelimiter(ldelim, rdelim)
+ end; {:826}
+ 32:
+ begin {832:}
+ groupline := line;
+ if internal[7] > 0 then
+ showcmdmod(curcmd, curmod);
+ begin
+ p := getavail;
+ mem[p].hh.lh := 0;
+ mem[p].hh.rh := saveptr;
+ saveptr := p
+ end;
+ repeat
+ dostatement
+ until curcmd <> 80;
+ if curcmd <> 81 then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(644)
+ end;
+ printint(groupline);
+ print(645);
+ begin
+ helpptr := 2;
+ helpline[1] := 646;
+ helpline[0] := 647
+ end;
+ backerror;
+ curcmd := 81
+ end;
+ unsave;
+ if internal[7] > 0 then
+ showcmdmod(curcmd, curmod)
+ end; {:832}
+ 39:
+ begin {833:}
+ curtype := 4;
+ curexp := curmod
+ end; {:833}
+ 42:
+ begin {837:}
+ curexp := curmod;
+ curtype := 16;
+ getxnext;
+ if curcmd <> 54 then begin
+ num := 0;
+ denom := 0
+ end else begin
+ getxnext;
+ if curcmd <> 42 then begin
+ backinput;
+ curcmd := 54;
+ curmod := 72;
+ cursym := 2233;
+ goto 30
+ end;
+ num := curexp;
+ denom := curmod;
+ if denom = 0 then begin {838:}
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(648)
+ end;
+ begin
+ helpptr := 1;
+ helpline[0] := 649
+ end;
+ error
+ end else {:838}
+ curexp := makescaled(num, denom);
+ begin
+ if aritherror then
+ cleararith
+ end;
+ getxnext
+ end;
+ if curcmd >= 30 then
+ if curcmd < 42 then begin
+ p := stashcurexp;
+ scanprimary;
+ if (abs(num) >= abs(denom)) or (curtype < 14) then
+ dobinary(p, 71)
+ else begin
+ fracmult(num, denom);
+ freenode(p, 2)
+ end
+ end;
+ goto 30
+ end; {:837}
+ 33: {834:}
+ donullary(curmod) {:834};
+ 34, 30, 36, 43:
+ begin {835:}
+ c := curmod;
+ getxnext;
+ scanprimary;
+ dounary(c);
+ goto 30
+ end; {:835}
+ 37:
+ begin {839:}
+ c := curmod;
+ getxnext;
+ scanexpression;
+ if curcmd <> 69 then begin
+ missingerr(347);
+ print(581);
+ printcmdmod(37, c);
+ begin
+ helpptr := 1;
+ helpline[0] := 582
+ end;
+ backerror
+ end;
+ p := stashcurexp;
+ getxnext;
+ scanprimary;
+ dobinary(p, c);
+ goto 30
+ end; {:839}
+ 35:
+ begin {840:}
+ getxnext;
+ scansuffix;
+ oldsetting := selector;
+ selector := 5;
+ showtokenlist(curexp, -30000, 100000, 0);
+ flushtokenlist(curexp);
+ curexp := makestring;
+ selector := oldsetting;
+ curtype := 4;
+ goto 30
+ end; {:840}
+ 40:
+ begin {841:}
+ q := curmod;
+ if myvarflag = 77 then begin
+ getxnext;
+ if curcmd = 77 then begin
+ curexp := getavail;
+ mem[curexp].hh.lh := q + 2241;
+ curtype := 20;
+ goto 30
+ end;
+ backinput
+ end;
+ curtype := 16;
+ curexp := internal[q]
+ end; {:841}
+ 38:
+ makeexpcopy(curmod);
+ 41:
+ begin {844:}
+ begin
+ prehead := avail;
+ if prehead = (-30000) then
+ prehead := getavail
+ else begin
+ avail := mem[prehead].hh.rh;
+ mem[prehead].hh.rh := -30000
+ end {dynused:=dynused+1;}
+ end;
+ tail := prehead;
+ posthead := -30000;
+ tt := 1;
+ while true do begin
+ t := curtok;
+ mem[tail].hh.rh := t;
+ if tt <> 0 then begin {850:}
+ begin
+ p := mem[prehead].hh.rh;
+ q := mem[p].hh.lh;
+ tt := 0;
+ if (eqtb[q].lh mod 83) = 41 then begin
+ q := eqtb[q].rh;
+ if q = (-30000) then
+ goto 32;
+ while true do begin
+ p := mem[p].hh.rh;
+ if p = (-30000) then begin
+ tt := mem[q].hh.b0;
+ goto 32
+ end;
+ if mem[q].hh.b0 <> 21 then
+ goto 32;
+ q := mem[mem[q + 1].hh.lh].hh.rh;
+ if p >= himemmin then begin
+ repeat
+ q := mem[q].hh.rh
+ until mem[q + 2].hh.lh >= mem[p].hh.lh;
+ if mem[q + 2].hh.lh > mem[p].hh.lh then
+ goto 32
+ end
+ end
+ end;
+ 32: {:850}
+
+ end;
+ if tt >= 22 then begin {845:}
+ mem[tail].hh.rh := -30000;
+ if tt > 22 then begin
+ posthead := getavail;
+ tail := posthead;
+ mem[tail].hh.rh := t;
+ tt := 0;
+ macroref := mem[q + 1].int;
+ mem[macroref].hh.lh := mem[macroref].hh.lh + 1
+ end else begin {853:}
+ p := getavail;
+ mem[prehead].hh.lh := mem[prehead].hh.rh;
+ mem[prehead].hh.rh := p;
+ mem[p].hh.lh := t;
+ macrocall(mem[q + 1].int, prehead, -30000);
+ getxnext;
+ goto 20
+ end {:853}
+ end {:845}
+ end;
+ getxnext;
+ tail := t;
+ if curcmd = 63 then begin {846:}
+ getxnext;
+ scanexpression;
+ if curcmd <> 64 then begin {847:}
+ backinput;
+ backexpr;
+ curcmd := 63;
+ curmod := 0;
+ cursym := 2232
+ end else begin {:847}
+ if curtype <> 16 then
+ badsubscript;
+ curcmd := 42;
+ curmod := curexp;
+ cursym := 0
+ end
+ end {:846};
+ if curcmd > 42 then
+ goto 31;
+ if curcmd < 40 then
+ goto 31
+ end;
+ 31: {852:}
+ if posthead <> (-30000) then begin {854:}
+ backinput;
+ p := getavail;
+ q := mem[posthead].hh.rh;
+ mem[prehead].hh.lh := mem[prehead].hh.rh;
+ mem[prehead].hh.rh := posthead;
+ mem[posthead].hh.lh := q;
+ mem[posthead].hh.rh := p;
+ mem[p].hh.lh := mem[q].hh.rh;
+ mem[q].hh.rh := -30000;
+ macrocall(macroref, prehead, -30000);
+ mem[macroref].hh.lh := mem[macroref].hh.lh - 1;
+ getxnext;
+ goto 20
+ end {:854};
+ q := mem[prehead].hh.rh;
+ begin
+ mem[prehead].hh.rh := avail;
+ avail := prehead
+ end
+ {dynused:=dynused-1;};
+ if curcmd = myvarflag then begin
+ curtype := 20;
+ curexp := q;
+ goto 30
+ end;
+ p := findvariable(q);
+ if p <> (-30000) then
+ makeexpcopy(p)
+ else begin
+ obliterated(q);
+ helpline[2] := 661;
+ helpline[1] := 662;
+ helpline[0] := 663;
+ putgetflusherror(0)
+ end;
+ flushnodelist(q);
+ goto 30 {:852}
+ end
+ end
+ else
+ begin {:844}
+ badexp(633);
+ goto 20
+ end;
+ getxnext;
+ 30:
+ if curcmd = 63 then
+ if curtype >= 16 then begin {859:}
+ p := stashcurexp;
+ getxnext;
+ scanexpression;
+ if curcmd <> 79 then begin {847:}
+ begin
+ backinput;
+ backexpr;
+ curcmd := 63;
+ curmod := 0;
+ cursym := 2232
+ end {:847};
+ unstashcurexp(p)
+ end else begin
+ q := stashcurexp;
+ getxnext;
+ scanexpression;
+ if curcmd <> 64 then begin
+ missingerr(93);
+ begin
+ helpptr := 3;
+ helpline[2] := 665;
+ helpline[1] := 666;
+ helpline[0] := 563
+ end;
+ backerror
+ end;
+ r := stashcurexp;
+ makeexpcopy(q);
+ dobinary(r, 70);
+ dobinary(p, 71);
+ dobinary(q, 69);
+ getxnext
+ end
+ end {:859}
+ end; {:823} {860:}
+
+ procedure scansuffix;
+ label
+ 30;
+ var
+ h, t: halfword;
+ p: halfword;
+ begin
+ h := getavail;
+ t := h;
+ while true do begin
+ if curcmd = 63 then begin {861:}
+ getxnext;
+ scanexpression;
+ if curtype <> 16 then
+ badsubscript;
+ if curcmd <> 64 then begin
+ missingerr(93);
+ begin
+ helpptr := 3;
+ helpline[2] := 667;
+ helpline[1] := 666;
+ helpline[0] := 563
+ end;
+ backerror
+ end;
+ curcmd := 42;
+ curmod := curexp
+ end {:861};
+ if curcmd = 42 then
+ p := newnumtok(curmod)
+ else if (curcmd = 41) or (curcmd = 40) then begin
+ p := getavail;
+ mem[p].hh.lh := cursym
+ end else
+ goto 30;
+ mem[t].hh.rh := p;
+ t := p;
+ getxnext
+ end;
+ 30:
+ curexp := mem[h].hh.rh;
+ begin
+ mem[h].hh.rh := avail;
+ avail := h
+ end {dynused:=dynused-1;};
+ curtype := 20
+ end; {:860} {862:}
+
+ procedure scansecondary;
+ label
+ 20, 22;
+ var
+ p, q, r: halfword;
+ c, d: halfword;
+ macname: halfword;
+ begin
+ 20:
+ if (curcmd < 30) or (curcmd > 43) then
+ badexp(668);
+ scanprimary;
+ 22:
+ if curcmd <= 55 then
+ if curcmd >= 52 then begin
+ p := stashcurexp;
+ c := curmod;
+ d := curcmd;
+ if d = 53 then begin
+ macname := cursym;
+ mem[c].hh.lh := mem[c].hh.lh + 1
+ end;
+ getxnext;
+ scanprimary;
+ if d <> 53 then
+ dobinary(p, c)
+ else begin
+ backinput;
+ binarymac(p, c, macname);
+ mem[c].hh.lh := mem[c].hh.lh - 1;
+ getxnext;
+ goto 20
+ end;
+ goto 22
+ end
+ end; {:862}
+ {864:}
+
+ procedure scantertiary;
+ label
+ 20, 22;
+ var
+ p: halfword;
+ c, d: halfword;
+ macname: halfword;
+ begin
+ 20:
+ if (curcmd < 30) or (curcmd > 43) then
+ badexp(669);
+ scansecondary;
+ if curtype = 8 then
+ materializepen;
+ 22:
+ if curcmd <= 45 then
+ if curcmd >= 43 then begin
+ p := stashcurexp;
+ c := curmod;
+ d := curcmd;
+ if d = 44 then begin
+ macname := cursym;
+ mem[c].hh.lh := mem[c].hh.lh + 1
+ end;
+ getxnext;
+ scansecondary;
+ if d <> 44 then
+ dobinary(p, c)
+ else begin
+ backinput;
+ binarymac(p, c, macname);
+ mem[c].hh.lh := mem[c].hh.lh - 1;
+ getxnext;
+ goto 20
+ end;
+ goto 22
+ end
+ end; {:864}
+ {868:}
+
+ procedure scanexpression;
+ label
+ 20, 30, 22, 25, 26, 10;
+ var
+ p, q, r, pp, qq: halfword;
+ c, d: halfword;
+ myvarflag: 0..82;
+ macname: halfword;
+ cyclehit: boolean;
+ x, y: scaled;
+ t: 0..4;
+ begin
+ myvarflag := varflag;
+ 20:
+ if (curcmd < 30) or (curcmd > 43) then
+ badexp(672);
+ scantertiary;
+ 22:
+ if curcmd <= 51 then
+ if curcmd >= 46 then
+ if (curcmd <> 51) or (myvarflag <> 77) then begin
+ p := stashcurexp;
+ c := curmod;
+ d := curcmd;
+ if d = 49 then begin
+ macname := cursym;
+ mem[c].hh.lh := mem[c].hh.lh + 1
+ end;
+ if (d < 48) or ((d = 48) and ((mem[p].hh.b0 = 14) or (mem[p].hh.b0 = 9))) then begin {869:}
+ cyclehit := false; {870:}
+ begin
+ unstashcurexp(p);
+ if curtype = 14 then
+ p := newknot
+ else if curtype = 9 then
+ p := curexp
+ else
+ goto 10;
+ q := p;
+ while mem[q].hh.rh <> p do
+ q := mem[q].hh.rh;
+ if mem[p].hh.b0 <> 0 then begin
+ r := copyknot(p);
+ mem[q].hh.rh := r;
+ q := r
+ end;
+ mem[p].hh.b0 := 4;
+ mem[q].hh.b1 := 4
+ end {:870};
+ 25: {874:}
+ if curcmd = 46 then begin {879:}
+ t := scandirection;
+ if t <> 4 then begin
+ mem[q].hh.b1 := t;
+ mem[q + 5].int := curexp;
+ if mem[q].hh.b0 = 4 then begin
+ mem[q].hh.b0 := t;
+ mem[q + 3].int := curexp
+ end
+ end
+ end {:879};
+ d := curcmd;
+ if d = 47 then begin {881:}
+ getxnext;
+ if curcmd = 58 then begin {882:}
+ getxnext;
+ y := curcmd;
+ if curcmd = 59 then
+ getxnext;
+ scanprimary; {883:}
+ if (curtype <> 16) or (curexp < 49152) then begin
+ disperr(-30000, 690);
+ begin
+ helpptr := 1;
+ helpline[0] := 691
+ end;
+ putgetflusherror(65536)
+ end {:883};
+ if y = 59 then
+ curexp := -curexp;
+ mem[q + 6].int := curexp;
+ if curcmd = 52 then begin
+ getxnext;
+ y := curcmd;
+ if curcmd = 59 then
+ getxnext;
+ scanprimary; {883:}
+ if (curtype <> 16) or (curexp < 49152) then begin
+ disperr(-30000, 690);
+ begin
+ helpptr := 1;
+ helpline[0] := 691
+ end;
+ putgetflusherror(65536)
+ end {:883};
+ if y = 59 then
+ curexp := -curexp
+ end;
+ y := curexp
+ end else if curcmd = 57 then begin {:882} {884:}
+ mem[q].hh.b1 := 1;
+ t := 1;
+ getxnext;
+ scanprimary;
+ knownpair;
+ mem[q + 5].int := curx;
+ mem[q + 6].int := cury;
+ if curcmd <> 52 then begin
+ x := mem[q + 5].int;
+ y := mem[q + 6].int
+ end else begin
+ getxnext;
+ scanprimary;
+ knownpair;
+ x := curx;
+ y := cury
+ end
+ end else begin {:884}
+ mem[q + 6].int := 65536;
+ y := 65536;
+ backinput;
+ goto 30
+ end;
+ if curcmd <> 47 then begin
+ missingerr(279);
+ begin
+ helpptr := 1;
+ helpline[0] := 689
+ end;
+ backerror
+ end;
+ 30: {:881}
+
+ end else if d <> 48 then
+ goto 26;
+ getxnext;
+ if curcmd = 46 then begin {880:}
+ t := scandirection;
+ if mem[q].hh.b1 <> 1 then
+ x := curexp
+ else
+ t := 1
+ end else if mem[q].hh.b1 <> 1 then begin {:880}
+ t := 4;
+ x := 0
+ end {:874};
+ if curcmd = 36 then begin {886:}
+ cyclehit := true;
+ getxnext;
+ pp := p;
+ qq := p;
+ if d = 48 then
+ if p = q then begin
+ d := 47;
+ mem[q + 6].int := 65536;
+ y := 65536
+ end
+ end else begin {:886}
+ scantertiary; {885:}
+ begin
+ if curtype <> 9 then
+ pp := newknot
+ else
+ pp := curexp;
+ qq := pp;
+ while mem[qq].hh.rh <> pp do
+ qq := mem[qq].hh.rh;
+ if mem[pp].hh.b0 <> 0 then begin
+ r := copyknot(pp);
+ mem[qq].hh.rh := r;
+ qq := r
+ end;
+ mem[pp].hh.b0 := 4;
+ mem[qq].hh.b1 := 4
+ end {:885}
+ end; {887:}
+ begin
+ if d = 48 then
+ if (mem[q + 1].int <> mem[pp + 1].int) or (mem[q + 2].int <> mem[pp + 2].int) then begin
+ begin
+ if interaction = 3 then
+ ;
+ printnl(133);
+ print(692)
+ end;
+ begin
+ helpptr := 3;
+ helpline[2] := 693;
+ helpline[1] := 694;
+ helpline[0] := 695
+ end;
+ putgeterror;
+ d := 47;
+ mem[q + 6].int := 65536;
+ y := 65536
+ end;
+ {889:}
+ if mem[pp].hh.b1 = 4 then
+ if (t = 3) or (t = 2) then begin
+ mem[pp].hh.b1 := t;
+ mem[pp + 5].int := x
+ end {:889};
+ if d = 48 then begin {890:}
+ if mem[q].hh.b0 = 4 then
+ if mem[q].hh.b1 = 4 then begin
+ mem[q].hh.b0 := 3;
+ mem[q + 3].int := 65536
+ end;
+ if mem[pp].hh.b1 = 4 then
+ if t = 4 then begin
+ mem[pp].hh.b1 := 3;
+ mem[pp + 5].int := 65536
+ end;
+ mem[q].hh.b1 := mem[pp].hh.b1;
+ mem[q].hh.rh := mem[pp].hh.rh;
+ mem[q + 5].int := mem[pp + 5].int;
+ mem[q + 6].int := mem[pp + 6].int;
+ freenode(pp, 7);
+ if qq = pp then
+ qq := q
+ end else begin {:890} {888:}
+ if mem[q].hh.b1 = 4 then
+ if (mem[q].hh.b0 = 3) or (mem[q].hh.b0 = 2) then begin
+ mem[q].hh.b1 := mem[q].hh.b0;
+ mem[q + 5].int := mem[q + 3].int
+ end {:888};
+ mem[q].hh.rh := pp;
+ mem[pp + 4].int := y;
+ if t <> 4 then begin
+ mem[pp + 3].int := x;
+ mem[pp].hh.b0 := t
+ end
+ end;
+ q := qq
+ end {:887};
+ if curcmd >= 46 then
+ if curcmd <= 48 then
+ if not cyclehit then
+ goto 25;
+ 26: {891:}
+ if cyclehit then begin
+ if d = 48 then
+ p := q
+ end else begin
+ mem[p].hh.b0 := 0;
+ if mem[p].hh.b1 = 4 then begin
+ mem[p].hh.b1 := 3;
+ mem[p + 5].int := 65536
+ end;
+ mem[q].hh.b1 := 0;
+ if mem[q].hh.b0 = 4 then begin
+ mem[q].hh.b0 := 3;
+ mem[q + 3].int := 65536
+ end;
+ mem[q].hh.rh := p
+ end;
+ makechoices(p);
+ curtype := 9;
+ curexp := p {:891}
+ end else begin {:869}
+ getxnext;
+ scantertiary;
+ if d <> 49 then
+ dobinary(p, c)
+ else begin
+ backinput;
+ binarymac(p, c, macname);
+ mem[c].hh.lh := mem[c].hh.lh - 1;
+ getxnext;
+ goto 20
+ end
+ end;
+ goto 22
+ end;
+ 10:
+
+ end; {:868} {892:}
+
+ procedure getboolean;
+ begin
+ getxnext;
+ scanexpression;
+ if curtype <> 2 then begin
+ disperr(-30000, 696);
+ begin
+ helpptr := 2;
+ helpline[1] := 697;
+ helpline[0] := 698
+ end;
+ putgetflusherror(31);
+ curtype := 2
+ end
+ end; {:892} {224:}
+
+ procedure printcapsule;
+ begin
+ printchar(40);
+ printexp(gpointer, 0);
+ printchar(41)
+ end;
+
+ procedure tokenrecycle;
+ begin
+ recyclevalue(gpointer)
+ end; {:224} {1205:}
+
+ procedure closefilesandtermina;
+ var
+ k: integer;
+ lh: integer;
+ p: halfword;
+ x: scaled;
+ {if internal[12]>0 then[1208:]if jobname>0 then begin writeln(
+ logfile,' ');
+ writeln(logfile,'Here is how much of METAFONT''s memory',' you used:');
+ write(logfile,' ',maxstrptr-initstrptr:1,' string');
+ if maxstrptr<>initstrptr+1 then write(logfile,'s');
+ writeln(logfile,' out of ',maxstrings-initstrptr:1);
+ writeln(logfile,' ',maxpoolptr-initpoolptr:1,
+ ' string characters out of ',poolsize-initpoolptr:1);
+ writeln(logfile,' ',lomemmax+30000+memend-himemmin+2:1,
+ ' words of memory out of ',memend+30001:1);
+ writeln(logfile,' ',stcount:1,' symbolic tokens out of ',2100:1);
+ writeln(logfile,' ',maxinstack:1,'i,',intptr:1,'n,',maxroundingptr:1,
+ 'r,',maxparamstack:1,'p,',maxbufstack+1:1,'b stack positions out of ',
+ stacksize:1,'i,',maxinternal:1,'n,',maxwiggle:1,'r,',150:1,'p,',bufsize:
+ 1,'b');end[:1208];}
+ begin
+ {1206:}
+ if (gfprevptr > 0) or (internal[33] > 0) then begin {1207:}
+ rover := -29977;
+ mem[rover].hh.rh := 32767;
+ lomemmax := himemmin - 1;
+ if (lomemmax - rover) > 32767 then
+ lomemmax := 32767 + rover;
+ mem[rover].hh.lh := lomemmax - rover;
+ mem[rover + 1].hh.lh := rover;
+ mem[rover + 1].hh.rh := rover;
+ mem[lomemmax].hh.rh := -30000;
+ mem[lomemmax].hh.lh := -30000 {:1207}; {1124:}
+ mem[29999].hh.rh := -29981;
+ for k := bc to ec do
+ if charexists[k] then
+ tfmwidth[k] := sortin(tfmwidth[k]);
+ nw := skimp(255) + 1;
+ dimenhead[1] := mem[29999].hh.rh;
+ if perturbation >= 4096 then
+ tfmwarning(20) {:1124};
+ fixdesignsize;
+ fixchecksum;
+ if internal[33] > 0 then begin {1126:}
+ mem[29999].hh.rh := -29981;
+ for k := bc to ec do
+ if charexists[k] then
+ if tfmheight[k] = 0 then
+ tfmheight[k] := -29985
+ else
+ tfmheight[k] := sortin(tfmheight[k]);
+ nh := skimp(15) + 1;
+ dimenhead[2] := mem[29999].hh.rh;
+ if perturbation >= 4096 then
+ tfmwarning(21);
+ mem[29999].hh.rh := -29981;
+ for k := bc to ec do
+ if charexists[k] then
+ if tfmdepth[k] = 0 then
+ tfmdepth[k] := -29985
+ else
+ tfmdepth[k] := sortin(tfmdepth[k]);
+ nd := skimp(15) + 1;
+ dimenhead[3] := mem[29999].hh.rh;
+ if perturbation >= 4096 then
+ tfmwarning(22);
+ mem[29999].hh.rh := -29981;
+ for k := bc to ec do
+ if charexists[k] then
+ if tfmitalcorr[k] = 0 then
+ tfmitalcorr[k] := -29985
+ else
+ tfmitalcorr[k] := sortin(tfmitalcorr[k]);
+ ni := skimp(63) + 1;
+ dimenhead[4] := mem[29999].hh.rh;
+ if perturbation >= 4096 then
+ tfmwarning(23) {:1126}; {1134:}
+ if jobname = 0 then
+ openlogfile;
+ packjobname(901);
+ while not bopenout(tfmfile, nameoffile) do
+ promptfilename(902, 901);
+ metricfilename := bmakenamestring(tfmfile); {1135:}
+ k := headersize;
+ while headerbyte[k] < 0 do
+ k := k - 1;
+ lh := (k + 3) div 4;
+ if bc > ec then
+ bc := 1;
+ bwrite2bytes(tfmfile, (((((((((6 + lh) + ((ec - bc) + 1)) + nw) + nh) + nd) + ni) + nl) + nk) + ne) + np);
+ bwrite2bytes(tfmfile, lh);
+ bwrite2bytes(tfmfile, bc);
+ bwrite2bytes(tfmfile, ec);
+ bwrite2bytes(tfmfile, nw);
+ bwrite2bytes(tfmfile, nh);
+ bwrite2bytes(tfmfile, nd);
+ bwrite2bytes(tfmfile, ni);
+ bwrite2bytes(tfmfile, nl);
+ bwrite2bytes(tfmfile, nk);
+ bwrite2bytes(tfmfile, ne);
+ bwrite2bytes(tfmfile, np);
+ for k := 1 to 4 * lh do begin
+ if headerbyte[k] < 0 then
+ headerbyte[k] := 0;
+ bwritebyte(tfmfile, headerbyte[k])
+ end {:1135}; {1137:}
+ for k := bc to ec do
+ if not charexists[k] then
+ bwrite4bytes(tfmfile, 0)
+ else begin
+ bwritebyte(tfmfile, mem[tfmwidth[k]].hh.lh);
+ bwritebyte(tfmfile, (mem[tfmheight[k]].hh.lh * 16) + mem[tfmdepth[k]].hh.lh);
+ bwritebyte(tfmfile, (mem[tfmitalcorr[k]].hh.lh * 4) + chartag[k]);
+ bwritebyte(tfmfile, charremainder[k])
+ end {:1137}; {1138:}
+ tfmchanged := 0;
+ for k := 1 to 4 do begin
+ bwrite4bytes(tfmfile, 0);
+ p := dimenhead[k];
+ while p <> (-29981) do begin
+ bwrite4bytes(tfmfile, dimenout(mem[p + 1].int));
+ p := mem[p].hh.rh
+ end
+ end {:1138}; {1139:}
+ for k := 0 to nl - 1 do
+ tfmqqqq(ligkern[k]);
+ for k := 0 to nk - 1 do
+ bwrite4bytes(tfmfile, dimenout(kern[k])) {:1139};
+ {1140:}
+ for k := 0 to ne - 1 do
+ tfmqqqq(exten[k]) {:1140}; {1141:}
+ for k := 1 to np do
+ if k = 1 then
+ if abs(param[1]) < 134217728 then
+ bwrite4bytes(tfmfile, param[1] * 16)
+ else begin
+ tfmchanged := tfmchanged + 1;
+ if param[1] > 0 then
+ bwrite4bytes(tfmfile, 2147483647)
+ else
+ bwrite4bytes(tfmfile, -2147483647)
+ end
+ else
+ bwrite4bytes(tfmfile, dimenout(param[k]));
+ if tfmchanged > 0 then begin
+ if tfmchanged = 1 then
+ printnl(904)
+ else begin
+ printnl(40);
+ printint(tfmchanged);
+ print(905)
+ end;
+ print(906)
+ end {:1141};
+ {if internal[12]>0 then[1136:]begin writeln(logfile,' ');
+ writeln(logfile,'(You used ',nw:1,'w,',nh:1,'h,',nd:1,'d,',ni:1,'i,',nl:
+ 1,'l,',nk:1,'k,',ne:1,'e,',np:1,'p metric file positions');
+ writeln(logfile,' out of ','256w,16h,16d,64i,',ligtablesize:1,
+ 'l,256k,256e,',maxfontdimen:1,'p)');end[:1136];}
+ printnl(903);
+ print(metricfilename);
+ bclose(tfmfile) {:1134}
+ end;
+ if gfprevptr > 0 then begin {1182:}
+ begin
+ gfbuf[gfptr] := 248;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(gfprevptr);
+ gfprevptr := (gfoffset + gfptr) - 5;
+ gffour(internal[26] * 16);
+ for k := 1 to 4 do begin
+ gfbuf[gfptr] := headerbyte[k];
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(internal[27]);
+ gffour(internal[28]);
+ gffour(gfminm);
+ gffour(gfmaxm);
+ gffour(gfminn);
+ gffour(gfmaxn);
+ for k := 0 to 255 do
+ if charexists[k] then begin
+ x := gfdx[k] div 65536;
+ if (((gfdy[k] = 0) and (x >= 0)) and (x < 256)) and (gfdx[k] = (x * 65536)) then begin
+ begin
+ gfbuf[gfptr] := 246;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := k;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := x;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end
+ end else begin
+ begin
+ gfbuf[gfptr] := 245;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ begin
+ gfbuf[gfptr] := k;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(gfdx[k]);
+ gffour(gfdy[k])
+ end;
+ x := mem[tfmwidth[k] + 1].int;
+ if abs(x) > maxtfmdimen then
+ if x > 0 then
+ x := 16777215
+ else
+ x := -16777215
+ else
+ x := makescaled(x * 16, internal[26]);
+ gffour(x);
+ gffour(charptr[k])
+ end;
+ begin
+ gfbuf[gfptr] := 249;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ gffour(gfprevptr);
+ begin
+ gfbuf[gfptr] := 131;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ k := 4 + ((gfbufsize - gfptr) mod 4);
+ while k > 0 do begin
+ begin
+ gfbuf[gfptr] := 223;
+ gfptr := gfptr + 1;
+ if gfptr = gflimit then
+ gfswap
+ end;
+ k := k - 1
+ end; {1156:}
+ if gflimit = halfbuf then
+ bwritebuf(gffile, gfbuf, halfbuf, gfbufsize - 1);
+ if gfptr > 0 then
+ bwritebuf(gffile, gfbuf, 0, gfptr - 1) {:1156};
+ printnl(917);
+ print(outputfilename);
+ print(425);
+ printint(totalchars);
+ print(918);
+ if totalchars <> 1 then
+ printchar(115);
+ print(919);
+ printint(gfoffset + gfptr);
+ print(920);
+ bclose(gffile)
+ end {:1182}
+ end {:1206};
+ if jobname > 0 then begin
+ writeln(logfile);
+ aclose(logfile);
+ selector := selector - 2;
+ if selector = 1 then begin
+ printnl(929);
+ print(logname);
+ printchar(46)
+ end
+ end;
+ println;
+ if (editnamestart <> 0) and (interaction > 0) then
+ calledit(strpool[editnamestart], editnamelength, editline)
+ end; {:1205} {1209:}
+
+ procedure finalcleanup;
+ label
+ 10;
+ var
+ c: smallnumber;
+ begin
+ c := curmod;
+ if jobname = 0 then
+ openlogfile;
+ while condptr <> (-30000) do begin
+ printnl(930);
+ printcmdmod(2, curif);
+ if ifline <> 0 then begin
+ print(931);
+ printint(ifline)
+ end;
+ print(932);
+ ifline := mem[condptr + 1].int;
+ curif := mem[condptr].hh.b1;
+ condptr := mem[condptr].hh.rh
+ end;
+ if history <> 0 then
+ if (history = 1) or (interaction < 3) then
+ if selector = 3 then begin
+ selector := 1;
+ printnl(933);
+ selector := 3
+ end;
+ if c = 1 then begin {storebasefile;goto 10;}
+ printnl(934);
+ goto 10
+ end;
+ 10:
+
+ end; {:1209} {1210:}
+ {procedure initprim;begin[192:]primitive(280,40,1);
+ primitive(281,40,2);primitive(282,40,3);primitive(283,40,4);
+ primitive(284,40,5);primitive(285,40,6);primitive(286,40,7);
+ primitive(287,40,8);primitive(288,40,9);primitive(289,40,10);
+ primitive(290,40,11);primitive(291,40,12);primitive(292,40,13);
+ primitive(293,40,14);primitive(294,40,15);primitive(295,40,16);
+ primitive(296,40,17);primitive(297,40,18);primitive(298,40,19);
+ primitive(299,40,20);primitive(300,40,21);primitive(301,40,22);
+ primitive(302,40,23);primitive(303,40,24);primitive(304,40,25);
+ primitive(305,40,26);primitive(306,40,27);primitive(307,40,28);
+ primitive(308,40,29);primitive(309,40,30);primitive(310,40,31);
+ primitive(311,40,32);primitive(312,40,33);primitive(313,40,34);
+ primitive(314,40,35);primitive(315,40,36);primitive(316,40,37);
+ primitive(317,40,38);primitive(318,40,39);primitive(319,40,40);
+ [:192][211:]primitive(279,47,0);primitive(91,63,0);
+ eqtb[2232]:=eqtb[cursym];primitive(93,64,0);primitive(125,65,0);
+ primitive(123,46,0);primitive(58,78,0);eqtb[2234]:=eqtb[cursym];
+ primitive(329,77,0);primitive(44,79,0);primitive(59,80,0);
+ eqtb[2235]:=eqtb[cursym];primitive(92,7,0);primitive(330,18,0);
+ primitive(331,72,0);primitive(332,59,0);primitive(333,32,0);
+ bgloc:=cursym;primitive(334,57,0);primitive(335,19,0);
+ primitive(336,60,0);primitive(337,27,0);primitive(338,11,0);
+ primitive(323,81,0);eqtb[2239]:=eqtb[cursym];egloc:=cursym;
+ primitive(339,26,0);primitive(340,6,0);primitive(341,9,0);
+ primitive(342,70,0);primitive(343,73,0);primitive(344,13,0);
+ primitive(345,14,0);primitive(346,15,0);primitive(347,69,0);
+ primitive(348,28,0);primitive(349,24,0);primitive(350,12,0);
+ primitive(351,8,0);primitive(352,17,0);primitive(353,74,0);
+ primitive(354,35,0);primitive(355,58,0);primitive(356,71,0);
+ primitive(357,75,0);[:211][683:]primitive(520,16,1);primitive(521,16,2);
+ primitive(522,16,53);primitive(523,16,44);primitive(524,16,49);
+ primitive(324,16,0);eqtb[2237]:=eqtb[cursym];primitive(525,4,2242);
+ primitive(526,4,2392);primitive(527,4,1);primitive(325,4,0);
+ eqtb[2236]:=eqtb[cursym];[:683][688:]primitive(528,61,0);
+ primitive(529,61,1);primitive(64,61,2);primitive(530,61,3);
+ [:688][695:]primitive(541,56,2242);primitive(542,56,2392);
+ primitive(543,56,2542);primitive(544,56,1);primitive(545,56,2);
+ primitive(546,56,3);[:695][709:]primitive(556,3,0);primitive(482,3,1);
+ [:709][740:]primitive(583,1,1);primitive(322,2,2);
+ eqtb[2238]:=eqtb[cursym];primitive(584,2,3);primitive(585,2,4);
+ [:740][893:]primitive(218,33,30);primitive(219,33,31);
+ primitive(220,33,32);primitive(221,33,33);primitive(222,33,34);
+ primitive(223,33,35);primitive(224,33,36);primitive(225,33,37);
+ primitive(226,34,38);primitive(227,34,39);primitive(228,34,40);
+ primitive(229,34,41);primitive(230,34,42);primitive(231,34,43);
+ primitive(232,34,44);primitive(233,34,45);primitive(234,34,46);
+ primitive(235,34,47);primitive(236,34,48);primitive(237,34,49);
+ primitive(238,34,50);primitive(239,34,51);primitive(240,34,52);
+ primitive(241,34,53);primitive(242,34,54);primitive(243,34,55);
+ primitive(244,34,56);primitive(245,34,57);primitive(246,34,58);
+ primitive(247,34,59);primitive(248,34,60);primitive(249,34,61);
+ primitive(250,34,62);primitive(251,34,63);primitive(252,34,64);
+ primitive(253,34,65);primitive(254,34,66);primitive(255,34,67);
+ primitive(256,36,68);primitive(43,43,69);primitive(45,43,70);
+ primitive(42,55,71);primitive(47,54,72);eqtb[2233]:=eqtb[cursym];
+ primitive(257,45,73);primitive(181,45,74);primitive(259,52,76);
+ primitive(258,45,75);primitive(60,50,77);primitive(260,50,78);
+ primitive(62,50,79);primitive(261,50,80);primitive(61,51,81);
+ primitive(262,50,82);primitive(272,37,94);primitive(273,37,95);
+ primitive(274,37,96);primitive(275,37,97);primitive(276,37,98);
+ primitive(277,37,99);primitive(278,37,100);primitive(38,48,83);
+ primitive(263,55,84);primitive(264,55,85);primitive(265,55,86);
+ primitive(266,55,87);primitive(267,55,88);primitive(268,55,89);
+ primitive(269,55,90);primitive(270,55,91);primitive(271,45,92);
+ [:893][1013:]primitive(211,30,15);primitive(197,30,4);
+ primitive(195,30,2);primitive(202,30,9);primitive(199,30,6);
+ primitive(204,30,11);primitive(206,30,13);primitive(207,30,14);
+ [:1013][1018:]primitive(776,82,0);primitive(777,82,1);
+ [:1018][1024:]primitive(143,23,0);primitive(144,23,1);
+ primitive(145,23,2);primitive(783,23,3);
+ [:1024][1027:]primitive(784,21,0);primitive(785,21,1);
+ [:1027][1037:]primitive(799,22,0);primitive(800,22,1);
+ primitive(801,22,2);primitive(802,22,3);primitive(803,22,4);
+ [:1037][1052:]primitive(820,68,1);primitive(821,68,0);
+ primitive(822,68,2);primitive(823,66,6);primitive(824,66,16);
+ primitive(825,67,0);primitive(826,67,1);
+ [:1052][1079:]primitive(856,25,0);primitive(857,25,1);
+ primitive(858,25,2);[:1079][1101:]primitive(868,20,0);
+ primitive(869,20,1);primitive(870,20,2);primitive(871,20,3);
+ primitive(872,20,4);[:1101][1109:]primitive(889,76,0);
+ primitive(890,76,128);[:1109][1176:]primitive(912,29,4);
+ primitive(913,29,16);[:1176];end;procedure inittab;var k:integer;
+ begin[176:]rover:=-29977;mem[rover].hh.rh:=32767;mem[rover].hh.lh:=1000;
+ mem[rover+1].hh.lh:=rover;mem[rover+1].hh.rh:=rover;
+ lomemmax:=rover+1000;mem[lomemmax].hh.rh:=-30000;
+ mem[lomemmax].hh.lh:=-30000;
+ for k:=29998 to 30000 do mem[k]:=mem[lomemmax];avail:=-30000;
+ memend:=30000;himemmin:=29998;varused:=23;dynused:=-1;
+ [:176][193:]intname[1]:=280;intname[2]:=281;intname[3]:=282;
+ intname[4]:=283;intname[5]:=284;intname[6]:=285;intname[7]:=286;
+ intname[8]:=287;intname[9]:=288;intname[10]:=289;intname[11]:=290;
+ intname[12]:=291;intname[13]:=292;intname[14]:=293;intname[15]:=294;
+ intname[16]:=295;intname[17]:=296;intname[18]:=297;intname[19]:=298;
+ intname[20]:=299;intname[21]:=300;intname[22]:=301;intname[23]:=302;
+ intname[24]:=303;intname[25]:=304;intname[26]:=305;intname[27]:=306;
+ intname[28]:=307;intname[29]:=308;intname[30]:=309;intname[31]:=310;
+ intname[32]:=311;intname[33]:=312;intname[34]:=313;intname[35]:=314;
+ intname[36]:=315;intname[37]:=316;intname[38]:=317;intname[39]:=318;
+ intname[40]:=319;[:193][203:]hashused:=2229;stcount:=0;
+ hash[2240].rh:=321;hash[2238].rh:=322;hash[2239].rh:=323;
+ hash[2237].rh:=324;hash[2236].rh:=325;hash[2235].rh:=59;
+ hash[2234].rh:=58;hash[2233].rh:=47;hash[2232].rh:=91;hash[2231].rh:=41;
+ hash[2229].rh:=326;eqtb[2231].lh:=62;
+ [:203][229:]mem[-29981].hh.lh:=2242;mem[-29981].hh.rh:=-30000;
+ [:229][324:]mem[30000].hh.lh:=32767;
+ [:324][475:]mem[-29997].hh.lh:=-30000;mem[-29997].hh.rh:=-30000;
+ mem[-29996].hh.lh:=1;mem[-29996].hh.rh:=-30000;
+ for k:=-29995 to-29989 do mem[k]:=mem[-29996];mem[-29988].int:=0;
+ mem[-30000].hh.rh:=-30000;mem[-30000].hh.lh:=-30000;mem[-29999].int:=0;
+ mem[-29998].int:=0;[:475][587:]serialno:=0;mem[-29987].hh.rh:=-29987;
+ mem[-29986].hh.lh:=-29987;mem[-29987].hh.lh:=-30000;
+ mem[-29986].hh.rh:=-30000;[:587][702:]mem[-29979].hh.b1:=0;
+ mem[-29979].hh.rh:=2240;eqtb[2240].rh:=-29979;eqtb[2240].lh:=41;
+ [:702][759:]eqtb[2230].lh:=88;hash[2230].rh:=600;
+ [:759][911:]mem[-29983].hh.b1:=11;
+ [:911][1116:]mem[-29980].int:=1073741824;
+ [:1116][1127:]mem[-29984].int:=0;mem[-29985].hh.lh:=0;
+ [:1127][1185:]baseident:=921;[:1185]end;}
+ {:1210}
+ {1212:}
+ {procedure debughelp;label 888,10;var k,l,m,n:integer;
+ begin while true do begin;printnl(935);flush(output);read(input,m);
+ if m<0 then goto 10 else if m=0 then begin goto 888;
+ 888:m:=0;
+ ['BREAKPOINT']
+ end else begin read(input,n);case m of[1213:]1:printword(mem[n]);
+ 2:printint(mem[n].hh.lh);3:printint(mem[n].hh.rh);
+ 4:begin printint(eqtb[n].lh);printchar(58);printint(eqtb[n].rh);end;
+ 5:printvariablename(n);6:printint(internal[n]);7:doshowdependencies;
+ 9:showtokenlist(n,-30000,100000,0);10:print(n);11:checkmem(n>0);
+ 12:searchmem(n);13:begin read(input,l);printcmdmod(n,l);end;
+ 14:for k:=0 to n do print(buffer[k]);15:panicking:=not panicking;
+ [:1213]others:print(63)end;end;end;10:end;}
+ {:1212}
+ {:1202}
+ {1204:}
+
+ begin
+ {-----------------------------------}
+ init_ps(psfile);
+ {-----------------------------------}
+ history := 3;
+ setpaths;
+ if readyalready = 314159 then
+ goto 1; {14:}
+ bad := 0;
+ if (halferrorline < 30) or (halferrorline > (errorline - 15)) then
+ bad := 1;
+ if maxprintline < 60 then
+ bad := 2;
+ if (gfbufsize mod 8) <> 0 then
+ bad := 3;
+ if (-28900) > 30000 then
+ bad := 4;
+ if 1777 > 2100 then
+ bad := 5;
+ if (headersize mod 4) <> 0 then
+ bad := 6; {:14} {154:}
+ {if memmax<>30000 then bad:=10;}
+ if memmax < 30000 then
+ bad := 10;
+ if ((-128) > 0) or (127 < 127) then
+ bad := 11;
+ if ((-32768) > 0) or (32767 < 32767) then
+ bad := 12;
+ if ((-128) < (-32768)) or (127 > 32767) then
+ bad := 13;
+ if ((-30000) < (-32768)) or (memmax >= 32767) then
+ bad := 14;
+ if maxstrings > 32767 then
+ bad := 15;
+ if bufsize > 32767 then
+ bad := 16;
+ if (255 < 255) or (65535 < 65535) then
+ bad := 17; {:154} {204:}
+ if (2241 + maxinternal) > 32767 then
+ bad := 21; {:204} {214:}
+ if 2692 > 32767 then
+ bad := 22; {:214} {310:}
+ if (15 * 11) > bistacksize then
+ bad := 31; {:310} {553:}
+ if (20 + (17 * 45)) > bistacksize then
+ bad := 32; {:553} {777:}
+ if 10 > filenamesize then
+ bad := 41; {:777}
+ if bad > 0 then begin
+ writeln(output, 'Ouch---my internal constants have been clobbered!', '---case ', bad: 1);
+ {if not getstringsstarted then goto 9999;
+ inittab;initprim;}
+ goto 9999
+ end;
+ initialize;
+ readyalready := 314159;
+ 1: {55:}
+ selector := 1;
+ tally := 0;
+ termoffset := 0;
+ fileoffset := 0; {:55} {61:}
+ write(output, 'This is METAFONT, Version 1.0 for Berkeley UNIX');
+ {-----------------------------------------------------------------}
+ writeln(output);
+ writeln(output,'*** embedded METAFONT to PostScript Compiler ***');
+ {-----------------------------------------------------------------}
+ if baseident = 0 then
+ writeln(output, ' (no base preloaded)')
+ else begin
+ print(baseident);
+ println
+ end;
+ flush(output); {:61} {783:}
+ jobname := 0; {:783}
+ {792:}
+ outputfilename := 0; {:792} {1211:} {657:}
+ begin
+ begin
+ inputptr := 0;
+ maxinstack := 0;
+ inopen := 0;
+ maxbufstack := 0;
+ paramptr := 0;
+ maxparamstack := 0;
+ first := 1;
+ curinput.startfield := 1;
+ curinput.indexfield := 0;
+ line := 0;
+ curinput.namefield := 0;
+ forceeof := false;
+ if not initterminal then
+ goto 9999;
+ curinput.limitfield := last;
+ first := last + 1
+ end; {:657} {660:}
+ scannerstatus := 0; {:660}
+ if (baseident = 0) or (buffer[curinput.locfield] = 38) then begin
+ if baseident <> 0 then
+ initialize;
+ if not openbasefile then
+ goto 9999;
+ if not loadbasefile then begin
+ wclose(basefile);
+ goto 9999
+ end;
+ wclose(basefile);
+ while (curinput.locfield < curinput.limitfield) and (buffer[curinput.locfield] = 32) do
+ curinput.locfield := curinput.locfield + 1
+ end;
+ buffer[curinput.limitfield] := 37;
+ fixdateandtime;
+ initrandoms((internal[17] div 65536) + internal[16]); {70:}
+ if interaction = 0 then
+ selector := 0
+ else
+ selector := 1 {:70};
+ if curinput.locfield < curinput.limitfield then
+ if buffer[curinput.locfield] <> 92 then
+ startinput
+ end {:1211};
+ initstrptr := strptr;
+ initpoolptr := poolptr;
+ maxstrptr := strptr;
+ maxpoolptr := poolptr;
+ history := 0;
+ if startsym > 0 then begin
+ cursym := startsym;
+ backinput
+ end;
+ maincontrol;
+ finalcleanup;
+ 9998:
+ closefilesandtermina;
+ 9999:
+ readyalready := 0;
+ {---------------------------------}
+ tini_ps(g);
+ {---------------------------------}
+ if (history <> 0) and (history <> 1) then
+ exit(1)
+ else
+ exit(0);
+ end. {:1204}
+
Index: llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p
diff -c /dev/null llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p:1.1
*** /dev/null Mon Feb 16 17:43:43 2004
--- llvm/test/Programs/MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p Mon Feb 16 17:43:31 2004
***************
*** 0 ****
--- 1,9736 ----
+ (***************************************************************************)
+ (***************************************************************************)
+ (** **)
+ (** Copyright (C) 1987 by Per Bergsten, Gothenburg, Sweden **)
+ (** **)
+ (** No part of this program, or parts derived from this program, **)
+ (** may be sold, hired or otherwise exploited without the author's **)
+ (** written consent. **)
+ (** **)
+ (** The program may be freely redistributed provided that: **)
+ (** **)
+ (** 1) the original program text, including this notice, **)
+ (** is reproduced unaltered, **)
+ (** 2) no charge (other than a nominal media cost) is **)
+ (** demanded for the copy. **)
+ (** **)
+ (** The program may be included in a package only on the condition **)
+ (** that the package as a whole is distributed at media cost. **)
+ (** **)
+ (***************************************************************************)
+ (***************************************************************************)
+ (** **)
+ (** The program ptc is a Pascal-to-C translator. **)
+ (** It accepts a correct Pascal program and creates a C program **)
+ (** with the same behaviour. It is not a complete compiler in the **)
+ (** sense that it does NOT do complete typechecking or error- **)
+ (** reporting. Only a minimal typecheck is done so that the meaning **)
+ (** of each construct can be determined. Therefore, an incorrect **)
+ (** Pascal program can easily cause the translator to malfunction. **)
+ (** **)
+ (***************************************************************************)
+ (***************************************************************************)
+ (** **)
+ (** Things which are known to be dependent on the underlying cha- **)
+ (** racterset are marked with a comment containing the word CHAR. **)
+ (** Things that are known to be dependent on the host operating **)
+ (** system are marked with a comment containing the word OS. **)
+ (** Things known to be dependent on the cpu and/or the target C- **)
+ (** implementation are marked with the word CPU. **)
+ (** Things dependent on the target C-library are marked with LIB. **)
+ (** **)
+ (** The code generated by the translator assumes that there is a **)
+ (** C-implementation with at least a reasonable <stdio> library **)
+ (** since all input/output is implemented in terms of C functions **)
+ (** like fprintf(), getc(), fopen(), rewind() etc. **)
+ (** If the source-program uses Pascal functions like sin(), sqrt() **)
+ (** etc, there must also exist such functions in the C-library. **)
+ (** **)
+ (***************************************************************************)
+ (***************************************************************************)
+
+ program ptc(input, output);
+
+ label 9999; (* end of program *)
+
+ const version = '@(#)ptc.p 1.5 Date 87/05/01';
+
+ keytablen = 38; (* nr of keywords *)
+ keywordlen = 10; (* length of a keyword *)
+ othersym = 'otherwise '; (* keyword for others *)
+ externsym = 'external '; (* keyword for external *)
+ dummysym = ' '; (* dummy keyword *)
+
+ (* a Pascal set is implemented as an array of "wordtype" where *)
+ (* each element contains bits numbered from 0 to "setbits" *)
+ wordtype = 'unsigned short'; (* CPU *)
+ setbits = 15; (* CPU *)
+
+ (* a Pascal file is implemented as a struct which (among other *)
+ (* things) contain a flag-field, currently 3 bits are used *)
+ filebits = 'unsigned short'; (* flags for files *)
+ filefill = 12; (* 16 less used 3 bits *)
+
+ maxsetrange = 15; (* nr of words in a set *)
+ scalbase = 0; (* ordinal value of first scalar member *)
+
+ maxprio = 7;
+
+ maxmachdefs = 8; (* max nr of machine integer types *)
+ machdeflen = 16; (* max length of machine int type name *)
+
+ (* limit of identifier table, identifiers and strings are saved *)
+ (* in an array 0 .. maxblkcnt of ^ array 0 .. maxstrblk of char *)
+ maxstrblk = 1023;
+ maxblkcnt = 63;
+ maxstrstor = 65535; (* maxstrstor should be ==
+ (maxblkcnt+1) * (maxstrblk+1) - 1 *)
+
+ maxtoknlen = 127; (* max size of token (i.e. identifier,
+ string or number); must be > keywordlen
+ and should be <= 256, see hashtokn() *)
+
+ hashmax = 64; (* size of hashtable - 1 *)
+
+ null = 0; (* "impossible" character value, CHAR;
+ a char with this value is used as delimiter
+ of strings in "strstor" and in toknbuffers;
+ it is also used as end-of-input marker by
+ the input procedures in lexical analysis *)
+
+ minchar = null;
+ maxchar = 127; (* greatest possible character, CHAR; limits
+ the number of elements in type "char" *)
+
+ (* tmpfilename is used in the generated code to obtain names of
+ temporary files for reset/rewrite, the last character is supplied
+ by the reset/rewrite routine *)
+ tmpfilename = '"/tmp/ptc%d%c", getpid(), '; (* OS *)
+
+ (* some frequently used characters *)
+ space = ' ';
+ tab1 = ' ';
+ tab2 = ' ';
+ tab3 = ' ';
+ tab4 = ' ';
+ bslash = '\';
+ nlchr = '''\n''';
+ ffchr = '''\f''';
+ nulchr = '''\0''';
+ spchr = ''' ''';
+ quote = '''';
+ cite = '"';
+ xpnent = 'e'; (* exponent char in output. CPU *)
+ percent = '%';
+ uscore = '_';
+ badchr = '?'; (* CHAR *)
+ okchr = quote; (* CHAR *)
+
+ tabwidth = 8; (* width of a tab-stop. OS *)
+
+ echo = false; (* echo input as read *)
+ diffcomm = false; (* comment delimiters different *)
+ lazyfor = false; (* compile for-stmts a la C *)
+ unionnew = true; (* malloc unions for variants *)
+
+ inttyp = 'int'; (* for predefined functions *)
+ chartyp = 'char';
+ setwtyp = 'setword';
+ setptyp = 'setptr';
+ floattyp = 'float';
+ doubletyp = 'double';
+ dblcast = '(double)'; (* for predefined functions *)
+
+ realtyp = doubletyp; (* user real-vars and functions *)
+
+ voidtyp = 'void'; (* for procedures *)
+ voidcast = '(void)';
+
+ intlen = 10; (* length of written integer *)
+ fixlen = 20; (* length of written real *)
+
+ type
+ hashtyp = 0 .. hashmax; (* index to hash-tables *)
+
+ strindx = 0 .. maxstrstor; (* index to "strstor" *)
+
+ (* string-table "strstor" is implemented as an array that is grown
+ dynamically by adding blocks when needed *)
+ strbidx = 0 .. maxstrblk;
+ strblk = array [ strbidx ] of char;
+ strptr = ^ strblk;
+ strbcnt = 0 .. maxblkcnt;
+
+ (* table for stored identifiers *)
+ (* an identifier in any scope is represented by an idnode which is
+ hooked to a slot in "idtab" as determined by a hash-function.
+ whenever the input procedures find an identifier its idnode is
+ immediately located, or created, if none was found; the identifier
+ is then always handled though a pointer to the idnode. the actual
+ text of the identifier is stored in "strstor". *)
+ idptr = ^ idnode;
+ idnode = record
+ inext : idptr; (* chain of idnode's *)
+ inref : 0 .. 127; (* # of refs to this id *)
+ ihash : hashtyp; (* its hash value *)
+ istr : strindx; (* index to "strstor" *)
+ end;
+
+ (* toknbuf is used to handle identifiers and strings in those situations
+ where the actual text is of intrest *)
+ toknidx = 1 .. maxtoknlen;
+ toknbuf = array [ toknidx ] of char;
+
+ (* a type to hold Pascal keywords *)
+ keyword = packed array [ 1 .. keywordlen ] of char;
+
+ (* predefined identifier enumeration *)
+ predefs = (
+ dabs, darctan, dargc, dargv,
+ dboolean, dchar, dchr, dclose,
+ dcos, ddispose, deof, deoln,
+ dexit, dexp, dfalse, dflush,
+ dget, dhalt, dinput, dinteger,
+ dln, dmaxint, dmessage, dnew,
+ dodd, dord, doutput, dpage,
+ dpack, dpred, dput, dread,
+ dreadln, dreal, dreset, drewrite,
+ dround, dsin, dsqr, dsqrt,
+ dsucc, dtext, dtrue, dtrunc,
+ dtan, dwrite, dwriteln, dunpack,
+ dzinit, dztring
+ );
+
+ (* lexical symbol enumeration *)
+ symtyp = (
+ (* keywords and eof are sorted alphabetically ...... *)
+ sand, sarray, sbegin, scase,
+ sconst, sdiv, sdo, sdownto,
+ selse, send, sextern, sfile,
+ sfor, sforward, sfunc, sgoto,
+ sif, sinn, slabel, smod,
+ snil, snot, sof, sor,
+ sother, spacked, sproc, spgm,
+ srecord, srepeat, sset, sthen,
+ sto, stype, suntil, svar,
+ swhile, swith, seof,
+ (* ...... sorted *)
+ sinteger,
+ sreal, sstring, schar, sid,
+ splus, sminus, smul, squot,
+ sarrow, slpar, srpar, slbrack,
+ srbrack, seq, sne, slt,
+ sle, sgt, sge, scomma,
+ scolon, ssemic, sassign, sdotdot,
+ sdot
+ );
+ symset = set of symtyp;
+
+ (* lexical symbol definition *)
+ (* the lexical symbol holds a descriptor and the value of a symbol
+ read by the input procedures; note that real values are represented
+ as strings saved in "strstor" like ordinary strings to avoid using
+ float-variables and float-arithmetic in the translator *)
+ lexsym =
+ record
+ case st : symtyp of
+ sid: (vid : idptr);
+ schar: (vchr : char);
+ sinteger: (vint : integer);
+ sreal: (vflt : strindx);
+ sstring: (vstr : strindx);
+ end;
+
+ (* enumeration of symnode variants *)
+ ltypes = (
+ lpredef, lidentifier, lfield, lforward,
+ lpointer, lstring, llabel, lforwlab,
+ linteger, lreal, lcharacter
+ );
+
+ declptr = ^ declnode;
+ treeptr = ^ treenode;
+ symptr = ^ symnode;
+ (* identifier/literal symbol definition *)
+ (* in a given scope an identifier or a label is uniquely represented
+ by a "symnode"; in order to have a uniform treatment of all objects
+ occurring in the same syntactical positions (and hence in the parse-
+ tree) the literal constants are represented in a similar manner *)
+ symnode =
+ record
+ lsymdecl : treeptr; (* symbol decl. point *)
+ lnext : symptr; (* symtab chain pointer *)
+ ldecl : declptr; (* backptr to symtab *)
+ case lt : ltypes of
+ lpredef, (* a predefined id *)
+ lfield, (* a record field *)
+ lpointer, (* a pointer id *)
+ lidentifier, (* an identifier *)
+ lforward:
+ (
+ lid : idptr; (* ptr to its idnode *)
+ lused : boolean (* true if symbol used *)
+ );
+ lstring: (* a string literal *)
+ (
+ lstr : strindx (* index to "strstor" *)
+ );
+ lreal: (* a real literal *)
+ (
+ lfloat : strindx (* index to "strstor" *)
+ );
+ lforwlab, (* a declared label *)
+ llabel: (* label decl & defined *)
+ (
+ lno : integer; (* label number *)
+ lgo : boolean (* non-local usage *)
+ );
+ linteger: (* an integer literal *)
+ (
+ linum : integer (* its value *)
+ );
+ lcharacter: (* a character literal *)
+ (
+ lchar : char (* its value *)
+ )
+ end;
+
+ (* symbol table definition *)
+ (* the symbol table consists of symnodes chained along the lnext
+ field; the nodes are connected in reverse order of occurence (last
+ declared, first in chain) in the slot in the declnode determined
+ by the hashfunction; when a new scope is entered a new declnode is
+ manufactured and the previous one is hooked to the dprev field, thus
+ nested scopes are represented by a list of declnodes *)
+ declnode = record
+ dprev : declptr;
+ ddecl : array [ hashtyp ] of symptr
+ end;
+
+ (* enumeration of nodes in parse tree *)
+ (* NOTE: the subrange [ assignment .. nil ] have priorities *)
+ treetyp = (
+ npredef, npgm, nfunc, nproc,
+ nlabel, nconst, ntype, nvar,
+ nvalpar, nvarpar, nparproc, nparfunc,
+ nsubrange, nvariant, nfield, nrecord,
+ narray, nconfarr, nfileof, nsetof,
+ nbegin, nptr, nscalar, nif,
+ nwhile, nrepeat, nfor, ncase,
+ nchoise, ngoto, nwith, nwithvar,
+ nempty, nlabstmt, nassign, nformat,
+ nin, neq, nne, nlt,
+ nle, ngt, nge, nor,
+ nplus, nminus, nand, nmul,
+ ndiv, nmod, nquot, nnot,
+ numinus, nuplus, nset, nrange,
+ nindex, nselect, nderef, ncall,
+ nid, nchar, ninteger, nreal,
+ nstring, nnil, npush, npop,
+ nbreak
+ );
+
+ (* enumeration of predefined types *)
+ pretyps = (
+ tnone, tboolean, tchar, tinteger,
+ treal, tstring, tnil, tset,
+ ttext, tpoly, terror
+ );
+
+ (* enumeration of some special attributes *)
+ attributes = (
+ anone, aregister, aextern, areference
+ );
+
+ (* parse tree definition *)
+ (* the sourceprogram is represented by a treestructure built from
+ treenodes where each node corresponds to one syntactic form from
+ the pascal program *)
+ treenode =
+ record
+ tnext, (* ptr to next node in a list *)
+ ttype, (* pointer to nodes type *)
+ tup : treeptr; (* ptr to parent node *)
+ case tt : treetyp of
+ npredef: (* predefined object decl *)
+ (
+ tdef: (* predefined object descr. *)
+ predefs;
+ tobtyp: (* object type *)
+ pretyps
+ );
+ npgm, (* program declaration *)
+ nproc, (* procedure declaration *)
+ nfunc: (* function declaration *)
+ (
+ tsubid, (* subr. identifier (nid) *)
+ tsubpar, (* parameter list *)
+ tfuntyp, (* function type (nid) *)
+ tsublab, (* label decl list (nlabel) *)
+ tsubconst, (* const decl list (nconst) *)
+ tsubtype, (* type decl list (ntype) *)
+ tsubvar, (* var decl list (nvar) *)
+ tsubsub, (* subr. decl (nproc/nfunc) *)
+ tsubstmt: (* stmt. list (NOT nbegin) *)
+ treeptr;
+ tstat: (* static declaration level *)
+ integer;
+ tscope: (* symbol table for local id's *)
+ declptr
+ );
+ nvalpar, (* value parameter declaration *)
+ nvarpar, (* var parameter declaration *)
+ nconst, (* constant declaration *)
+ ntype, (* type declaration *)
+ nfield, (* record field declaration *)
+ nvar: (* var declaration declaration *)
+ (
+ tidl, (* list of declared id's (nid) *)
+ tbind: (* var/type-type, const-value *)
+ treeptr;
+ tattr: (* special attributes for vars *)
+ attributes
+ );
+ nparproc, (* parameter procedure *)
+ nparfunc: (* parameter function *)
+ (
+ tparid, (* parm proc/func id (nid) *)
+ tparparm, (* parm proc/func parm decl *)
+ tpartyp: (* parm func type (nid) *)
+ treeptr
+ );
+ nptr: (* pointer constructor *)
+ (
+ tptrid: (* referenced type (nid) *)
+ treeptr;
+ tptrflag: (* have seen node before *)
+ boolean
+ );
+ nscalar: (* scalar type constructor *)
+ (
+ tscalid: (* list of scalar ids (nid) *)
+ treeptr
+ );
+ nfileof, (* file type constructor *)
+ nsetof: (* set type constructor *)
+ (
+ tof: (* set/file component type *)
+ treeptr
+ );
+ nsubrange: (* subrange type constructor *)
+ (
+ tlo, thi: (* subrange limits *)
+ treeptr
+ );
+ nvariant: (* record variant constructor *)
+ (
+ tselct, (* selector list (constants) *)
+ tvrnt: (* variant field decl (nrecord) *)
+ treeptr
+ );
+
+ (* the tuid field is used to attach a name to variants since
+ C requires all union members to have names *)
+ nrecord: (* record/variant constructor *)
+ (
+ tflist, (* fixed field list (nfield) *)
+ tvlist: (* variant list (nvariant) *)
+ treeptr;
+ tuid: (* variant name *)
+ idptr;
+ trscope: (* symbol table for local id's *)
+ declptr
+ );
+ nconfarr: (* conformant array constructor *)
+ (
+ tcindx, (* index declaration *)
+ tindtyp, (* conf. arr. index type (nid) *)
+ tcelem: (* array element type decl *)
+ treeptr;
+ tcuid: (* variant name *)
+ idptr
+ );
+ narray: (* array type constructor *)
+ (
+ taindx, (* index declaration *)
+ taelem: (* array element type decl *)
+ treeptr
+ );
+ nbegin: (* begin statement *)
+ (
+ tbegin: (* statement list *)
+ treeptr
+ );
+ nlabstmt: (* labeled statement *)
+ (
+ tlabno, (* label number (nlabel) *)
+ tstmt: (* statement *)
+ treeptr
+ );
+ ngoto: (* goto statement *)
+ (
+ tlabel: (* label to go to (nlabel) *)
+ treeptr
+ );
+
+ nassign: (* assignment statement *)
+ (
+ tlhs, (* variable *)
+ trhs: (* value *)
+ treeptr
+ );
+
+ (* npush/npop is used in proc/func which have local variables
+ used in local proc/funcs; those variables are converted to
+ global ptrs initialized to reference the local variable *)
+ npush, (* init code for proc/func *)
+ npop: (* exit code for proc/func *)
+ (
+ tglob, (* global identifier (nid) *)
+ tloc, (* local identifier (nid) *)
+ ttmp: (* temp store for global (nid) *)
+ treeptr
+ );
+
+ nbreak:
+ (
+ tbrkid, (* for-variable *)
+ tbrkxp: (* value for break *)
+ treeptr
+ );
+
+ ncall: (* procedure/function call *)
+ (
+ tcall, (* called identifier *)
+ taparm: (* actual paramters *)
+ treeptr
+ );
+ nif: (* if statement *)
+ (
+ tifxp, (* conditional expression *)
+ tthen, (* stmt execd if true condition *)
+ telse: (* stmt execd if true condition *)
+ treeptr
+ );
+ nwhile: (* while statemnet *)
+ (
+ twhixp, (* conditional expression *)
+ twhistmt: (* stmt execd if true condition *)
+ treeptr
+ );
+ nrepeat: (* repeat statement *)
+ (
+ treptstmt, (* statement list *)
+ treptxp: (* conditional expression *)
+ treeptr
+ );
+ nfor: (* for statement *)
+ (
+ tforid, (* loop control variable (nid) *)
+ tfrom, (* initial value *)
+ tto, (* final value *)
+ tforstmt: (* stmt execd in loop *)
+ treeptr;
+ tincr: (* to/downto flag true <==> to *)
+ boolean
+ );
+ ncase: (* case statement *)
+ (
+ tcasxp, (* selecting expression *)
+ tcaslst, (* list of choises *)
+ tcasother: (* default action *)
+ treeptr
+ );
+ nchoise: (* a choise in a case-stmt *)
+ (
+ tchocon, (* list of constants *)
+ tchostmt: (* execd statement *)
+ treeptr
+ );
+ nwith: (* with statment *)
+ (
+ twithvar, (* list of variables (nwithvar) *)
+ twithstmt: (* statement execd in new scope *)
+ treeptr
+ );
+
+ (* the local symbol table holds identifiers, picked from
+ the record fields, temporarily declared during parsing
+ of remainder of with-statement; these identifiers are
+ later converted into fields referenced through a ptr *)
+ nwithvar: (* variable in with statement *)
+ (
+ texpw: (* record variable *)
+ treeptr;
+ tenv: (* symbol table for local scope *)
+ declptr
+ );
+
+ nindex: (* array indexing expression *)
+ (
+ tvariable, (* indexed variable *)
+ toffset: (* index expression *)
+ treeptr
+ );
+ nselect: (* record field selection expr *)
+ (
+ trecord, (* record variable *)
+ tfield: (* selected field (nid) *)
+ treeptr
+ );
+
+ (* binary operators or constructors *)
+ nrange, (* .. (set range) *)
+ nformat, (* : (write format) *)
+ nin, (* in *)
+ neq, (* = *)
+ nne, (* <> *)
+ nlt, (* < *)
+ nle, (* <= *)
+ ngt, (* > *)
+ nge, (* >= *)
+ nor, (* or *)
+ nplus, (* + *)
+ nminus, (* - *)
+ nand, (* and *)
+ nmul, (* * *)
+ ndiv, (* div *)
+ nmod, (* mod *)
+ nquot: (* / *)
+ (
+ texpl, (* left operand expr *)
+ texpr: (* right operand expr *)
+ treeptr
+ );
+
+ (* unary operators or constructors; note that uplus is
+ used to represent any parenthesized expression *)
+ nderef, (* ^ (ptr dereference) *)
+ nnot, (* not *)
+ nset, (* [ ] (set constr) *)
+ nuplus, (* + *)
+ numinus: (* - *)
+ (
+ texps: (* operand expression *)
+ treeptr
+ );
+
+ nid, (* identifier in decl or stmt *)
+ nreal, (* literal real (decl or stmt) *)
+ ninteger, (* literal int ( - " - ) *)
+ nchar, (* literal char ( - " - ) *)
+ nstring, (* literal string ( - " - ) *)
+ nlabel: (* label (decl, defpt or use) *)
+ (
+ tsym:
+ symptr
+ );
+
+ nnil, (* nil (pointer constant) *)
+ nempty: (* empty statement *)
+ ( );
+ end;
+
+ (* "reserved" words and standard identifiers from C, C LIB and
+ OS environment excluding those reserved in Pascal *)
+ cnames = (
+ cabort, cbreak, ccontinue, cdefine,
+ cdefault, cdouble, cedata, cenum,
+ cetext, cextern, cfgetc, cfclose,
+ cfflush, cfloat, cfloor, cfprintf,
+ cfputc, cfread, cfscanf, cfwrite,
+ cgetc, cgetpid, cint, cinclude,
+ clong, clog, cmain, cmalloc,
+ cprintf, cpower, cputc, cread,
+ creturn, cregister, crewind, cscanf,
+ csetbits, csetword, csetptr, cshort,
+ csigned, csizeof, csprintf, cstdin,
+ cstdout, cstderr, cstrncmp, cstrncpy,
+ cstruct, cstatic, cswitch, ctypedef,
+ cundef, cungetc, cunion, cunlink,
+ cunsigned, cwrite
+ );
+
+ (* these are the detected errors. some are user-errors,
+ some are internal problems and some are host system errors *)
+ errors = (
+ ebadsymbol, elongstring, elongtokn, erange,
+ emanytokn, enotdeclid, emultdeclid, enotdecllab,
+ emultdecllab, emuldeflab, ebadstring, enulchr,
+ ebadchar, eeofcmnt, eeofstr, evarpar,
+ enew, esetbase, esetsize, eoverflow,
+ etree, etag, euprconf, easgnconf,
+ ecmpconf, econfconf, evrntfile, evarfile,
+ emanymachs, ebadmach
+ );
+
+ machdefstr = packed array [ 1 .. machdeflen ] of char;
+
+ var
+ usemax, (* program needs max-function *)
+ usejmps, (* source program uses non-local gotos *)
+ usecase, (* source program has case-statement *)
+ usesets, (* source program uses set-operations *)
+ useunion,
+ usediff,
+ usemksub,
+ useintr,
+ usesge,
+ usesle,
+ useseq,
+ usesne,
+ usememb,
+ useins,
+ usescpy,
+ usecomp, (* source program uses string-compare *)
+ usefopn, (* source program uses reset/rewrite *)
+ usescan,
+ usegetl,
+ usenilp, (* source program uses nil-pointer *)
+ usebool : boolean; (* source program writes boolean-values *)
+
+ top : treeptr; (* top of parsetree, result from parse *)
+
+ setlst : treeptr; (* list of set-initializations *)
+ setcnt : integer; (* counter for setlst length *)
+
+ currsym : lexsym; (* current lexical symbol *)
+
+ keytab : array [ 0 .. keytablen ] of (* table of keywords *)
+ record
+ wrd : keyword; (* keyword text *)
+ sym : symtyp (* corresponding symbol *)
+ end;
+
+ strstor : array [ strbcnt ] of strptr; (* store for strings *)
+ strfree : strindx; (* first free position *)
+ strleft : strbidx; (* room in last blk *)
+
+ idtab : array [ hashtyp ] of idptr; (* hashed table of id's *)
+
+ symtab : declptr; (* table of symbols *)
+
+ statlvl, (* static decl. level *)
+ maxlevel : integer; (* - " - maximum value *)
+
+ deftab : array [ predefs ] of treeptr; (* predefined idents. *)
+ defnams : array [ predefs ] of symptr; (* - " - *)
+ typnods : array [ pretyps ] of treeptr; (* predef. types. *)
+
+ pprio,
+ cprio : array [ nassign .. nnil ] of 0 .. maxprio;
+
+ ctable : array [ cnames ] of idptr; (* table of C-keywords *)
+
+ nmachdefs : 0 .. maxmachdefs;
+ machdefs : array [ 1 .. maxmachdefs ] of (* table of C-types *)
+ record
+ lolim, hilim : integer;
+ typstr : strindx
+ end;
+
+ lineno, (* input line number *)
+ colno, (* input column number *)
+ lastcol, (* last OK input column *)
+ lastline : integer; (* last OK input line *)
+
+ lasttok : toknbuf; (* last input token *)
+
+ varno : integer; (* counter for unique id's *)
+
+ hexdig : packed array [ 0 .. 15 ] of char;
+
+ (* Prtmsg produces an error message. It asssumes that procedure *)
+ (* "message" (predefined) will "writeln" to user tty. OS *)
+ procedure prtmsg(m : errors);
+
+ const user = 'Error: ';
+ restr = 'Implementation restriction: ';
+ inter = '* Internal error * ';
+ xtoklen = 64; (* should be <= maxtoklen *)
+
+ var i : toknidx;
+ xtok : packed array [ 1 .. xtoklen ] of char;
+
+ begin
+ case m of
+ ebadsymbol:
+ message(user, 'Unexpected symbol');
+ ebadchar:
+ message(user, 'Bad character');
+ elongstring:
+ message(restr, 'Too long string');
+ ebadstring:
+ message(user, 'Newline in string or character');
+ eeofstr:
+ message(user, 'End of file in string or character');
+ eeofcmnt:
+ message(user, 'End of file in comment');
+ elongtokn:
+ message(restr, 'Too long identfier');
+ emanytokn:
+ message(restr, 'Too many strings, identifiers or real numbers');
+ enotdeclid:
+ message(user, 'Identifier not declared');
+ emultdeclid:
+ message(user, 'Identifier declared twice');
+ enotdecllab:
+ message(user, 'Label not declared');
+ emultdecllab:
+ message(user, 'Label declared twice');
+ emuldeflab:
+ message(user, 'Label defined twice');
+ evarpar:
+ message(user, 'Actual parameter not a variable');
+ enulchr:
+ message(restr, 'Cannot handle nul-character in strings');
+ enew:
+ message(restr, 'New returned a nil-pointer');
+ eoverflow:
+ message(restr, 'Token buffer overflowed');
+ esetbase:
+ message(restr, 'Cannot handle sets with base >> 0');
+ esetsize:
+ message(restr, 'Cannot handle sets with very large range');
+ etree:
+ message(inter, 'Bad tree structure');
+ etag:
+ message(inter, 'Cannot find tag');
+ evrntfile:
+ message(restr, 'Cannot initialize files in record variants');
+ evarfile:
+ message(restr, 'Cannot handle files in structured variables');
+ euprconf:
+ message(inter, 'No upper bound on conformant arrays');
+ easgnconf:
+ message(inter, 'Cannot assign conformant arrays');
+ ecmpconf:
+ message(inter, 'Cannot compare conformant arrays');
+ econfconf:
+ message(restr, 'Cannot handle nested conformat arrays');
+ erange:
+ message(inter, 'Cannot find C-type for integer-subrange');
+ emanymachs:
+ message(restr, 'Too many machine integer types');
+ ebadmach:
+ message(inter, 'Bad name for machine integer type');
+ end;(* case *)
+ if lastline <> 0 then
+ begin
+ (* error detected during parsing,
+ report line/column and print the offending symbol *)
+ message('Line ', lastline:1, ', col ', lastcol:1, ':');
+ if m in [enulchr, ebadchar, ebadstring, ebadsymbol,
+ emuldeflab, emultdecllab, enotdecllab, emultdeclid,
+ enotdeclid, elongtokn, elongstring] then
+ begin
+ i := 1;
+ while (i < xtoklen) and (lasttok[i] <> chr(null)) do
+ begin
+ xtok[i] := lasttok[i];
+ i := i + 1
+ end;
+ while i < xtoklen do
+ begin
+ xtok[i] := ' ';
+ i := i + 1
+ end;
+ xtok[xtoklen] := ' ';
+ message('Current symbol: ', xtok)
+ end
+ end
+ end;
+
+ procedure fatal(m : errors); forward;
+ procedure error(m : errors); forward;
+
+ (* Map letters to upper-case. *)
+ (* This function assumes a machine collating sequence where the *)
+ (* letters of either case form a contigous sequence, CHAR. *)
+ function uppercase(c : char) : char;
+
+ begin
+ if (c >= 'a') and (c <= 'z') then
+ uppercase := chr(ord(c) + ord('A') - ord('a'))
+ else
+ uppercase := c
+ end;
+
+
+ (* Map letters to lower-case. *)
+ (* This function assumes a machine collating sequence where the *)
+ (* letters of either case form a contigous sequence, CHAR. *)
+ function lowercase(c : char) : char;
+
+ begin
+ if (c >= 'A') and (c <= 'Z') then
+ lowercase := chr(ord(c) - ord('A') + ord('a'))
+ else
+ lowercase := c
+ end;
+
+ (* Retrieve a string from strstor. *)
+ procedure gettokn(i : strindx; var t : toknbuf);
+
+ var c : char;
+ k : toknidx;
+ j : strbidx;
+ p : strptr;
+
+ begin
+ k := 1;
+ (* compute block and offset in block *)
+ p := strstor[i div (maxstrblk + 1)];
+ j := i mod (maxstrblk + 1);
+ (* retrieve text up to null *)
+ repeat
+ c := p^[j];
+ t[k] := c;
+ j := j + 1;
+ k := k + 1;
+ if k = maxtoknlen then
+ begin
+ c := chr(null);
+ t[maxtoknlen] := chr(null);
+ prtmsg(eoverflow)
+ end
+ until c = chr(null)
+ end;
+
+ (* Deposit a string into strstor at a given start-position. *)
+ procedure puttokn(i : strindx; var t : toknbuf);
+
+ var c : char;
+ k : toknidx;
+ j : strbidx;
+ p : strptr;
+
+ begin
+ k := 1;
+ p := strstor[i div (maxstrblk + 1)];
+ j := i mod (maxstrblk + 1);
+ repeat
+ c := t[k];
+ p^[j] := c;
+ k := k + 1;
+ j := j + 1
+ until c = chr(null)
+ end;
+
+ (* Write a token on standard output. *)
+ procedure writetok(var w : toknbuf);
+
+ var j : toknidx;
+
+ begin
+ j := 1;
+ while w[j] <> chr(null) do
+ begin
+ write(w[j]);
+ j := j + 1
+ end
+ end;
+
+ (* Print a float number on standard output. *)
+ procedure printtok(i : strindx);
+
+ var w : toknbuf;
+
+ begin
+ gettokn(i, w);
+ writetok(w)
+ end;
+
+ (* Print an identifier on standard output. *)
+ procedure printid(ip : idptr);
+
+ begin
+ printtok(ip^.istr)
+ end;
+
+ (* Print a character on standard output with proper C-quoting. *)
+ procedure printchr(c : char);
+
+ begin
+ if (c = quote) or (c = bslash) then
+ write(quote, bslash, c, quote)
+ else
+ write(quote, c, quote)
+ end;
+
+ (* Print a string on standard output with proper C-quoting. *)
+ procedure printstr(i : strindx);
+
+ var k : toknidx;
+ c : char;
+ w : toknbuf;
+
+ begin
+ gettokn(i, w);
+ write(cite);
+ k := 1;
+ while w[k] <> chr(null) do
+ begin
+ c := w[k];
+ k := k + 1;
+ if (c = cite) or (c = bslash) then
+ write(bslash);
+ write(c)
+ end;
+ write(cite)
+ end;
+
+ (* Return a pointer to the declarationpoint of an identifier. *)
+ function idup(ip : treeptr) : treeptr;
+
+ begin
+ idup := ip^.tsym^.lsymdecl^.tup
+ end;
+
+ (* Compute a hashvalue for an identifier or a string. *)
+ function hashtokn(var id : toknbuf) : hashtyp;
+
+ var h : integer;
+ i : toknidx;
+
+ begin
+ i := 1;
+ h := 0;
+ while id[i] <> chr(null) do
+ begin
+ (* if ord() of a character ranges from 0 to 127 then we can loop
+ 256 times without causing h to exceed 32767, this is safe as
+ both strings and identifiers are limited in length *)
+ h := h + ord(id[i]); (* CHAR, CPU *)
+ i := i + 1
+ end;
+ hashtokn := h mod hashmax
+ end;
+
+ (* Global string table update. *)
+ (* This function accepts a string and stores it in strstor. *)
+ (* It returns the id-number for the new string. *)
+ function savestr(var t : toknbuf) : strindx;
+
+ var k : toknidx;
+ i : strindx;
+ j : strbcnt;
+
+ begin
+ (* find length of new string including null-char *)
+ k := 1;
+ while t[k] <> chr(null) do
+ k := k + 1;
+ if k > strleft then
+ begin
+ (* out of space in strstore *)
+ if strstor[maxblkcnt] <> nil then (* last slot used *)
+ error(emanytokn);
+ (* allocate a new block *)
+ j := (strfree + maxstrblk) div (maxstrblk + 1);
+ new(strstor[j]);
+ if strstor[j] = nil then
+ error(enew);
+ strfree := j * (maxstrblk + 1);
+ strleft := maxstrblk
+ end;
+ (* copy new str, update location of last used cell,
+ return starting location for new str *)
+ i := strfree;
+ strfree := strfree + k;
+ strleft := strleft - k;
+ puttokn(i, t);
+ savestr := i
+ end;
+
+ (* Global id table lookup. *)
+ (* This procedure accepts an identifier and determines if it has *)
+ (* been seen before. If that is the case a pointer to its idnode *)
+ (* is returned, otherwise the identifier is saved and a pointer to *)
+ (* a new node is returned. *)
+ function saveid(var id : toknbuf) : idptr;
+
+ label 999;
+
+ var k : toknidx;
+ ip : idptr;
+ h : hashtyp;
+ t : toknbuf;
+
+ begin
+ h := hashtokn(id);
+ ip := idtab[h]; (* scan hashlist for id *)
+ while ip <> nil do
+ begin
+ gettokn(ip^.istr, t); (* look at saved token *)
+ k := 1;
+ while id[k] = t[k] do
+ if id[k] = chr(null) then
+ goto 999 (* found it! *)
+ else
+ k := k + 1; (* look at next char *)
+ ip := ip^.inext
+ end;
+
+ (* identifier wasn't previously seen, manufacture a new idnode,
+ save index to strstor and hashvalue, insert idnode in idtab *)
+ new(ip);
+ if ip = nil then
+ error(enew);
+ ip^.inref := 0;
+ ip^.istr := savestr(id);
+ ip^.ihash := h;
+ ip^.inext := idtab[h];
+ idtab[h] := ip;
+
+ 999:
+ (* return the idnode *)
+ saveid := ip
+ end;
+
+ (* This function creates a new variable by concatenating one name *)
+ (* with another injecting a given separator. *)
+ function mkconc(sep : char; p, q : idptr) : idptr;
+
+ var w, x : toknbuf;
+ i, j : toknidx;
+
+ begin
+ (* fetch second part and determine its length *)
+ gettokn(q^.istr, x);
+ j := 1;
+ while x[j] <> chr(null) do
+ j := j + 1;
+ (* fetch first part and locate its end *)
+ w[1] := chr(null);
+ if p <> nil then
+ gettokn(p^.istr, w);
+ i := 1;
+ while w[i] <> chr(null) do
+ i := i + 1;
+ (* check total length *)
+ if i + j + 2 >= maxtoknlen then
+ error(eoverflow);
+
+ (* add separators *)
+ if sep = '>' then
+ begin
+ (* special case 1: > gives arrow: a->b *)
+ w[i] := '-';
+ i := i + 1
+ end;
+ if sep <> space then
+ begin
+ (* special case 2: space gives nothing: ab *)
+ w[i] := sep;
+ i := i + 1
+ end;
+ (* add second part *)
+ j := 1;
+ repeat
+ w[i] := x[j];
+ i := i + 1;
+ j := j + 1
+ until w[i-1] = chr(null);
+ (* save new identifier *)
+ mkconc := saveid(w)
+ end;
+
+ (* Create a new id with name-prefix from w. *)
+ function mkuniqname(var t : toknbuf) : idptr;
+
+ var i : toknidx;
+
+ procedure dig(n : integer);
+ begin
+ if n > 0 then
+ begin
+ dig(n div 10);
+ if i = maxtoknlen then
+ error(eoverflow);
+ t[i] := chr(n mod 10 + ord('0')); (* CHAR *)
+ i := i + 1
+ end
+ end;
+
+ begin
+ i := 1;
+ while t[i] <> chr(null) do
+ i := i + 1;
+ varno := varno + 1;
+ dig(varno);
+ t[i] := chr(null);
+ mkuniqname := saveid(t)
+ end;
+
+ (* Make a new unique variable with given char as prefix. *)
+ function mkvariable(c : char) : idptr;
+
+ var t : toknbuf;
+
+ begin
+ t[1] := c;
+ t[2] := chr(null);
+ mkvariable := mkuniqname(t)
+ end;
+
+ (* Make a new unique variable with given char as prefix and *)
+ (* with a given id as tail. Commonly used for renaming id's. *)
+ function mkrename(c : char; ip : idptr) : idptr;
+
+ begin
+ mkrename := mkconc(uscore, mkvariable(c), ip)
+ end;
+
+ (* Make a name for a variant. Variants are mapped onto C unions, *)
+ (* which we always give the name "U", thus the name of the variant *)
+ (* becomes "U.Vnnn" where "nnn" is a unique number. *)
+ function mkvrnt : idptr;
+
+ var t : toknbuf;
+
+ begin
+ t[1] := 'U';
+ t[2] := '.';
+ t[3] := 'V';
+ t[4] := chr(null);
+ mkvrnt := mkuniqname(t)
+ end;
+
+ procedure checksymbol(ss : symset);
+ begin
+ if not (currsym.st in ss) then
+ error(ebadsymbol);
+ end;
+
+ (* Lexical analysis routine. *)
+ (* This procedure reads and classifies the next lexical token in *)
+ (* the input stream. The token is saved in the global variable *)
+ (* "currsym". The found symbol should be one of the symbols given *)
+ (* in the parameter "ss" otherwise the error routine is called. *)
+ procedure nextsymbol(ss : symset);
+
+ var lastchr : 0 .. maxtoknlen;
+
+ (* This function reads the next character from the input *)
+ (* and updates "lineno" and "colno" accordingly. *)
+ function nextchar : char;
+
+ var c : char;
+
+ begin
+ if eof then
+ c := chr(null)
+ else begin
+ colno := colno + 1;
+ if eoln then
+ begin
+ lineno := lineno + 1;
+ colno := 0
+ end;
+ read(c);
+ if echo then
+ if colno = 0 then
+ writeln
+ else
+ write(c);
+ if c = tab1 then
+ colno := ((colno div tabwidth) + 1) * tabwidth
+ end;
+ if lastchr > 0 then
+ begin
+ lasttok[lastchr] := c;
+ lastchr := lastchr + 1
+ end;
+ nextchar := c
+ end;
+
+ (* This function looks at the next input character. *)
+ function peekchar : char;
+
+ begin
+ if eof then
+ peekchar := chr(null)
+ else
+ peekchar := input^
+ end;
+
+ (* Read and classify the next token. *)
+ procedure nexttoken(realok : boolean);
+
+ var c : char;
+ n : integer;
+
+ ready : boolean;
+
+ wl : toknidx;
+ wb : toknbuf;
+
+ (* Determine if c is valid in an identifier. *)
+ (* This function assumes a machine collating *)
+ (* sequence where letters and digits form conti- *)
+ (* gous sequences, CHAR. *)
+ function idchar(c : char) : boolean;
+
+ begin
+ idchar :=
+ (c >= 'a') and (c <= 'z') or
+ (c >= '0') and (c <= '9') or
+ (c >= 'A') and (c <= 'Z') or
+ (c = uscore)
+ end;
+
+ (* Determine if c is valid in a number. CHAR. *)
+ function numchar(c : char) : boolean;
+
+ begin
+ numchar := (c >= '0') and (c <= '9')
+ end;
+
+ (* Convert a digit to its numeric value. CHAR *)
+ function numval(c : char) : integer;
+
+ begin
+ numval := ord(c) - ord('0')
+ end;
+
+ (* Determine if the current token is a keyword. *)
+ function keywordcheck(var w : toknbuf; l : toknidx) : symtyp;
+
+ var n : 1 .. keywordlen;
+ i, j, k : 0 .. keytablen;
+ wrd : keyword;
+ kwc : symtyp;
+
+ begin
+ (* quick check on token length,
+ pascal keywords range from 2 to 9 chars in length *)
+ if (l > 1) and (l < keywordlen) then
+ begin
+ (* could be a keyword, initialize wrd *)
+ wrd := keytab[keytablen].wrd;
+ (* copy w to wrd *)
+ for n := 1 to l do
+ wrd[n] := w[n];
+
+ (* binary search for tokn,
+ relies on symtyp being sorted *)
+ i := 0;
+ j := keytablen;
+ while j > i do
+ begin
+ k := (i + j) div 2;
+ if keytab[k].wrd >= wrd then
+ j := k
+ else
+ i := k + 1
+ end;
+ if keytab[j].wrd = wrd then
+ kwc := keytab[j].sym
+ else
+ kwc := sid
+ end
+ else
+ kwc := sid;
+ keywordcheck := kwc
+ end;
+
+ begin (* nexttoken *)
+ (* don't save blanks/comments *)
+ lastchr := 0;
+ (* read non-blank character *)
+ repeat
+ c := nextchar;
+ (* skip comments, the two comment delimiters of pascal
+ are treated as different if "diffcomm" is true *)
+ if c = '{' then
+ begin
+ repeat
+ c := nextchar;
+ if diffcomm then
+ ready := c = '}'
+ else
+ ready := ((c = '*') and
+ (peekchar = ')'))
+ or (c = '}')
+ until ready or eof;
+ if eof and not ready then
+ error(eeofcmnt);
+ if (c = '*') and not eof then
+ c := nextchar;
+ c := space
+ end
+ else if (c = '(') and (peekchar = '*') then
+ begin
+ c := nextchar;
+ repeat
+ c := nextchar;
+ if diffcomm then
+ ready := (c = '*') and
+ (peekchar = ')')
+ else
+ ready := ((c = '*') and
+ (peekchar = ')'))
+ or (c = '}')
+ until ready or eof;
+ if eof and not ready then
+ error(eeofcmnt);
+ if (c = '*') and not eof then
+ c := nextchar;
+ c := space
+ end
+ until (c <> space) and (c <> tab1);
+
+ (* save characters from this token and save line- and column-
+ numbers for errormessages *)
+ lasttok[1] := c;
+ lastchr := 2;
+ lastcol := colno;
+ lastline := lineno;
+
+ (* map all CHAR control characters onto "badchr" *)
+ if c < okchr then
+ c := badchr;
+
+ (* decode symbol *)
+ with currsym do
+ if eof then
+ begin
+ lasttok[1] := '*';
+ lasttok[2] := 'E';
+ lasttok[3] := 'O';
+ lasttok[4] := 'F';
+ lasttok[5] := '*';
+ lastchr := 6;
+ st := seof
+ end
+ else
+ case c of
+
+
+ (* CHAR, chars not in Pascal *)
+ '|', '`', '~', '}',
+ bslash, uscore, badchr:
+ error(ebadchar);
+
+ (* identifiers or keywords *)
+ 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
+ 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
+ 'u', 'v', 'w', 'x', 'y', 'z',
+ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
+ 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
+ 'U', 'V', 'W', 'X', 'Y', 'Z':
+ begin
+ (* read token into buffer *)
+ wb[1] := lowercase(c);
+ wl := 2;
+ while (wl < maxtoknlen) and idchar(peekchar) do
+ begin
+ wb[wl] := lowercase(nextchar);
+ wl := wl + 1
+ end;
+ if wl >= maxtoknlen then
+ begin
+ lasttok[lastchr] := chr(null);
+ error(elongtokn)
+ end;
+ (* terminate token and match *)
+ wb[wl] := chr(null);
+ (* check if keyword/identifier *)
+ st := keywordcheck(wb, wl-1);
+ if st = sid then
+ vid := saveid(wb)
+ end;
+
+ (* integer or real numbers *)
+ '0', '1', '2', '3', '4', '5', '6', '7' ,'8', '9':
+ begin
+ (* assume integer number, save it in buffer *)
+ wb[1] := c;
+ wl := 2;
+ n := numval(c);
+ while numchar(peekchar) do
+ begin
+ c := nextchar;
+ n := n * 10 + numval(c);
+ wb[wl] := c;
+ wl := wl + 1
+ end;
+ st := sinteger;
+ vint := n;
+ if realok then
+ begin
+ (* accept real numbers *)
+ if peekchar = '.' then
+ begin
+ (* this is a real number *)
+ st := sreal;
+ wb[wl] := nextchar;
+ wl := wl + 1;
+ while numchar(peekchar) do
+ begin
+ wb[wl] := nextchar;
+ wl := wl + 1
+ end
+ end;
+ c := peekchar;
+ if (c = 'e') or (c = 'E') then
+ begin
+ (* this is a real number *)
+ st := sreal;
+ c := nextchar;
+ wb[wl] := xpnent;
+ wl := wl + 1;
+ c := peekchar;
+ if (c = '-') or (c = '+') then
+ begin
+ wb[wl] := nextchar;
+ wl := wl + 1
+ end;
+ while numchar(peekchar) do
+ begin
+ wb[wl] := nextchar;
+ wl := wl + 1
+ end
+ end;
+ if st = sreal then
+ begin
+ wb[wl] := chr(null);
+ vflt := savestr(wb)
+ end
+ end
+ end;
+
+ '(':
+ if peekchar = '.' then
+ begin
+ (* some compilers on non-ascii systems
+ use (. for [ and .) for ] *)
+ c := nextchar;
+ st := slbrack
+ end
+ else
+ st := slpar;
+ ')':
+ st := srpar;
+ '[':
+ st := slbrack;
+ ']':
+ st := srbrack;
+ '.':
+ if peekchar = '.' then
+ begin
+ c := nextchar;
+ st := sdotdot
+ end
+ else if peekchar = ')' then
+ begin
+ c := nextchar;
+ st := srbrack
+ end
+ else
+ st := sdot;
+ ';':
+ st := ssemic;
+ ':':
+ if peekchar = '=' then
+ begin
+ c := nextchar;
+ st := sassign
+ end
+ else
+ st := scolon;
+ ',':
+ st := scomma;
+ '@',
+ '^':
+ st := sarrow;
+ '=':
+ st := seq;
+ '<':
+ if peekchar = '=' then
+ begin
+ c := nextchar;
+ st := sle
+ end
+ else if peekchar = '>' then
+ begin
+ c := nextchar;
+ st := sne
+ end
+ else
+ st := slt;
+ '>':
+ if peekchar = '=' then
+ begin
+ c := nextchar;
+ st := sge
+ end
+ else
+ st := sgt;
+ '+':
+ st := splus;
+ '-':
+ st := sminus;
+ '*':
+ st := smul;
+ '/':
+ st := squot;
+ quote:
+ begin
+ (* assume the symbol is a literal string *)
+ wl := 0;
+ ready := false;
+ repeat
+ if eoln then
+ begin
+ lasttok[lastchr] := chr(null);
+ error(ebadstring)
+ end;
+ c := nextchar;
+ if c = quote then
+ if peekchar = quote then
+ c := nextchar
+ else
+ ready := true;
+ if c = chr(null) then
+ begin
+ if eof then
+ error(eeofstr);
+ lasttok[lastchr] := chr(null);
+ error(enulchr)
+ end;
+ if not ready then
+ begin
+ wl := wl + 1;
+ if wl >= maxtoknlen then
+ begin
+ lasttok[lastchr] :=
+ chr(null);
+ error(elongstring)
+ end;
+ wb[wl] := c
+ end
+ until ready;
+ if wl = 1 then
+ begin
+ (* only 1 character => not a string *)
+ st := schar;
+ vchr := wb[1]
+ end
+ else begin
+ (* > 1 character => its a string *)
+ wl := wl + 1;
+ if wl >= maxtoknlen then
+ begin
+ lasttok[lastchr] := chr(null);
+ error(elongstring)
+ end;
+ wb[wl] := chr(null);
+ st := sstring;
+ vstr := savestr(wb)
+ end
+ end
+
+ end;(* case *)
+ if lastchr = 0 then
+ lastchr := 1;
+ lasttok[lastchr] := chr(null)
+ end; (* nexttoken *)
+
+ begin (* nextsymbol *)
+ nexttoken(sreal in ss);
+ checksymbol(ss)
+ end; (* nextsymbol *)
+
+ (* Return a pointer to the node describing the type of tp. This *)
+ (* function also stores the result in the node for future ref. *)
+ function typeof(tp : treeptr) : treeptr;
+
+ var tf, tq : treeptr;
+
+ begin
+ tq := tp;
+ tf := tq^.ttype;
+ (* keep working until a type is found *)
+ while tf = nil do
+ begin
+ case tq^.tt of
+ nchar:
+ tf := typnods[tchar];
+
+ ninteger:
+ tf := typnods[tinteger];
+
+ nreal:
+ tf := typnods[treal];
+
+ nstring:
+ tf := typnods[tstring];
+
+ nnil:
+ tf := typnods[tnil];
+
+ nid:
+ begin
+ tq := idup(tq);
+ if tq = nil then
+ fatal(etree)
+ end;
+
+ ntype,
+ nvar,
+ nconst,
+ nfield,
+ nvalpar,
+ nvarpar:
+ tq := tq^.tbind;
+
+ npredef,
+ nptr,
+ nscalar,
+ nrecord,
+ nconfarr,
+ narray,
+ nfileof,
+ nsetof:
+ tf := tq; (* these nodetypes represent types *)
+
+ nsubrange:
+ if tq^.tup^.tt = nconfarr then
+ tf := tq^.tup^.tindtyp
+ else
+ tf := tq;
+
+ ncall:
+ begin
+ tf := typeof(tq^.tcall);
+ if tf = typnods[tpoly] then
+ tf := typeof(tq^.taparm)
+ end;
+
+ nfunc:
+ tq := tq^.tfuntyp;
+
+ nparfunc:
+ tq := tq^.tpartyp;
+
+ nproc,
+ nparproc:
+ tf := typnods[tnone];
+
+ nvariant,
+ nlabel,
+ npgm,
+ nempty,
+ nbegin,
+ nlabstmt,
+ nassign,
+ npush,
+ npop,
+ nif,
+ nwhile,
+ nrepeat,
+ nfor,
+ ncase,
+ nchoise,
+ ngoto,
+ nwith,
+ nwithvar:
+ fatal(etree);
+
+ nformat,
+ nrange:
+ tq := tq^.texpl;
+
+ nplus,
+ nminus,
+ nmul:
+ begin
+ tf := typeof(tq^.texpl);
+ if tf = typnods[tinteger] then
+ tf := typeof(tq^.texpr)
+ else if tf^.tt = nsetof then
+ tf := typnods[tset]
+ end;
+
+ numinus,
+ nuplus:
+ tq := tq^.texps;
+
+ nmod,
+ ndiv:
+ tf := typnods[tinteger];
+
+ nquot:
+ tf := typnods[treal];
+
+ neq,
+ nne,
+ nlt,
+ nle,
+ ngt,
+ nge,
+ nin,
+ nor,
+ nand,
+ nnot:
+ tf := typnods[tboolean];
+
+ nset:
+ tf := typnods[tset];
+
+ nselect:
+ tq := tq^.tfield;
+
+ nderef:
+ begin
+ tq := typeof(tq^.texps);
+ case tq^.tt of
+ nptr:
+ tq := tq^.tptrid;
+ nfileof:
+ tq := tq^.tof;
+ npredef:
+ tf := typnods[tchar] (* textfile *)
+ end (* case *)
+ end;
+
+ nindex:
+ begin
+ tq := typeof(tq^.tvariable);
+ if tq^.tt = nconfarr then
+ tq := tq^.tcelem
+ else if tq = typnods[tstring] then
+ tf := typnods[tchar]
+ else
+ tq := tq^.taelem
+ end;
+
+ end (* case *)
+ end;
+ if tp^.ttype = nil then
+ tp^.ttype := tf; (* remember type for future reference *)
+ typeof := tf
+ end; (* typeof *)
+
+ (* Connect all nodes to their fathers. *)
+ procedure linkup(up, tp : treeptr);
+
+ begin
+ while tp <> nil do
+ begin
+ if tp^.tup = nil then
+ begin
+ tp^.tup := up;
+ case tp^.tt of
+ npgm,
+ nfunc,
+ nproc:
+ begin
+ linkup(tp, tp^.tsubid);
+ linkup(tp, tp^.tsubpar);
+ linkup(tp, tp^.tfuntyp);
+ linkup(tp, tp^.tsublab);
+ linkup(tp, tp^.tsubconst);
+ linkup(tp, tp^.tsubtype);
+ linkup(tp, tp^.tsubvar);
+ linkup(tp, tp^.tsubsub);
+ linkup(tp, tp^.tsubstmt)
+ end;
+
+
+ nvalpar,
+ nvarpar,
+ nconst,
+ ntype,
+ nfield,
+ nvar:
+ begin
+ linkup(tp, tp^.tidl);
+ linkup(tp, tp^.tbind)
+ end;
+
+ nparproc,
+ nparfunc:
+ begin
+ linkup(tp, tp^.tparid);
+ linkup(tp, tp^.tparparm);
+ linkup(tp, tp^.tpartyp)
+ end;
+
+ nptr:
+ linkup(tp, tp^.tptrid);
+ nscalar:
+ linkup(tp, tp^.tscalid);
+
+ nsubrange:
+ begin
+ linkup(tp, tp^.tlo);
+ linkup(tp, tp^.thi)
+ end;
+ nvariant:
+ begin
+ linkup(tp, tp^.tselct);
+ linkup(tp, tp^.tvrnt)
+ end;
+ nrecord:
+ begin
+ linkup(tp, tp^.tflist);
+ linkup(tp, tp^.tvlist)
+ end;
+ nconfarr:
+ begin
+ linkup(tp, tp^.tcindx);
+ linkup(tp, tp^.tcelem);
+ linkup(tp, tp^.tindtyp)
+ end;
+ narray:
+ begin
+ linkup(tp, tp^.taindx);
+ linkup(tp, tp^.taelem)
+ end;
+ nfileof,
+ nsetof:
+ linkup(tp, tp^.tof);
+ nbegin:
+ linkup(tp, tp^.tbegin);
+ nlabstmt:
+ begin
+ linkup(tp, tp^.tlabno);
+ linkup(tp, tp^.tstmt)
+ end;
+ nassign:
+ begin
+ linkup(tp, tp^.tlhs);
+ linkup(tp, tp^.trhs)
+ end;
+ npush,
+ npop:
+ begin
+ linkup(tp, tp^.tglob);
+ linkup(tp, tp^.tloc);
+ linkup(tp, tp^.ttmp)
+ end;
+ ncall:
+ begin
+ linkup(tp, tp^.tcall);
+ linkup(tp, tp^.taparm )
+ end;
+ nif:
+ begin
+ linkup(tp, tp^.tifxp);
+ linkup(tp, tp^.tthen);
+ linkup(tp, tp^.telse)
+ end;
+ nwhile:
+ begin
+ linkup(tp, tp^.twhixp);
+ linkup(tp, tp^.twhistmt)
+ end;
+ nrepeat:
+ begin
+ linkup(tp, tp^.treptstmt);
+ linkup(tp, tp^.treptxp)
+ end;
+ nfor:
+ begin
+ linkup(tp, tp^.tforid);
+ linkup(tp, tp^.tfrom);
+ linkup(tp, tp^.tto);
+ linkup(tp, tp^.tforstmt)
+ end;
+ ncase:
+ begin
+ linkup(tp, tp^.tcasxp);
+ linkup(tp, tp^.tcaslst);
+ linkup(tp, tp^.tcasother)
+ end;
+ nchoise:
+ begin
+ linkup(tp, tp^.tchocon);
+ linkup(tp, tp^.tchostmt)
+ end;
+ nwith:
+ begin
+ linkup(tp, tp^.twithvar);
+ linkup(tp, tp^.twithstmt)
+ end;
+ nwithvar:
+ linkup(tp, tp^.texpw);
+ nindex:
+ begin
+ linkup(tp, tp^.tvariable);
+ linkup(tp, tp^.toffset)
+ end;
+ nselect:
+ begin
+ linkup(tp, tp^.trecord);
+ linkup(tp, tp^.tfield)
+ end;
+
+ ngoto:
+ linkup(tp, tp^.tlabel);
+
+ nrange, nformat,
+ nin, neq,
+ nne, nlt, nle,
+ ngt, nge, nor,
+ nplus, nminus,
+ nand, nmul,
+ ndiv, nmod,
+ nquot:
+ begin
+ linkup(tp, tp^.texpl);
+ linkup(tp, tp^.texpr)
+ end;
+
+ nderef,
+ nnot, nset,
+ numinus,
+ nuplus:
+ linkup(tp, tp^.texps);
+
+ nid,
+ nnil, ninteger,
+ nreal, nchar,
+ nstring, npredef,
+ nlabel, nempty:
+ (* no op *)
+ end (* case *)
+ end;
+ tp := tp^.tnext
+ end
+ end; (* linkup *)
+
+ (* Allocate a new symbol node. *)
+ function mksym(vt : ltypes) : symptr;
+
+ var mp : symptr;
+
+ begin
+ new(mp);
+ if mp = nil then
+ error(enew);
+ mp^.lt := vt;
+ mp^.lnext := nil;
+ mp^.lsymdecl := nil;
+ mp^.ldecl := nil;
+ mksym := mp
+ end;
+
+ (* Enter a symbol at current declarationlevel. *)
+ procedure declsym(sp : symptr);
+
+ var h : hashtyp;
+
+ begin
+ if sp^.lt in [lpredef, lidentifier, lfield, lforward, lpointer] then
+ h := sp^.lid^.ihash
+ else
+ h := hashmax;
+ sp^.lnext := symtab^.ddecl[h];
+ symtab^.ddecl[h] := sp;
+ sp^.ldecl := symtab
+ end;
+
+ (* Create a node of selected type. *)
+ function mknode(nt : treetyp) : treeptr;
+
+ var tp : treeptr;
+
+ begin
+ tp := nil;
+ case nt of
+ npredef: new(tp, npredef);
+ npgm: new(tp, npgm);
+ nfunc: new(tp, nfunc);
+ nproc: new(tp, nproc);
+ nlabel: new(tp, nlabel);
+ nconst: new(tp, nconst);
+ ntype: new(tp, ntype);
+ nvar: new(tp, nvar);
+ nvalpar: new(tp, nvalpar);
+ nvarpar: new(tp, nvarpar);
+ nparproc: new(tp, nparproc);
+ nparfunc: new(tp, nparfunc);
+ nsubrange: new(tp, nsubrange);
+ nvariant: new(tp, nvariant);
+ nfield: new(tp, nfield);
+ nrecord: new(tp, nrecord);
+ nconfarr: new(tp, nconfarr);
+ narray: new(tp, narray);
+ nfileof: new(tp, nfileof);
+ nsetof: new(tp, nsetof);
+ nbegin: new(tp, nbegin);
+ nptr: new(tp, nptr);
+ nscalar: new(tp, nscalar);
+ nif: new(tp, nif);
+ nwhile: new(tp, nwhile);
+ nrepeat: new(tp, nrepeat);
+ nfor: new(tp, nfor);
+ ncase: new(tp, ncase);
+ nchoise: new(tp, nchoise);
+ ngoto: new(tp, ngoto);
+ nwith: new(tp, nwith);
+ nwithvar: new(tp, nwithvar);
+ nempty: new(tp, nempty);
+ nlabstmt: new(tp, nlabstmt);
+ nassign: new(tp, nassign);
+ nformat: new(tp, nformat);
+ nin: new(tp, nin);
+ neq: new(tp, neq);
+ nne: new(tp, nne);
+ nlt: new(tp, nlt);
+ nle: new(tp, nle);
+ ngt: new(tp, ngt);
+ nge: new(tp, nge);
+ nor: new(tp, nor);
+ nplus: new(tp, nplus);
+ nminus: new(tp, nminus);
+ nand: new(tp, nand);
+ nmul: new(tp, nmul);
+ ndiv: new(tp, ndiv);
+ nmod: new(tp, nmod);
+ nquot: new(tp, nquot);
+ nnot: new(tp, nnot);
+ numinus: new(tp, numinus);
+ nuplus: new(tp, nuplus);
+ nset: new(tp, nset);
+ nrange: new(tp, nrange);
+ nindex: new(tp, nindex);
+ nselect: new(tp, nselect);
+ nderef: new(tp, nderef);
+ ncall: new(tp, ncall);
+ nid: new(tp, nid);
+ nchar: new(tp, nchar);
+ ninteger: new(tp, ninteger);
+ nreal: new(tp, nreal);
+ nstring: new(tp, nstring);
+ nnil: new(tp, nnil);
+ npush: new(tp, npush);
+ npop: new(tp, npop);
+ nbreak: new(tp, nbreak)
+ end;(* case *)
+ if tp = nil then
+ error(enew);
+ tp^.tt := nt;
+ tp^.tnext := nil;
+ tp^.tup := nil;
+ tp^.ttype := nil;
+ mknode := tp
+ end;
+
+ (* Create a node with a literal value. *)
+ function mklit : treeptr;
+
+ var sp : symptr;
+ tp : treeptr;
+
+ begin
+ case currsym.st of
+ sinteger:
+ begin
+ sp := mksym(linteger);
+ sp^.linum := currsym.vint;
+ tp := mknode(ninteger);
+ end;
+ sreal:
+ begin
+ sp := mksym(lreal);
+ sp^.lfloat := currsym.vflt;
+ tp := mknode(nreal);
+ end;
+ schar:
+ begin
+ sp := mksym(lcharacter);
+ sp^.lchar := currsym.vchr;
+ tp := mknode(nchar);
+ end;
+ sstring:
+ begin
+ sp := mksym(lstring);
+ sp^.lstr := currsym.vstr;
+ tp := mknode(nstring);
+ end
+ end;(* case *)
+ tp^.tsym := sp;
+ sp^.lsymdecl := tp;
+ mklit := tp
+ end;
+
+ (* Look up an identifier among declared symbols. *)
+ function lookupid(ip : idptr; fieldok : boolean) : symptr;
+
+ label 999;
+
+ var sp : symptr;
+ dp : declptr;
+ vs : set of ltypes;
+
+ begin
+ lookupid := nil;
+ if fieldok then
+ vs := [lidentifier, lforward, lpointer, lfield]
+ else
+ vs := [lidentifier, lforward, lpointer];
+ sp := nil;
+
+ (* pick up symboltable from innermost scope *)
+ dp := symtab;
+ while dp <> nil do
+ begin
+ (* scan linked symbols with same hasvalue *)
+ sp := dp^.ddecl[ip^.ihash];
+ while sp <> nil do
+ begin
+ (* break out when proper id found *)
+ if (sp^.lt in vs) and (sp^.lid = ip) then
+ goto 999;
+ sp := sp^.lnext
+ end;
+ (* proceed to enclosing scope *)
+ dp := dp^.dprev
+ end;
+ 999:
+ lookupid := sp
+ end;
+
+ (* Look up a label. *)
+ function lookuplabel(i : integer) : symptr;
+
+ label 999;
+
+ var sp : symptr;
+ dp : declptr;
+
+ begin
+ sp := nil;
+ dp := symtab;
+ while dp <> nil do
+ begin
+ sp := dp^.ddecl[hashmax];
+ while sp <> nil do
+ begin
+ if (sp^.lt in [lforwlab, llabel]) and (sp^.lno = i) then
+ goto 999;
+ sp := sp^.lnext
+ end;
+ dp := dp^.dprev
+ end;
+ 999:
+ lookuplabel := sp
+ end;
+
+ (* Create a new declaration level (a new scope) link declnode to *)
+ (* previous node. dp is non-nil when a procedure/function body *)
+ (* is encountered for which we have seen a forward declaration. *)
+ procedure enterscope(dp : declptr);
+
+ var h : hashtyp;
+
+ begin
+ if dp = nil then
+ begin
+ new(dp);
+ for h := 0 to hashmax do
+ dp^.ddecl[h] := nil
+ end;
+ dp^.dprev := symtab;
+ symtab := dp
+ end;
+
+ (* Return current scope (as a pointer to symbol-table). *)
+ function currscope : declptr;
+
+ begin
+ currscope := symtab
+ end;
+
+ (* Drop innermost declaration scope. *)
+ procedure leavescope;
+
+ begin
+ symtab := symtab^.dprev
+ end;
+
+ (* Create a new identifier symbol. *)
+ function mkid(ip : idptr) : symptr;
+
+ var sp : symptr;
+
+ begin
+ sp := mksym(lidentifier);
+ sp^.lid := ip;
+ sp^.lused := false;
+ declsym(sp);
+ ip^.inref := ip^.inref + 1;
+ mkid := sp
+ end;
+
+ (* Check that the current identifier is new then save it in the *)
+ (* current scope. Create and return a new node representing this *)
+ (* instance of the identifier. *)
+ function newid(ip : idptr) : treeptr;
+
+ var sp : symptr;
+ tp : treeptr;
+
+ begin
+ sp := lookupid(ip, false);
+ if sp <> nil then
+ if sp^.ldecl <> symtab then
+ sp := nil;
+ if sp = nil then
+ begin
+ (* new identifier *)
+ tp := mknode(nid);
+ sp := mkid(ip);
+ sp^.lsymdecl := tp;
+ tp^.tsym := sp
+ end
+ else if sp^.lt = lpointer then
+ begin
+ (* previously declared as a pointer type *)
+ tp := mknode(nid);
+ tp^.tsym := sp;
+ sp^.lt := lidentifier;
+ sp^.lsymdecl := tp
+ end
+ else if sp^.lt = lforward then
+ begin
+ (* previously forward declared *)
+ sp^.lt := lidentifier;
+ tp := sp^.lsymdecl
+ end
+ else
+ error(emultdeclid);
+ newid := tp
+ end;
+
+ (* Check that the current identifier is already declared, *)
+ (* we fail unless l in [lforward, lpointer]. *)
+ (* Create and return a new node referencing it. *)
+ function oldid(ip : idptr; l : ltypes) : treeptr;
+
+ var sp : symptr;
+ tp : treeptr;
+
+ begin
+ sp := lookupid(ip, true);
+ if sp = nil then
+ begin
+ if l in [lforward, lpointer] then
+ begin
+ tp := newid(ip);
+ tp^.tsym^.lt := l
+ end
+ else
+ error(enotdeclid)
+ end
+ else begin
+ sp^.lused := true;
+ tp := mknode(nid);
+ tp^.tsym := sp;
+ if (sp^.lt = lpointer) and (l = lidentifier) then
+ begin
+ sp^.lt := lidentifier;
+ sp^.lsymdecl := tp
+ end
+ end;
+ oldid := tp
+ end;
+
+ (* Look up a field in a record declaration. *)
+ (* Return nil if field isn't declared in "tp" or its variants. *)
+ function oldfield(tp : treeptr; ip : idptr) : treeptr;
+
+ label 999;
+
+ var tq, ti,
+ fp : treeptr;
+
+ begin
+ fp := nil;
+ tq := tp^.tflist;
+ while tq <> nil do
+ begin
+ ti := tq^.tidl;
+ while ti <> nil do
+ begin
+ if ti^.tsym^.lid = ip then
+ begin
+ fp := mknode(nid);
+ fp^.tsym := ti^.tsym;
+ goto 999
+ end;
+ ti := ti^.tnext
+ end;
+ tq := tq^.tnext
+ end;
+ tq := tp^.tvlist;
+ while tq <> nil do
+ begin
+ fp := oldfield(tq^.tvrnt, ip);
+ if fp <> nil then
+ tq := nil
+ else
+ tq := tq^.tnext
+ end;
+ 999:
+ oldfield := fp
+ end;
+
+ (* This is the main parsing routine. It parses a correct pascal- *)
+ (* program and builds a parsetree which is left in the global *)
+ (* variable top. *)
+ (* Parsing is done through recursive descent using a set of *)
+ (* mutually recursive functions. *)
+ procedure parse;
+
+ function plabel : treeptr; forward;
+ function pidlist(l : ltypes) : treeptr; forward;
+ function pconst : treeptr; forward;
+ function pconstant(realok : boolean) : treeptr; forward;
+ function precord(cs : symtyp; dp : declptr) : treeptr; forward;
+ function ptypedef : treeptr; forward;
+ function ptype : treeptr; forward;
+ function pvar : treeptr; forward;
+ function psubs : treeptr; forward;
+ function psubpar : treeptr; forward;
+ function plabstmt : treeptr; forward;
+ function pstmt : treeptr; forward;
+ function psimple : treeptr; forward;
+ function pvariable(varptr : treeptr) : treeptr; forward;
+ function pexpr(tnp : treeptr) : treeptr; forward;
+ function pcase : treeptr; forward;
+ function pif : treeptr; forward;
+ function pwhile : treeptr; forward;
+ function prepeat : treeptr; forward;
+ function pfor : treeptr; forward;
+ function pwith : treeptr; forward;
+ function pgoto : treeptr; forward;
+ function pbegin(retain : boolean) : treeptr; forward;
+
+ (* Open scope of a record variable. *)
+ procedure scopeup(tp : treeptr);
+
+ (* Scan a record-declaration and add all fields to *)
+ (* current scope. *)
+ procedure addfields(rp : treeptr);
+
+ var fp, ip, vp : treeptr;
+ sp : symptr;
+
+ begin
+ fp := rp^.tflist;
+ while fp <> nil do
+ begin
+ ip := fp^.tidl;
+ while ip <> nil do
+ begin
+ sp := mksym(lfield);
+ sp^.lid := ip^.tsym^.lid;
+ sp^.lused := false;
+ sp^.lsymdecl := ip;
+ declsym(sp);
+ ip := ip^.tnext
+ end;
+ fp := fp^.tnext
+ end;
+ vp := rp^.tvlist;
+ while vp <> nil do
+ begin
+ addfields(vp^.tvrnt);
+ vp := vp^.tnext
+ end
+ end;
+ begin
+ addfields(typeof(tp))
+ end;
+
+ (* Check that the current label is new then save it in the *)
+ (* current scope. Create and return a new node referencing *)
+ (* the label. *)
+ function newlbl : treeptr;
+
+ var sp : symptr;
+ tp : treeptr;
+
+ begin
+ tp := mknode(nlabel);
+ sp := lookuplabel(currsym.vint);
+ if sp <> nil then
+ if sp^.ldecl <> symtab then
+ sp := nil;
+ if sp = nil then
+ begin
+ sp := mksym(lforwlab);
+ sp^.lno := currsym.vint;
+ sp^.lgo := false;
+ sp^.lsymdecl := tp;
+ declsym(sp)
+ end
+ else
+ error(emultdecllab);
+ tp^.tsym := sp;
+ newlbl := tp
+ end;
+
+ (* Check that the current label is already declared. *)
+ (* Create and return a new node referencing it. *)
+ function oldlbl(defpt : boolean) : treeptr;
+
+ var sp : symptr;
+ tp : treeptr;
+
+ begin
+ sp := lookuplabel(currsym.vint);
+ if sp = nil then
+ begin
+ prtmsg(enotdecllab);
+ tp := newlbl;
+ sp := tp^.tsym
+ end
+ else begin
+ tp := mknode(nlabel);
+ tp^.tsym := sp
+ end;
+ if defpt then
+ begin
+
+ if sp^.lt = lforwlab then
+ sp^.lt := llabel
+ else
+ error(emuldeflab);
+ end;
+ oldlbl := tp
+ end;
+
+ (* Parse declaration and statement-body for prog/subs. *)
+ procedure pbody(tp : treeptr);
+
+ var tq : treeptr;
+
+ begin
+ statlvl := statlvl + 1;
+ if currsym.st = slabel then
+ begin
+ tp^.tsublab := plabel;
+ linkup(tp, tp^.tsublab)
+ end
+ else
+ tp^.tsublab := nil;
+ if currsym.st = sconst then
+ begin
+ tp^.tsubconst := pconst;
+ linkup(tp, tp^.tsubconst)
+ end
+ else
+ tp^.tsubconst := nil;
+ if currsym.st = stype then
+ begin
+ tp^.tsubtype := ptype;
+ linkup(tp, tp^.tsubtype)
+ end
+ else
+ tp^.tsubtype := nil;
+ if currsym.st = svar then
+ begin
+ tp^.tsubvar := pvar;
+ linkup(tp, tp^.tsubvar)
+ end
+ else
+ tp^.tsubvar := nil;
+ tp^.tsubsub := nil;
+ tq := nil;
+ while (currsym.st = sproc) or (currsym.st = sfunc) do
+ begin
+ if tq = nil then
+ begin
+ tq := psubs;
+ tp^.tsubsub := tq
+ end
+ else begin
+ tq^.tnext := psubs;
+ tq := tq^.tnext
+ end
+ end;
+ linkup(tp, tp^.tsubsub);
+ checksymbol([sbegin, seof]);
+ if currsym.st = sbegin then
+ begin
+ tp^.tsubstmt := pbegin(false);
+ linkup(tp, tp^.tsubstmt)
+ end;
+ statlvl := statlvl - 1
+ end;
+
+ (* Parse program-declaration. *)
+ function pprogram : treeptr;
+
+ var tp : treeptr;
+
+ (* Parse a program parameter id-list. *)
+ function pprmlist : treeptr;
+
+ label 999;
+
+ var tp,
+ tq : treeptr;
+ din,
+ dut : idptr;
+
+ begin
+ tp := nil;
+ din := deftab[dinput]^.tidl^.tsym^.lid;
+ dut := deftab[doutput]^.tidl^.tsym^.lid;
+ while (currsym.vid = din) or (currsym.vid = dut) do
+ begin
+ (* ignore input/output as parameters so that
+ they will be bound to stdin/stdout unless
+ declared as variables *)
+ if currsym.vid = din then
+ defnams[dinput]^.lused := true
+ else
+ defnams[doutput]^.lused := true;
+ nextsymbol([scomma, srpar]);
+ if currsym.st = srpar then
+ goto 999;
+ nextsymbol([sid])
+ end;
+ tq := newid(currsym.vid);
+ tq^.tsym^.lt := lpointer;
+ tp := tq;
+ nextsymbol([scomma, srpar]);
+ while currsym.st = scomma do
+ begin
+ nextsymbol([sid]);
+ if currsym.vid = din then
+ defnams[dinput]^.lused := true
+ else if currsym.vid = dut then
+ defnams[doutput]^.lused := true
+ else begin
+ tq^.tnext := newid(currsym.vid);
+ tq := tq^.tnext;
+ tq^.tsym^.lt := lpointer;
+ end;
+ nextsymbol([scomma, srpar])
+ end;
+ 999:
+ pprmlist := tp
+ end;
+
+ begin (* pprogram *)
+ enterscope(nil);
+ tp := mknode(npgm);
+ nextsymbol([sid]);
+ tp^.tstat := statlvl;
+ tp^.tsubid := mknode(nid);
+ tp^.tsubid^.tup := tp;
+ tp^.tsubid^.tsym := mksym(lidentifier);
+ tp^.tsubid^.tsym^.lid := currsym.vid;
+ tp^.tsubid^.tsym^.lsymdecl := tp^.tsubid;
+ linkup(tp, tp^.tsubid);
+ nextsymbol([slpar, ssemic]);
+ if currsym.st = slpar then
+ begin
+ nextsymbol([sid]);
+ tp^.tsubpar := pprmlist;
+ linkup(tp, tp^.tsubpar);
+ nextsymbol([ssemic])
+ end
+ else
+ tp^.tsubpar := nil;
+ nextsymbol([slabel, sconst, stype, svar,
+ sproc, sfunc, sbegin]);
+ pbody(tp);
+ checksymbol([sdot]);
+ tp^.tscope := currscope;
+ leavescope;
+ pprogram := tp
+ end; (* pprogram *)
+
+ (* Parse a module. *)
+ function pmodule : treeptr;
+
+ var tp : treeptr;
+
+ begin (* pmodule *)
+ enterscope(nil);
+ tp := mknode(npgm);
+ tp^.tstat := statlvl;
+ tp^.tsubid := nil;
+ tp^.tsubpar := nil;
+ pbody(tp);
+ checksymbol([ssemic]);
+ tp^.tscope := currscope;
+ leavescope;
+ pmodule := tp
+ end; (* pmodule *)
+
+
+ (* Parse label-clause. *)
+ function plabel;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ tq := nil;
+ repeat
+ nextsymbol([sinteger]);
+ if tq = nil then
+ begin
+ tq := newlbl;
+ tp := tq
+ end
+ else begin
+ tq^.tnext := newlbl;
+ tq := tq^.tnext;
+ end;
+ nextsymbol([scomma, ssemic])
+ until currsym.st = ssemic;
+ nextsymbol([sconst, stype, svar, sbegin, sproc, sfunc]);
+ plabel := tp
+ end;
+
+ (* Parse an id-list. *)
+ function pidlist;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ tq := newid(currsym.vid);
+ tq^.tsym^.lt := l;
+ tp := tq;
+ nextsymbol([scomma, scolon, seq, srpar]);
+ while currsym.st = scomma do
+ begin
+ nextsymbol([sid]);
+ tq^.tnext := newid(currsym.vid);
+ tq := tq^.tnext;
+ tq^.tsym^.lt := l;
+ nextsymbol([scomma, scolon, seq, srpar])
+ end;
+ pidlist := tp
+ end;
+
+ (* Parse const-clause. *)
+ function pconst;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ tq := nil;
+ nextsymbol([sid]);
+ repeat
+ if tq = nil then
+ begin
+ tq := mknode(nconst);
+ tq^.tattr := anone;
+ tp := tq
+ end
+ else begin
+ tq^.tnext := mknode(nconst);
+ tq := tq^.tnext;
+ tq^.tattr := anone
+ end;
+ tq^.tidl := pidlist(lidentifier);
+ checksymbol([seq]);
+ nextsymbol([sid, schar, sstring, sinteger, sreal,
+ splus, sminus]);
+ tq^.tbind := pconstant(true);
+ nextsymbol([ssemic]);
+ nextsymbol([sid, stype, svar, sbegin,
+ sfunc, sproc, seof])
+ until currsym.st <> sid;
+ pconst := tp
+ end;
+
+ (* Parse a declared constant or a case-statment const. *)
+ function pconstant;
+
+ var tp,
+ tq : treeptr;
+ neg : boolean;
+
+ begin
+ neg := currsym.st = sminus;
+ if currsym.st in [splus, sminus] then
+ if realok then
+ nextsymbol([sid, sinteger, sreal])
+ else
+ nextsymbol([sid, sinteger]);
+ if currsym.st = sid then
+ tp := oldid(currsym.vid, lidentifier)
+ else
+ tp := mklit;
+ if neg then
+ begin
+ tq := mknode(numinus);
+ tq^.texps := tp;
+ tp := tq
+ end;
+ pconstant := tp
+ end;
+
+ (* Parse a record (or record-variant) declaration. *)
+ (* Cs is the expected closing symbol, dp the scope. *)
+ function precord;
+
+ label 999;
+
+ var tp,
+ tq,
+ tl,
+ tv : treeptr;
+ tsym : lexsym;
+
+ begin
+ tp := mknode(nrecord);
+ tp^.tflist := nil;
+ tp^.tvlist := nil;
+ tp^.tuid := nil;
+ tp^.trscope := nil;
+ if cs = send then
+ begin
+ enterscope(dp);
+ dp := currscope
+ end;
+ nextsymbol([sid, scase] + [cs]);
+ tq := nil;
+ while currsym.st = sid do
+ begin
+ if tq = nil then
+ begin
+ tq := mknode(nfield);
+ tq^.tattr := anone;
+ tp^.tflist := tq
+ end
+ else begin
+ tq^.tnext := mknode(nfield);
+ tq := tq^.tnext;
+ tq^.tattr := anone
+ end;
+ tq^.tidl := pidlist(lfield);
+ checksymbol([scolon]);
+ leavescope;
+ tq^.tbind := ptypedef;
+ enterscope(dp);
+ if currsym.st = ssemic then
+ nextsymbol([sid, scase] + [cs])
+ end;
+ if currsym.st = scase then
+ begin
+ nextsymbol([sid]);
+ tsym := currsym;
+ nextsymbol([scolon, sof]);
+ if currsym.st = scolon then
+ begin
+ tv := newid(tsym.vid);
+ if tq = nil then
+ begin
+ tq := mknode(nfield);
+ tp^.tflist := tq
+ end
+ else begin
+ tq^.tnext := mknode(nfield);
+ tq := tq^.tnext
+ end;
+ tq^.tidl := tv;
+ tv^.tsym^.lt := lfield;
+ nextsymbol([sid]);
+ leavescope;
+ tq^.tbind := oldid(currsym.vid, lidentifier);
+ enterscope(dp);
+ nextsymbol([sof])
+ end;
+ tq := nil;
+ repeat
+ tv := nil;
+ repeat
+ nextsymbol([sid, sinteger, schar, splus,
+ sminus] + [cs]);
+ if currsym.st = cs then
+ goto 999;
+ if tv = nil then
+ begin
+ tv := pconstant(false);
+ tl := tv
+ end
+ else begin
+ tv^.tnext := pconstant(false);
+ tv := tv^.tnext
+ end;
+ nextsymbol([scolon, scomma])
+ until currsym.st = scolon;
+ nextsymbol([slpar]);
+ if tq = nil then
+ begin
+ tq := mknode(nvariant);
+ tp^.tvlist := tq;
+ end
+ else begin
+ tq^.tnext := mknode(nvariant);
+ tq := tq^.tnext;
+ end;
+ tq^.tselct := tl;
+ tq^.tvrnt := precord(srpar, dp)
+ until currsym.st = cs
+ end;
+ 999:
+ if cs = send then
+ begin
+ tp^.trscope := dp;
+ leavescope
+ end;
+ nextsymbol([ssemic, send, srpar]);
+ (* currsym is the symbol following record end/rpar,
+ (usually semicolon, sometimes enclosing end/rpar) *)
+ precord := tp
+ end;
+
+ function ptypedef;
+
+ var tp,
+ tq : treeptr;
+ st : symtyp;
+ ss : symset;
+
+ begin
+ nextsymbol([sid, slpar, sarrow, sinteger, schar, splus, sminus,
+ spacked, sarray, srecord, sfile, sset]);
+
+ (* the "packed" keyword is completely ignored *)
+ if currsym.st = spacked then
+ nextsymbol([sarray, srecord, sfile, sset]);
+
+ ss := [ssemic, send, srpar, scomma, srbrack];
+ case currsym.st of
+ splus,
+ sminus,
+ schar,
+ sinteger,
+ sid:
+ begin
+ st := currsym.st;
+ tp := pconstant(false);
+ if st = sid then
+ nextsymbol([sdotdot] + ss)
+ else
+ nextsymbol([sdotdot]);
+ if currsym.st = sdotdot then
+ begin
+ nextsymbol([sid, sinteger, schar,
+ splus, sminus]);
+ tq := mknode(nsubrange);
+ tq^.tlo := tp;
+ tq^.thi := pconstant(false);
+ tp := tq;
+ nextsymbol(ss)
+ end
+ end;
+ slpar:
+ begin
+ tp := mknode(nscalar);
+ nextsymbol([sid]);
+ tp^.tscalid := pidlist(lidentifier);
+ checksymbol([srpar]);
+ nextsymbol(ss)
+ end;
+ sarrow:
+ begin
+ tp := mknode(nptr);
+ nextsymbol([sid]);
+ tp^.tptrid := oldid(currsym.vid, lpointer);
+ tp^.tptrflag := false;
+ nextsymbol([ssemic, send, srpar])
+ end;
+ sarray:
+ begin
+ nextsymbol([slbrack]);
+ tp := mknode(narray);
+ tp^.taindx := ptypedef; (* parse subrange ... *)
+ tq := tp;
+ while currsym.st = scomma do
+ begin
+ (* expand: array [ A , B ] of X
+ to: array [ A ] of array [ B ] of X *)
+ tq^.taelem := mknode(narray);
+ tq := tq^.taelem;
+ tq^.taindx := ptypedef (* ... again *)
+ end;
+ checksymbol([srbrack]);
+ nextsymbol([sof]);
+ tq^.taelem := ptypedef
+ end;
+ srecord:
+ tp := precord(send, nil);
+ sfile,
+ sset:
+ begin
+ if currsym.st = sfile then
+ tp := mknode(nfileof)
+ else begin
+ tp := mknode(nsetof);
+ usesets := true
+ end;
+ nextsymbol([sof]);
+ tp^.tof := ptypedef
+ end
+ end;
+ (* at this point "currsym" holds the symbol following the type
+ (usually semicolon, sometimes the following end/rpar) *)
+ ptypedef := tp
+ end;
+
+ (* Parse type-clause. *)
+ function ptype;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ tq := nil;
+ nextsymbol([sid]);
+ repeat
+ if tq = nil then
+ begin
+ tq := mknode(ntype);
+ tq^.tattr := anone;
+ tp := tq
+ end
+ else begin
+ tq^.tnext := mknode(ntype);
+ tq := tq^.tnext;
+ tq^.tattr := anone
+ end;
+ tq^.tidl := pidlist(lidentifier);
+ checksymbol([seq]);
+ tq^.tbind := ptypedef;
+ nextsymbol([sid, svar, sbegin, sfunc, sproc, seof])
+ until currsym.st <> sid;
+ ptype := tp;
+ end;
+
+ (* Parse var-clause. *)
+ function pvar;
+
+ var ti,
+ tp,
+ tq : treeptr;
+
+ begin
+ tq := nil;
+ nextsymbol([sid]);
+ repeat
+ if tq = nil then
+ begin
+ tq := mknode(nvar);
+ tq^.tattr := anone;
+ tp := tq
+ end
+ else begin
+ tq^.tnext := mknode(nvar);
+ tq := tq^.tnext;
+ tq^.tattr := anone
+ end;
+
+ ti := newid(currsym.vid);
+ tq^.tidl := ti;
+ nextsymbol([scomma, scolon]);
+ while currsym.st = scomma do
+ begin
+ nextsymbol([sid]);
+ ti^.tnext := newid(currsym.vid);
+ ti := ti^.tnext;
+ nextsymbol([scomma, scolon])
+ end;
+
+ tq^.tbind := ptypedef;
+ nextsymbol([sid, sbegin, sfunc, sproc, seof])
+ until currsym.st <> sid;
+ pvar := tp
+ end;
+
+ (* Parse subroutine-declaration. *)
+ function psubs;
+
+ var tp, (* return value *)
+ tv, tq : treeptr; (* temporary *)
+ func : boolean; (* true for functions *)
+ colsem : symtyp; (* colon/semicolon *)
+
+ begin
+ (* parsing function or procedure *)
+ func := currsym.st = sfunc;
+ if func then
+ colsem := scolon
+ else
+ colsem := ssemic;
+
+ (* parse id, it may already be forward declared *)
+ nextsymbol([sid]);
+ tq := newid(currsym.vid);
+ if tq^.tup = nil then
+ begin
+ enterscope(nil);
+ (* id wasn't previously declared, params possible *)
+ if func then
+ tp := mknode(nfunc)
+ else
+ tp := mknode(nproc);
+ tp^.tstat := statlvl;
+ tp^.tsubid := tq;
+ linkup(tp, tq);
+ nextsymbol([slpar, colsem]);
+ if currsym.st = slpar then
+ begin
+ tp^.tsubpar := psubpar;
+ linkup(tp, tp^.tsubpar);
+ nextsymbol([colsem])
+ end
+ else
+ tp^.tsubpar := nil;
+ if func then
+ begin
+ (* parse function type *)
+ nextsymbol([sid]);
+ tp^.tfuntyp := oldid(currsym.vid, lidentifier);
+ nextsymbol([ssemic])
+ end
+ else
+ tp^.tfuntyp := mknode(nempty);
+ linkup(tp, tp^.tfuntyp);
+ nextsymbol([sextern, sforward,
+ slabel, sconst, stype, svar,
+ sproc, sfunc, sbegin]);
+ end
+ else begin
+ (* id was forward declared =>
+ pick up declarations from parameterlist *)
+ enterscope(tq^.tup^.tscope);
+ if func then
+ tp := mknode(nfunc)
+ else
+ tp := mknode(nproc);
+ tp^.tfuntyp := tq^.tup^.tfuntyp;
+ (* steal id and params from forward decl *)
+ tv := tq^.tup^.tsubpar;
+ tp^.tsubpar := tv;
+ while tv <> nil do
+ begin
+ tv^.tup := tp;
+ tv := tv^.tnext
+ end;
+ tp^.tsubid := tq;
+ tq^.tup := tp;
+ (* id was forward declared =>
+ no params, no function type, no forward *)
+ nextsymbol([ssemic]);
+ nextsymbol([slabel, sconst, stype, svar,
+ sproc, sfunc, sbegin]);
+ end;
+ if currsym.st in [sforward, sextern] then
+ begin
+ tp^.tsubid^.tsym^.lt := lforward;
+ nextsymbol([ssemic]);
+ tp^.tsublab := nil;
+ tp^.tsubconst := nil;
+ tp^.tsubtype := nil;
+ tp^.tsubvar := nil;
+ tp^.tsubsub := nil;
+ tp^.tsubstmt := nil
+ end
+ else
+ pbody(tp);
+ nextsymbol([sproc, sfunc, sbegin, seof]);
+ tp^.tscope := currscope;
+ leavescope;
+ psubs := tp
+ end;
+
+ (* Parse a conformant array index type. *)
+ function pconfsub : treeptr;
+
+ var tp : treeptr;
+
+ begin
+ tp := mknode(nsubrange);
+ nextsymbol([sid]);
+ tp^.tlo := newid(currsym.vid);
+ nextsymbol([sdotdot]);
+ nextsymbol([sid]);
+ tp^.thi := newid(currsym.vid);
+ nextsymbol([scolon]);
+ pconfsub := tp
+ end;
+
+ (* Parse a conformant array-declaration. *)
+ function pconform : treeptr;
+
+ var tp, tq : treeptr;
+
+ begin
+ nextsymbol([slbrack]);
+ tp := mknode(nconfarr);
+ tp^.tcuid := mkvariable('S');
+ tp^.tcindx := pconfsub; (* parse subrange ... *)
+ nextsymbol([sid]);
+ tp^.tindtyp := oldid(currsym.vid, lidentifier);
+ nextsymbol([ssemic, srbrack]);
+ tq := tp;
+ while currsym.st = ssemic do
+ begin
+ error(econfconf); (* what size does tp have *)
+
+ (* expand: array [ A ; B ] of X
+ to: array [ A ] of array [ B ] of X *)
+ tq^.tcelem := mknode(nconfarr);
+ tq := tq^.tcelem;
+ tq^.tcindx := pconfsub; (* ... again *)
+ nextsymbol([sid]);
+ tq^.tindtyp := oldid(currsym.vid, lidentifier);
+ nextsymbol([ssemic, srbrack])
+ end;
+ nextsymbol([sof]);
+ nextsymbol([sid, sarray]);
+ case currsym.st of
+ sid:
+ tq^.tcelem := oldid(currsym.vid, lidentifier);
+ sarray:
+ begin
+ error(econfconf); (* what size does tp have *)
+
+ tq^.tcelem := pconform
+ end;
+ end;(* case *)
+ pconform := tp
+ end;
+
+ (* Parse subroutine parameter list. *)
+ function psubpar;
+
+ var tp,
+ tq : treeptr;
+ nt : treetyp;
+
+ begin
+ tq := nil;
+ repeat
+ nextsymbol([sid, svar, sfunc, sproc]);
+ case currsym.st of
+ sid:
+ nt := nvalpar;
+ svar:
+ nt := nvarpar;
+ sfunc:
+ nt := nparfunc;
+ sproc:
+ nt := nparproc;
+ end;
+ if nt <> nvalpar then
+ nextsymbol([sid]);
+ if tq = nil then
+ begin
+ tq := mknode(nt);
+ tp := tq
+ end
+ else begin
+ tq^.tnext := mknode(nt);
+ tq := tq^.tnext
+ end;
+ case nt of
+ nvarpar,
+ nvalpar:
+ begin
+ tq^.tidl := pidlist(lidentifier);
+ tq^.tattr := anone;
+ checksymbol([scolon]);
+ if nt = nvalpar then
+ nextsymbol([sid])
+ else
+ nextsymbol([sid, sarray]);
+ case currsym.st of
+ sid:
+ tq^.tbind :=
+ oldid(currsym.vid, lidentifier);
+ sarray:
+ tq^.tbind := pconform
+ end;(* case *)
+ nextsymbol([srpar, ssemic])
+ end;
+ nparproc:
+ begin
+ tq^.tparid := newid(currsym.vid);
+ nextsymbol([ssemic, slpar, srpar]);
+ if currsym.st = slpar then
+ begin
+ enterscope(nil);
+ tq^.tparparm := psubpar;
+ nextsymbol([ssemic, srpar]);
+ leavescope
+ end
+ else
+ tq^.tparparm := nil;
+ tq^.tpartyp := nil
+ end;
+ nparfunc:
+ begin
+ tq^.tparid := newid(currsym.vid);
+ nextsymbol([scolon, slpar]);
+ if currsym.st = slpar then
+ begin
+ enterscope(nil);
+ tq^.tparparm := psubpar;
+ nextsymbol([scolon]);
+ leavescope
+ end
+ else
+ tq^.tparparm := nil;
+ nextsymbol([sid]);
+ tq^.tpartyp := oldid(currsym.vid, lidentifier);
+ nextsymbol([srpar, ssemic])
+ end
+ end (* case *)
+ until currsym.st = srpar;
+ psubpar := tp
+ end;
+
+ (* Parse a (possibly labeled) statement. *)
+ function plabstmt;
+
+ var tp : treeptr;
+
+ begin
+ nextsymbol([sid, sinteger, sif, swhile, srepeat, sfor, scase,
+ swith, sbegin, sgoto,
+ selse, ssemic, send, suntil]);
+ if currsym.st = sinteger then
+ begin
+ tp := mknode(nlabstmt);
+ tp^.tlabno := oldlbl(true);
+ nextsymbol([scolon]);
+ nextsymbol([sid, sif, swhile, srepeat, sfor, scase,
+ swith, sbegin, sgoto,
+ selse, ssemic, send, suntil]);
+ tp^.tstmt := pstmt
+ end
+ else
+ tp := pstmt;
+ plabstmt := tp
+ end;
+
+ (* Parse an unlabeled statement. *)
+ function pstmt;
+
+ var tp : treeptr;
+
+ begin
+ case currsym.st of
+ sid:
+ tp := psimple;
+ sif:
+ tp := pif;
+ swhile:
+ tp := pwhile;
+ srepeat:
+ tp := prepeat;
+ sfor:
+ tp := pfor;
+ scase:
+ tp := pcase;
+ swith:
+ tp := pwith;
+ sbegin:
+ tp := pbegin(true);
+ sgoto:
+ tp := pgoto;
+ send,
+ selse,
+ suntil,
+ ssemic:
+ tp := mknode(nempty);
+ end;
+ pstmt := tp
+ end;
+
+ (* Parse an assignment or a procedure call. *)
+ function psimple;
+
+ var tq,
+ tp : treeptr;
+
+ begin
+ tp := pvariable(oldid(currsym.vid, lidentifier));
+ if currsym.st = sassign then
+ begin
+ tq := mknode(nassign);
+ tq^.tlhs := tp;
+ tq^.trhs := pexpr(nil);
+ tp := tq
+ end;
+ psimple := tp
+ end;
+
+ (* Parse a varable-reference (or a subroutine-call). *)
+ function pvariable;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ nextsymbol([slpar, slbrack, sdot, sarrow,
+ sassign, ssemic, scomma, scolon, sdotdot,
+ splus, sminus, smul, sdiv, smod, squot,
+ sand, sor, sinn, srpar, srbrack,
+ sle, slt, seq, sge, sgt, sne,
+ send, suntil, sthen, selse, sdo, sdownto, sto, sof]);
+ if currsym.st in [slpar, slbrack, sdot, sarrow] then
+ begin
+ case currsym.st of
+ slpar:
+ begin
+ tp := mknode(ncall);
+ tp^.tcall := varptr;
+ tq := nil;
+ repeat
+ if tq = nil then
+ begin
+ tq := pexpr(nil);
+ tp^.taparm := tq
+ end
+ else begin
+ tq^.tnext := pexpr(nil);
+ tq := tq^.tnext
+ end;
+ until currsym.st = srpar
+ end;
+ slbrack:
+ begin
+ tq := varptr;
+ repeat
+ tp := mknode(nindex);
+ tp^.tvariable := tq;
+ tp^.toffset := pexpr(nil);
+ tq := tp
+ until currsym.st = srbrack
+ end;
+ sdot:
+ begin
+ tp := mknode(nselect);
+ tp^.trecord := varptr;
+ nextsymbol([sid]);
+ tq := typeof(varptr);
+ enterscope(tq^.trscope);
+ tp^.tfield := oldid(currsym.vid, lfield);
+ leavescope
+ end;
+ sarrow:
+ begin
+ tp := mknode(nderef);
+ tp^.texps := varptr
+ end
+ end;(* case *)
+ tp := pvariable(tp)
+ end
+ else begin
+ tp := varptr;
+ if tp^.tt = nid then
+ begin
+ tq := idup(tp);
+ if tq <> nil then
+ if tq^.tt in [nfunc, nproc,
+ nparproc, nparfunc] then
+ begin
+ (* subroutine-call without
+ parameters *)
+ tp := mknode(ncall);
+ tp^.tcall := varptr;
+ tp^.taparm := nil
+ end
+ end
+ end;
+ pvariable := tp
+ end;
+
+ (* Parse an expression. *)
+ function pexpr;
+
+ var tp,
+ tq : treeptr;
+ nt : treetyp;
+ next : boolean;
+
+ function padjust(tu, tr : treeptr) : treeptr;
+ begin
+ if pprio[tu^.tt] >= pprio[tr^.tt] then
+ begin
+ if tr^.tt in [nnot, numinus, nuplus,
+ nset, nderef] then
+ tr^.texps := padjust(tu, tr^.texps)
+ else
+ tr^.texpl := padjust(tu, tr^.texpl);
+ padjust := tr
+ end
+ else begin
+ if tu^.tt in [nnot, numinus, nuplus,
+ nset, nderef] then
+ tu^.texps := tr
+ else
+ tu^.texpr := tr;
+ padjust := tu
+ end
+ end;
+
+ begin
+ nextsymbol([sid, schar, sinteger, sreal, sstring, snil,
+ splus, sminus, snot, slpar, slbrack, srbrack]);
+ next := true;
+ case currsym.st of
+ splus:
+ begin
+ tp := mknode(nuplus);
+ tp^.texps := nil;
+ tp := pexpr(tp);
+ next := false
+ end;
+ sminus:
+ begin
+ tp := mknode(numinus);
+ tp^.texps := nil;
+ tp := pexpr(tp);
+ next := false
+ end;
+ snot:
+ begin
+ tp := mknode(nnot);
+ tp^.texps := nil;
+ tp := pexpr(tp);
+ next := false
+ end;
+ schar,
+ sinteger,
+ sreal,
+ sstring:
+ tp := mklit;
+ snil:
+ begin
+ usenilp := true;
+ tp := mknode(nnil);
+ end;
+ sid:
+ begin
+ tp := pvariable(oldid(currsym.vid, lidentifier));
+ next := false
+ end;
+ slpar:
+ begin
+ tp := mknode(nuplus);
+ tp^.texps := pexpr(nil)
+ end;
+ slbrack:
+ begin
+ usesets := true;
+ tp := mknode(nset);
+ tp^.texps := nil;
+ tq := nil;
+ repeat
+ if tq = nil then
+ begin
+ tq := pexpr(nil);
+ tp^.texps := tq
+ end
+ else begin
+ tq^.tnext := pexpr(nil);
+ tq := tq^.tnext
+ end
+ until currsym.st = srbrack;
+ end;
+ srbrack:
+ begin
+ tp := mknode(nempty);
+ next := false
+ end
+ end;
+ if next then
+ nextsymbol([
+ scolon, ssemic, scomma, sdotdot, srpar, srbrack,
+ sle, slt, seq, sge, sgt, sne,
+ splus, sminus, smul, sdiv, smod, squot,
+ sand, sor, sinn,
+ send, suntil, sthen, selse, sdo, sdownto, sto,
+ sof, slpar, slbrack]);
+ case currsym.st of
+ sdotdot:
+ nt := nrange;
+ splus:
+ nt := nplus;
+ sminus:
+ nt := nminus;
+ smul:
+ nt := nmul;
+ sdiv:
+ nt := ndiv;
+ smod:
+ nt := nmod;
+ squot:
+ begin
+ defnams[dreal]^.lused := true;
+ nt := nquot;
+ end;
+ sand:
+ nt := nand;
+ sor:
+ nt := nor;
+ sinn:
+ begin
+ nt := nin;
+ usesets := true
+ end;
+ sle:
+ nt := nle;
+ slt:
+ nt := nlt;
+ seq:
+ nt := neq;
+ sge:
+ nt := nge;
+ sgt:
+ nt := ngt;
+ sne:
+ nt := nne;
+ scolon:
+ nt := nformat;
+ sid, schar, sinteger, sreal, sstring, snil,
+ ssemic, scomma, slpar, slbrack, srpar, srbrack,
+ send, suntil, sthen, selse, sdo, sdownto, sto, sof:
+ nt := nnil
+ end;(* case *)
+ if nt in [nin .. nor, nand, nnot] then
+ defnams[dboolean]^.lused := true;
+ if nt <> nnil then
+ begin
+ (* binary operator *)
+ tq := mknode(nt);
+ tq^.texpl := tp;
+ tq^.texpr := nil;
+ tp := pexpr(tq)
+ end;
+
+ (* this statement yilds proper operator precedence *)
+ if tnp <> nil then
+ tp := padjust(tnp, tp);
+ pexpr := tp
+ end;
+
+ (* Parse a case-statement. *)
+ function pcase;
+
+ label 999;
+
+ var tp,
+ tq,
+ tv : treeptr;
+
+ begin
+ tp := mknode(ncase);
+ tp^.tcasxp := pexpr(nil);
+ checksymbol([sof]);
+ tq := nil;
+ repeat
+ if tq = nil then
+ begin
+ tq := mknode(nchoise);
+ tp^.tcaslst := tq
+ end
+ else begin
+ tq^.tnext := mknode(nchoise);
+ tq := tq^.tnext
+ end;
+ tv := nil;
+ repeat
+ nextsymbol([sid, sinteger, schar,
+ splus, sminus, send, sother]);
+ if currsym.st in [send, sother] then
+ goto 999;
+ if tv = nil then
+ begin
+ tv := pconstant(false);
+ tq^.tchocon := tv
+ end
+ else begin
+ tv^.tnext := pconstant(false);
+ tv := tv^.tnext
+ end;
+ nextsymbol([scomma, scolon])
+ until currsym.st = scolon;
+ tq^.tchostmt := plabstmt
+ until currsym.st = send;
+ 999:
+ if currsym.st = sother then
+ begin
+ nextsymbol([scolon, sid, sif, swhile, srepeat, sfor,
+ scase, swith, sbegin, sgoto,
+ selse, ssemic, send, suntil]);
+ if currsym.st = scolon then
+ nextsymbol([sid, sif, swhile, srepeat, sfor,
+ scase, swith, sbegin, sgoto,
+ selse, ssemic, send, suntil]);
+ tp^.tcasother := pstmt
+ end
+ else begin
+ tp^.tcasother := nil;
+ usecase := true
+ end;
+ nextsymbol([ssemic, send, selse, suntil]);
+ pcase := tp
+ end;
+
+ (* Parse an if-statement. *)
+ function pif;
+
+ var tp : treeptr;
+
+ begin
+ tp := mknode(nif);
+ tp^.tifxp := pexpr(nil);
+ checksymbol([sthen]);
+ tp^.tthen := plabstmt;
+ if currsym.st = selse then
+ tp^.telse := plabstmt
+ else
+ tp^.telse := nil;
+ pif := tp;
+ end;
+
+ (* Parse a while-statement. *)
+ function pwhile;
+
+ var tp : treeptr;
+
+ begin
+ tp := mknode(nwhile);
+ tp^.twhixp := pexpr(nil);
+ checksymbol([sdo]);
+ tp^.twhistmt := plabstmt;
+ pwhile := tp;
+ end;
+
+ (* Parse a repeat-statement. *)
+ function prepeat;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ tp := mknode(nrepeat);
+ tq := nil;
+ repeat
+ if tq = nil then
+ begin
+ tq := plabstmt;
+ tp^.treptstmt := tq
+ end
+ else begin
+ tq^.tnext := plabstmt;
+ tq := tq^.tnext
+ end;
+ checksymbol([ssemic, suntil])
+ until currsym.st = suntil;
+ tp^.treptxp := pexpr(nil);
+ prepeat := tp
+ end;
+
+ (* Parse a for-statement. *)
+ function pfor;
+
+ var tp : treeptr;
+
+ begin
+ tp := mknode(nfor);
+ nextsymbol([sid]);
+ tp^.tforid := oldid(currsym.vid, lidentifier);
+ nextsymbol([sassign]);
+ tp^.tfrom := pexpr(nil);
+ checksymbol([sdownto, sto]);
+ tp^.tincr := currsym.st = sto;
+ tp^.tto := pexpr(nil);
+ checksymbol([sdo]);
+ tp^.tforstmt := plabstmt;
+ pfor := tp
+ end;
+
+ (* Parse a with-statement. *)
+ function pwith;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ tp := mknode(nwith);
+ tq := nil;
+ repeat
+ if tq = nil then
+ begin
+ tq := mknode(nwithvar);
+ tp^.twithvar := tq
+ end
+ else begin
+ tq^.tnext := mknode(nwithvar);
+ tq := tq^.tnext
+ end;
+ enterscope(nil);
+ tq^.tenv := currscope;
+ tq^.texpw := pexpr(nil);
+ scopeup(tq^.texpw);
+ checksymbol([scomma, sdo])
+ until currsym.st = sdo;
+ tp^.twithstmt := plabstmt;
+ tq := tp^.twithvar;
+ while tq <> nil do
+ begin
+ leavescope;
+ tq := tq^.tnext
+ end;
+ pwith := tp
+ end;
+
+ (* Parse a goto-statement. *)
+ function pgoto;
+
+ var tp : treeptr;
+
+ begin
+ nextsymbol([sinteger]);
+ tp := mknode(ngoto);
+ tp^.tlabel := oldlbl(false);
+ nextsymbol([ssemic, send, suntil, selse]);
+ pgoto := tp
+ end;
+
+ (* Parse a begin-statement. *)
+ function pbegin;
+
+ var tp,
+ tq : treeptr;
+
+ begin
+ tq := nil;
+ repeat
+ if tq = nil then
+ begin
+ tq := plabstmt;
+ tp := tq
+ end
+ else begin
+ tq^.tnext := plabstmt;
+ tq := tq^.tnext
+ end
+ until currsym.st = send;
+ if retain then
+ begin
+ tq := mknode(nbegin);
+ tq^.tbegin := tp;
+ tp := tq
+ end;
+ nextsymbol([send, selse, suntil, sdot, ssemic]);
+ pbegin := tp
+ end;
+
+ begin (* parse *)
+ nextsymbol([spgm, sconst, stype, svar, sproc, sfunc]);
+ if currsym.st = spgm then
+ top := pprogram
+ else
+ top := pmodule;
+ nextsymbol([seof]);
+ end; (* parse *)
+
+ (* Compute value for a node (which must be some kind of constant). *)
+ function cvalof(tp : treeptr) : integer;
+
+ var v : integer;
+ tq : treeptr;
+
+ begin
+ case tp^.tt of
+ nuplus:
+ cvalof := cvalof(tp^.texps);
+ numinus:
+ cvalof := - cvalof(tp^.texps);
+ nnot:
+ cvalof := 1 - cvalof(tp^.texps);
+ nid:
+ begin
+ tq := idup(tp);
+ if tq = nil then
+ fatal(etree);
+ tp := tp^.tsym^.lsymdecl;
+ case tq^.tt of
+ nscalar:
+ begin
+ v := 0;
+ tq := tq^.tscalid;
+ while tq <> nil do
+ if tq = tp then
+ tq := nil
+ else begin
+ v := v + 1;
+ tq := tq^.tnext
+ end;
+ cvalof := v
+ end;
+ nconst:
+ cvalof := cvalof(tq^.tbind);
+ end;(* case *)
+ end;
+ ninteger:
+ cvalof := tp^.tsym^.linum;
+ nchar:
+ cvalof := ord(tp^.tsym^.lchar);
+ end (* case *)
+ end; (* cvalof *)
+
+ (* Compute lower value of subrange or scalar type. *)
+ function clower(tp : treeptr) : integer;
+
+ var tq : treeptr;
+
+ begin
+ tq := typeof(tp);
+ if tq^.tt = nscalar then
+ clower := scalbase
+ else if tq^.tt = nsubrange then
+ if tq^.tup^.tt = nconfarr then
+ clower := 0
+ else
+ clower := cvalof(tq^.tlo)
+ else if tq = typnods[tchar] then
+ clower := 0
+ else if tq = typnods[tinteger] then
+ clower := -maxint
+ else
+ fatal(etree)
+ end; (* clower *)
+
+ (* Compute upper value of subrange or scalar type. *)
+ function cupper(tp : treeptr) : integer;
+
+ var tq : treeptr;
+ i : integer;
+
+ begin
+ tq := typeof(tp);
+ if tq^.tt = nscalar then
+ begin
+ tq := tq^.tscalid;
+ i := scalbase;
+ while tq^.tnext <> nil do
+ begin
+ i := i + 1;
+ tq := tq^.tnext
+ end;
+ cupper := i
+ end
+ else if tq^.tt = nsubrange then
+ if tq^.tup^.tt = nconfarr then
+ fatal(euprconf)
+ else
+ cupper := cvalof(tq^.thi)
+ else if tq = typnods[tchar] then
+ cupper := maxchar
+ else if tq = typnods[tinteger] then
+ cupper := maxint
+ else
+ fatal(etree)
+ end; (* cupper *)
+
+ (* Compute the number of elements in a subrange. *)
+ function crange(tp : treeptr) : integer;
+
+ begin
+ crange := cupper(tp) - clower(tp) + 1
+ end;
+
+ (* Return number of words uset to store a set. *)
+ function csetwords(i : integer) : integer;
+
+ begin
+ i := (i+(setbits)) div (setbits+1);
+ if i > maxsetrange then
+ error(esetsize);
+ csetwords := i
+ end;
+
+ (* Return number of words uset to store a set. *)
+ function csetsize(tp : treeptr) : integer;
+
+ var tq : treeptr;
+ i : integer;
+
+ begin
+ tq := typeof(tp^.tof);
+ i := clower(tq);
+ (* bits in sets are always numbered from 0, so we (arbitrarily)
+ decide that the base must be in the first 6 words to avoid
+ unnecessary waste of space *)
+ if (i < 0) or (i >= 6 * (setbits+1)) then
+ error(esetbase);
+ csetsize := csetwords(crange(tq)) + 1
+ end;
+
+ (* Determine if tp is declared in the procedure it is used in. *)
+ function islocal(tp : treeptr) : boolean;
+
+ var tq : treeptr;
+
+ begin
+ tq := tp^.tsym^.lsymdecl;
+ while not (tq^.tt in [nproc, nfunc, npgm]) do
+ tq := tq^.tup;
+ while not (tp^.tt in [nproc, nfunc, npgm]) do
+ tp := tp^.tup;
+ islocal := tp = tq
+ end;
+
+ (* Perform necessary transformations on tree and identifiers *)
+ (* before generating code. *)
+ procedure transform;
+
+
+ (* Rename function when used as a variable. *)
+ procedure renamf(tp : treeptr);
+
+ var ip, iq : symptr;
+ tq, tv : treeptr;
+
+ (* This procedure recursively descends the tree *)
+ (* and replaces function-assignments with variable *)
+ (* assignments. *)
+ procedure crtnvar(tp : treeptr);
+
+ begin
+ while tp <> nil do
+ begin
+ case tp^.tt of
+ npgm:
+ crtnvar(tp^.tsubsub);
+ nfunc,
+ nproc:
+ begin
+ crtnvar(tp^.tsubsub);
+ crtnvar(tp^.tsubstmt)
+ end;
+ nbegin:
+ crtnvar(tp^.tbegin);
+ nif:
+ begin
+ crtnvar(tp^.tthen);
+ crtnvar(tp^.telse)
+ end;
+ nwhile:
+ crtnvar(tp^.twhistmt);
+ nrepeat:
+ crtnvar(tp^.treptstmt);
+ nfor:
+ crtnvar(tp^.tforstmt);
+ ncase:
+ begin
+ crtnvar(tp^.tcaslst);
+ crtnvar(tp^.tcasother)
+ end;
+ nchoise:
+ crtnvar(tp^.tchostmt);
+ nwith:
+ crtnvar(tp^.twithstmt);
+ nlabstmt:
+ crtnvar(tp^.tstmt);
+ nassign:
+ begin
+ (* revoke calls in assignment lhs, (mis-
+ parsed due to ambiguous syntax) *)
+ if tp^.tlhs^.tt = ncall then
+ begin
+ tp^.tlhs := tp^.tlhs^.tcall;
+ tp^.tlhs^.tup := tp
+ end;
+ (* function name -> variable name *)
+ tv := tp^.tlhs;
+ if tv^.tt = nid then
+ if tv^.tsym = ip then
+ tv^.tsym := iq
+ end;
+ nbreak,
+ npush,
+ npop,
+ ngoto,
+ nempty,
+ ncall:
+ (* no op *)
+ end;(* case *)
+ tp := tp^.tnext
+ end
+ end;
+
+ begin (* renamf *)
+ while tp <> nil do
+ begin
+ case tp^.tt of
+ npgm,
+ nproc:
+ renamf(tp^.tsubsub);
+ nfunc:
+ begin
+ (* create a variable to hold return value *)
+ tq := mknode(nvar);
+ tq^.tattr := aregister;
+ tq^.tup := tp;
+ tq^.tidl := newid(mkvariable('R'));
+ tq^.tidl^.tup := tq;
+ tq^.tbind := tp^.tfuntyp;
+ (* put it FIRST among variables, see esubr() *)
+ tq^.tnext := tp^.tsubvar;
+ tp^.tsubvar := tq;
+
+ iq := tq^.tidl^.tsym;
+ ip := tp^.tsubid^.tsym;
+ crtnvar(tp^.tsubsub);
+ crtnvar(tp^.tsubstmt);
+ (* process inner functions *)
+ renamf(tp^.tsubsub)
+ end;
+ end;(* case *)
+ tp := tp^.tnext
+ end
+ end; (* renamf *)
+
+ (* This procedure rearranges the tree such that multiple *)
+ (* vardeclarations don't have (structured) types attached *)
+ (* to them. If such a declararation is found, a new name *)
+ (* is created and the type is moved to the type section. *)
+ procedure extract(tp : treeptr);
+
+ var vp : treeptr;
+
+ (* Create a declaration for tp, enter in pp type- *)
+ (* list and return an identifier referencing it. *)
+ function xtrit(tp, pp : treeptr; last : boolean) : treeptr;
+
+ var np, rp : treeptr;
+ ip : idptr;
+
+ begin
+ (* create new declaration *)
+ np := mknode(ntype);
+ ip := mkvariable('T');
+ np^.tidl := newid(ip);
+ np^.tidl^.tup := np;
+
+ (* create substitute id *)
+ rp := oldid(ip, lidentifier);
+ rp^.tup := tp^.tup;
+ rp^.tnext := tp^.tnext;
+
+ (* steal type description *)
+ np^.tbind := tp;
+ tp^.tup := np;
+ tp^.tnext := nil;
+
+ (* add new declaration to tree *)
+ np^.tup := pp;
+ if last and (pp^.tsubtype <> nil) then
+ begin
+ pp := pp^.tsubtype;
+ while pp^.tnext <> nil do
+ pp := pp^.tnext;
+ pp^.tnext := np
+ end
+ else begin
+ np^.tnext := pp^.tsubtype;
+ pp^.tsubtype := np;
+ end;
+
+ xtrit := rp;
+ end;
+
+ (* Extract anonymous enumeration types. *)
+ function xtrenum(tp, pp : treeptr) : treeptr;
+
+ (* Name record-types referenced by ptrs. *)
+ procedure nametype(tp : treeptr);
+
+ begin
+ tp := typeof(tp);
+ if tp^.tt = nrecord then
+ if tp^.tuid = nil then
+ tp^.tuid := mkvariable('S');
+ end;
+
+ begin
+ if tp <> nil then
+ begin
+ case tp^.tt of
+ nfield,
+ ntype,
+ nvar:
+ tp^.tbind :=
+ xtrenum(tp^.tbind, pp);
+
+ nscalar:
+ if tp^.tup^.tt <> ntype then
+ tp := xtrit(tp, pp, false);
+
+ narray:
+ begin
+ tp^.taindx := xtrenum(tp^.taindx, pp);
+ tp^.taelem := xtrenum(tp^.taelem, pp);
+ end;
+ nrecord:
+ begin
+ tp^.tflist := xtrenum(tp^.tflist, pp);
+ tp^.tvlist := xtrenum(tp^.tvlist, pp);
+ end;
+ nvariant:
+ tp^.tvrnt := xtrenum(tp^.tvrnt, pp);
+ nfileof:
+ tp^.tof := xtrenum(tp^.tof, pp);
+
+ nptr:
+ nametype(tp^.tptrid);
+
+ nid,
+ nsubrange,
+ npredef,
+ nempty,
+ nsetof:
+ (* no op *)
+ end;(* case *)
+ tp^.tnext := xtrenum(tp^.tnext, pp)
+ end;
+ xtrenum := tp
+ end;
+
+ begin (* extract *)
+ while tp <> nil do
+ begin
+ (* tp points to a program/procedure/function node *)
+ tp^.tsubtype := xtrenum(tp^.tsubtype, tp);
+ tp^.tsubvar := xtrenum(tp^.tsubvar, tp);
+ vp := tp^.tsubvar;
+ while vp <> nil do
+ begin
+ (* variables of structured unnamed types *)
+ if vp^.tbind^.tt in [nscalar, narray,
+ nrecord, nfileof] then
+ vp^.tbind := xtrit(vp^.tbind, tp, true);
+ vp := vp^.tnext
+ end;
+ extract(tp^.tsubsub);
+ tp := tp^.tnext
+ end
+ end; (* extract *)
+
+ (* This procedure moves all local constants and types *)
+ (* used in nested procedures to the outermost declaration *)
+ (* level so that nested procedures may be extracted. *)
+ procedure global(tp, dp : treeptr; depend : boolean);
+
+ label 555;
+
+ var ip : treeptr;
+ dep : boolean;
+
+ (* Mark all declared identifiers as unused. *)
+ procedure markdecl(xp : treeptr);
+
+ begin
+ while xp <> nil do
+ begin
+ case xp^.tt of
+ nid:
+ xp^.tsym^.lused := false;
+ nconst:
+ markdecl(xp^.tidl);
+ ntype,
+ nvar,
+ nvalpar,
+ nvarpar,
+ nfield:
+ begin
+ markdecl(xp^.tidl);
+ if xp^.tbind^.tt <> nid then
+ markdecl(xp^.tbind)
+ end;
+ nscalar:
+ markdecl(xp^.tscalid);
+ nrecord:
+ begin
+ markdecl(xp^.tflist);
+ markdecl(xp^.tvlist)
+ end;
+ nvariant:
+ markdecl(xp^.tvrnt);
+ nconfarr:
+ if xp^.tcelem^.tt <> nid then
+ markdecl(xp^.tcelem);
+ narray:
+ if xp^.taelem^.tt <> nid then
+ markdecl(xp^.taelem);
+ nsetof,
+ nfileof:
+ if xp^.tof^.tt <> nid then
+ markdecl(xp^.tof);
+ nparproc,
+ nparfunc:
+ markdecl(xp^.tparid);
+ nptr,
+ nsubrange:
+ (* no op *)
+ end;(* case *)
+ xp := xp^.tnext
+ end
+ end; (* markdecl *)
+
+ (* Move all marked declarations to global scope. *)
+ function movedecl(tp : treeptr) : treeptr;
+
+ var ip, np : treeptr;
+ sp : symptr;
+ move : boolean;
+
+ begin
+ if tp <> nil then
+ begin
+ move := false;
+ case tp^.tt of
+ nconst,
+ ntype:
+ ip := tp^.tidl
+ end;(* case *)
+ while ip <> nil do
+ begin
+ if ip^.tsym^.lused then
+ begin
+ move := true;
+ sp := ip^.tsym;
+ if sp^.lid^.inref > 1 then
+ begin
+ sp^.lid :=
+ mkrename( 'M', sp^.lid);
+ sp^.lid^.inref :=
+ sp^.lid^.inref - 1
+ end;
+ ip := nil
+ end
+ else
+ ip := ip^.tnext
+ end;
+ if move then
+ begin
+ np := tp^.tnext;
+ tp^.tnext := nil;
+ ip := tp;
+ while ip^.tt <> npgm do
+ ip := ip^.tup;
+ tp^.tup := ip;
+ case tp^.tt of
+ nconst:
+ begin
+ if ip^.tsubconst = nil then
+ ip^.tsubconst := tp
+ else begin
+ ip := ip^.tsubconst;
+ while ip^.tnext <> nil
+ do ip := ip^.tnext;
+ ip^.tnext := tp
+ end
+ end;
+ ntype:
+ begin
+ if ip^.tsubtype = nil then
+ ip^.tsubtype := tp
+ else begin
+ ip := ip^.tsubtype;
+ while ip^.tnext <> nil
+ do ip := ip^.tnext;
+ ip^.tnext := tp
+ end
+ end
+ end;(* case *)
+ (* tp is moved, drop it and process
+ remainder of declarationlist *)
+ tp := movedecl(np)
+ end
+ else
+ tp^.tnext := movedecl(tp^.tnext)
+ end;
+ movedecl := tp
+ end; (* movedecl *)
+
+ (* This procedure lifts out variables/parameters *)
+ (* used in nested procedures/functions. *)
+ procedure movevars(tp, vp : treeptr);
+
+ label 555;
+
+ var ep, dp, np : treeptr;
+ ip : idptr;
+ sp : symptr;
+
+ (* Move a variable declaration to global *)
+ (* var declaration lists. *)
+ procedure moveglob(tp, dp : treeptr);
+
+ begin
+ while tp^.tt <> npgm do
+ tp := tp^.tup;
+ dp^.tup := tp;
+ dp^.tnext := tp^.tsubvar;
+ tp^.tsubvar := dp
+ end;
+
+ (* Create nodes for saving a global *)
+ (* pointer variable. *)
+ function stackop(decl, glob, loc : treeptr) : treeptr;
+
+ var op, ip, dp, tp : treeptr;
+
+ begin
+ (* create a new variable to hold old value
+ of the global variable during a call *)
+ ip := newid(mkvariable('F'));
+ case vp^.tt of
+ nvarpar,
+ nvalpar,
+ nvar:
+ begin
+ dp := mknode(nvarpar);
+ dp^.tattr := areference;
+ dp^.tidl := ip;
+ (* use same type as the global var *)
+ dp^.tbind := decl^.tbind
+ end;
+ nparproc,
+ nparfunc:
+ begin
+ dp := mknode(vp^.tt);
+ dp^.tparid := ip;
+ dp^.tparparm := nil;
+ dp^.tpartyp := vp^.tpartyp
+ end
+ end;(* case *)
+ ip^.tup := dp;
+
+ (* add variable to declarationlists *)
+ tp := decl;
+ while not (tp^.tt in [nproc, nfunc, npgm]) do
+ tp := tp^.tup;
+ dp^.tup := tp;
+ if tp^.tsubvar = nil then
+ tp^.tsubvar := dp
+ else begin
+ tp := tp^.tsubvar;
+ while tp^.tnext <> nil do
+ tp := tp^.tnext;
+ tp^.tnext := dp
+ end;
+ dp^.tnext := nil;
+
+ (* create an assignment saving value *)
+ op := mknode(npush);
+ op^.tglob := glob;
+ op^.tloc := loc;
+ op^.ttmp := ip;
+ stackop := op
+ end;
+
+ (* Take a "push" node, create "pop" node *)
+ (* and add both to tree. *)
+ procedure addcode(tp, push : treeptr);
+
+ var pop : treeptr;
+
+ begin
+ pop := mknode(npop);
+ (* share variables with "push"-node *)
+ pop^.tglob := push^.tglob;
+ pop^.ttmp := push^.ttmp;
+ pop^.tloc := nil;
+
+ (* add npush to head of statement list *)
+ push^.tnext := tp^.tsubstmt;
+ tp^.tsubstmt := push;
+ push^.tup := tp;
+
+ (* add npop to end of statement list *)
+ while push^.tnext <> nil do
+ push := push^.tnext;
+ push^.tnext := pop;
+ pop^.tup := tp
+ end;
+
+ begin (* movevars *)
+ while vp <> nil do
+ begin
+ case vp^.tt of
+ nvar,
+ nvalpar,
+ nvarpar:
+ dp := vp^.tidl;
+ nparproc,
+ nparfunc:
+ begin
+ dp := vp^.tparid;
+ if dp^.tsym^.lused then
+ begin
+ (* create a var declaration *)
+ ep := mknode(vp^.tt);
+ ep^.tparparm := nil;
+ ep^.tpartyp := vp^.tpartyp;
+ np := newid(mkrename('G',
+ dp^.tsym^.lid));
+ ep^.tparid := np;
+ np^.tup := ep;
+ (* swap id's and symbols *)
+ sp := np^.tsym;
+ ip := sp^.lid;
+ np^.tsym^.lid := dp^.tsym^.lid;
+ dp^.tsym^.lid := ip;
+ np^.tsym := dp^.tsym;
+ dp^.tsym := sp;
+ np^.tsym^.lsymdecl := np;
+ dp^.tsym^.lsymdecl := dp;
+ (* make declaration global *)
+ moveglob(tp, ep);
+ (* add save/restore-code *)
+ addcode(tp, stackop(vp, np, dp))
+ end;
+ goto 555
+ end
+ end;(* case *)
+ while dp <> nil do
+ begin
+ if dp^.tsym^.lused then
+ begin
+ (* create a varpar declaration,
+ (nvarpar will cause emit to
+ treat the new identifier
+ as a pointer) *)
+ ep := mknode(nvarpar);
+ ep^.tattr := areference;
+ np := newid(mkrename('G',
+ dp^.tsym^.lid));
+ ep^.tidl := np;
+ np^.tup := ep;
+ ep^.tbind := vp^.tbind;
+ if ep^.tbind^.tt = nid then
+ ep^.tbind^.tsym^.lused
+ := true;
+ (* swap id's and symbols *)
+ sp := np^.tsym;
+ ip := sp^.lid;
+ np^.tsym^.lid := dp^.tsym^.lid;
+ dp^.tsym^.lid := ip;
+ np^.tsym := dp^.tsym;
+ dp^.tsym := sp;
+ np^.tsym^.lsymdecl := np;
+ dp^.tsym^.lsymdecl := dp;
+ (* note that dp is referenced *)
+ dp^.tup^.tattr := aextern;
+ (* make declaration global *)
+ moveglob(tp, ep);
+ (* add save/restore-code *)
+ addcode(tp, stackop(vp, np, dp))
+ end;
+ dp := dp^.tnext
+ end;
+ 555:
+ vp := vp^.tnext
+ end
+ end; (* movevars *)
+
+ (* Break out a local variable and set the register *)
+ (* attribute. *)
+ procedure registervar(tp : treeptr);
+
+ var vp, xp : treeptr;
+
+ begin
+ vp := idup(tp);
+ tp := tp^.tsym^.lsymdecl;
+ (* vp points to nvar node *)
+ if (vp^.tidl <> tp) or (tp^.tnext <> nil) then
+ begin
+ (* tp is not alone in list of identifiers,
+ create a new nvar-node and hook up tp *)
+ xp := mknode(nvar);
+ xp^.tattr := anone;
+ xp^.tidl := tp;
+ tp^.tup := xp;
+ (* enter new nvar node among declarations *)
+ xp^.tup := vp^.tup;
+ xp^.tbind := vp^.tbind; (* borrow type *)
+ xp^.tnext := vp^.tnext;
+ vp^.tnext := xp;
+ (* break tp out of list of identifiers *)
+ if vp^.tidl = tp then
+ vp^.tidl := tp^.tnext
+ else begin
+ vp := vp^.tidl;
+ while vp^.tnext <> tp do
+ vp := vp^.tnext;
+ vp^.tnext := tp^.tnext
+ end;
+ tp^.tnext := nil
+ end;
+ (* tp is alone in this declaration, set attribute *)
+ if tp^.tup^.tattr = anone then
+ tp^.tup^.tattr := aregister
+ end; (* registervar *)
+
+ (* Check static declarationlevel for a label *)
+ (* used in a non-local goto. *)
+ procedure cklevel(tp : treeptr);
+
+ begin
+ tp := tp^.tsym^.lsymdecl;
+ while not(tp^.tt in [npgm, nproc, nfunc]) do
+ tp := tp^.tup;
+ if tp^.tstat > maxlevel then
+ maxlevel := tp^.tstat
+ end;
+
+ begin (* global *)
+ while tp <> nil do
+ begin
+ case tp^.tt of
+ nproc,
+ nfunc:
+ begin
+ (* procid/parameters/const/type/var not used *)
+ markdecl(tp^.tsubid);
+ markdecl(tp^.tsubpar);
+ markdecl(tp^.tsubconst);
+ markdecl(tp^.tsubtype);
+ markdecl(tp^.tsubvar);
+
+ (* mark those used in nested subroutines *)
+ global(tp^.tsubsub, tp, false);
+
+ (* move out variables used in inner scope *)
+ movevars(tp, tp^.tsubpar);
+ movevars(tp, tp^.tsubvar);
+ (* move out const/type used in inner scope *)
+ tp^.tsubtype := movedecl(tp^.tsubtype);
+ tp^.tsubconst := movedecl(tp^.tsubconst);
+
+ (* mark identifiers used in this subroutine *)
+ global(tp^.tsubstmt, tp, true);
+ global(tp^.tsubpar, tp, false);
+ global(tp^.tsubvar, tp, false);
+ global(tp^.tsubtype, tp, false);
+ global(tp^.tfuntyp, tp, false);
+ end;
+
+ npgm:
+ begin
+ markdecl(tp^.tsubconst);
+ markdecl(tp^.tsubtype);
+ markdecl(tp^.tsubvar);
+ global(tp^.tsubsub, tp, false);
+ global(tp^.tsubstmt, tp, true)
+ end;
+
+ nconst,
+ ntype,
+ nvar,
+ nfield,
+ nvalpar,
+ nvarpar:
+ begin
+ ip := tp^.tidl;
+ dep := depend;
+ while (ip <> nil) and not dep do
+ begin
+ (* for all used identifiers, propagate
+ the use to their bindings *)
+ if ip^.tsym^.lused then
+ dep := true;
+ ip := ip^.tnext
+ end;
+ global(tp^.tbind, dp, dep);
+ end;
+ nparproc,
+ nparfunc:
+ begin
+ global(tp^.tparparm, dp, depend);
+ global(tp^.tpartyp, dp, depend)
+ end;
+ nsubrange:
+ begin
+ global(tp^.tlo, dp, depend);
+ global(tp^.thi, dp, depend)
+ end;
+ nvariant:
+ begin
+ global(tp^.tselct, dp, depend);
+ global(tp^.tvrnt, dp, depend)
+ end;
+ nrecord:
+ begin
+ global(tp^.tflist, dp, depend);
+ global(tp^.tvlist, dp, depend)
+ end;
+ nconfarr:
+ begin
+ global(tp^.tcindx, dp, depend);
+ global(tp^.tcelem, dp, depend)
+ end;
+ narray:
+ begin
+ global(tp^.taindx, dp, depend);
+ global(tp^.taelem, dp, depend)
+ end;
+ nfileof,
+ nsetof:
+ global(tp^.tof, dp, depend);
+ nptr:
+ global(tp^.tptrid, dp, depend);
+ nscalar:
+ global(tp^.tscalid, dp, depend);
+ nbegin:
+ global(tp^.tbegin, dp, depend);
+ nif:
+ begin
+ global(tp^.tifxp, dp, depend);
+ global(tp^.tthen, dp, depend);
+ global(tp^.telse, dp, depend)
+ end;
+ nwhile:
+ begin
+ global(tp^.twhixp, dp, depend);
+ global(tp^.twhistmt, dp, depend)
+ end;
+ nrepeat:
+ begin
+ global(tp^.treptstmt, dp, depend);
+ global(tp^.treptxp, dp, depend)
+ end;
+ nfor:
+ begin
+ ip := idup(tp^.tforid);
+ if ip^.tup^.tt in [nproc, nfunc] then
+ registervar(tp^.tforid);
+ global(tp^.tforid, dp, depend);
+ global(tp^.tfrom, dp, depend);
+ global(tp^.tto, dp, depend);
+ global(tp^.tforstmt, dp, depend)
+ end;
+ ncase:
+ begin
+ global(tp^.tcasxp, dp, depend);
+ global(tp^.tcaslst, dp, depend);
+ global(tp^.tcasother, dp, depend)
+ end;
+ nchoise:
+ begin
+ global(tp^.tchocon, dp, depend);
+ global(tp^.tchostmt, dp, depend);
+ end;
+ nwith:
+ begin
+ global(tp^.twithvar, dp, depend);
+ global(tp^.twithstmt, dp, depend)
+ end;
+ nwithvar:
+ begin
+ ip := typeof(tp^.texpw);
+ if ip^.tuid = nil then
+ ip^.tuid := mkvariable('S');
+ global(tp^.texpw, dp, depend);
+ end;
+ nlabstmt:
+ global(tp^.tstmt, dp, depend);
+ neq, nne, nlt, nle, ngt, nge:
+ begin
+ global(tp^.texpl, dp, depend);
+ global(tp^.texpr, dp, depend);
+ ip := typeof(tp^.texpl);
+ if (ip = typnods[tstring]) or
+ (ip^.tt = narray) then
+ usecomp := true;
+ ip := typeof(tp^.texpr);
+ if (ip = typnods[tstring]) or
+ (ip^.tt = narray) then
+ usecomp := true
+ end;
+ nin, nor, nplus, nminus,
+ nand, nmul, ndiv, nmod, nquot,
+ nformat, nrange:
+ begin
+ global(tp^.texpl, dp, depend);
+ global(tp^.texpr, dp, depend)
+ end;
+
+ nassign:
+ begin
+ global(tp^.tlhs, dp, depend);
+ global(tp^.trhs, dp, depend)
+ end;
+
+ nnot,
+ numinus,
+ nuplus,
+ nderef:
+ global(tp^.texps, dp, depend);
+ nset:
+ global(tp^.texps, dp, depend);
+ nindex:
+ begin
+ global(tp^.tvariable, dp, depend);
+ global(tp^.toffset, dp, depend)
+ end;
+ nselect:
+ global(tp^.trecord, dp, depend);
+ ncall:
+ begin
+ global(tp^.tcall, dp, depend);
+ global(tp^.taparm, dp, depend)
+ end;
+ nid:
+ begin
+ (* find declaration point *)
+ ip := idup(tp);
+ if ip = nil then
+ goto 555;
+ (* ip points to nconst/ntype/nvar/nproc/nfunc/
+ nvalpar/nvarpar/nparproc or nparfunc node,
+ move to beginning of enclosing scope *)
+ repeat
+ ip := ip^.tup;
+ if ip = nil then
+ goto 555
+ (* stop only for locally declared items,
+ for global or predefined identifiers
+ we will have gone to label 555 *)
+ until ip^.tt in [npgm, nproc, nfunc];
+ if dp = ip then
+ begin
+ (* identifier used here, mark it used *)
+ if depend then
+ tp^.tsym^.lused := true
+ end
+ else begin
+ (* identifier declared in enclosing
+ scope, mark it used *)
+ tp^.tsym^.lused := true
+ end;
+ 555:
+ end;
+ ngoto:
+ if not islocal(tp^.tlabel) then
+ begin
+ tp^.tlabel^.tsym^.lgo := true;
+ usejmps := true;
+ cklevel(tp^.tlabel)
+ end;
+
+ nbreak,
+ npush,
+ npop,
+ npredef,
+ nempty,
+ nchar,
+ ninteger,
+ nreal,
+ nstring,
+ nnil:
+ end;(* case *)
+ tp := tp^.tnext
+ end
+ end; (* global *)
+
+ (* Rename identifiers identical to C keywords. *)
+ procedure renamc;
+
+ var ip : idptr;
+ cn : cnames;
+
+ begin
+ (* rename identifiers that mustn't be redefined
+ if C and Pascal semantix are to be preserved *)
+ for cn := cabort to cwrite do
+ begin
+ ip := mkrename('C', ctable[cn]);
+ ctable[cn]^.istr := ip^.istr
+ end
+ end;
+
+ (* Rename subroutines declared in other subroutines such *)
+ (* that they can be moved to a global scope without name- *)
+ (* clashes. *)
+ procedure renamp(tp : treeptr; on : boolean);
+
+ var sp : symptr;
+
+ begin
+ (* tp points to subroutine-list *)
+ while tp <> nil do
+ begin
+ renamp(tp^.tsubsub, true);
+ if on and (tp^.tsubstmt <> nil) then
+ begin
+ (* change name of subroutine by prefixing
+ a unique name *)
+ sp := tp^.tsubid^.tsym;
+ if sp^.lid^.inref > 1 then
+ begin
+ sp^.lid := mkrename('P', sp^.lid);
+ sp^.lid^.inref := sp^.lid^.inref - 1
+ end
+ end;
+ tp := tp^.tnext
+ end
+ end;
+
+ (* Add initialization-code for file-variables. *)
+ procedure initcode(tp : treeptr);
+
+ var ti, tq, tu, tv : treeptr;
+
+ (* Determine if a type contains a file. *)
+ function filevar(tp : treeptr) : boolean;
+
+ var fv : boolean;
+ tq : treeptr;
+
+ begin
+ case tp^.tt of
+ npredef:
+ fv := tp = typnods[ttext];
+ nfileof:
+ fv := true;
+ nconfarr:
+ fv := filevar(typeof(tp^.tcelem));
+ narray:
+ fv := filevar(typeof(tp^.taelem));
+ nrecord:
+ begin
+ fv := false;
+ tq := tp^.tvlist;
+ while tq <> nil do
+ begin
+ if filevar(tq^.tvrnt) then
+ error(evrntfile);
+ tq := tq^.tnext
+ end;
+ tq := tp^.tflist;
+ while tq <> nil do
+ begin
+ if filevar(typeof(tq^.tbind)) then
+ begin
+ fv := true;
+ tq := nil
+ end
+ else
+ tq := tq^.tnext
+ end
+ end;
+ nptr:
+ begin
+ fv := false;
+ if not tp^.tptrflag then
+ begin
+ tp^.tptrflag := true;
+ if filevar(typeof(tp^.tptrid)) then
+ error(evarfile);
+ tp^.tptrflag := false
+ end
+ end;
+ nsubrange,
+ nscalar,
+ nsetof:
+ fv := false
+ end;
+ filevar := fv
+ end;
+
+ (* Create code for initialization of files. *)
+ function fileinit(ti, tq : treeptr; opn : boolean) : treeptr;
+
+ var tx, ty, tz : treeptr;
+
+ begin
+ (* create 1 statement initializing "ti" *)
+ case tq^.tt of
+ narray:
+ begin
+ (* create declaration for a loopvariable *)
+ tz := newid(mkvariable('I'));
+ ty := mknode(nvar);
+ ty^.tattr := aregister;
+ ty^.tidl := tz;
+ ty^.tbind := typeof(tq^.taindx);
+ tz := tq;
+ while not(tz^.tt in [nproc, nfunc, npgm]) do
+ tz := tz^.tup;
+ linkup(tz, ty);
+ if tz^.tsubvar = nil then
+ tz^.tsubvar := ty
+ else begin
+ tz := tz^.tsubvar;
+ while tz^.tnext <> nil do
+ tz := tz^.tnext;
+ tz^.tnext := ty
+ end;
+ ty := ty^.tidl;
+ (* create a loop initializing tq *)
+ tz := mknode(nindex);
+ tz^.tvariable := ti;
+ tz^.toffset := ty;
+ tz := fileinit(tz, tq^.taelem, opn);
+ tx := mknode(nfor);
+ tx^.tforid := ty;
+ ty := typeof(tq^.taindx);
+ if ty^.tt = nsubrange then
+ begin
+ tx^.tfrom := ty^.tlo;
+
+ tx^.tto := ty^.thi
+ end
+ else if ty^.tt = nscalar then
+ begin
+ ty := ty^.tscalid;
+ tx^.tfrom := ty;
+ while ty^.tnext <> nil do
+ ty := ty^.tnext;
+ tx^.tto := ty
+ end
+ else if ty = typnods[tchar] then
+ begin
+ currsym.st := schar;
+ currsym.vchr := chr(minchar);
+ tx^.tfrom := mklit;
+ currsym.st := schar;
+ currsym.vchr := chr(maxchar);
+ tx^.tto := mklit
+ end
+ else if ty = typnods[tinteger] then
+ begin
+ currsym.st := sinteger;
+ currsym.vint := -maxint;
+ tx^.tfrom := mklit;
+ currsym.st := sinteger;
+ currsym.vint := maxint;
+ tx^.tto := mklit
+ end
+ else
+ fatal(etree);
+ tx^.tforstmt := tz;
+ tx^.tincr := true
+ end;
+ npredef,
+ nfileof:
+ if opn then
+ begin
+ (* create file-struct initialization *)
+ ty := mknode(nselect);
+ ty^.trecord := ti;
+ ty^.tfield :=
+ oldid(defnams[dzinit]^.lid,
+ lforward);
+ tx := mknode(nassign);
+ tx^.tlhs := ty;
+ currsym.st := sinteger;
+ currsym.vint := 0;
+ tx^.trhs := mklit
+ end
+ else begin
+ (* create file-struct wrapup *)
+ tx := mknode(ncall);
+ tx^.tcall :=
+ oldid(defnams[dclose]^.lid,
+ lidentifier);
+ tx^.taparm := ti
+ end;
+ nrecord:
+ begin
+ ty := nil;
+ tq := tq^.tflist;
+ while tq <> nil do
+ begin
+ if filevar(typeof(tq^.tbind)) then
+ begin
+ tz := tq^.tidl;
+ while tz <> nil do
+ begin
+ tx := mknode(nselect);
+ tx^.trecord := ti;
+ tx^.tfield := tz;
+ tx := fileinit(tx,
+ typeof(tq^.tbind),
+ opn);
+ tx^.tnext := ty;
+ ty := tx;
+ tz := tz^.tnext
+ end
+ end;
+ tq := tq^.tnext
+ end;
+ tx := mknode(nbegin);
+ tx^.tbegin := ty
+ end;
+ end;(* case *)
+ fileinit := tx
+ end;
+
+ begin (* initcode *)
+ while tp <> nil do
+ begin
+ initcode(tp^.tsubsub);
+ tv := tp^.tsubvar;
+ while tv <> nil do
+ begin
+ tq := typeof(tv^.tbind);
+ if filevar(tq) then
+ begin
+ ti := tv^.tidl;
+ while ti <> nil do
+ begin
+ tu := fileinit(ti, tq, true);
+ linkup(tp, tu);
+ tu^.tnext := tp^.tsubstmt;
+ tp^.tsubstmt := tu;
+ while tu^.tnext <> nil do
+ tu := tu^.tnext;
+ tu^.tnext := fileinit(ti, tq,
+ false);
+ linkup(tp, tu^.tnext);
+ ti := ti^.tnext
+ end
+ end;
+ tv := tv^.tnext;
+ end;
+ tp := tp^.tnext
+ end
+ end; (* initcode *)
+
+ begin (* transform *)
+ renamc;
+ renamp(top^.tsubsub, false);
+ extract(top);
+ renamf(top);
+ initcode(top^.tsubsub);
+ global(top, top, false)
+ end; (* transform *)
+
+ (* Emit C-code for program or module. *)
+ procedure emit;
+
+ const include = '# include ';
+ define = '# define ';
+ ifdef = '# ifdef ';
+ ifndef = '# ifndef ';
+ elsif = '# else';
+ endif = '# endif';
+ static = 'static ';
+ xtern = 'extern ';
+ typdef = 'typedef ';
+ registr = 'register ';
+ usigned = 'unsigned ';
+ indstep = 8;
+
+ var conflag,
+ setused,
+ dropset,
+ donearr : boolean;
+ doarrow,
+ indnt : integer;
+
+ procedure increment;
+ begin
+ indnt := indnt + indstep
+ end;
+
+ procedure decrement;
+ begin
+ indnt := indnt - indstep
+ end;
+
+ (* Write tabs/blanks to properly (?) indent C-code. *)
+ procedure indent;
+
+ var i : integer;
+
+ begin
+ i := indnt;
+ (* limit indent to an integral number of tabs *)
+ if i > 60 then
+ i := i div tabwidth * tabwidth;
+ while i >= tabwidth do
+ begin
+ write(tab1);
+ i := i - tabwidth
+ end;
+ while i > 0 do
+ begin
+ write(space);
+ i := i - 1
+ end;
+ end;
+
+ (* Determine if tp must be cast to an integer before being *)
+ (* used in an arithmetic expression. *)
+ function arithexpr(tp : treeptr) : boolean;
+
+ begin
+ tp := typeof(tp);
+ if tp^.tt = nsubrange then
+ if tp^.tup^.tt = nconfarr then
+ tp := typeof(tp^.tup^.tindtyp)
+ else
+ tp := typeof(tp^.tlo);
+ arithexpr := (tp = typnods[tinteger]) or
+ (tp = typnods[tchar]) or
+ (tp = typnods[treal])
+ end;
+
+ procedure eexpr(tp : treeptr); forward;
+ procedure etypedef(tp : treeptr); forward;
+
+ (* Emit code to select a record member. *)
+ procedure eselect(tp : treeptr);
+
+ begin
+ doarrow := doarrow + 1;
+ eexpr(tp);
+ doarrow := doarrow - 1;
+ if donearr then
+ donearr := false
+ else
+ write('.')
+ end;
+
+ (* Emit code for call to a predefined function/procedure. *)
+ procedure epredef(ts, tp : treeptr);
+
+ label 444, 555;
+
+ var tq,
+ tv, tx : treeptr;
+ td : predefs;
+ nelems : integer;
+ ch : char;
+ txtfile : boolean;
+
+ (* Determine a format-code for fprintf. *)
+ (* Update nelems as a sideeffect. *)
+ function typeletter(tp : treeptr) : char;
+
+ label 999;
+
+ var tq : treeptr;
+
+ begin
+ tq := tp;
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpl^.tt = nformat then
+ begin
+ typeletter := 'f';
+ goto 999
+ end;
+ tq := tp^.texpl
+ end;
+ tq := typeof(tq);
+ if tq^.tt = nsubrange then
+ tq := typeof(tq^.tlo);
+ if tq = typnods[tstring] then
+ typeletter := 's'
+ else if tq = typnods[tinteger] then
+ typeletter := 'd'
+ else if tq = typnods[tchar] then
+ typeletter := 'c'
+ else if tq = typnods[treal] then
+ if tp^.tt = nformat then
+ typeletter := 'e'
+ else
+ typeletter := 'g'
+ else if tq = typnods[tboolean] then
+ begin
+ typeletter := 'b';
+ nelems := 6
+ end
+ else if tq^.tt = narray then
+ begin
+ typeletter := 'a';
+ nelems := crange(tq^.taindx)
+ end
+ else if tq^.tt = nconfarr then
+ begin
+ typeletter := 'v';
+ nelems := 0
+ end
+ else
+ fatal(etree);
+ 999:
+ end; (* typeletter *)
+
+ procedure etxt(tp : treeptr);
+
+ var w : toknbuf;
+ c : char;
+ i : toknidx;
+
+ begin
+ case tp^.tt of
+ nid:
+ begin
+ tp := idup(tp);
+ if tp^.tt = nconst then
+ etxt(tp^.tbind)
+ else
+ fatal(etree)
+ end;
+ nstring:
+ begin
+ (* printf format string *)
+ gettokn(tp^.tsym^.lstr, w);
+ i := 1;
+ while w[i] <> chr(null) do
+ begin
+ c := w[i];
+ if (c = cite) or (c = bslash) then
+ write(bslash)
+ else if c = percent then
+ write(percent);
+ write(c);
+ i := i + 1
+ end
+ end;
+ nchar:
+ begin
+ (* single character in printf format *)
+ c := tp^.tsym^.lchar;
+ if (c = cite) or (c = bslash) then
+ write(bslash)
+ else if c = percent then
+ write(percent);
+ write(c)
+ end;
+ end;(* case *)
+ end; (* etxt *)
+
+ (* Emit format for fprintf. *)
+ procedure eformat(tq : treeptr);
+
+ var tx : treeptr;
+ i : integer;
+
+ begin
+ case typeletter(tq) of
+ 'a':
+ begin
+ write(percent);
+ if tq^.tt = nformat then
+ if tq^.texpr^.tt = ninteger then
+ eexpr(tq^.texpr)
+ else
+ write('*');
+ write('.', nelems:1, 's')
+ end;
+ 'b':
+ begin
+ write(percent);
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpr^.tt = ninteger then
+ eexpr(tq^.texpr)
+ else
+ write('*')
+ end;
+ write('s')
+ end;
+ 'c':
+ if tq^.tt = nchar then
+ etxt(tq)
+ else begin
+ write(percent);
+ if tq^.tt = nformat then
+ if tq^.texpr^.tt = ninteger then
+ eexpr(tq^.texpr)
+ else
+ write('*');
+ write('c')
+ end;
+ 'd':
+ begin
+ write(percent);
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpr^.tt = ninteger then
+ eexpr(tq^.texpr)
+ else
+ write('*')
+ end
+ else
+ write(intlen:1);
+ write('d')
+ end;
+ 'e':
+ begin
+ write(percent, space);
+ tx := tq^.texpr;
+ if tx^.tt = ninteger then
+ begin
+ i := cvalof(tx);
+ write(i:1, '.');
+ i := i - 7;
+ if i < 1 then
+ write('1')
+ else
+ write(i:1)
+ end
+ else
+ write('*.*');
+ write('e')
+ end;
+ 'f':
+ begin
+ write(percent);
+ tx := tq^.texpl;
+ if tx^.texpr^.tt = ninteger then
+ begin
+ eexpr(tx^.texpr);
+ write('.');
+ tx := tq^.texpr;
+ if tx^.tt = ninteger then
+ begin
+ i := cvalof(tx);
+ tx := tq^.texpl^.texpr;
+ if i > cvalof(tx) - 1 then
+ write('1')
+ else
+ write(i:1)
+ end
+ else
+ write('*');
+ end
+ else
+ write('*.*');
+ write('f')
+ end;
+ 'g':
+ write(percent, fixlen:1, 'e');
+ 's':
+ if tq^.tt = nstring then
+ etxt(tq)
+ else begin
+ write(percent);
+ if tq^.tt = nformat then
+ if tq^.texpr^.tt = ninteger then
+ eexpr(tq^.texpr)
+ else
+ write('*.*');
+ write('s')
+ end
+ end (* case *)
+ end; (* eformat *)
+
+ (* Emit parameters to fprintf except format. *)
+ procedure ewrite(tq : treeptr);
+
+ var tx : treeptr;
+
+ begin
+ case typeletter(tq) of
+ 'a':
+ begin
+ write(', ');
+ tx := tq;
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpr^.tt <> ninteger then
+ begin
+ eexpr(tq^.texpr);
+ write(', ')
+ end;
+ tx := tq^.texpl
+ end;
+ eexpr(tx);
+ write('.A')
+ end;
+ 'b':
+ begin
+ write(', ');
+ tx := tq;
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpr^.tt <> ninteger then
+ begin
+ eexpr(tq^.texpr);
+ write(', ')
+ end;
+ tx := tq^.texpl
+ end;
+ usebool := true;
+ write('Bools[(int)(');
+ eexpr(tx);
+ write(')]')
+ end;
+ 'c':
+ begin
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpr^.tt <> ninteger then
+ begin
+ write(', ');
+ eexpr(tq^.texpr)
+ end;
+ write(', ');
+ eexpr(tq^.texpl)
+ end
+ else if tq^.tt <> nchar then
+ begin
+ write(', ');
+ eexpr(tq)
+ end
+ end;
+ 'd':
+ begin
+ write(', ');
+ tx := tq;
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpr^.tt <> ninteger then
+ begin
+ eexpr(tq^.texpr);
+ write(', ')
+ end;
+ tx := tq^.texpl
+ end;
+ eexpr(tx)
+ end;
+ 'e':
+ begin
+ write(', ');
+ tx := tq^.texpr;
+ if tx^.tt <> ninteger then
+ begin
+ usemax := true;
+ eexpr(tx);
+ write(', Max(');
+ eexpr(tx);
+ write(' - 7, 1), ')
+ end;
+ eexpr(tq^.texpl)
+ end;
+ 'f':
+ begin
+ write(', ');
+ tx := tq^.texpl;
+ if tx^.texpr^.tt <> ninteger then
+ begin
+ eexpr(tx^.texpr);
+ write(', ')
+ end;
+ if (tx^.texpr^.tt <> ninteger) or
+ (tq^.texpr^.tt <> ninteger) then
+ begin
+ usemax := true;
+ write('Max((');
+ eexpr(tx^.texpr);
+ write(') - (');
+ eexpr(tq^.texpr);
+ write(') - 1, 1), ')
+ end;
+ eexpr(tq^.texpl^.texpl)
+ end;
+ 'g':
+ begin
+ write(', ');
+ eexpr(tq)
+ end;
+ 's':
+ begin
+ if tq^.tt = nformat then
+ begin
+ if tq^.texpr^.tt <> ninteger then
+ begin
+ write(', ');
+ eexpr(tq^.texpr);
+ write(', ');
+ eexpr(tq^.texpr)
+ end;
+ write(', ');
+ eexpr(tq^.texpl)
+ end
+ else if tq^.tt <> nstring then
+ begin
+ write(', ');
+ eexpr(tq)
+ end
+ end
+ end (* case *)
+ end; (* ewrite *)
+
+ (* Emit size of *tp for call to malloc. CPU *)
+ (* There is no safe way to compute the size of a *)
+ (* particular variant of a C-union, we assume that *)
+ (* the size can be computed by taking the address *)
+ (* of the first member and subracting the address *)
+ (* of the record and then adding the size of the *)
+ (* variant containing the record. *)
+ procedure enewsize(tp : treeptr);
+
+ label 555;
+
+ var tq, tx, ty : treeptr;
+ v : integer;
+
+ (* Emit size of union member tq. *)
+ procedure esubsize(tp, tq : treeptr);
+
+ label 555, 666;
+
+ var tx, ty : treeptr;
+ addsize : boolean;
+
+ begin
+ tx := tq^.tvrnt;
+ ty := tx^.tflist;
+ if ty = nil then
+ begin
+ ty := tx^.tvlist;
+ while ty <> nil do
+ begin
+ if ty^.tvrnt^.tflist <> nil then
+ begin
+ ty := ty^.tvrnt^.tflist;
+ goto 555
+ end;
+ ty := ty^.tnext
+ end;
+ 555:
+ end;
+ addsize := true;
+ if ty = nil then
+ begin
+ (* empty variant, try using another *)
+ addsize := false;
+ ty := tx^.tup^.tup^.tvlist;
+ while ty <> nil do
+ begin
+ if ty^.tvrnt^.tflist <> nil then
+ begin
+ ty := ty^.tvrnt^.tflist;
+ goto 666
+ end;
+ ty := ty^.tnext
+ end;
+ 666:
+ end;
+ if ty = nil then
+ begin
+ (* its getting too complicated,
+ ignore tag value *)
+ write('sizeof(*');
+ eexpr(tp);
+ write(')')
+ end
+ else begin
+ (* compute offset to first member of
+ the selected union variant *)
+ write('Unionoffs(');
+ eexpr(tp);
+ write(', ');
+ printid(ty^.tidl^.tsym^.lid);
+ if addsize then
+ begin
+ (* add the size of the selected
+ union variant *)
+ write(') + sizeof(');
+ eexpr(tp);
+ write('->');
+ printid(tx^.tuid)
+ end;
+ write(')')
+ end
+ end;
+
+ begin (* newsize *)
+ if (tp^.tnext <> nil) and unionnew then
+ begin
+ (* tnext points to a tag-value, evaluate it *)
+ v := cvalof(tp^.tnext);
+ (* find union type *)
+ tq := typeof(tp);
+ tq := typeof(tq^.tptrid);
+ if tq^.tt <> nrecord then
+ fatal(etree);
+ (* find corresponding variant *)
+ tx := tq^.tvlist;
+ while tx <> nil do
+ begin
+ ty := tx^.tselct;
+ while ty <> nil do
+ begin
+ if v = cvalof(ty) then
+ goto 555;
+ ty := ty^.tnext
+ end;
+ tx := tx^.tnext
+ end;
+ fatal(etag);
+ 555:
+ (* emit size for that variant *)
+ esubsize(tp, tx)
+ end
+ else begin
+ write('sizeof(*');
+ eexpr(tp);
+ write(')')
+ end
+ end; (* newsize *)
+
+ begin (* epredef *)
+ td := ts^.tsubstmt^.tdef;
+ case td of
+ dabs:
+ begin
+ tq := typeof(tp^.taparm);
+ if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
+ write('abs(') (* LIB *)
+ else
+ write('fabs('); (* LIB *)
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dargv:
+ begin
+ write('Argvgt(');
+ eexpr(tp^.taparm);
+ write(', ');
+ eexpr(tp^.taparm^.tnext);
+ write('.A, sizeof(');
+ eexpr(tp^.taparm^.tnext);
+ writeln('.A));')
+ end;
+ dchr:
+ begin
+ tq := typeof(tp^.taparm);
+ if tq^.tt = nsubrange then
+ if tq^.tup^.tt = nconfarr then
+ tq := typeof(tq^.tup^.tindtyp)
+ else
+ tq := typeof(tq^.tlo);
+ if (tq = typnods[tinteger]) or
+ (tq = typnods[tchar]) then
+ eexpr(tp^.taparm)
+ else begin
+ write('(char)(');
+ eexpr(tp^.taparm);
+ write(')')
+ end
+ end;
+ ddispose:
+ begin
+ write('free('); (* LIB *)
+ eexpr(tp^.taparm);
+ writeln(');')
+ end;
+ deof:
+ begin
+ write('Eof(');
+ if tp^.taparm = nil then
+ begin
+ defnams[dinput]^.lused := true;
+ printid(defnams[dinput]^.lid)
+ end
+ else
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ deoln:
+ begin
+ write('Eoln(');
+ if tp^.taparm = nil then
+ begin
+ defnams[dinput]^.lused := true;
+ printid(defnams[dinput]^.lid)
+ end
+ else
+ eexpr(tp^.taparm);
+ write(')');
+ end;
+ dexit:
+ begin
+ write('exit('); (* OS *)
+ if tp^.taparm = nil then
+ write('0')
+ else
+ eexpr(tp^.taparm);
+ writeln(');');
+ end;
+ dflush:
+ begin
+ write('fflush('); (* LIB *)
+ if tp^.taparm = nil then
+ begin
+ defnams[doutput]^.lused := true;
+ printid(defnams[doutput]^.lid)
+ end
+ else
+ eexpr(tp^.taparm);
+ writeln('.fp);')
+ end;
+ dpage:
+ begin
+ (* write form-feed character *)
+ write('Putchr(', ffchr, ', '); (* CHAR *)
+ if tp^.taparm = nil then
+ begin
+ defnams[doutput]^.lused := true;
+ printid(defnams[doutput]^.lid)
+ end
+ else
+ eexpr(tp^.taparm);
+ writeln(');');
+ end;
+ dput,
+ dget:
+ begin
+ if typeof(tp^.taparm) = typnods[ttext] then
+ if td = dget then
+ write('Getx')
+ else
+ write('Putx')
+ else begin
+ write(voidcast);
+ if td = dget then
+ write('Get')
+ else
+ write('Put')
+ end;
+ write('(');
+ eexpr(tp^.taparm);
+ writeln(');')
+ end;
+ dhalt:
+ writeln('abort();'); (* OS *)
+ dnew:
+ begin
+ eexpr(tp^.taparm);
+ write(' = (');
+ etypedef(typeof(tp^.taparm));
+ write(')malloc((unsigned)('); (* LIB *)
+ enewsize(tp^.taparm);
+ writeln('));')
+ end;
+ dord:
+ begin
+ write('(unsigned)(');
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dread,
+ dreadln:
+ begin
+ txtfile := false;
+ tq := tp^.taparm;
+ if tq <> nil then
+ begin
+ tv := typeof(tq);
+ if tv = typnods[ttext] then
+ begin
+ (* reading from textfile *)
+ txtfile := true;
+ tv := tq;
+ tq := tq^.tnext
+ end
+ else if tv^.tt = nfileof then
+ begin
+ (* reading from other file *)
+ txtfile := typeof(tv^.tof) =
+ typnods[tchar];
+ tv := tq;
+ tq := tq^.tnext
+ end
+ else begin
+ (* reading from std-input *)
+ txtfile := true;
+ tv := nil
+ end
+ end
+ else begin
+ tv := nil;
+ txtfile := true
+ end;
+ if txtfile then
+ begin
+ (* check for special case *)
+ if tq = nil then
+ goto 444;
+ if (tq^.tt <> nformat) and
+ (tq^.tnext = nil) and
+ (typeletter(tq) = 'c') then
+ begin
+ (* read single char *)
+ eexpr(tq);
+ write(' = ');
+ write('Getchr(');
+ if tv = nil then
+ printid(defnams[dinput]^.lid)
+ else
+ eexpr(tv);
+ write(')');
+ if td = dreadln then
+ write(',');
+ goto 444
+ end;
+ usescan := true;
+ write('Fscan(');
+ if tv = nil then
+ printid(defnams[dinput]^.lid)
+ else
+ eexpr(tv);
+ write('), ');
+ (* first pass, emit format string *)
+ while tq <> nil do
+ begin
+ write('Scan(', cite);
+ ch := typeletter(tq);
+ case ch of
+ 'a':
+ write(percent, 's');
+ 'c':
+ write(percent, 'c');
+ 'd':
+ write(percent, 'ld');
+ 'g':
+ write(percent, 'le')
+ end;(* case *)
+ write(cite, ', ');
+ case ch of
+ 'a':
+ begin
+ eexpr(tq);
+ write('.A')
+ end;
+ 'c':
+ begin
+ write('&');
+ eexpr(tq)
+ end;
+ 'd':
+ write('&Tmplng');
+ 'g':
+ write('&Tmpdbl')
+ end;(* case *)
+ write(')');
+ case ch of
+ 'd':
+ begin
+ write(', ');
+ eexpr(tq);
+ write(' = Tmplng')
+ end;
+ 'g':
+ begin
+ write(', ');
+ eexpr(tq);
+ write(' = Tmpdbl')
+ end;
+ 'a',
+ 'c':
+ (* no op *)
+ end;(* case *)
+ tq := tq^.tnext;
+ if tq <> nil then
+ begin
+ writeln(',');
+ indent;
+ write(tab1)
+ end
+ end;
+ write(', Getx(');
+ if tv = nil then
+ printid(defnams[dinput]^.lid)
+ else
+ eexpr(tv);
+ write(')');
+ if td = dreadln then
+ write(',');
+ 444:
+ if td = dreadln then
+ begin
+ usegetl := true;
+ write('Getl(&');
+ if tv = nil then
+ printid(defnams[dinput]^.lid)
+ else
+ eexpr(tv);
+ write(')')
+ end
+ end
+ else begin
+ increment;
+ while tq <> nil do
+ begin
+ write(voidcast, 'Fread(');
+ eexpr(tq);
+ write(', ');
+ eexpr(tv);
+ write('.fp)');
+ tq := tq^.tnext;
+ if tq <> nil then
+ begin
+ writeln(',');
+ indent
+ end
+ end;
+ decrement
+ end;
+ writeln(';')
+ end;
+ dwrite,
+ dwriteln,
+ dmessage:
+ begin
+ txtfile := false;
+ tq := tp^.taparm;
+ if tq <> nil then
+ begin
+ tv := typeof(tq);
+ if tv = typnods[ttext] then
+ begin
+ (* writing to textfile *)
+ txtfile := true;
+ tv := tq;
+ tq := tq^.tnext
+ end
+ else if tv^.tt = nfileof then
+ begin
+ (* writing to other file *)
+ txtfile := typeof(tv^.tof) =
+ typnods[tchar];
+ tv := tq;
+ tq := tq^.tnext
+ end
+ else begin
+ (* writing to std-output *)
+ txtfile := true;
+ tv := nil
+ end
+ end
+ else begin
+ tv := nil;
+ txtfile := true
+ end;
+ if txtfile then
+ begin
+ (* check for special case *)
+ if tq = nil then
+ begin
+ (* writeln whithout parameters *)
+ if td in [dwriteln, dmessage] then
+ begin
+ write('Putchr(', nlchr, ', ');
+ if tv = nil then
+ printid(
+ defnams[doutput]^.lid)
+ else
+ eexpr(tv);
+ write(')')
+ end;
+ writeln(';');
+ goto 555
+ end
+ else if (tq^.tt <> nformat) and
+ (tq^.tnext = nil) then
+ if typeletter(tq) = 'c' then
+ begin
+ (* print single char *)
+ write('Putchr(');
+ eexpr(tq);
+ write(', ');
+ if tv = nil then
+ printid(
+ defnams[doutput]^.lid)
+ else
+ eexpr(tv);
+ write(')');
+ if td = dwriteln then
+ begin
+ write(',Putchr(',
+ nlchr, ', ');
+ if tv = nil then
+ printid(
+ defnams[doutput]^.lid)
+ else
+ eexpr(tv);
+ write(')');
+ end;
+ writeln(';');
+ goto 555
+ end;
+ tx := nil;
+ write(voidcast, 'fprintf('); (* LIB *)
+ if td = dmessage then
+ write('stderr, ')
+ else begin
+ if tv = nil then
+ printid(defnams[doutput]^.lid)
+ else
+ eexpr(tv);
+ write('.fp, ')
+ end;
+ write(cite);
+ tx := tq; (* remember 1:st parm *)
+ (* first pass, emit format string *)
+ while tq <> nil do
+ begin
+ eformat(tq);
+ tq := tq^.tnext
+ end;
+ if (td = dmessage) or (td = dwriteln) then
+ write('\n');
+ write(cite);
+ (* second pass, add parameters *)
+ tq := tx;
+ while tq <> nil do
+ begin
+ ewrite(tq);
+ tq := tq^.tnext
+ end;
+ write('), Putl(');
+ if tv = nil then
+ printid(defnams[doutput]^.lid)
+ else
+ eexpr(tv);
+ if td = dwrite then
+ write(', 0)')
+ else
+ write(', 1)')
+ end
+ else begin
+ increment;
+ tx := typeof(tv);
+ if tx = typnods[ttext] then
+ tx := typnods[tchar]
+ else if tx^.tt = nfileof then
+ tx := typeof(tx^.tof)
+ else
+ fatal(etree);
+ while tq <> nil do
+ begin
+ if (tq^.tt in [nid, nindex, nselect,
+ nderef]) and
+ (tx = typeof(tq)) then
+ begin
+ write(voidcast, 'Fwrite(');
+ eexpr(tq)
+ end
+ else begin
+ if tx^.tt = nsetof then
+ begin
+ usescpy := true;
+ write('Setncpy(');
+ eselect(tv);
+ write('buf.S, ');
+ eexpr(tq);
+ if typeof(tp^.trhs) =
+ typnods[tset] then
+ eexpr(tq)
+ else begin
+ eselect(tq);
+ write('S')
+ end;
+ write(', sizeof(');
+ eexpr(tv);
+ write('.buf))');
+ end
+ else begin
+ eexpr(tv);
+ write('.buf = ');
+ eexpr(tq)
+ end;
+ write(', Fwrite(');
+ eexpr(tv);
+ write('.buf');
+ end;
+ write(', ');
+ eexpr(tv);
+ write('.fp)');
+ tq := tq^.tnext;
+ if tq <> nil then
+ begin
+ writeln(',');
+ indent
+ end
+ end;
+ decrement
+ end;
+ writeln(';');
+ 555:
+ end;
+ dclose:
+ begin
+ tq := typeof(tp^.taparm);
+ txtfile := tq = typnods[ttext];
+ if (not txtfile) and (tq^.tt = nfileof) then
+ if typeof(tq^.tof) = typnods[tchar] then
+ txtfile := true;
+ if txtfile then
+ write('Closex(')
+ else
+ write('Close(');
+ eexpr(tp^.taparm);
+ writeln(');');
+ end;
+ dreset,
+ drewrite:
+ begin
+ tq := typeof(tp^.taparm);
+ txtfile := tq = typnods[ttext];
+ if (not txtfile) and (tq^.tt = nfileof) then
+ if typeof(tq^.tof) = typnods[tchar] then
+ txtfile := true;
+ if txtfile then
+ if td = dreset then
+ write('Resetx(')
+ else
+ write('Rewritex(')
+ else
+ if td = dreset then
+ write('Reset(')
+ else
+ write('Rewrite(');
+ eexpr(tp^.taparm);
+ write(', ');
+ tq := tp^.taparm^.tnext;
+ if tq = nil then
+ write('NULL')
+ else begin
+ tq := typeof(tq);
+ if tq = typnods[tchar] then
+ begin
+ write(cite);
+ ch := chr(cvalof(tp^.taparm^.tnext));
+ if (ch = bslash) or (ch = cite) then
+ write(bslash);
+ write(ch, cite)
+ end
+ else if tq = typnods[tstring] then
+ eexpr(tp^.taparm^.tnext)
+ else if tq^.tt in [narray, nconfarr] then
+ begin
+ eexpr(tp^.taparm^.tnext);
+ write('.A')
+ end
+ else
+ fatal(etree)
+ end;
+ writeln(');')
+ end;
+ darctan:
+ begin
+ write('atan('); (* LIB *)
+ if typeof(tp^.taparm) <> typnods[treal] then
+ write(dblcast);
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dln:
+ begin
+ write('log('); (* LIB *)
+ if typeof(tp^.taparm) <> typnods[treal] then
+ write(dblcast);
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dexp:
+ begin
+ write('exp('); (* LIB *)
+ if typeof(tp^.taparm) <> typnods[treal] then
+ write(dblcast);
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dcos,
+ dsin,
+ dsqrt:
+ begin
+ eexpr(tp^.tcall); (* LIB *)
+ write('(');
+ if typeof(tp^.taparm) <> typnods[treal] then
+ write(dblcast);
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dtan:
+ begin
+ write('atan('); (* LIB *)
+ if typeof(tp^.taparm) <> typnods[treal] then
+ write(dblcast);
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dsucc,
+ dpred:
+ begin
+ tq := typeof(tp^.taparm);
+ if tq^.tt = nsubrange then
+ if tq^.tup^.tt = nconfarr then
+ tq := typeof(tq^.tup^.tindtyp)
+ else
+ tq := typeof(tq^.tlo);
+ if (tq = typnods[tinteger]) or
+ (tq = typnods[tchar]) then
+ begin
+ write('((');
+ eexpr(tp^.taparm);
+ if td = dpred then
+ write(')-1)')
+ else
+ write(')+1)')
+ end
+ else begin
+ (* some sort of scalar type, casting needed *)
+ write('(');
+ tq := tq^.tup;
+ if tq^.tt = ntype then
+ begin
+ (* cast only if it is a named type *)
+ write('(');
+ printid(tq^.tidl^.tsym^.lid);
+ write(')')
+ end;
+ write('((int)(');
+ eexpr(tp^.taparm);
+ if td = dpred then
+ write(')-1))')
+ else
+ write(')+1))')
+ end
+ end;
+ dodd:
+ begin
+ write('(');
+ printid(defnams[dboolean]^.lid);
+ write(')((');
+ eexpr(tp^.taparm);
+ write(') & 1)')
+ end;
+ dsqr:
+ begin
+ tq := typeof(tp^.taparm);
+ if (tq = typnods[tinteger]) or (tq^.tt = nsubrange) then
+ begin
+ write('((');
+ eexpr(tp^.taparm);
+ write(') * (');
+ eexpr(tp^.taparm);
+ write('))')
+ end
+ else begin
+ write('pow('); (* LIB *)
+ if typeof(tp^.taparm) <> typnods[treal] then
+ write(dblcast);
+ eexpr(tp^.taparm);
+ write(', 2.0)')
+ end
+ end;
+ dround:
+ begin
+ write('Round(');
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dtrunc:
+ begin
+ write('Trunc(');
+ eexpr(tp^.taparm);
+ write(')')
+ end;
+ dpack:
+ begin
+ tq := typeof(tp^.taparm);
+ tx := typeof(tp^.taparm^.tnext^.tnext);
+ write('{ ', registr, inttyp, tab1, '_j, _i = ');
+ if not arithexpr(tp^.taparm^.tnext) then
+ write('(int)');
+ eexpr(tp^.taparm^.tnext);
+ if tx^.tt = narray then
+ write(' - ', clower(tq^.taindx):1);
+ writeln(';');
+ indent;
+ write(' for (_j = 0; _j < ');
+ if tq^.tt = nconfarr then
+ begin
+ write('(int)(');
+ printid(tx^.tcindx^.thi^.tsym^.lid);
+ write(')')
+ end
+ else
+ write(crange(tx^.taindx):1);
+ writeln('; )');
+ indent;
+ write(tab1);
+ eexpr(tp^.taparm^.tnext^.tnext);
+ write('.A[_j++] = ');
+ eexpr(tp^.taparm);
+ writeln('.A[_i++];');
+ indent;
+ writeln('}')
+ end;
+ dunpack:
+ begin
+ tq := typeof(tp^.taparm);
+ tx := typeof(tp^.taparm^.tnext);
+ write('{ ', registr, inttyp, tab1, '_j, _i = ');
+ if not arithexpr(tp^.taparm^.tnext^.tnext) then
+ write('(int)');
+ eexpr(tp^.taparm^.tnext^.tnext);
+ if tx^.tt <> nconfarr then
+ write(' - ', clower(tx^.taindx):1);
+ writeln(';');
+ indent;
+ write(' for (_j = 0; _j < ');
+ if tq^.tt = nconfarr then
+ begin
+ write('(int)(');
+ printid(tq^.tcindx^.thi^.tsym^.lid);
+ write(')')
+ end
+ else
+ write(crange(tq^.taindx):1);
+ writeln('; )');
+ indent;
+ write(tab1);
+ eexpr(tp^.taparm^.tnext);
+ write('.A[_i++] = ');
+ eexpr(tp^.taparm);
+ writeln('.A[_j++];');
+ indent;
+ writeln('}')
+ end;
+ end (* case *)
+ end; (* epredef *)
+
+ procedure eaddr(tp : treeptr);
+
+ begin
+ write('&');
+ if not(tp^.tt in [nid, nselect, nindex, nderef]) then
+ error(evarpar);
+ eexpr(tp)
+ end;
+
+ (* Emit code for a subroutine call. *)
+ procedure ecall(tp : treeptr);
+
+ var tf, tq, tx : treeptr;
+
+ begin
+ (* find first formal parameter id *)
+ tf := idup(tp^.tcall);
+ case tf^.tt of
+ nproc,
+ nfunc:
+ tf := tf^.tsubpar;
+ nparproc,
+ nparfunc:
+ tf := tf^.tparparm
+ end;(* case *)
+ if tf <> nil then
+ begin
+ case tf^.tt of
+ nvalpar,
+ nvarpar:
+ tf := tf^.tidl;
+ nparproc,
+ nparfunc:
+ tf := tf^.tparid
+ end (* case *)
+ end;
+ (* emit called function name *)
+ eexpr(tp^.tcall);
+ write('(');
+ (* emit actual parameters *)
+ tq := tp^.taparm;
+ while tq <> nil do
+ begin
+ if tf^.tup^.tt in [nparfunc, nparproc] then
+ begin
+ (* single subroutine-nid converted to ncall *)
+ if tq^.tt = ncall then
+ printid(tq^.tcall^.tsym^.lid)
+ else
+ printid(tq^.tsym^.lid)
+ end
+ else begin
+ tx := typeof(tq);
+ if tx = typnods[tboolean] then
+ begin
+ tx := tq;
+ while tx^.tt = nuplus do
+ tx := tx^.texps;
+ if tx^.tt in [nin .. nor, nand, nnot]
+ then
+ begin
+ write('(');
+ printid(defnams[dboolean]^.lid);
+ write(')(');
+ eexpr(tq);
+ write(')')
+ end
+ else
+ eexpr(tq);
+ end
+ else if (tx = typnods[tstring]) or
+ (tx = typnods[tset]) then
+ begin
+ (* cast literal to proper type *)
+ write('*((');
+ etypedef(tf^.tup^.tbind);
+ write(' *)');
+ if tx = typnods[tset] then
+ begin
+ dropset := true;
+ eexpr(tq);
+ dropset := false
+ end
+ else
+ eexpr(tq);
+ write(')')
+ end
+ else if tx = typnods[tnil] then
+ begin
+ write('(');
+ etypedef(tf^.tup^.tbind);
+ write(')NIL')
+ end
+ else if tf^.tup^.tbind^.tt = nconfarr then
+ begin
+ write('(struct ');
+ printid(tf^.tup^.tbind^.tcuid);
+ write(' *)&');
+ eexpr(tq);
+ (* add upper bound of actual value *)
+ if tq^.tnext = nil then
+ write(', ',
+ crange(tx^.taindx):1)
+ end
+ else begin
+ if tf^.tup^.tt = nvarpar then
+ eaddr(tq)
+ else
+ eexpr(tq)
+ end
+ end;
+ tq := tq^.tnext;
+ if tq <> nil then
+ begin
+ write(', ');
+ (* next formal parameter *)
+ if tf^.tnext = nil then
+ begin
+ tf := tf^.tup^.tnext;
+ case tf^.tt of
+ nvalpar,
+ nvarpar:
+ tf := tf^.tidl;
+ nparproc,
+ nparfunc:
+ tf := tf^.tparid
+ end (* case *)
+ end
+ else
+ tf := tf^.tnext;
+ end;
+ end;
+ write(')')
+ end; (* ecall *)
+
+ (* Emit code for a general expression. *)
+ procedure eexpr;
+
+ label 999;
+
+ var tq : treeptr;
+ flag : boolean;
+
+ function constset(tp : treeptr) : boolean;
+
+ function constxps(tp : treeptr) : boolean;
+ begin
+ case tp^.tt of
+ nrange:
+ if constxps(tp^.texpr) then
+ constxps := constxps(tp^.texpl)
+ else
+ constxps := false;
+ nempty,
+ ninteger,
+ nchar:
+ constxps := true;
+ nid:
+ begin
+ tp := idup(tp);
+ constxps := (tp^.tt = nconst)
+ or (tp^.tt = nscalar)
+ end;
+ nin, neq, nne, nlt, nle, ngt, nge, nor,
+ nplus, nminus, nand, nmul, ndiv, nmod,
+ nquot, nnot, numinus, nuplus, nset,
+ nindex, nselect, nderef, ncall,
+ nreal, nstring, nnil:
+ constxps := false
+ end (* case *)
+ end;
+
+ begin
+ constset := true;
+ while tp <> nil do
+ if constxps(tp) then
+ tp := tp^.tnext
+ else begin
+ constset := false;
+ tp := nil
+ end
+ end;
+
+ begin (* eexpr *)
+ donearr := false;
+ if tp^.tt in [nplus, nminus, nmul, nle, nge, neq, nne] then
+ begin
+ tq := typeof(tp^.texpl);
+ if (tq^.tt in [nset, nsetof]) or
+ (tq = typnods[tset]) then
+ begin
+ (* set operations *)
+ case tp^.tt of
+ nplus:
+ begin
+ setused := true;
+ useunion := true;
+ write('Union')
+ end;
+ nminus:
+ begin
+ setused := true;
+ usediff := true;
+ write('Diff')
+ end;
+ nmul:
+ begin
+ setused := true;
+ useintr := true;
+ write('Inter')
+ end;
+ neq:
+ begin
+ useseq := true;
+ write('Eq')
+ end;
+ nne:
+ begin
+ usesne := true;
+ write('Ne')
+ end;
+ nge:
+ begin
+ usesge := true;
+ write('Ge')
+ end;
+ nle:
+ begin
+ usesle := true;
+ write('Le')
+ end
+ end;(* case *)
+ if tp^.tt in [nplus, nminus, nmul] then
+ dropset := false;
+ write('(');
+ eexpr(tp^.texpl);
+ if tq^.tt = nsetof then
+ write('.S');
+ write(', ');
+ eexpr(tp^.texpr);
+ tq := typeof(tp^.texpr);
+ if tq^.tt = nsetof then
+ write('.S');
+ write(')');
+ goto 999
+ end
+ end;
+ if tp^.tt in [neq, nne, ngt, nlt, nge, nle] then
+ begin
+ tq := typeof(tp^.texpl);
+ if tq^.tt = nconfarr then
+ fatal(ecmpconf);
+ if (tq^.tt in [nstring, narray]) or
+ (tq = typnods[tstring]) then
+ begin
+ write('Cmpstr(');
+ eexpr(tp^.texpl);
+ if tq^.tt = narray then
+ write('.A');
+ write(', ');
+ tq := typeof(tp^.texpr);
+ if tq^.tt = nconfarr then
+ fatal(ecmpconf);
+ eexpr(tp^.texpr);
+ if tq^.tt = narray then
+ write('.A');
+ write(')');
+ case tp^.tt of
+ neq:
+ write(' == ');
+ nne:
+ write(' != ');
+ ngt:
+ write(' > ');
+ nlt:
+ write(' < ');
+ nge:
+ write(' >= ');
+ nle:
+ write(' <= ');
+ end;(* case *)
+ write('0');
+ goto 999
+ end
+ end;
+ case tp^.tt of
+ neq, nne, nlt, nle,
+ ngt, nge, nor, nand, nplus, nminus,
+ nmul, ndiv, nmod, nquot:
+ begin
+ flag := cprio[tp^.tt] > cprio[tp^.texpl^.tt];
+ if (tp^.tt in [nlt, nle, ngt, nge]) and
+ not arithexpr(tp^.texpl) then
+ begin
+ write('(int)');
+ flag := true
+ end;
+ if flag then
+ write('(');
+ eexpr(tp^.texpl);
+ if flag then
+ write(')');
+ case tp^.tt of
+ neq:
+ write(' == ');
+ nne:
+ write(' != ');
+ nlt:
+ write(' < ');
+ nle:
+ write(' <= ');
+ ngt:
+ write(' > ');
+ nge:
+ write(' >= ');
+ nor:
+ write(' || ');
+ nand:
+ write(' && ');
+ nplus:
+ write(' + ');
+ nminus:
+ write(' - ');
+ nmul:
+ write(' * ');
+ ndiv:
+ write(' / ');
+ nmod:
+ write(' % ');
+ nquot:
+ begin
+ write(' / ((');
+ printid(defnams[dreal]^.lid);
+ write(')')
+ end
+ end;(* case *)
+ flag := cprio[tp^.tt] > cprio[tp^.texpr^.tt];
+ if (tp^.tt in [nlt, nle, ngt, nge]) and
+ not arithexpr(tp^.texpr) then
+ begin
+ write('(int)');
+ flag := true
+ end;
+ if flag then
+ write('(');
+ eexpr(tp^.texpr);
+ if flag then
+ write(')');
+ if tp^.tt = nquot then
+ write(')')
+ end;
+
+ nuplus, numinus, nnot:
+ begin
+ case tp^.tt of
+ numinus:
+ write('-');
+ nnot:
+ write('!');
+ nuplus:
+ end;(* case *)
+ flag := cprio[tp^.tt] >= cprio[tp^.texps^.tt];
+ if flag then
+ write('(');
+ eexpr(tp^.texps);
+ if flag then
+ write(')');
+ end;
+
+ nin:
+ begin
+ usememb := true;
+ write('Member((unsigned)(');
+ eexpr(tp^.texpl);
+ write('), ');
+ dropset := true; (* no need to save set-expr *)
+ eexpr(tp^.texpr);
+ dropset := false;
+ tq := typeof(tp^.texpr);
+ if tq^.tt = nsetof then
+ write('.S');
+ write(')')
+ end;
+
+ nassign:
+ begin
+ tq := typeof(tp^.trhs);
+ if tq = typnods[tstring] then
+ begin
+ write(voidcast, 'strncpy(');
+ eexpr(tp^.tlhs);
+ write('.A, ');
+ eexpr(tp^.trhs);
+ write(', sizeof(');
+ eexpr(tp^.tlhs);
+ write('.A))')
+ end
+ else if tq = typnods[tboolean] then
+ begin
+ eexpr(tp^.tlhs);
+ write(' = ');
+ tq := tp^.trhs;
+ while tq^.tt = nuplus do
+ tq := tq^.texps;
+ if tq^.tt in [nin .. nor, nand, nnot] then
+ begin
+ write('(');
+ printid(defnams[dboolean]^.lid);
+ write(')(');
+ eexpr(tq);
+ write(')')
+ end
+ else
+ eexpr(tq)
+ end
+ else if tq = typnods[tnil] then
+ begin
+ eexpr(tp^.tlhs);
+ write(' = (');
+ etypedef(typeof(tp^.tlhs));
+ write(')NIL')
+ end
+ else begin
+ tq := typeof(tp^.tlhs);
+ if tq^.tt = nsetof then
+ begin
+ usescpy := true;
+ write('Setncpy(');
+ eselect(tp^.tlhs);
+ write('S, ');
+ dropset := true;
+ tq := typeof(tp^.trhs);
+ if tq = typnods[tset] then
+ eexpr(tp^.trhs)
+ else begin
+ eselect(tp^.trhs);
+ write('S')
+ end;
+ dropset := false;
+ write(', sizeof(');
+ eselect(tp^.tlhs);
+ write('S))')
+ end
+ else begin
+ eexpr(tp^.tlhs);
+ write(' = ');
+ eexpr(tp^.trhs)
+ end
+ end
+ end;
+
+ ncall:
+ begin
+ tq := idup(tp^.tcall);
+ if (tq^.tt in [nfunc, nproc]) and
+ (tq^.tsubstmt <> nil) then
+ if tq^.tsubstmt^.tt = npredef then
+ epredef(tq, tp)
+ else
+ ecall(tp)
+ else
+ ecall(tp)
+ end;
+
+ nselect:
+ begin
+ eselect(tp^.trecord);
+ eexpr(tp^.tfield)
+ end;
+ nindex:
+ begin
+ eselect(tp^.tvariable);
+ write('A[');
+ tq := tp^.toffset;
+ if arithexpr(tq) then
+ eexpr(tq)
+ else begin
+ write('(int)(');
+ eexpr(tq);
+ write(')')
+ end;
+ tq := typeof(tp^.tvariable);
+ if tq^.tt = narray then
+ if clower(tq^.taindx) <> 0 then
+ begin
+ write(' - ');
+ tq := typeof(tq^.taindx);
+ if tq^.tt = nsubrange then
+ if arithexpr(tq^.tlo) then
+ eexpr(tq^.tlo)
+ else begin
+ write('(int)(');
+ eexpr(tq^.tlo);
+ write(')')
+ end
+ else
+ fatal(etree)
+ end;
+ write(']')
+ end;
+ nderef:
+ begin
+ tq := typeof(tp^.texps);
+ if (tq^.tt = nfileof) or
+ ((tq^.tt = npredef) and (tq^.tdef = dtext)) then
+ begin
+ (* using a file-variable as pointer *)
+ eexpr(tp^.texps);
+ write('.buf')
+ end
+ else if doarrow = 0 then
+ begin
+ write('*');
+ eexpr(tp^.texps)
+ end
+ else begin
+ eexpr(tp^.texps);
+ write('->');
+ donearr := true
+ end
+ end;
+ nid:
+ begin
+ (* add pointer-dereference if this id is declared as a
+ var-parameter or as a procedure-parameter *)
+ tq := idup(tp);
+ if tq^.tt = nvarpar then
+ begin
+ if (doarrow = 0) or
+ (tq^.tattr = areference) then
+ begin
+ write('(*');
+ printid(tp^.tsym^.lid);
+ write(')')
+ end
+ else begin
+ printid(tp^.tsym^.lid);
+ write('->');
+ donearr := true
+ end
+ end
+ else if (tq^.tt = nconst) and conflag then
+ write(cvalof(tp):1)
+ else if tq^.tt in [nparproc, nparfunc] then
+ begin
+ write('(*');
+ printid(tp^.tsym^.lid);
+ write(')')
+ end
+ else
+ printid(tp^.tsym^.lid);
+ end;
+ nchar:
+ printchr(tp^.tsym^.lchar);
+ ninteger:
+ write(tp^.tsym^.linum:1);
+ nreal:
+ printtok(tp^.tsym^.lfloat);
+ nstring:
+ printstr(tp^.tsym^.lstr);
+ nset:
+ if constset(tp^.texps) then
+ begin
+ (* save set expression for initialization *)
+ write('Conset[', setcnt:1, ']');
+ setcnt := setcnt + 1;
+ tq := mknode(nset);
+ tq^.tnext := setlst;
+ setlst := tq;
+ tq^.texps := tp^.texps
+ end
+ else begin
+ increment;
+ flag := dropset;
+ (* if a set-constructor is used in an
+ expression involving + - * it will need to
+ be saved temporarily (by Saveset) but often
+ we can simply forget the set-value when we
+ have finished using it *)
+ if dropset then
+ dropset := false
+ else
+ write('Saveset(');
+ write('(Tmpset = Newset(), ');
+ tq := tp^.texps;
+ while tq <> nil do
+ begin
+ case tq^.tt of
+ nrange:
+ begin
+ usemksub := true;
+ write(voidcast, 'Mksubr(');
+ write('(unsigned)(');
+ eexpr(tq^.texpl);
+ write('), ');
+ write('(unsigned)(');
+ eexpr(tq^.texpr);
+ write('), Tmpset)')
+ end;
+ nin, neq, nne, nlt, nle, ngt, nge,
+ nor, nand, nmul, ndiv, nmod, nquot,
+ nplus, nminus, nnot, numinus, nuplus,
+ nindex, nselect, nderef, ncall,
+ ninteger, nchar, nid:
+ begin
+ useins := true;
+ write(voidcast, 'Insmem(');
+ write('(unsigned)(');
+ eexpr(tq);
+ write('), Tmpset)')
+ end
+ end;(* case *)
+ tq := tq^.tnext;
+ if tq <> nil then
+ begin
+ writeln(',');
+ indent
+ end
+ end;
+ write(', Tmpset)');
+ if not flag then
+ begin
+ write(')');
+ setused := true
+ end;
+ decrement
+ end;
+ nnil:
+ begin
+ tq := tp;
+ repeat
+ tq := tq^.tup
+ until tq^.tt in [neq, nne, ncall, nassign, npgm];
+ if tq^.tt in [neq, nne] then
+ begin
+ if typeof(tq^.texpl) = typnods[tnil] then
+ tq := typeof(tq^.texpr)
+ else
+ tq := typeof(tq^.texpl);
+ if tq^.tt = nptr then
+ begin
+ write('(');
+ etypedef(tq);
+ write(')')
+ end
+ end;
+ write('NIL')
+ end;
+ end;(* case *)
+ 999:
+ end; (* eexpr *)
+
+ (* Emit constant definitions. *)
+ procedure econst(tp : treeptr);
+
+ var sp : symptr;
+
+ begin
+ while tp <> nil do
+ begin
+ sp := tp^.tidl^.tsym;
+ if sp^.lid^.inref > 1 then
+ sp^.lid := mkrename('X', sp^.lid);
+ if tp^.tbind^.tt = nstring then
+ begin
+ (* string constants emitted as
+ static local variables *)
+ indent;
+ write(static, chartyp, tab1);
+ printid(sp^.lid);
+ write('[] = ');
+ eexpr(tp^.tbind);
+ writeln(';')
+ end
+ else begin
+ (* all other constants emitted as
+ preprocessor # defines *)
+ write(define);
+ printid(sp^.lid);
+ write(space);
+ eexpr(tp^.tbind);
+ writeln
+ end;
+ tp := tp^.tnext
+ end
+ end; (* econst *)
+
+ (* Emit a typedef. *)
+ procedure etypedef;
+
+ (* Workhorse for etypedef, this procedure also *)
+ (* renames all fields in record-unions when *)
+ (* necessary. *)
+ procedure etdef(uid : idptr; tp : treeptr);
+
+ var i : integer;
+ tq : treeptr;
+
+ (* Emit definition for an integer subrange *)
+ (* using data from worddefs set up during *)
+ (* initialization. *)
+ procedure etrange(tp : treeptr);
+
+ label 999;
+
+ var lo, hi : integer;
+ i : 1 .. maxmachdefs;
+
+ begin
+ lo := clower(tp);
+ hi := cupper(tp);
+ (* scan CPU word definitions for a type
+ enclosing wanted range *)
+ for i := 1 to nmachdefs do
+ with machdefs[i] do
+ if (lo >= lolim) and (hi <= hilim) then
+ begin
+ (* found it, print type name *)
+ printtok(typstr);
+ goto 999
+ end;
+ fatal(erange);
+ 999:
+ end;
+
+ (* Print last component of identifier. *)
+ procedure printsuf(ip : idptr);
+
+ var w : toknbuf;
+ i, j : toknidx;
+
+ begin
+ gettokn(ip^.istr, w);
+ i := 1;
+ j := i;
+ while w[i] <> chr(null) do
+ begin
+ if w[i] = '.' then
+ j := i;
+ i := i + 1
+ end;
+ if w[j] = '.' then
+ j := j + 1;
+ while w[j] <> chr(null) do
+ begin
+ write(w[j]);
+ j := j + 1
+ end
+ end;
+
+ begin (* etdef *)
+ case tp^.tt of
+ nid:
+ printid(tp^.tsym^.lid);
+ nptr:
+ begin
+ tq := typeof(tp^.tptrid);
+ if tq^.tt = nrecord then
+ begin
+ write('struct ');
+ printid(tq^.tuid)
+ end
+ else
+ printid(tp^.tptrid^.tsym^.lid);
+ write(' *');
+ end;
+ nscalar:
+ begin
+ write('enum { ');
+ increment;
+ tp := tp^.tscalid;
+
+ (* avoid bug in C-compiler:
+ enums are mixed in same namespace *)
+ if tp^.tsym^.lid^.inref > 1 then
+ tp^.tsym^.lid :=
+ mkrename('E', tp^.tsym^.lid);
+ printid(tp^.tsym^.lid);
+ i := 1;
+ while tp^.tnext <> nil do
+ begin
+ if i >= 4 then
+ begin
+ writeln(',');
+ indent;
+ i := 1
+ end
+ else begin
+ write(', ');
+ i := i + 1
+ end;
+ tp := tp^.tnext;
+ if tp^.tsym^.lid^.inref > 1 then
+ tp^.tsym^.lid :=
+ mkrename('E', tp^.tsym^.lid);
+ printid(tp^.tsym^.lid)
+ end;
+ decrement;
+ write(' } ')
+ end;
+ nsubrange:
+ begin
+ tq := typeof(tp^.tlo);
+ if tq = typnods[tinteger] then
+ etrange(tp)
+ else begin
+ if tq^.tup^.tt = ntype then
+ tq := tq^.tup^.tidl;
+ etdef(nil, tq)
+ end
+ end;
+ nfield:
+ begin
+ etdef(nil, tp^.tbind);
+ write(tab1);
+ tp := tp^.tidl;
+ if uid <> nil then
+ tp^.tsym^.lid :=
+ mkconc('.', uid, tp^.tsym^.lid);
+ printsuf(tp^.tsym^.lid);
+ i := 1;
+ while tp^.tnext <> nil do
+ begin
+ if i >= 4 then
+ begin
+ writeln(',');
+ indent;
+ write(tab1);
+ i := 1
+ end
+ else begin
+ write(', ');
+ i := i + 1
+ end;
+ tp := tp^.tnext;
+ if uid <> nil then
+ tp^.tsym^.lid :=
+ mkconc('.', uid, tp^.tsym^.lid);
+ printsuf(tp^.tsym^.lid);
+ end;
+ writeln(';');
+ end;
+ nrecord:
+ begin
+ write('struct ');
+ if tp^.tuid = nil then
+ tp^.tuid := uid
+ else if uid = nil then
+ printid(tp^.tuid);
+ writeln(' {');
+ increment;
+ if (tp^.tflist = nil) and
+ (tp^.tvlist = nil) then
+ begin
+ (* C doesn't allow empty structures *)
+ indent;
+ writeln(inttyp, tab1, 'dummy;')
+ end;
+ tq := tp^.tflist;
+ while tq <> nil do
+ begin
+ indent;
+ etdef(uid, tq);
+ tq := tq^.tnext
+ end;
+ if tp^.tvlist <> nil then
+ begin
+ indent;
+ writeln('union {');
+ increment;
+ tq := tp^.tvlist;
+ while tq <> nil do
+ begin
+ if (tq^.tvrnt^.tflist <> nil) or
+ (tq^.tvrnt^.tvlist <> nil) then
+ begin
+ indent;
+ if uid = nil then
+ etdef(mkvrnt,
+ tq^.tvrnt)
+ else
+ etdef(mkconc('.',
+ uid, mkvrnt),
+ tq^.tvrnt);
+ writeln(';')
+ end;
+ tq := tq^.tnext
+ end;
+ decrement;
+ indent;
+ writeln('} U;');
+ end;
+ decrement;
+ indent;
+ if tp^.tup^.tt = nvariant then
+ begin
+ write('} ');
+ printsuf(tp^.tuid)
+ end
+ else
+ write('}');
+ end;
+ nconfarr:
+ begin
+ write('struct ');
+ printid(tp^.tcuid);
+ write(' { ');
+ etdef(nil, tp^.tcelem);
+ write(tab1, 'A[]; }')
+ end;
+ narray:
+ begin
+ write('struct { ');
+ etdef(nil, tp^.taelem);
+ write(tab1, 'A[');
+ tq := typeof(tp^.taindx);
+ if tq^.tt = nsubrange then
+ begin
+ if arithexpr(tq^.thi) then
+ begin
+ eexpr(tq^.thi);
+ if cvalof(tq^.tlo) <> 0 then
+ begin
+ write(' - ');
+ eexpr(tq^.tlo)
+ end
+ end
+ else begin
+ write('(int)(');
+ eexpr(tq^.thi);
+ if cvalof(tq^.tlo) <> 0 then
+ begin
+ write(') - (int)(');
+ eexpr(tq^.tlo)
+ end;
+ write(')')
+ end;
+ write(' + 1')
+ end
+ else
+ write(crange(tp^.taindx):1);
+ write(']; }')
+ end;
+ nfileof:
+ begin
+ writeln('struct {');
+ indent;
+ writeln(tab1, 'FILE', tab1, '*fp;');
+ indent;
+ writeln(tab1, filebits, tab1, 'eoln:1,');
+ indent;
+ writeln(tab3, 'eof:1,');
+ indent;
+ writeln(tab3, 'out:1,');
+ indent;
+ writeln(tab3, 'init:1,');
+ indent;
+ writeln(tab3, ':', filefill:1, ';');
+ indent;
+ write(tab1);
+ etdef(nil, tp^.tof);
+ writeln(tab1, 'buf;');
+ indent;
+ write('} ')
+ end;
+ nsetof:
+ write('struct { ', setwtyp, tab1, 'S[',
+ csetsize(tp):1, ']; }');
+ npredef:
+ begin
+ case tp^.tobtyp of
+ tboolean:
+ printid(defnams[dboolean]^.lid);
+ tchar:
+ write(chartyp);
+ tinteger:
+ printid(defnams[dinteger]^.lid);
+ treal:
+ printid(defnams[dreal]^.lid);
+ tstring:
+ write(chartyp, ' *');
+ ttext:
+ write('text');
+ tnil,
+ tset,
+ terror:
+ fatal(etree);
+ tnone:
+ write(voidtyp);
+ end (* case *)
+ end;
+ nempty:
+ write(voidtyp);
+ end;(* case *)
+ end; (* etdef *)
+ begin
+ etdef(nil, tp)
+ end; (* etypedef *)
+
+ (* Emit code for type declarations. *)
+ procedure etype(tp : treeptr);
+
+ var sp : symptr;
+
+ begin
+ while tp <> nil do
+ begin
+ (* if identifier used more than once we rename the type
+ to avoid typedef'ing an identifier twice *)
+ sp := tp^.tidl^.tsym;
+ if sp^.lid^.inref > 1 then
+ sp^.lid := mkrename('Y', sp^.lid);
+ indent;
+ write(typdef);
+ etypedef(tp^.tbind);
+ write(tab1);
+ printid(sp^.lid);
+ writeln(';');
+ tp := tp^.tnext
+ end
+ end;
+
+ (* Emit code for variable declarations. *)
+ procedure evar(tp : treeptr);
+
+ label 555;
+
+ var tq : treeptr;
+ i : integer;
+
+ begin
+ while tp <> nil do
+ begin
+ indent;
+ case tp^.tt of
+ nvar,
+ nvalpar,
+ nvarpar:
+ begin
+ if tp^.tattr = aregister then
+ write(registr);
+ etypedef(tp^.tbind)
+ end;
+ nparproc,
+ nparfunc:
+ begin
+ if tp^.tt = nparproc then
+ write(voidtyp)
+ else
+ etypedef(tp^.tpartyp);
+ tq := tp^.tparid;
+ write(tab1, '(*');
+ printid(tq^.tsym^.lid);
+ write(')()');
+ goto 555
+ end
+ end;(* case *)
+ write(tab1);
+ tq := tp^.tidl;
+ i := 1;
+ repeat
+ if tp^.tt = nvarpar then
+ write('*');
+ printid(tq^.tsym^.lid);
+ tq := tq^.tnext;
+ if tq <> nil then
+ begin
+ if i >= 6 then
+ begin
+ i := 1;
+ writeln(',');
+ indent;
+ write(tab1)
+ end
+ else begin
+ i := i + 1;
+ write(', ')
+ end
+
+ end
+ until tq = nil;
+ 555:
+ writeln(';');
+ if tp^.tt = nvarpar then
+ if tp^.tbind^.tt = nconfarr then
+ begin
+ indent;
+ etypedef(tp^.tbind^.tindtyp);
+ write(tab1);
+ tq := tp^.tbind^.tcindx^.thi;
+ printid(tq^.tsym^.lid);
+ writeln(';')
+ end;
+ tp := tp^.tnext
+ end
+ end; (* evar *)
+
+ (* Emit code for a statment. *)
+ procedure estmt(tp : treeptr);
+
+ var tq : treeptr;
+ locid1,
+ locid2 : idptr;
+ stusd : boolean;
+ opc1,
+ opc2 : char;
+
+ (* Emit typename for with-variable. *)
+ procedure ewithtype(tp : treeptr);
+
+ var tq : treeptr;
+
+ begin
+ tq := typeof(tp);
+ write('struct ');
+ printid(tq^.tuid)
+ end;
+
+ (* Emit code for a case-choise. *)
+ procedure echoise(tp : treeptr);
+
+ var tq : treeptr;
+ i : integer;
+
+ begin
+ while tp <> nil do
+ begin
+ tq := tp^.tchocon;
+ i := 0;
+ indent;
+ while tq <> nil do
+ begin
+ write(' case ');
+ conflag := true;
+ eexpr(tq);
+ conflag := false;
+ write(':');
+ i := i + 1;
+ tq := tq^.tnext;
+ if (tq = nil) or (i mod 4 = 0) then
+ begin
+ writeln;
+ if tq <> nil then
+ indent;
+ i := 0
+ end
+ end;
+ increment;
+ if tp^.tchostmt^.tt = nbegin then
+ estmt(tp^.tchostmt^.tbegin)
+ else
+ estmt(tp^.tchostmt);
+ indent;
+ writeln('break ;');
+ decrement;
+ tp := tp^.tnext;
+ if tp <> nil then
+ if tp^.tchocon = nil then
+ tp := nil
+ end
+ end; (* echoise *)
+
+ (* Rename all accessible record-fields to include *)
+ (* pointer name. *)
+ procedure cenv(ip : idptr; dp : declptr);
+
+ var tp : treeptr;
+ sp : symptr;
+ np : idptr;
+ h : hashtyp;
+
+ begin
+ with dp^ do
+ for h := 0 to hashmax - 1 do
+ begin
+ sp := ddecl[h];
+ while sp <> nil do
+ begin
+ if sp^.lt = lfield then
+ begin
+ np := sp^.lid;
+ tp := sp^.lsymdecl^.tup^.tup;
+ if (tp^.tup^.tt = nvariant) and
+ (tp^.tuid <> nil) then
+ np := mkconc('.',
+ tp^.tuid, np);
+ np := mkconc('>', ip, np);
+ sp^.lid := np
+ end;
+ sp := sp^.lnext
+ end
+ end
+ end; (* cenv *)
+
+ (* Emit identifiers for push/pop of global ptrs. *)
+ procedure eglobid(tp : treeptr);
+
+ var j : toknidx;
+ w : toknbuf;
+
+ begin
+ gettokn(tp^.tsym^.lid^.istr, w);
+ j := 1;
+ if w[1] = '*' then
+ j := 2;
+ while w[j] <> chr(null) do
+ begin
+ write(w[j]);
+ j := j + 1
+ end
+ end;
+
+ begin (* estmt *)
+ while tp <> nil do
+ begin
+ case tp^.tt of
+ nbegin:
+ begin
+ if tp^.tup^.tt in [nbegin, nrepeat,
+ nproc, nfunc, npgm] then
+ indent;
+ writeln('{');
+ increment;
+ estmt(tp^.tbegin);
+ decrement;
+ indent;
+ write('}');
+ if tp^.tup^.tt <> nif then
+ writeln
+ end;
+ nrepeat:
+ begin
+ indent;
+ writeln('do {');
+ increment;
+ estmt(tp^.treptstmt);
+ decrement;
+ indent;
+ write('} while (!(');
+ eexpr(tp^.treptxp);
+ writeln('));')
+ end;
+ nwhile:
+ begin
+ indent;
+ write('while (');
+ increment;
+ eexpr(tp^.twhixp);
+ stusd := setused;
+ if tp^.twhistmt^.tt = nbegin then
+ begin
+ decrement;
+ write(') ');
+ estmt(tp^.twhistmt)
+ end
+ else begin
+ writeln(')');
+ estmt(tp^.twhistmt);
+ decrement
+ end;
+ setused := stusd or setused
+ end;
+ nfor:
+ begin
+ indent;
+ if tp^.tincr then
+ begin
+ opc1 := '+'; (* increment variable *)
+ opc2 := '<' (* test for <= *)
+ end
+ else begin
+ opc1 := '-'; (* decrement variable *)
+ opc2 := '>'; (* test for >= *)
+ end;
+ if not lazyfor then
+ begin
+ locid1 := mkvariable('B');
+ locid2 := mkvariable('B');
+ writeln('{');
+ increment;
+ indent;
+ tq := idup(tp^.tforid);
+ etypedef(tq^.tbind);
+ tq := typeof(tq^.tbind);
+ write(tab1);
+ printid(locid1);
+ write(' = ');
+ eexpr(tp^.tfrom);
+ writeln(',');
+ indent;
+ write(tab1);
+ printid(locid2);
+ write(' = ');
+ eexpr(tp^.tto);
+ writeln(';');
+ writeln;
+ indent;
+ write('if (');
+ if tq^.tt = nscalar then
+ begin
+ write('(int)(');
+ printid(locid1);
+ write(')')
+ end
+ else
+ printid(locid1);
+ write(' ', opc2, '= ');
+ if tq^.tt = nscalar then
+ begin
+ write('(int)(');
+ printid(locid2);
+ write(')')
+ end
+ else
+ printid(locid2);
+ writeln(')');
+ increment;
+ indent;
+ tp^.tfrom := newid(locid1);
+ tp^.tfrom^.tup := tp
+ end;
+ write('for (');
+ increment;
+ eexpr(tp^.tforid);
+ tq := typeof(tp^.tforid);
+ write(' = ');
+ eexpr(tp^.tfrom);
+ write('; ');
+ if lazyfor then
+ begin
+ if tq^.tt = nscalar then
+ begin
+ write('(int)(');
+ eexpr(tp^.tforid);
+ write(')')
+ end
+ else
+ eexpr(tp^.tforid);
+ write(' ', opc2, '= ');
+ if tq^.tt = nscalar then
+ begin
+ write('(int)(');
+ eexpr(tp^.tto);
+ write(')')
+ end
+ else
+ eexpr(tp^.tto)
+ end;
+ write('; ');
+ eexpr(tp^.tforid);
+ if tq^.tt = nscalar then
+ begin
+ write(' = (');
+ eexpr(tq^.tup^.tidl);
+ write(')((int)(');
+ eexpr(tp^.tforid);
+ write(')', opc1, '1)')
+ end
+ else
+ write(opc1, opc1);
+ if not lazyfor then
+ begin
+ if tp^.tforstmt^.tt <> nbegin then
+ begin
+ (* create compund stmt *)
+ tq := mknode(nbegin);
+ tq^.tbegin := tp^.tforstmt;
+ tq^.tbegin^.tup := tq;
+ tp^.tforstmt := tq;
+ tq^.tup := tp
+ end;
+ (* find end of loop *)
+ tq := tp^.tforstmt^.tbegin;
+ while tq^.tnext <> nil do
+ tq := tq^.tnext;
+ (* add break stmt *)
+ tq^.tnext := mknode(nbreak);
+ tq := tq^.tnext;
+ tq^.tup := tp^.tforstmt;
+ tq^.tbrkid := tp^.tforid;
+ tq^.tbrkxp := newid(locid2);
+ tq^.tbrkxp^.tup := tq
+ end;
+ if tp^.tforstmt^.tt = nbegin then
+ begin
+ decrement;
+ write(') ');
+ estmt(tp^.tforstmt)
+ end
+ else begin
+ writeln(')');
+ estmt(tp^.tforstmt);
+ decrement
+ end;
+ if not lazyfor then
+ begin
+ decrement;
+ decrement;
+ indent;
+ writeln('}')
+ end
+ end;
+ nif:
+ begin
+ indent;
+ write('if (');
+ increment;
+ eexpr(tp^.tifxp);
+ stusd := setused;
+ setused := false;
+ if tp^.tthen^.tt = nbegin then
+ begin
+ decrement;
+ write(') ');
+ estmt(tp^.tthen);
+ if tp^.telse <> nil then
+ write(space)
+ else
+ writeln
+ end
+ else begin
+ writeln(')');
+ estmt(tp^.tthen);
+ decrement;
+ if tp^.telse <> nil then
+ indent
+ end;
+ if tp^.telse <> nil then
+ begin
+ write('else');
+ if tp^.telse^.tt = nbegin then
+ begin
+ write(space);
+ estmt(tp^.telse);
+ writeln
+ end
+ else begin
+ increment;
+ writeln;
+ estmt(tp^.telse);
+ decrement
+ end;
+ end;
+ setused := stusd or setused
+ end;
+ ncase:
+ begin
+ indent;
+ write('switch (');
+ increment;
+ eexpr(tp^.tcasxp);
+ writeln(') {');
+ decrement;
+ echoise(tp^.tcaslst);
+ indent;
+ writeln(' default:');
+ increment;
+ if tp^.tcasother = nil then
+ begin
+ indent;
+ writeln('Caseerror(Line);')
+ end
+ else
+ estmt(tp^.tcasother);
+ decrement;
+ indent;
+ writeln('}')
+ end;
+ nwith:
+ begin
+ indent;
+ writeln('{');
+ increment;
+ tq := tp^.twithvar;
+ while tq <> nil do
+ begin
+ indent;
+ write(registr);
+ ewithtype(tq^.texpw);
+ write(' *');
+ locid1 := mkvariable('W');
+ printid(locid1);
+ write(' = ');
+ eaddr(tq^.texpw);
+ writeln(';');
+ cenv(locid1, tq^.tenv);
+ tq := tq^.tnext
+ end;
+ writeln;
+ if tp^.twithstmt^.tt = nbegin then
+ estmt(tp^.twithstmt^.tbegin)
+ else
+ estmt(tp^.twithstmt);
+ decrement;
+ indent;
+ writeln('}')
+ end;
+ ngoto:
+ begin
+ indent;
+ if islocal(tp^.tlabel) then
+ writeln('goto L',
+ tp^.tlabel^.tsym^.lno:1, ';')
+ else begin
+ tq := idup(tp^.tlabel);
+ writeln('longjmp(J[', (* LIB *)
+ tq^.tstat:1, '].jb, ',
+ tp^.tlabel^.tsym^.lno:1, ');')
+ end
+ end;
+ nlabstmt:
+ begin
+ decrement;
+ indent;
+ writeln('L', tp^.tlabno^.tsym^.lno:1, ':');
+ increment;
+ estmt(tp^.tstmt)
+ end;
+ nassign:
+ begin
+ indent;
+ eexpr(tp);
+ writeln(';')
+ end;
+ ncall:
+ begin
+ indent;
+ tq := idup(tp^.tcall);
+ if (tq^.tt in [nfunc, nproc]) and
+ (tq^.tsubstmt <> nil) then
+ if tq^.tsubstmt^.tt = npredef then
+ epredef(tq, tp)
+ else begin
+ ecall(tp);
+ writeln(';')
+ end
+ else begin
+ ecall(tp);
+ writeln(';')
+ end
+ end;
+ npush:
+ begin
+ indent;
+ eglobid(tp^.ttmp);
+ write(' = ');
+ eglobid(tp^.tglob);
+ writeln(';');
+ indent;
+ eglobid(tp^.tglob);
+ write(' = ');
+ if tp^.tloc^.tt = nid then
+ begin
+ tq := idup(tp^.tloc);
+ if tq^.tt in [nparproc, nparfunc] then
+ printid(tp^.tloc^.tsym^.lid)
+ else
+ eaddr(tp^.tloc)
+ end
+ else
+ eaddr(tp^.tloc);
+ writeln(';')
+ end;
+ npop:
+ begin
+ indent;
+ eglobid(tp^.tglob);
+ write(' = ');
+ eglobid(tp^.ttmp);
+ writeln(';')
+ end;
+ nbreak:
+ begin
+ indent;
+ write('if (');
+ eexpr(tp^.tbrkid);
+ write(' == ');
+ eexpr(tp^.tbrkxp);
+ writeln(') break;')
+ end;
+ nempty:
+ if not (tp^.tup^.tt in [npgm, nproc, nfunc,
+ nchoise, nbegin, nrepeat]) then
+ begin
+ indent;
+ writeln(';')
+ end
+ end;(* case *)
+ if setused and
+ (tp^.tup^.tt in [npgm, nproc, nfunc, nrepeat,
+ nbegin, nchoise, nwith]) then
+ begin
+ indent;
+ writeln('Claimset();');
+ setused := false
+ end;
+ tp := tp^.tnext
+ end
+ end; (* estmt *)
+
+ (* Emit initialization for non-local gotos. *)
+ procedure elabel(tp : treeptr);
+
+ var tq : treeptr;
+ i : integer;
+
+ begin
+ i := 0;
+ tq := tp^.tsublab;
+ while tq <> nil do
+ begin
+ if tq^.tsym^.lgo then
+ i := i + 1;
+ tq := tq^.tnext
+ end;
+ if i =1 then
+ begin
+ tq := tp^.tsublab;
+ while not tq^.tsym^.lgo do
+ tq := tq^.tnext;
+ indent;
+ writeln('if (',
+ 'setjmp(J[', tp^.tstat:1, '].jb))'); (* LIB *)
+ writeln(tab1, 'goto L', tq^.tsym^.lno:1, ';')
+ end
+ else if i > 1 then
+ begin
+ indent;
+ writeln('switch (',
+ 'setjmp(J[', tp^.tstat:1, '].jb)) {'); (* LIB *)
+ indent;
+ writeln(' case 0:');
+ indent;
+ writeln(tab1, 'break');
+ tq := tp^.tsublab;
+ while tq <> nil do
+ begin
+ if tq^.tsym^.lgo then
+ begin
+ (* label used in non-local goto *)
+ indent;
+ writeln(' case ',
+ tq^.tsym^.lno:1, ':');
+ indent;
+ writeln(tab1, 'goto L',
+ tq^.tsym^.lno:1, ';')
+ end;
+ tq := tq^.tnext
+ end;
+ indent;
+ writeln(' default:');
+ indent;
+ writeln(tab1, 'Caseerror(Line)');
+ indent;
+ writeln('}')
+ end
+ end; (* elabel *)
+
+ (* Emit declaration for lower bound of conformant array. *)
+ procedure econf(tp : treeptr);
+
+ var tq : treeptr;
+
+ begin
+ while tp <> nil do
+ begin
+ if tp^.tt = nvarpar then
+ if tp^.tbind^.tt = nconfarr then
+ begin
+ indent;
+ etypedef(tp^.tbind^.tindtyp);
+ write(tab1);
+ tq := tp^.tbind^.tcindx^.tlo;
+ printid(tq^.tsym^.lid);
+ write(' = (');
+ etypedef(tp^.tbind^.tindtyp);
+ writeln(')0;')
+ end;
+ tp := tp^.tnext
+ end
+ end; (* econf *)
+
+ (* Emit code for subroutines. *)
+ procedure esubr(tp : treeptr);
+
+ label 999;
+
+ var tq, ti : treeptr;
+
+ begin
+ while tp <> nil do
+ begin
+ (* emit nested subroutines *)
+ if tp^.tsubsub <> nil then
+ begin
+ (* emit forward declaration of this subroutine
+ in case of recursion *)
+ etypedef(tp^.tfuntyp);
+ write(space);
+ printid(tp^.tsubid^.tsym^.lid);
+ writeln('();');
+ writeln;
+ esubr(tp^.tsubsub)
+ end;
+ (* emit this subroutine *)
+ if tp^.tsubstmt = nil then
+ begin
+ (* forward/external decl *)
+ if tp^.tsubid^.tsym^.lsymdecl^.tup = tp then
+ write(xtern);
+ etypedef(tp^.tfuntyp);
+ write(space);
+ printid(tp^.tsubid^.tsym^.lid);
+ writeln('();');
+ goto 999
+ end;
+ write(space);
+ etypedef(tp^.tfuntyp);
+ writeln;
+ printid(tp^.tsubid^.tsym^.lid);
+ write('(');
+ tq := tp^.tsubpar;
+ while tq <> nil do
+ begin
+ case tq^.tt of
+ nvarpar,
+ nvalpar:
+ begin
+ ti := tq^.tidl;
+ while ti <> nil do
+ begin
+ printid(ti^.tsym^.lid);
+ ti := ti^.tnext;
+ if ti <> nil then
+ write(', ');
+ end;
+ if tq^.tbind^.tt = nconfarr then
+ begin
+ (* add upper bound parameter *)
+ ti := tq^.tbind^.tcindx^.thi;
+ write(', ');
+ printid(ti^.tsym^.lid)
+ end;
+ end;
+ nparproc,
+ nparfunc:
+ begin
+ ti := tq^.tparid;
+ printid(ti^.tsym^.lid)
+ end
+ end;(* case *)
+ tq := tq^.tnext;
+ if tq <> nil then
+ write(', ');
+ end;
+ writeln(')');
+ increment;
+ evar(tp^.tsubpar);
+ writeln('{');
+ econf(tp^.tsubpar);
+ econst(tp^.tsubconst);
+ etype(tp^.tsubtype);
+ evar(tp^.tsubvar);
+
+ if (tp^.tsubconst <> nil) or (tp^.tsubtype <> nil) or
+ (tp^.tsubvar <> nil) then
+ writeln;
+ elabel(tp);
+ estmt(tp^.tsubstmt);
+ if tp^.tt = nfunc then
+ begin
+ (* return value in the FIRST variable,
+ see renamf() above *)
+ indent;
+ write('return ');
+ printid(tp^.tsubvar^.tidl^.tsym^.lid);
+ writeln(';');
+ end;
+ decrement;
+ writeln('}');
+ 999:
+ writeln;
+ tp := tp^.tnext
+ end
+ end; (* esubr *)
+
+ function use(d : predefs) : boolean;
+
+ begin
+ use := defnams[d]^.lused
+ end;
+
+ (* Emit code for main program. *)
+ procedure eprogram(tp : treeptr);
+
+ (* Symbol that sp refers to is renamed if it has *)
+ (* been redefined in source program. *)
+ procedure capital(sp : symptr);
+
+ var tb : toknbuf;
+
+ begin
+ if sp^.lid^.inref > 1 then
+ begin
+ gettokn(sp^.lid^.istr, tb);
+ tb[1] := uppercase(tb[1]);
+ sp^.lid := saveid(tb)
+ end
+ end;
+
+ procedure etextdef;
+
+ var tq : treeptr;
+
+ begin
+ write('typedef ');
+ tq := mknode(nfileof);
+ tq^.tof := typnods[tchar];
+ etypedef(tq);
+ writeln(tab1, 'text;')
+ end;
+
+ begin (* eprogram *)
+ if tp^.tsubid <> nil then
+ begin
+ (* program heading was seen *)
+ writeln('/', '*');
+ write('** Code derived from program ');
+ printid(tp^.tsubid^.tsym^.lid);
+ writeln;
+ writeln('*', '/');
+ writeln(xtern, voidtyp, tab1, 'exit();')
+ end;
+ if usecase or usesets or
+ use(dinput) or use(doutput) or
+ use(dwrite) or use(dwriteln) or use(dmessage) or
+ use(deof) or use(deoln) or use(dflush) or use(dpage) or
+ use(dread) or use(dreadln) or use(dclose) or
+ use(dreset) or use(drewrite) or use(dget) or use(dput) then
+ begin
+ writeln('/', '*');
+ writeln('** Definitions for i/o');
+ writeln('*', '/');
+ writeln(include, '<stdio.h>') (* LIB *)
+ end;
+ if use(dinput) or use(doutput) or use(dtext) then
+ begin
+ etextdef;
+ if use(dinput) then
+ begin
+ if tp^.tsubid = nil then
+ write(xtern);
+ write('text', tab1);
+ printid(defnams[dinput]^.lid);
+ if tp^.tsubid <> nil then
+ write(' = { stdin, 0, 0 }');
+ writeln(';')
+ end;
+ if use(doutput) then
+ begin
+ if tp^.tsubid = nil then
+ write(xtern);
+ write('text', tab1);
+ printid(defnams[doutput]^.lid);
+ if tp^.tsubid <> nil then
+ write(' = { stdout, 0, 0 }');
+ writeln(';')
+ end
+ end;
+ if use(dinput) or use(dget) or use(dread) or use(dreadln) or
+ use(deof) or use(deoln) or use(dreset) or use(drewrite) then
+ begin
+ writeln(define, 'Fread(x, f) ',
+ 'fread((char *)&x, sizeof(x), 1, f)'); (* LIB *)
+ writeln(define, 'Get(f) Fread((f).buf, (f).fp)');
+ writeln(define, 'Getx(f) (f).init = 1, ',
+ '(f).eoln = (((f).buf = ',
+ 'fgetc((f).fp)', (* LIB *)
+ ') == ', nlchr, ') ? (((f).buf = ',
+ spchr, '), 1) : 0');
+ writeln(define, 'Getchr(f) (f).buf, Getx(f)')
+ end;
+ if use(dread) or use(dreadln) then
+ begin
+ writeln(static, 'FILE', tab1, '*Tmpfil;');
+ writeln(static, 'long', tab1, 'Tmplng;');
+ writeln(static, 'double', tab1, 'Tmpdbl;');
+ writeln(define, 'Fscan(f) (f).init ? ',
+ 'ungetc((f).buf, (f).fp)', (* LIB *)
+ ' : 0, Tmpfil = (f).fp');
+ writeln(define, 'Scan(p, a) ',
+ 'Scanck(fscanf(Tmpfil, p, a))'); (* LIB *)
+ writeln(voidtyp, tab1, 'Scanck();');
+ if use(dreadln) then
+ writeln(voidtyp, tab1, 'Getl();');
+ end;
+ if use(deoln) then
+ writeln(define, 'Eoln(f) ((f).eoln ? true : false)');
+ if use(deof) then
+ writeln(define, 'Eof(f) ',
+ '((((f).init == 0) ? (Get(f)) : 0, ',
+ '((f).eof ? 1 : ',
+ 'feof((f).fp))) ? ', (* LIB *)
+ 'true : false)');
+ if use(doutput) or use(dput) or
+ use(dwrite) or use(dwriteln) or
+ use(dreset) or use(drewrite) or use(dclose) then
+ begin
+ writeln(define, 'Fwrite(x, f) ',
+ 'fwrite((char *)&x, sizeof(x), 1, f)');(* LIB *)
+ writeln(define, 'Put(f) Fwrite((f).buf, (f).fp)');
+ writeln(define, 'Putx(f) (f).eoln = ((f).buf == ',
+ nlchr, '), ', voidcast,
+ 'fputc((f).buf, (f).fp)'); (* LIB *)
+ writeln(define, 'Putchr(c, f) (f).buf = (c), Putx(f)');
+ writeln(define, 'Putl(f, v) (f).eoln = v')
+ end;
+ if use(dreset) or use(drewrite) or use(dclose) then
+ writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
+ '(Putchr(', nlchr, ', f), 0) : 0, ',
+ 'rewind((f).fp)'); (* LIB *)
+ if use(dclose) then
+ begin
+ writeln(define, 'Close(f) (f).init = ',
+ '((f).init ? (',
+ 'fclose((f).fp), ', (* LIB *)
+ '0) : 0), (f).fp = NULL');
+ writeln(define, 'Closex(f) (f).init = ',
+ '((f).init ? ',
+ '(Finish(f), ',
+ 'fclose((f).fp), ', (* LIB *)
+ '0) : 0), (f).fp = NULL')
+ end;
+ if use(dreset) then
+ begin
+ writeln(ifdef, 'READONLY');
+ writeln(static, chartyp, tab1, 'Rmode[] = "r";');
+ writeln(elsif);
+ writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
+ writeln(endif);
+ writeln(define, 'Reset(f, n) (f).init = ',
+ '(f).init ? rewind((f).fp) : ', (* LIB *)
+ '(((f).fp = Fopen(n, Rmode)), 1), ',
+ '(f).eof = (f).out = 0, Get(f)');
+ writeln(define, 'Resetx(f, n) (f).init = ',
+ '(f).init ? (Finish(f)) : ',
+ '(((f).fp = Fopen(n, Rmode)), 1), ',
+ '(f).eof = (f).out = 0, Getx(f)');
+ usefopn := true
+ end;
+ if use(drewrite) then
+ begin
+ writeln(ifdef, 'WRITEONLY');
+ writeln(static, chartyp, tab1, 'Wmode[] = "w";');
+ writeln(elsif);
+ writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
+ writeln(endif);
+ writeln(define, 'Rewrite(f, n) (f).init = ',
+ '(f).init ? rewind((f).fp) : ', (* LIB *)
+ '(((f).fp = Fopen(n, Wmode)), 1), ',
+ '(f).out = (f).eof = 1');
+ writeln(define, 'Rewritex(f, n) (f).init = ',
+ '(f).init ? (Finish(f)) : ',
+ '(((f).fp = Fopen(n, Wmode)), 1), ',
+ '(f).out = (f).eof = (f).eoln = 1');
+ usefopn := true
+ end;
+ if usefopn then
+ begin
+ writeln('FILE *Fopen();');
+ writeln(define, 'MAXFILENAME 256')
+ end;
+ if usecase or usejmps then
+ begin
+ writeln('/', '*');
+ writeln('** Definitions for case-statements');
+ writeln('** and for non-local gotos');
+ writeln('*', '/');
+ writeln(define, 'Line __LINE__');
+ writeln(voidtyp, tab1, 'Caseerror();')
+ end;
+ if usejmps then
+ begin
+ writeln(include, '<setjmp.h>'); (* LIB *)
+ writeln(static, 'struct Jb { jmp_buf', tab1, 'jb; } J[',
+ (maxlevel+1):1, '];')
+ end;
+ if use(dinteger) or use(dmaxint) or
+ use(dboolean) or use(dfalse) or use(dtrue) or
+ use(deof) or use(deoln) or use(dexp) or
+ use(dln) or use(dsqr) or use(dsin) or
+ use(dcos) or use(dtan) or use(darctan) or
+ use(dsqrt) or use(dreal) then
+ begin
+ writeln('/', '*');
+ writeln('** Definitions for standard types');
+ writeln('*', '/')
+ end;
+ if usecomp then
+ begin
+ writeln(xtern, inttyp, ' strncmp();'); (* LIB *)
+ writeln(define,
+ 'Cmpstr(x, y) ',
+ 'strncmp((x), (y), sizeof(x))') (* LIB *)
+ end;
+ if use(dboolean) or use(dfalse) or use(dtrue) or
+ use(deof) or use(deoln) or usesets then
+ begin
+ capital(defnams[dboolean]);
+ write(typdef, chartyp, tab1);
+ printid(defnams[dboolean]^.lid);
+ writeln(';');
+ capital(defnams[dfalse]);
+ write(define);
+ printid(defnams[dfalse]^.lid);
+ write(' (');
+ printid(defnams[dboolean]^.lid);
+ writeln(')0');
+ capital(defnams[dtrue]);
+ write(define);
+ printid(defnams[dtrue]^.lid);
+ write(' (');
+ printid(defnams[dboolean]^.lid);
+ writeln(')1');
+ writeln(xtern, chartyp, tab1, '*Bools[];')
+ end;
+ capital(defnams[dinteger]);
+ if use(dinteger) then
+ begin
+ write(typdef, inttyp, tab1);
+ printid(defnams[dinteger]^.lid);
+ writeln(';')
+ end;
+ if use(dmaxint) then
+ writeln(define, 'maxint', tab1, maxint:1);
+ capital(defnams[dreal]);
+ if use(dreal) then
+ begin
+ write(typdef, realtyp, tab1);
+ printid(defnams[dreal]^.lid);
+ writeln(';')
+ end;
+ if use(dexp) then
+ writeln(xtern, doubletyp, ' exp();'); (* LIB *)
+ if use(dln) then
+ writeln(xtern, doubletyp, ' log();'); (* LIB *)
+ if use(dsqr) then
+ writeln(xtern, doubletyp, ' pow();'); (* LIB *)
+ if use(dsin) then
+ writeln(xtern, doubletyp, ' sin();'); (* LIB *)
+ if use(dcos) then
+ writeln(xtern, doubletyp, ' cos();'); (* LIB *)
+ if use(dtan) then
+ writeln(xtern, doubletyp, ' tan();'); (* LIB *)
+ if use(darctan) then
+ writeln(xtern, doubletyp, ' atan();'); (* LIB *)
+ if use(dsqrt) then
+ writeln(xtern, doubletyp, ' sqrt();'); (* LIB *)
+ if use(dabs) and use(dreal) then
+ writeln(xtern, doubletyp, ' fabs();'); (* LIB *)
+ if use(dhalt) then
+ writeln(xtern, voidtyp, ' abort();'); (* LIB *)
+ if use(dnew) or usenilp then
+ begin
+ writeln('/', '*');
+ writeln('** Definitions for pointers');
+ writeln('*', '/');
+ end;
+ if use(dnew) then
+ begin
+ writeln(ifndef, 'Unionoffs');
+ writeln(define, 'Unionoffs(p, m) ',
+ '(((long)(&(p)->m))-((long)(p)))'); (* CPU *)
+ writeln(endif)
+ end;
+ if usenilp then
+ writeln(define, 'NIL 0'); (* CPU *)
+ if use(dnew) then
+ writeln(xtern, chartyp, ' *malloc();'); (* LIB *)
+ if use(ddispose) then
+ writeln(xtern, voidtyp, ' free();'); (* LIB *)
+ if usesets then
+ begin
+ writeln('/', '*');
+ writeln('** Definitions for set-operations');
+ writeln('*', '/');
+ writeln(define, 'Claimset() ',
+ voidcast, 'Currset(0, (', setptyp, ')0)');
+ writeln(define, 'Newset() ',
+ 'Currset(1, (', setptyp, ')0)');
+ writeln(define, 'Saveset(s) Currset(2, s)');
+ writeln(define, 'setbits ', setbits:1);
+ writeln(typdef, wordtype, tab1, setwtyp, ';');
+ writeln(typdef, setwtyp, ' *', tab1, setptyp, ';');
+ printid(defnams[dboolean]^.lid);
+ writeln(tab1, 'Member(), Le(), Ge(), Eq(), Ne();');
+ writeln(setptyp, tab1, 'Union(), Diff();');
+ writeln(setptyp, tab1, 'Insmem(), Mksubr();');
+ writeln(setptyp, tab1, 'Currset(), Inter();');
+ writeln(static, setptyp, tab1, 'Tmpset;');
+ writeln(xtern, setptyp, tab1, 'Conset[];');
+ writeln(voidtyp, tab1, 'Setncpy();')
+ end;
+ writeln(xtern, chartyp, ' *strncpy();'); (* LIB *)
+ if use(dargc) or use(dargv) then
+ begin
+ writeln('/', '*');
+ writeln('** Definitions for argv-operations');
+ writeln('*', '/');
+ writeln(inttyp, tab1, 'argc;'); (* OS *)
+ writeln(chartyp, tab1, '**argv;');
+ writeln(' void');
+ writeln('Argvgt(n, cp, l)');
+ writeln(inttyp, tab1, 'n;');
+ writeln(registr, inttyp, tab1, 'l;');
+ writeln(registr, chartyp, tab1, '*cp;');
+ writeln('{');
+ writeln(tab1, registr, chartyp, tab1, '*sp;');
+ writeln;
+ writeln(tab1, 'for (sp = argv[n]; l > 0 && *sp; l--)');
+ writeln(tab2, '*cp++ = *sp++;');
+ writeln(tab1, 'while (l-- > 0)');
+ writeln(tab2, '*cp++ = ', spchr, ';');
+ writeln('}');
+ end;
+ if (tp^.tsubconst <> nil) or (tp^.tsubtype<> nil) or
+ (tp^.tsubvar <> nil) or (tp^.tsubsub <> nil) then
+ begin
+ writeln('/', '*');
+ writeln('** Start of program definitions');
+ writeln('*', '/');
+ end;
+ econst(tp^.tsubconst);
+ etype(tp^.tsubtype);
+ evar(tp^.tsubvar);
+ if tp^.tsubsub <> nil then
+ writeln;
+ esubr(tp^.tsubsub);
+ if tp^.tsubid <> nil then
+ begin
+ (* program heading was seen *)
+ writeln('/', '*');
+ writeln('** Start of program code');
+ writeln('*', '/');
+ if use(dargc) or use(dargv) then
+ begin
+ writeln('main(_ac, _av)'); (* OS *)
+ writeln(inttyp, tab1, '_ac;');
+ writeln(chartyp, tab1, '*_av[];');
+ writeln('{');
+ writeln;
+ writeln(tab1, 'argc = _ac;');
+ writeln(tab1, 'argv = _av;')
+ end
+ else begin
+ writeln('main()');
+ writeln('{')
+ end;
+ increment;
+ elabel(tp);
+ estmt(tp^.tsubstmt);
+ indent;
+ writeln('exit(0);');
+ decrement;
+ writeln('}');
+ writeln('/', '*');
+ writeln('** End of program code');
+ writeln('*', '/')
+ end
+ end; (* eprogram *)
+
+ (* Emit definitions for constant sets *)
+ procedure econset(tp : treeptr; len : integer);
+
+ var i : integer;
+
+ function size(tp : treeptr) : integer;
+
+ var r, x : integer;
+
+ begin
+ r := 0;
+ while tp <> nil do
+ begin
+ if tp^.tt = nrange then
+ x := cvalof(tp^.texpr)
+ else if tp^.tt = nempty then
+ x := 0
+ else
+ x := cvalof(tp);
+ if x > r then
+ r := x;
+ tp := tp^.tnext
+ end;
+ size := csetwords(r+1)
+ end;
+
+ (* Emit bits in a constant set *)
+ procedure ebits(tp : treeptr);
+
+ type bitset = set of 0 .. setbits;
+
+ var sets : array [ 0 .. maxsetrange ] of bitset;
+ s, m, n : integer;
+
+ procedure eword(s : bitset);
+
+ const bitshex = 4; (* nr of bits in a hex-digit *)
+
+ var n, i : integer;
+ x : 0 .. setbits;
+
+ begin
+ n := 0;
+ while n <= setbits do
+ n := n + bitshex;
+ n := n - bitshex;
+ while n >= 0 do
+ begin
+ (* compute 1 hexdigit *)
+ x := 0;
+ for i := 0 to bitshex - 1 do
+ if (n + i) in s then
+ case i of
+ 0: x := x + 1;
+ 1: x := x + 2;
+ 2: x := x + 4;
+ 3: x := x + 8
+ end;(* case *)
+ (* print it *)
+ write(hexdig[x]);
+ n := n - bitshex
+ end
+ end;
+
+ begin
+ s := size(tp);
+ for n := 0 to s - 1 do
+ sets[n] := [];
+ while tp <> nil do
+ begin
+ if tp^.tt = nrange then
+ for m := cvalof(tp^.texpl) to
+ cvalof(tp^.texpr) do
+ begin
+ n := m div (setbits+1);
+ sets[n] := sets[n] +
+ [m mod (setbits+1)]
+ end
+ else if tp^.tt <> nempty then
+ begin
+ m := cvalof(tp);
+ n := m div (setbits+1);
+ sets[n] := sets[n] +
+ [m mod (setbits+1)]
+ end;
+ tp := tp^.tnext
+ end;
+ write(tab1, s:1);
+ for n := 0 to s - 1 do
+ begin
+ write(',');
+ if n mod 6 = 0 then
+ writeln;
+ write(tab1, '0x');
+ eword(sets[n]);
+ end;
+ writeln
+ end;
+
+ begin
+ i := 0;
+ while tp <> nil do
+ begin
+ writeln(static, setwtyp, tab1, 'Q', i:1, '[] = {');
+ ebits(tp^.texps);
+ writeln('};');
+ i := i + 1;
+ tp := tp^.tnext
+ end;
+ writeln(static, setwtyp, tab1, '*Conset[] = {');
+ for i := len - 1 downto 1 do
+ begin
+ write(tab1, 'Q', i:1, ',');
+ if i mod 6 = 5 then
+ writeln
+ end;
+ writeln(tab1, 'Q0');
+ writeln('};');
+ end;
+
+ begin (* emit *)
+ indnt := 0;
+ varno := 0;
+ conflag := false;
+ setused := false;
+ dropset := false;
+ doarrow := 0;
+ eprogram(top);
+ if usebool then
+ writeln(chartyp, tab1, '*Bools[] = { "false", "true" };');
+ if usescan then
+ begin
+ writeln;
+ writeln(static, voidtyp);
+ writeln('Scanck(n)');
+ writeln(inttyp, tab1, 'n;');
+ writeln('{');
+ writeln(tab1, 'if (n != 1) {');
+ writeln(tab2, voidcast, 'fprintf(stderr, "Bad input\n");');
+ writeln(tab2, 'exit(1);');
+ writeln(tab1, '}');
+ writeln('}')
+ end;
+ if usegetl then
+ begin
+ writeln;
+ writeln(static, voidtyp);
+ writeln('Getl(f)');
+ writeln(' text', tab1, '*f;');
+ writeln('{');
+ writeln(tab1, 'while (f->eoln == 0)');
+ writeln(tab2, 'Getx(*f);');
+ writeln(tab1, 'Getx(*f);');
+ writeln('}')
+ end;
+ if usefopn then
+ begin
+ writeln;
+ writeln(static, 'FILE *');
+ writeln('Fopen(n, m)');
+ writeln(chartyp, tab1, '*n, *m;');
+ writeln('{');
+ writeln(tab1, 'FILE', tab2, '*f;');
+ writeln(tab1, registr, chartyp, tab1, '*s;');
+ writeln(tab1, static, chartyp, tab1, 'ch = ',
+ quote, 'A', quote, ';');
+ writeln(tab1, static, chartyp, tab1, 'tmp[MAXFILENAME];');
+ writeln(tab1, xtern , inttyp, tab1, 'unlink();'); (* OS *)
+ writeln;
+ writeln(tab1, 'if (n == NULL)');
+ writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
+ writeln(tab1, 'else {');
+ writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
+ writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
+ spchr, ' || *s == ', nulchr, '; )');
+ writeln(tab3, '*s-- = ', nulchr, ';');
+ writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
+ writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
+ quote, '%s', quote, '\n", n);');
+ writeln(tab3, 'exit(1);');
+ writeln(tab2, '}');
+ writeln(tab1, '}');
+ writeln(tab1, 's = tmp;');
+ writeln(tab1, 'if ((f = fopen(s, m)) == NULL) {');
+ writeln(tab2, voidcast,
+ 'fprintf(stderr, "Cannot open: %s\n", s);');
+ writeln(tab2, 'exit(1);');
+ writeln(tab1, '}');
+ writeln(tab1, 'if (n == NULL)');
+ writeln(tab2, 'unlink(tmp);'); (* OS *)
+ writeln(tab1, 'return (f);');
+ writeln('}');
+ writeln(xtern, inttyp, tab1, 'rewind();')
+ end;
+ if setcnt > 0 then
+ econset(setlst, setcnt);
+ if useunion then
+ begin
+ writeln;
+ writeln(static, setptyp);
+ writeln('Union(p1, p2)');
+ writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
+ writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
+ writeln(tab4, 'p3 = sp;');
+ writeln;
+ writeln(tab1, 'j = *p1;');
+ writeln(tab1, '*p3 = j;');
+ writeln(tab1, 'if (j > *p2)');
+ writeln(tab2, 'j = *p2;');
+ writeln(tab1, 'else');
+ writeln(tab2, '*p3 = *p2;');
+ writeln(tab1, 'k = *p1 - *p2;');
+ writeln(tab1, 'p1++, p2++, p3++;');
+ writeln(tab1, 'for (i = 0; i < j; i++)');
+ writeln(tab2, '*p3++ = (*p1++ | *p2++);');
+ writeln(tab1, 'while (k > 0) {');
+ writeln(tab2, '*p3++ = *p1++;');
+ writeln(tab2, 'k--;');
+ writeln(tab1, '}');
+ writeln(tab1, 'while (k < 0) {');
+ writeln(tab2, '*p3++ = *p2++;');
+ writeln(tab2, 'k++;');
+ writeln(tab1, '}');
+ writeln(tab1, 'return (Saveset(sp));');
+ writeln('}')
+ end;
+ if usediff then
+ begin
+ writeln;
+ writeln(static, setptyp);
+ writeln('Diff(p1, p2)');
+ writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
+ writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
+ writeln(tab4, 'p3 = sp;');
+ writeln;
+ writeln(tab1, 'j = *p1;');
+ writeln(tab1, '*p3 = j;');
+ writeln(tab1, 'if (j > *p2)');
+ writeln(tab2, 'j = *p2;');
+ writeln(tab1, 'k = *p1 - *p2;');
+ writeln(tab1, 'p1++, p2++, p3++;');
+ writeln(tab1, 'for (i = 0; i < j; i++)');
+ writeln(tab2, '*p3++ = (*p1++ & ~ (*p2++));');
+ writeln(tab1, 'while (k > 0) {');
+ writeln(tab2, '*p3++ = *p1++;');
+ writeln(tab2, 'k--;');
+ writeln(tab1, '}');
+ writeln(tab1, 'return (Saveset(sp));');
+ writeln('}')
+ end;
+ if useintr then
+ begin
+ writeln;
+ writeln(static, setptyp);
+ writeln('Inter(p1, p2)');
+ writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
+ writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
+ writeln(tab4, 'p3 = sp;');
+ writeln;
+ writeln(tab1, 'if ((j = *p1) > *p2)');
+ writeln(tab2, 'j = *p2;');
+ writeln(tab1, '*p3 = j;');
+ writeln(tab1, 'p1++, p2++, p3++;');
+ writeln(tab1, 'for (i = 0; i < j; i++)');
+ writeln(tab2, '*p3++ = (*p1++ & *p2++);');
+ writeln(tab1, 'return (Saveset(sp));');
+ writeln('}')
+ end;
+ if usememb then
+ begin
+ writeln;
+ write(static);
+ printid(defnams[dboolean]^.lid);
+ writeln;
+ writeln('Member(m, sp)');
+ writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
+ writeln(tab1, registr, setptyp, tab1, 'sp;');
+ writeln('{');
+ writeln(tab1, registr, usigned, inttyp,
+ tab1, 'i = m / (setbits+1) + 1;');
+ writeln;
+ writeln(tab1, 'if ((i <= *sp) &&',
+ ' (sp[i] & (1 << (m % (setbits+1)))))');
+ write(tab2, 'return (');
+ printid(defnams[dtrue]^.lid);
+ writeln(');');
+ write(tab1, 'return (');
+ printid(defnams[dfalse]^.lid);
+ writeln(');');
+ writeln('}')
+ end;
+ if useseq or usesne then
+ begin
+ writeln;
+ write(static);
+ printid(defnams[dboolean]^.lid);
+ writeln;
+ writeln('Eq(p1, p2)');
+ writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab1, 'i, j;');
+ writeln;
+ writeln(tab1, 'i = *p1++;');
+ writeln(tab1, 'j = *p2++;');
+ writeln(tab1, 'while (i != 0 && j != 0) {');
+ writeln(tab2, 'if (*p1++ != *p2++)');
+ write(tab3, 'return (');
+ printid(defnams[dfalse]^.lid);
+ writeln(');');
+ writeln(tab2, 'i--, j--;');
+ writeln(tab1, '}');
+ writeln(tab1, 'while (i != 0) {');
+ writeln(tab2, 'if (*p1++ != 0)');
+ write(tab3, 'return (');
+ printid(defnams[dfalse]^.lid);
+ writeln(');');
+ writeln(tab2, 'i--;');
+ writeln(tab1, '}');
+ writeln(tab1, 'while (j != 0) {');
+ writeln(tab2, 'if (*p2++ != 0)');
+ write(tab3, 'return (');
+ printid(defnams[dfalse]^.lid);
+ writeln(');');
+ writeln(tab2, 'j--;');
+ writeln(tab1, '}');
+ write(tab1, 'return (');
+ printid(defnams[dtrue]^.lid);
+ writeln(');');
+ writeln('}')
+ end;
+ if usesne then
+ begin
+ writeln;
+ write(static);
+ printid(defnams[dboolean]^.lid);
+ writeln;
+ writeln('Ne(p1, p2)');
+ writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
+ writeln('{');
+ write(tab1, 'return (!Eq(p1, p2));');
+ writeln('}')
+ end;
+ if usesle then
+ begin
+ writeln;
+ write(static);
+ printid(defnams[dboolean]^.lid);
+ writeln;
+ writeln('Le(p1, p2)');
+ writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab1, 'i, j;');
+ writeln;
+ writeln(tab1, 'i = *p1++;');
+ writeln(tab1, 'j = *p2++;');
+ writeln(tab1, 'while (i != 0 && j != 0) {');
+ writeln(tab2, 'if ((*p1++ & ~ *p2++) != 0)');
+ write(tab3, 'return (');
+ printid(defnams[dfalse]^.lid);
+ writeln(');');
+ writeln(tab2, 'i--, j--;');
+ writeln(tab1, '}');
+ writeln(tab1, 'while (i != 0) {');
+ writeln(tab2, 'if (*p1++ != 0)');
+ write(tab3, 'return (');
+ printid(defnams[dfalse]^.lid);
+ writeln(');');
+ writeln(tab2, 'i--;');
+ writeln(tab1, '}');
+ write(tab1, 'return (');
+ printid(defnams[dtrue]^.lid);
+ writeln(');');
+ writeln('}')
+ end;
+ if usesge then
+ begin
+ writeln;
+ write(static);
+ printid(defnams[dboolean]^.lid);
+ writeln;
+ writeln('Ge(p1, p2)');
+ writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab1, 'i, j;');
+ writeln;
+ writeln(tab1, 'i = *p1++;');
+ writeln(tab1, 'j = *p2++;');
+ writeln(tab1, 'while (i != 0 && j != 0) {');
+ writeln(tab2, 'if ((*p2++ & ~ *p1++) != 0)');
+ writeln(tab3, 'return (false);');
+ writeln(tab2, 'i--, j--;');
+ writeln(tab1, '}');
+ writeln(tab1, 'while (j != 0) {');
+ writeln(tab2, 'if (*p2++ != 0)');
+ write(tab3, 'return (');
+ printid(defnams[dfalse]^.lid);
+ writeln(');');
+ writeln(tab2, 'j--;');
+ writeln(tab1, '}');
+ write(tab1, 'return (');
+ printid(defnams[dtrue]^.lid);
+ writeln(');');
+ writeln('}')
+ end;
+ if usemksub then
+ begin
+ writeln;
+ writeln(static, setptyp);
+ writeln('Mksubr(lo, hi, sp)');
+ writeln(tab1, registr, usigned, inttyp, tab1, 'lo, hi;');
+ writeln(tab1, registr, setptyp, tab1, 'sp;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab1, 'i, k;');
+ writeln;
+ writeln(tab1, 'if (hi < lo)');
+ writeln(tab2, 'return (sp);');
+ writeln(tab1, 'i = hi / (setbits+1) + 1;');
+ writeln(tab1, 'for (k = *sp + 1; k <= i; k++)');
+ writeln(tab2, 'sp[k] = 0;');
+ writeln(tab1, 'if (*sp < i)');
+ writeln(tab2, '*sp = i;');
+ writeln(tab1, 'for (k = lo; k <= hi; k++)');
+ writeln(tab2, 'sp[k / (setbits+1) + 1] |= ',
+ '(1 << (k % (setbits+1)));');
+ writeln(tab1, 'return (sp);');
+ writeln('}')
+ end;
+ if useins then
+ begin
+ writeln;
+ writeln(static, setptyp);
+ writeln('Insmem(m, sp)');
+ writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
+ writeln(tab1, registr, setptyp, tab1, 'sp;');
+ writeln('{');
+ writeln(tab1, registr, inttyp, tab1, 'i,');
+ writeln(tab3, tab1, 'j = m / (setbits+1) + 1;');
+ writeln;
+ writeln(tab1, 'if (*sp < j)');
+ writeln(tab2, 'for (i = *sp + 1, *sp = j; i <= *sp; i++)');
+ writeln(tab3, 'sp[i] = 0;');
+ writeln(tab1, 'sp[j] |= (1 << (m % (setbits+1)));');
+ writeln(tab1, 'return (sp);');
+ writeln('}')
+ end;
+ if usesets then
+ begin
+ writeln;
+ writeln(ifndef, 'SETSPACE');
+ writeln(define, 'SETSPACE 256');
+ writeln(endif);
+ writeln(static, setptyp);
+ writeln('Currset(n,sp)');
+ writeln(tab1, inttyp, tab1, 'n;');
+ writeln(tab1, setptyp, tab1, 'sp;');
+ writeln('{');
+ writeln(tab1, static, setwtyp, tab1, 'Space[SETSPACE];');
+ writeln(tab1, static, setptyp, tab1, 'Top = Space;');
+ writeln;
+ writeln(tab1, 'switch (n) {');
+ writeln(tab1, ' case 0:');
+ writeln(tab2, 'Top = Space;');
+ writeln(tab2, 'return (0);');
+ writeln(tab1, ' case 1:');
+ writeln(tab2, 'if (&Space[SETSPACE] - Top <= ',
+ maxsetrange:1, ') {');
+ writeln(tab3,
+ voidcast, 'fprintf(stderr, "Set-space exhausted\n");');
+ writeln(tab3, 'exit(1);');
+ writeln(tab2, '}');
+ writeln(tab2, '*Top = 0;');
+ writeln(tab2, 'return (Top);');
+ writeln(tab1, ' case 2:');
+ writeln(tab2, 'if (Top <= &sp[*sp])');
+ writeln(tab3, 'Top = &sp[*sp + 1];');
+ writeln(tab2, 'return (sp);');
+ writeln(tab1, '}');
+ writeln(tab1, '/', '* NOTREACHED *', '/');
+ writeln('}')
+ end;
+ if usescpy then
+ begin
+ writeln;
+ writeln(static, voidtyp);
+ writeln('Setncpy(S1, S2, N)');
+ writeln(tab1, registr, setptyp, tab1, 'S1, S2;');
+ writeln(tab1, registr, usigned, inttyp, tab1, 'N;');
+ writeln('{');
+ writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
+ writeln;
+ writeln(tab1, 'N /= sizeof(', setwtyp, ');');
+ writeln(tab1, '*S1++ = --N;');
+ writeln(tab1, 'm = *S2++;');
+ writeln(tab1, 'while (m != 0 && N != 0) {');
+ writeln(tab2, '*S1++ = *S2++;');
+ writeln(tab2, '--N;');
+ writeln(tab2, '--m;');
+ writeln(tab1, '}');
+ writeln(tab1, 'while (N-- != 0)');
+ writeln(tab2, '*S1++ = 0;');
+ writeln('}')
+ end;
+ if usecase then
+ begin
+ writeln;
+ writeln(static, voidtyp);
+ writeln('Caseerror(n)');
+ writeln(tab1, inttyp, tab1, 'n;');
+ writeln('{');
+ writeln(tab1, voidcast,
+ 'fprintf(stderr, "Missing case limb: line %d\n", n);');
+ writeln(tab1, 'exit(1);');
+ writeln('}')
+ end;
+ if usemax then
+ begin
+ writeln;
+ writeln(static, inttyp);
+ writeln('Max(m, n)');
+ writeln(tab1, inttyp, tab1, 'm, n;');
+ writeln('{');
+ writeln(tab1, 'if (m > n)');
+ writeln(tab2, 'return (m);');
+ writeln(tab1, 'return (n);');
+ writeln('}')
+ end;
+ if use(dtrunc) then
+ begin
+ writeln(static, inttyp);
+ writeln('Trunc(f)');
+ printid(defnams[dreal]^.lid);
+ writeln(tab1, 'f;');
+ writeln('{');
+ writeln(tab1, 'return f;');
+ writeln('}')
+ end;
+ if use(dround) then
+ begin
+ writeln(static, inttyp);
+ writeln('Round(f)');
+ printid(defnams[dreal]^.lid);
+ writeln(tab1, 'f;');
+ writeln('{');
+ writeln(tab1, xtern, doubletyp, ' floor();'); (* LIB *)
+ writeln(tab1,
+ 'return floor(', dblcast, '(0.5+f));'); (* LIB *)
+ writeln('}')
+ end
+ end; (* emit *)
+
+ (* Initialize all global structures used in translator. *)
+ procedure initialize;
+
+ var s : hashtyp;
+ t : pretyps;
+ d : predefs;
+
+ (* Define names in ctable. *)
+ procedure defname(cn : cnames; str : keyword);
+
+ label 999;
+
+ var w : toknbuf;
+ i : toknidx;
+
+ begin
+ unpack(str, w, 1);
+ for i := 1 to keywordlen do
+ if w[i] = space then
+ begin
+ w[i] := chr(null);
+ goto 999
+ end;
+ w[keywordlen+1] := chr(null);
+ 999:
+ ctable[cn] := saveid(w)
+ end;
+
+ (* Define predefined identifiers. *)
+ procedure defid(nt : treetyp; did : predefs; str : keyword);
+
+ label 999;
+
+ var w : toknbuf;
+ i : toknidx;
+ tp, tq,
+ tv : treeptr;
+
+ begin
+ for i := 1 to keywordlen do
+ if str[i] = space then
+ begin
+ w[i] := chr(null);
+ goto 999
+ end
+ else
+ w[i] := str[i];
+ w[keywordlen+1] := chr(null);
+ 999:
+ tp := newid(saveid(w));
+ defnams[did] := tp^.tsym;
+ if nt in [ntype, nfunc, nproc] then
+ begin
+ (* predefined types, procedures and functions
+ are marked with a particular node *)
+ tv := mknode(npredef);
+ tv^.tdef := did;
+ tv^.tobtyp := tnone
+ end
+ else
+ tv := nil; (* predefined constants and variables will
+ eventually be bound to something *)
+ case nt of
+ nscalar:
+ begin
+ tv := mknode(nscalar);
+ tv^.tscalid := nil;
+ tq := mknode(ntype);
+ tq^.tbind := tv;
+ tq^.tidl := tp;
+ tp := tq
+ end;
+ nconst,
+ ntype,
+ nfield,
+ nvar:
+ begin
+ tq := mknode(nt);
+ tq^.tbind := tv;
+ tq^.tidl := tp;
+ tq^.tattr := anone;
+ tp := tq
+ end;
+ nfunc,
+ nproc:
+ begin
+ tq := mknode(nt);
+ tq^.tsubid := tp;
+ tq^.tsubstmt := tv;
+ tq^.tfuntyp := nil;
+ tq^.tsubpar := nil;
+ tq^.tsublab := nil;
+ tq^.tsubconst := nil;
+ tq^.tsubtype := nil;
+ tq^.tsubvar := nil;
+ tq^.tsubsub := nil;
+ tq^.tscope := nil;
+ tq^.tstat := 0;
+ tp := tq
+ end;
+ nid:
+ end;(* case *)
+ deftab[did] := tp
+ end; (* defid *)
+
+ (* Define keywords. *)
+ procedure defkey(s : symtyp; w : keyword);
+
+ var i : 1 .. keywordlen;
+
+ begin
+ for i := 1 to keywordlen do
+ if w[i] = space then
+ w[i] := chr(null);
+ (* relies on symtyp being sorted *)
+ with keytab[ord(s)] do
+ begin
+ wrd := w;
+ sym := s
+ end;
+ end;
+
+ procedure fixinit(i : strindx);
+
+ var t : toknbuf;
+
+ begin
+ gettokn(i, t);
+ t[1] := 'i';
+ puttokn(i, t);
+ end;
+
+ (* Add a cpu word type description. *)
+ (* Parameters lo and hi gives the range of a machine- *)
+ (* dependant integer type. Parameter str gives the corres- *)
+ (* ponding C-language type-name. *)
+ procedure defmach(lo, hi : integer; str : machdefstr);
+
+ label 999;
+
+ var i : toknidx;
+ w : toknbuf;
+
+ begin
+ unpack(str, w, 1);
+ if w[machdeflen] <> space then
+ error(ebadmach);
+ for i := machdeflen - 1 downto 1 do
+ if w[i] <> space then
+ begin
+ w[i+1] := chr(null);
+ goto 999
+ end;
+ error(ebadmach);
+ 999:
+ if nmachdefs >= maxmachdefs then
+ error(emanymachs);
+ nmachdefs := nmachdefs + 1;
+ with machdefs[nmachdefs] do
+ begin
+ lolim := lo;
+ hilim := hi;
+ typstr := savestr(w)
+ end
+ end;
+
+ procedure initstrstore;
+
+ var i : strbcnt;
+
+ begin
+ for i := 1 to maxblkcnt do
+ strstor[i] := nil;
+ new(strstor[0]);
+ strstor[0]^[0] := chr(null);
+ strfree := 1;
+ strleft := maxstrblk
+ end;
+
+ begin (* initialize *)
+ lineno := 1;
+ colno := 0;
+
+ initstrstore;
+
+ setlst := nil;
+ setcnt := 0;
+ hexdig := '0123456789ABCDEF';
+
+ symtab := nil;
+ statlvl := 0;
+ maxlevel := -1;
+ enterscope(nil);
+ varno:= 0;
+
+ usenilp := false;
+
+ usesets := false;
+ useunion := false;
+ usediff := false;
+ usemksub := false;
+ useintr := false;
+ usesge := false;
+ usesle := false;
+ usesne := false;
+ useseq := false;
+ usememb := false;
+ useins := false;
+ usescpy := false;
+ usefopn := false;
+ usescan := false;
+ usegetl := false;
+
+ usecase := false;
+ usejmps := false;
+
+ usebool := false;
+
+ usecomp := false;
+ usemax := false;
+
+ for s := 0 to hashmax do
+ idtab[s] := nil;
+ for d := dabs to dztring do
+ begin
+ deftab[d] := nil;
+ defnams[d] := nil
+ end;
+
+ (* Pascal keywords *)
+ defkey(sand, 'and ');
+ defkey(sarray, 'array ');
+ defkey(sbegin, 'begin ');
+ defkey(scase, 'case ');
+ defkey(sconst, 'const ');
+ defkey(sdiv, 'div ');
+ defkey(sdo, 'do ');
+ defkey(sdownto, 'downto ');
+ defkey(selse, 'else ');
+ defkey(send, 'end ');
+ defkey(sextern, externsym); (* non-standard *)
+ defkey(sfile, 'file ');
+ defkey(sfor, 'for ');
+ defkey(sforward,'forward ');
+ defkey(sfunc, 'function ');
+ defkey(sgoto, 'goto ');
+ defkey(sif, 'if ');
+ defkey(sinn, 'in ');
+ defkey(slabel, 'label ');
+ defkey(smod, 'mod ');
+ defkey(snil, 'nil ');
+ defkey(snot, 'not ');
+ defkey(sof, 'of ');
+ defkey(sor, 'or ');
+ defkey(sother, othersym); (* non-standard *)
+ defkey(spacked, 'packed ');
+ defkey(sproc, 'procedure ');
+ defkey(spgm, 'program ');
+ defkey(srecord, 'record ');
+ defkey(srepeat, 'repeat ');
+ defkey(sset, 'set ');
+ defkey(sthen, 'then ');
+ defkey(sto, 'to ');
+ defkey(stype, 'type ');
+ defkey(suntil, 'until ');
+ defkey(svar, 'var ');
+ defkey(swhile, 'while ');
+ defkey(swith, 'with ');
+ defkey(seof, dummysym); (* dummy entry *)
+
+ (* C language operator priorities *)
+ cprio[nformat] := 0;
+ cprio[nrange] := 0;
+ cprio[nin] := 0;
+ cprio[nset] := 0;
+ cprio[nassign] := 0;
+ cprio[nor] := 1;
+ cprio[nand] := 2;
+ cprio[neq] := 3;
+ cprio[nne] := 3;
+ cprio[nlt] := 3;
+ cprio[nle] := 3;
+ cprio[ngt] := 3;
+ cprio[nge] := 3;
+ cprio[nplus] := 4;
+ cprio[nminus] := 4;
+ cprio[nmul] := 5;
+ cprio[ndiv] := 5;
+ cprio[nmod] := 5;
+ cprio[nquot] := 5;
+ cprio[nnot] := 6;
+ cprio[numinus] := 6;
+ cprio[nuplus] := 7;
+ cprio[nindex] := 7;
+ cprio[nselect] := 7;
+ cprio[nderef] := 7;
+ cprio[ncall] := 7;
+ cprio[nid] := 7;
+ cprio[nchar] := 7;
+ cprio[ninteger] := 7;
+ cprio[nreal] := 7;
+ cprio[nstring] := 7;
+ cprio[nnil] := 7;
+
+ (* Pascal language operator priorities *)
+ pprio[nassign] := 0;
+ pprio[nformat] := 0;
+ pprio[nrange] := 1;
+ pprio[nin] := 1;
+ pprio[neq] := 1;
+ pprio[nne] := 1;
+ pprio[nlt] := 1;
+ pprio[nle] := 1;
+ pprio[ngt] := 1;
+ pprio[nge] := 1;
+ pprio[nor] := 2;
+ pprio[nplus] := 2;
+ pprio[nminus] := 2;
+ pprio[nand] := 3;
+ pprio[nmul] := 3;
+ pprio[ndiv] := 3;
+ pprio[nmod] := 3;
+ pprio[nquot] := 3;
+ pprio[nnot] := 4;
+ pprio[numinus] := 4;
+ pprio[nuplus] := 5;
+ pprio[nset] := 6;
+ pprio[nindex] := 6;
+ pprio[nselect] := 6;
+ pprio[nderef] := 6;
+ pprio[ncall] := 6;
+ pprio[nid] := 6;
+ pprio[nchar] := 6;
+ pprio[ninteger] := 6;
+ pprio[nreal] := 6;
+ pprio[nstring] := 6;
+ pprio[nnil] := 6;
+
+ (* table of C keywords/functions (which Pascal doesn't know about) *)
+ defname(cabort, 'abort '); (* OS *)
+ defname(cbreak, 'break ');
+ defname(ccontinue, 'continue ');
+ defname(cdefine, 'define ');
+ defname(cdefault, 'default ');
+ defname(cdouble, 'double ');
+ defname(cedata, 'edata '); (* OS *)
+ defname(cenum, 'enum ');
+ defname(cetext, 'etext '); (* OS *)
+ defname(cextern, 'extern ');
+ defname(cfclose, 'fclose '); (* LIB *)
+ defname(cfflush, 'fflush '); (* LIB *)
+ defname(cfgetc, 'fgetc '); (* LIB *)
+ defname(cfloat, 'float ');
+ defname(cfloor, 'floor '); (* OS *)
+ defname(cfprintf, 'fprintf '); (* LIB *)
+ defname(cfputc, 'fputc '); (* LIB *)
+ defname(cfread, 'fread '); (* LIB *)
+ defname(cfscanf, 'fscanf '); (* LIB *)
+ defname(cfwrite, 'fwrite '); (* LIB *)
+ defname(cgetc, 'getc '); (* OS *)
+ defname(cgetpid, 'getpid '); (* OS *)
+ defname(cint, 'int ');
+ defname(cinclude, 'include ');
+ defname(clong, 'long ');
+ defname(clog, 'log '); (* OS *)
+ defname(cmain, 'main ');
+ defname(cmalloc, 'malloc '); (* LIB *)
+ defname(cprintf, 'printf '); (* LIB *)
+ defname(cpower, 'pow '); (* OS *)
+ defname(cputc, 'putc '); (* LIB *)
+ defname(cread, 'read '); (* OS *)
+ defname(creturn, 'return ');
+ defname(cregister, 'register ');
+ defname(crewind, 'rewind '); (* LIB *)
+ defname(cscanf, 'scanf '); (* LIB *)
+ defname(csetbits, 'setbits ');
+ defname(csetword, 'setword ');
+ defname(csetptr, 'setptr ');
+ defname(cshort, 'short ');
+ defname(csigned, 'signed ');
+ defname(csizeof, 'sizeof ');
+ defname(csprintf, 'sprintf '); (* LIB *)
+ defname(cstatic, 'static ');
+ defname(cstdin, 'stdin '); (* LIB *)
+ defname(cstdout, 'stdout '); (* LIB *)
+ defname(cstderr, 'stderr '); (* LIB *)
+ defname(cstrncmp, 'strncmp '); (* OS *)
+ defname(cstrncpy, 'strncpy '); (* OS *)
+ defname(cstruct, 'struct ');
+ defname(cswitch, 'switch ');
+ defname(ctypedef, 'typedef ');
+ defname(cundef, 'undef ');
+ defname(cungetc, 'ungetc '); (* LIB *)
+ defname(cunion, 'union ');
+ defname(cunlink, 'unlink '); (* OS *)
+ defname(cunsigned, 'unsigned ');
+ defname(cwrite, 'write '); (* OS *)
+
+ (* create predefined identifiers *)
+ defid(nfunc, dabs, 'abs ');
+ defid(nfunc, darctan, 'arctan ');
+ defid(nvar, dargc, 'argc '); (* OS *)
+ defid(nproc, dargv, 'argv '); (* OS *)
+ defid(nscalar, dboolean, 'boolean ');
+ defid(ntype, dchar, 'char ');
+ defid(nfunc, dchr, 'chr ');
+ defid(nproc, dclose, 'close '); (* OS *)
+ defid(nfunc, dcos, 'cos ');
+ defid(nproc, ddispose, 'dispose ');
+ defid(nid, dfalse, 'false ');
+ defid(nfunc, deof, 'eof ');
+ defid(nfunc, deoln, 'eoln ');
+ defid(nproc, dexit, 'exit '); (* OS *)
+ defid(nfunc, dexp, 'exp ');
+ defid(nproc, dflush, 'flush '); (* OS *)
+ defid(nproc, dget, 'get ');
+ defid(nproc, dhalt, 'halt '); (* OS *)
+ defid(nvar, dinput, 'input ');
+ defid(ntype, dinteger, 'integer ');
+ defid(nfunc, dln, 'ln ');
+ defid(nconst, dmaxint, 'maxint ');
+ defid(nproc, dmessage, 'message '); (* OS *)
+ defid(nproc, dnew, 'new ');
+ defid(nfunc, dodd, 'odd ');
+ defid(nfunc, dord, 'ord ');
+ defid(nvar, doutput, 'output ');
+ defid(nproc, dpack, 'pack ');
+ defid(nproc, dpage, 'page ');
+ defid(nfunc, dpred, 'pred ');
+ defid(nproc, dput, 'put ');
+ defid(nproc, dread, 'read ');
+ defid(nproc, dreadln, 'readln ');
+ defid(ntype, dreal, 'real ');
+ defid(nproc, dreset, 'reset ');
+ defid(nproc, drewrite, 'rewrite ');
+ defid(nfunc, dround, 'round ');
+ defid(nfunc, dsin, 'sin ');
+ defid(nfunc, dsqr, 'sqr ');
+ defid(nfunc, dsqrt, 'sqrt ');
+ defid(nfunc, dsucc, 'succ ');
+ defid(ntype, dtext, 'text ');
+ defid(nid, dtrue, 'true ');
+ defid(nfunc, dtrunc, 'trunc ');
+ defid(nfunc, dtan, 'tan ');
+ defid(nproc, dunpack, 'unpack ');
+ defid(nproc, dwrite, 'write ');
+ defid(nproc, dwriteln, 'writeln ');
+
+ defid(nfield, dzinit, '$nit '); (* for internal use *)
+ defid(ntype, dztring, '$ztring ');
+
+ (* bind constants and variables *)
+ deftab[dboolean]^.tbind^.tscalid := deftab[dfalse];
+ deftab[dfalse]^.tnext := deftab[dtrue];
+ currsym.st := sinteger;
+ currsym.vint := maxint;
+ deftab[dmaxint]^.tbind := mklit;
+ deftab[dargc]^.tbind := deftab[dinteger]^.tbind;
+ deftab[dinput]^.tbind := deftab[dtext]^.tbind;
+ deftab[doutput]^.tbind := deftab[dtext]^.tbind;
+
+ for t := tnone to terror do
+ begin
+ (* for predefined types: set up pointers to "npredef" nodes
+ describing type, fill in constant identifying type *)
+ case t of
+ tboolean:
+ typnods[t] := deftab[dboolean]; (* scalar type *)
+ tchar:
+ typnods[t] := deftab[dchar]^.tbind;
+ tinteger:
+ typnods[t] := deftab[dinteger]^.tbind;
+ treal:
+ typnods[t] := deftab[dreal]^.tbind;
+ ttext:
+ typnods[t] := deftab[dtext]^.tbind;
+ tstring:
+ typnods[t] := deftab[dztring]^.tbind;
+ tnil,
+ tset,
+ tpoly,
+ tnone:
+ typnods[t] := mknode(npredef);
+ terror:
+ (* no op *)
+ end;(* case *)
+ if t in [tchar, tinteger, treal, ttext, tnone, tpoly,
+ tstring, tnil, tset] then
+ typnods[t]^.tobtyp := t
+ end;
+
+ (* fix name and type of field "init" *)
+ fixinit(defnams[dzinit]^.lid^.istr);
+ deftab[dzinit]^.tbind := deftab[dinteger]^.tbind;
+
+ for d := dabs to dztring do
+ linkup(nil, deftab[d]);
+
+ deftab[dchr]^.tfuntyp := typnods[tchar];
+
+ deftab[deof]^.tfuntyp := typnods[tboolean];
+ deftab[deoln]^.tfuntyp := typnods[tboolean];
+ deftab[dodd]^.tfuntyp := typnods[tboolean];
+
+ deftab[dord]^.tfuntyp := typnods[tinteger];
+ deftab[dround]^.tfuntyp := typnods[tinteger];
+ deftab[dtrunc]^.tfuntyp := typnods[tinteger];
+
+ deftab[darctan]^.tfuntyp := typnods[treal];
+ deftab[dcos]^.tfuntyp := typnods[treal];
+ deftab[dsin]^.tfuntyp := typnods[treal];
+ deftab[dtan]^.tfuntyp := typnods[treal];
+ deftab[dsqrt]^.tfuntyp := typnods[treal];
+ deftab[dexp]^.tfuntyp := typnods[treal];
+ deftab[dln]^.tfuntyp := typnods[treal];
+
+ deftab[dsqr]^.tfuntyp := typnods[tpoly];
+ deftab[dabs]^.tfuntyp := typnods[tpoly];
+ deftab[dpred]^.tfuntyp := typnods[tpoly];
+ deftab[dsucc]^.tfuntyp := typnods[tpoly];
+
+ deftab[dargv]^.tfuntyp := typnods[tnone];
+ deftab[ddispose]^.tfuntyp := typnods[tnone];
+ deftab[dexit]^.tfuntyp := typnods[tnone];
+ deftab[dget]^.tfuntyp := typnods[tnone];
+ deftab[dhalt]^.tfuntyp := typnods[tnone];
+ deftab[dnew]^.tfuntyp := typnods[tnone];
+ deftab[dpack]^.tfuntyp := typnods[tnone];
+ deftab[dput]^.tfuntyp := typnods[tnone];
+ deftab[dread]^.tfuntyp := typnods[tnone];
+ deftab[dreadln]^.tfuntyp := typnods[tnone];
+ deftab[dreset]^.tfuntyp := typnods[tnone];
+ deftab[drewrite]^.tfuntyp := typnods[tnone];
+ deftab[dwrite]^.tfuntyp := typnods[tnone];
+ deftab[dwriteln]^.tfuntyp := typnods[tnone];
+ deftab[dmessage]^.tfuntyp := typnods[tnone];
+ deftab[dunpack]^.tfuntyp := typnods[tnone];
+
+ (* set up definitions for integer subranges *)
+ nmachdefs := 0;
+ defmach(0, 255, 'unsigned char '); (* CPU *)
+ defmach(-128, 127, 'char '); (* CPU *)
+ defmach(0, 65535, 'unsigned short '); (* CPU *)
+ defmach(-32768, 32767, 'short '); (* CPU *)
+ defmach(-2147483647, 2147483647, 'long '); (* CPU *)
+ { defmach(0, 4294967295, 'unsigned long ');}(* CPU *)
+ end; (* initialize *)
+
+ procedure exit(i : integer); external; (* OS *)
+
+ (* Action to take when an error is detected. *)
+ procedure error;
+
+ begin
+ prtmsg(m);
+ exit(1); (* OS *)
+ goto 9999
+ end;
+
+ (* Action to take when a fatal error is detected. *)
+ procedure fatal;
+
+ begin
+ prtmsg(m);
+ halt (* OS *)
+ (* goto 9999 *)
+ end;
+
+
+ begin (* program *)
+ initialize;
+ if echo then
+ writeln('# ifdef PASCAL');
+ parse;
+ if echo then
+ writeln('# else');
+ lineno := 0; lastline := 0;
+ transform;
+ emit;
+ if echo then
+ writeln('# endif');
+ 9999:
+ (* the very *)
+ end.
+
More information about the llvm-commits
mailing list