aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Criswell <criswell@uiuc.edu>2004-02-16 23:43:31 +0000
committerJohn Criswell <criswell@uiuc.edu>2004-02-16 23:43:31 +0000
commitd9c3e7a009df96bc366150cbaab843c5a7aa1c09 (patch)
treee545005209802df9ab1d034c310c0dcf98dfbf82
parent4ea6ad37ccc1955429c24df4b49a4deb5e347aa0 (diff)
Initial commit of the p2c benchmark (part of the Malloc Benchmark).
git-svn-id: https://llvm.org/svn/llvm-project/test-suite/trunk@11508 91177308-0d34-0410-b5e6-96231b3b80d8
Diffstat
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/INPUT/README8
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/INPUT/grading.p514
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p19497
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p9736
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/LICENSE.TXT10
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/Makefile5
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/citmods.c1153
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/comment.c466
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/decl.c5444
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/dir.c257
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/expr.c5574
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/funcs.c5405
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/hpmods.c140
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/lex.c3421
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/libp2c.abin0 -> 53131 bytes
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/loc.p2clib.c6
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/makeprotobin0 -> 24385 bytes
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/out.c1580
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/p2c.h511
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/parse.c4380
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/pexpr.c3626
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/stuff.c839
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/trans.c1512
-rw-r--r--MultiSource/Benchmarks/MallocBench/p2c/trans.h1867
24 files changed, 65951 insertions, 0 deletions
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/INPUT/README b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/README
new file mode 100644
index 00000000..2cb61f0d
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/README
@@ -0,0 +1,8 @@
+
+Test Inputs to p2c program:
+
+p2c -v < INPUT/grading.p
+p2c -v < INPUT/ptc.p
+p2c -v < INPUT/mf.p
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/INPUT/grading.p b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/grading.p
new file mode 100644
index 00000000..04a7b84a
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/grading.p
@@ -0,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.
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p
new file mode 100644
index 00000000..1969e693
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/mf.p
@@ -0,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$ }
+
+{ 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$ }
+
+{ 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}
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p
new file mode 100644
index 00000000..5af0da90
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/INPUT/ptc.p
@@ -0,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.
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/LICENSE.TXT b/MultiSource/Benchmarks/MallocBench/p2c/LICENSE.TXT
new file mode 100644
index 00000000..a92f0f7f
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/LICENSE.TXT
@@ -0,0 +1,10 @@
+p2c - Part of the Malloc Benchmark Suite
+-------------------------------------------------------------------------------
+All files are licensed under the LLVM license with the following additions:
+
+These files are licensed to you under the GNU General Public License (any
+version). Redistribution must follow the additional restrictions required by
+the GPL.
+
+Please see individiual files for additional copyright information.
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/Makefile b/MultiSource/Benchmarks/MallocBench/p2c/Makefile
new file mode 100644
index 00000000..9bd7a176
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/Makefile
@@ -0,0 +1,5 @@
+LEVEL = ../../../../../..
+PROG = p2c
+RUN_OPTIONS = -v
+STDIN_FILENAME = $(SourceDir)/INPUT/mf.p
+include ../../../Makefile.multisrc
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/citmods.c b/MultiSource/Benchmarks/MallocBench/p2c/citmods.c
new file mode 100644
index 00000000..b13604e2
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/citmods.c
@@ -0,0 +1,1153 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_CITMODS_C
+#include "trans.h"
+
+
+
+/* The following functions define special translations for several
+ * HP Pascal modules developed locally at Caltech. For non-Caltech
+ * readers this file will serve mainly as a body of examples.
+ *
+ * The FuncMacro mechanism (introduced after this file was written)
+ * provides a simpler method for cases where the function translates
+ * into some fixed C equivalent.
+ */
+
+
+
+
+/* NEWASM functions */
+
+
+/* na_fillbyte: equivalent to memset, though convert_size is used to
+ * generalize the size a bit: na_fillbyte(a, 0, 80) where a is an array
+ * of integers (4 bytes in HP Pascal) will be translated to
+ * memset(a, 0, 20 * sizeof(int)).
+ */
+
+Static Stmt *proc_na_fillbyte(ex)
+Expr *ex;
+{
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
+ ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILLBYTE");
+ return makestmt_call(makeexpr_bicall_3("memset", tp_void,
+ ex->args[0],
+ makeexpr_arglong(ex->args[1], 0),
+ makeexpr_arglong(ex->args[2], (size_t_long != 0))));
+}
+
+
+
+/* This function fills with a 32-bit pattern. If all four bytes of the
+ * pattern are equal, memset is used, otherwise the na_fill call is
+ * left unchanged.
+ */
+
+Static Stmt *proc_na_fill(ex)
+Expr *ex;
+{
+ unsigned long ul;
+ Symbol *sym;
+
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
+ ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILL");
+ if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_FILLP")) {
+ sym = findsymbol("NA_FILL");
+ if (sym->mbase)
+ ex->val.i = (long)sym->mbase;
+ }
+ if (isliteralconst(ex->args[1], NULL) != 2)
+ return makestmt_call(ex);
+ ul = ex->args[1]->val.i;
+ if ((((ul >> 16) ^ ul) & 0xffff) || /* all four bytes must be the same */
+ (((ul >> 8) ^ ul) & 0xff))
+ return makestmt_call(ex);
+ ex->args[1]->val.i &= 0xff;
+ return makestmt_call(makeexpr_bicall_3("memset", tp_void,
+ ex->args[0],
+ makeexpr_arglong(ex->args[1], 0),
+ makeexpr_arglong(ex->args[2], (size_t_long != 0))));
+}
+
+
+
+Static Stmt *proc_na_move(ex)
+Expr *ex;
+{
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr); /* source */
+ ex->args[1] = gentle_cast(ex->args[1], tp_anyptr); /* dest */
+ ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
+ argbasetype(ex->args[1])), ex->args[2], "NA_MOVE");
+ return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
+ ex->args[1],
+ ex->args[0],
+ makeexpr_arglong(ex->args[2], (size_t_long != 0))));
+}
+
+
+
+/* This just generalizes the size and leaves the function call alone,
+ * except that na_exchp (a version using pointer args) is transformed
+ * to na_exch (a version using VAR args, equivalent in C).
+ */
+
+Static Stmt *proc_na_exch(ex)
+Expr *ex;
+{
+ Symbol *sym;
+
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
+ ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
+ ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
+ argbasetype(ex->args[1])), ex->args[2], "NA_EXCH");
+ if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_EXCHP")) {
+ sym = findsymbol("NA_EXCH");
+ if (sym->mbase)
+ ex->val.i = (long)sym->mbase;
+ }
+ return makestmt_call(ex);
+}
+
+
+
+Static Expr *func_na_comp(ex)
+Expr *ex;
+{
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
+ ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
+ ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
+ argbasetype(ex->args[1])), ex->args[2], "NA_COMP");
+ return makeexpr_bicall_3("memcmp", tp_int,
+ ex->args[0],
+ ex->args[1],
+ makeexpr_arglong(ex->args[2], (size_t_long != 0)));
+}
+
+
+
+Static Expr *func_na_scaneq(ex)
+Expr *ex;
+{
+ Symbol *sym;
+
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
+ ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANEQ");
+ if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANEQP")) {
+ sym = findsymbol("NA_SCANEQ");
+ if (sym->mbase)
+ ex->val.i = (long)sym->mbase;
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_na_scanne(ex)
+Expr *ex;
+{
+ Symbol *sym;
+
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
+ ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANNE");
+ if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANNEP")) {
+ sym = findsymbol("NA_SCANNE");
+ if (sym->mbase)
+ ex->val.i = (long)sym->mbase;
+ }
+ return ex;
+}
+
+
+
+Static Stmt *proc_na_new(ex)
+Expr *ex;
+{
+ Expr *vex, *ex2, *sz = NULL;
+ Stmt *sp;
+
+ vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
+ ex2 = ex->args[1];
+ if (vex->val.type->kind == TK_POINTER)
+ ex2 = convert_size(vex->val.type->basetype, ex2, "NA_NEW");
+ if (alloczeronil)
+ sz = copyexpr(ex2);
+ ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, ex2);
+ sp = makestmt_assign(copyexpr(vex), ex2);
+ if (malloccheck) {
+ sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(vex), makeexpr_nil()),
+ makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int,
+ makeexpr_long(-2))),
+ NULL));
+ }
+ if (sz && !isconstantexpr(sz)) {
+ if (alloczeronil == 2)
+ note("Called NA_NEW with variable argument [500]");
+ sp = makestmt_if(makeexpr_rel(EK_NE, sz, makeexpr_long(0)),
+ sp,
+ makestmt_assign(vex, makeexpr_nil()));
+ } else
+ freeexpr(vex);
+ return sp;
+}
+
+
+
+Static Stmt *proc_na_dispose(ex)
+Expr *ex;
+{
+ Stmt *sp;
+ Expr *vex;
+
+ vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
+ sp = makestmt_call(makeexpr_bicall_1(freename, tp_void, copyexpr(vex)));
+ if (alloczeronil) {
+ sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
+ sp, NULL);
+ } else
+ freeexpr(vex);
+ return sp;
+}
+
+
+
+/* These functions provide functionality similar to alloca; we just warn
+ * about them here since alloca would not have been portable enough for
+ * our purposes anyway.
+ */
+
+Static Stmt *proc_na_alloc(ex)
+Expr *ex;
+{
+ Expr *ex2;
+
+ note("Call to NA_ALLOC [501]");
+ ex->args[0] = eatcasts(ex->args[0]);
+ ex2 = ex->args[0];
+ if (ex2->val.type->kind == TK_POINTER &&
+ ex2->val.type->basetype->kind == TK_POINTER)
+ ex->args[1] = convert_size(ex2->val.type->basetype->basetype,
+ ex->args[1], "NA_ALLOC");
+ return makestmt_call(ex);
+}
+
+
+
+Static Stmt *proc_na_outeralloc(ex)
+Expr *ex;
+{
+ note("Call to NA_OUTERALLOC [502]");
+ return makestmt_call(ex);
+}
+
+
+
+Static Stmt *proc_na_free(ex)
+Expr *ex;
+{
+ note("Call to NA_FREE [503]");
+ return makestmt_call(ex);
+}
+
+
+
+
+Static Expr *func_na_memavail(ex)
+Expr *ex;
+{
+ freeexpr(ex);
+ return makeexpr_bicall_0("memavail", tp_integer);
+}
+
+
+
+
+/* A simple collection of bitwise operations. */
+
+Static Expr *func_na_and(ex)
+Expr *ex;
+{
+ Expr *ex0, *ex1;
+
+ ex0 = makeexpr_unlongcast(ex->args[0]);
+ ex1 = makeexpr_unlongcast(ex->args[1]);
+ return makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
+}
+
+
+
+Static Expr *func_na_bic(ex)
+Expr *ex;
+{
+ Expr *ex0, *ex1;
+
+ ex0 = makeexpr_unlongcast(ex->args[0]);
+ ex1 = makeexpr_unlongcast(ex->args[1]);
+ return makeexpr_bin(EK_BAND, tp_integer,
+ ex0,
+ makeexpr_un(EK_BNOT, ex1->val.type, ex1));
+}
+
+
+
+Static Expr *func_na_or(ex)
+Expr *ex;
+{
+ Expr *ex0, *ex1;
+
+ ex0 = makeexpr_unlongcast(ex->args[0]);
+ ex1 = makeexpr_unlongcast(ex->args[1]);
+ return makeexpr_bin(EK_BOR, tp_integer, ex0, ex1);
+}
+
+
+
+Static Expr *func_na_xor(ex)
+Expr *ex;
+{
+ Expr *ex0, *ex1;
+
+ ex0 = makeexpr_unlongcast(ex->args[0]);
+ ex1 = makeexpr_unlongcast(ex->args[1]);
+ return makeexpr_bin(EK_BXOR, tp_integer, ex0, ex1);
+}
+
+
+
+Static Expr *func_na_not(ex)
+Expr *ex;
+{
+ ex = makeexpr_unlongcast(grabarg(ex, 0));
+ return makeexpr_un(EK_BNOT, ex->val.type, ex);
+}
+
+
+
+Static Expr *func_na_mask(ex)
+Expr *ex;
+{
+ Expr *ex0, *ex1;
+
+ ex0 = makeexpr_unlongcast(ex->args[0]);
+ ex1 = makeexpr_unlongcast(ex->args[1]);
+ ex = makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
+ return makeexpr_rel(EK_NE, ex, makeexpr_long(0));
+}
+
+
+
+Static int check0_31(ex)
+Expr *ex;
+{
+ if (isliteralconst(ex, NULL) == 2)
+ return (ex->val.i >= 0 && ex->val.i <= 31);
+ else
+ return (assumebits != 0);
+}
+
+
+
+/* This function is defined to test a bit of an integer, returning false
+ * if the bit number is out of range. It is only safe to use C bitwise
+ * ops if we can prove the bit number is always in range, or if the
+ * user has asked us to assume that it is. Lacking flow analysis,
+ * we settle for checking constants only.
+ */
+
+Static Expr *func_na_test(ex)
+Expr *ex;
+{
+ Expr *ex1;
+ int longness;
+
+ if (!check0_31(ex->args[0]))
+ return ex;
+ ex1 = makeexpr_unlongcast(ex->args[1]);
+ longness = (exprlongness(ex1) != 0);
+ return makeexpr_rel(EK_NE,
+ makeexpr_bin(EK_BAND, tp_integer,
+ ex1,
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(1), longness),
+ makeexpr_unlongcast(ex->args[0]))),
+ makeexpr_long(0));
+}
+
+
+
+Static Stmt *proc_na_set(ex)
+Expr *ex;
+{
+ Stmt *sp;
+ Expr *vex;
+ Meaning *tvar;
+
+ if (!check0_31(ex->args[0]))
+ return makestmt_call(ex);
+ if (!nosideeffects(ex->args[1], 1)) {
+ tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
+ sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
+ vex = makeexpr_hat(makeexpr_var(tvar), 0);
+ } else {
+ sp = NULL;
+ vex = makeexpr_hat(ex->args[1], 0);
+ }
+ sp = makestmt_seq(sp,
+ makestmt_assign(vex,
+ makeexpr_bin(EK_BOR, tp_integer,
+ copyexpr(vex),
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ makeexpr_unlongcast(ex->args[0])))));
+ return sp;
+}
+
+
+
+Static Stmt *proc_na_clear(ex)
+Expr *ex;
+{
+ Stmt *sp;
+ Expr *vex;
+ Meaning *tvar;
+
+ if (!check0_31(ex->args[0]))
+ return makestmt_call(ex);
+ if (!nosideeffects(ex->args[1], 1)) {
+ tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
+ sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
+ vex = makeexpr_hat(makeexpr_var(tvar), 0);
+ } else {
+ sp = NULL;
+ vex = makeexpr_hat(ex->args[1], 0);
+ }
+ sp = makestmt_seq(sp,
+ makestmt_assign(vex,
+ makeexpr_bin(EK_BAND, tp_integer,
+ copyexpr(vex),
+ makeexpr_un(EK_BNOT, tp_integer,
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ makeexpr_unlongcast(ex->args[0]))))));
+ return sp;
+}
+
+
+
+Static Expr *func_na_po2(ex)
+Expr *ex;
+{
+ if (!check0_31(ex->args[0]))
+ return ex;
+ return makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ makeexpr_unlongcast(grabarg(ex, 0)));
+}
+
+
+
+Static Expr *func_na_lobits(ex)
+Expr *ex;
+{
+ if (!check0_31(ex->args[0]))
+ return ex;
+ return makeexpr_un(EK_BNOT, tp_integer,
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(-1), 1),
+ makeexpr_unlongcast(grabarg(ex, 0))));
+}
+
+
+
+Static Expr *func_na_hibits(ex)
+Expr *ex;
+{
+ if (!check0_31(ex->args[0]))
+ return ex;
+ return makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(-1), 1),
+ makeexpr_minus(makeexpr_long(32),
+ makeexpr_unlongcast(grabarg(ex, 0))));
+}
+
+
+
+/* This function does an arithmetic shift left, or right for negative shift
+ * count. We translate into a C shift only if we are confident of the
+ * sign of the shift count.
+ */
+
+Static Expr *func_na_asl(ex)
+Expr *ex;
+{
+ Expr *ex2;
+
+ ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
+ if (expr_is_neg(ex2)) {
+ if (signedshift == 0 || signedshift == 2)
+ return ex;
+ if (possiblesigns(ex2) & 4) {
+ if (assumesigns)
+ note("Assuming count for NA_ASL is negative [504]");
+ else
+ return ex;
+ }
+ if (signedshift != 1)
+ note("Assuming >> is an arithmetic shift [505]");
+ return makeexpr_bin(EK_RSH, tp_integer,
+ grabarg(ex, 1), makeexpr_neg(ex2));
+ } else {
+ if (possiblesigns(ex2) & 1) {
+ if (assumesigns)
+ note("Assuming count for NA_ASL is positive [504]");
+ else
+ return ex;
+ }
+ return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
+ }
+}
+
+
+
+Static Expr *func_na_lsl(ex)
+Expr *ex;
+{
+ Expr *ex2;
+
+ ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
+ if (expr_is_neg(ex2)) {
+ if (possiblesigns(ex2) & 4) {
+ if (assumesigns)
+ note("Assuming count for NA_LSL is negative [506]");
+ else
+ return ex;
+ }
+ return makeexpr_bin(EK_RSH, tp_integer,
+ force_unsigned(grabarg(ex, 1)),
+ makeexpr_neg(ex2));
+ } else {
+ if (possiblesigns(ex2) & 1) {
+ if (assumesigns)
+ note("Assuming count for NA_LSL is positive [506]");
+ else
+ return ex;
+ }
+ return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
+ }
+}
+
+
+
+/* These bit-field operations were generalized slightly on the way to C;
+ * they used to perform D &= S and now perform D = S1 & S2.
+ */
+
+Static Stmt *proc_na_bfand(ex)
+Expr *ex;
+{
+ Stmt *sp;
+ Meaning *tvar;
+
+ if (!nosideeffects(ex->args[2], 1)) {
+ tvar = makestmttempvar(ex->args[2]->val.type, name_TEMP);
+ sp = makestmt_assign(makeexpr_var(tvar), ex->args[2]);
+ ex->args[2] = makeexpr_var(tvar);
+ } else
+ sp = NULL;
+ insertarg(&ex, 1, copyexpr(ex->args[2]));
+ return makestmt_seq(sp, makestmt_call(ex));
+}
+
+
+
+Static Stmt *proc_na_bfbic(ex)
+Expr *ex;
+{
+ return proc_na_bfand(ex);
+}
+
+
+
+Static Stmt *proc_na_bfor(ex)
+Expr *ex;
+{
+ return proc_na_bfand(ex);
+}
+
+
+
+Static Stmt *proc_na_bfxor(ex)
+Expr *ex;
+{
+ return proc_na_bfand(ex);
+}
+
+
+
+Static Expr *func_imin(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_2("P_imin2", tp_integer,
+ ex->args[0], ex->args[1]);
+}
+
+
+
+Static Expr *func_imax(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_2("P_imax2", tp_integer,
+ ex->args[0], ex->args[1]);
+}
+
+
+
+/* Unsigned non-overflowing arithmetic functions in Pascal; we translate
+ * into plain arithmetic in C and assume C doesn't check for overflow.
+ * (A valid assumption in the case when this was used.)
+ */
+
+Static Expr *func_na_add(ex)
+Expr *ex;
+{
+ return makeexpr_plus(makeexpr_unlongcast(ex->args[0]),
+ makeexpr_unlongcast(ex->args[1]));
+}
+
+
+
+Static Expr *func_na_sub(ex)
+Expr *ex;
+{
+ return makeexpr_minus(makeexpr_unlongcast(ex->args[0]),
+ makeexpr_unlongcast(ex->args[1]));
+}
+
+
+
+extern Stmt *proc_exit(); /* from funcs.c */
+
+Static Stmt *proc_return()
+{
+ return proc_exit();
+}
+
+
+
+Static Expr *func_charupper(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("toupper", tp_char,
+ grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_charlower(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("tolower", tp_char,
+ grabarg(ex, 0));
+}
+
+
+
+/* Convert an integer to its string representation. We produce a sprintf
+ * into a temporary variable; the temporary will probably be eliminated
+ * as the surrounding code is translated.
+ */
+
+Static Expr *func_strint(ex)
+Expr *ex;
+{
+ Expr *ex2;
+
+ ex2 = makeexpr_forcelongness(ex->args[1]);
+ return makeexpr_bicall_3("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string((exprlongness(ex2) > 0) ? "%ld" : "%d"),
+ ex2);
+}
+
+
+
+Static Expr *func_strint2(ex)
+Expr *ex;
+{
+ Expr *ex2, *len, *fmt;
+
+ if (checkconst(ex->args[2], 0) || checkconst(ex->args[2], 1))
+ return func_strint(ex);
+ if (expr_is_neg(ex->args[2])) {
+ if (possiblesigns(ex->args[2]) & 4) {
+ if (assumesigns)
+ note("Assuming width for STRINT2 is negative [507]");
+ else
+ return ex;
+ }
+ ex2 = makeexpr_forcelongness(ex->args[1]);
+ fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%0*ld" : "%0*d");
+ len = makeexpr_neg(makeexpr_longcast(ex->args[2], 0));
+ } else {
+ if (possiblesigns(ex->args[2]) & 1) {
+ if (assumesigns)
+ note("Assuming width for STRINT2 is positive [507]");
+ else
+ return ex;
+ }
+ ex2 = makeexpr_forcelongness(ex->args[1]);
+ fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%*ld" : "%*d");
+ len = makeexpr_longcast(ex->args[2], 0);
+ }
+ ex = makeexpr_bicall_4("sprintf", ex->val.type,
+ ex->args[0], fmt, len, ex2);
+ return cleansprintf(ex);
+}
+
+
+
+Static Expr *func_strhex(ex)
+Expr *ex;
+{
+ Expr *ex2, *ex3;
+ Value val;
+
+ if (isliteralconst(ex->args[2], &val) == 2) {
+ ex2 = makeexpr_forcelongness(ex->args[1]);
+ if (val.i < 1 || val.i > 8) {
+ ex = makeexpr_bicall_3("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string((exprlongness(ex2) > 0) ? "%lX" : "%X"),
+ ex2);
+ } else {
+ if (val.i < 8) {
+ ex3 = makeexpr_long((1 << (val.i*4)) - 1);
+ insertarg(&ex3, 0, makeexpr_name("%#lx", tp_integer));
+ ex2 = makeexpr_bin(EK_BAND, ex2->val.type, ex2, ex3);
+ }
+ ex = makeexpr_bicall_3("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string(format_d((exprlongness(ex2) > 0) ? "%%.%ldlX" :
+ "%%.%ldX",
+ val.i)),
+ ex2);
+ }
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_strreal(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_3("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string("%g"),
+ ex->args[1]);
+}
+
+
+
+Static Expr *func_strchar(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_3("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string("%c"),
+ ex->args[1]);
+}
+
+
+
+Static Expr *func_strreadint(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_3("strtol", tp_integer,
+ grabarg(ex, 0),
+ makeexpr_nil(),
+ makeexpr_long(0));
+}
+
+
+
+Static Expr *func_strreadreal(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("atof", tp_longreal,
+ grabarg(ex, 0));
+}
+
+
+
+Static Stmt *proc_strappendc(ex)
+Expr *ex;
+{
+ Expr *ex2;
+
+ ex2 = makeexpr_hat(ex->args[0], 0);
+ return makestmt_assign(ex2, makeexpr_concat(copyexpr(ex2), ex->args[1], 0));
+}
+
+
+
+/* Check if a string begins with a given prefix; this is easy if the
+ * prefix is known at compile-time.
+ */
+
+Static Expr *func_strbegins(ex)
+Expr *ex;
+{
+ Expr *ex1, *ex2;
+
+ ex1 = ex->args[0];
+ ex2 = ex->args[1];
+ if (ex2->kind == EK_CONST) {
+ if (ex2->val.i == 1) {
+ return makeexpr_rel(EK_EQ,
+ makeexpr_hat(ex1, 0),
+ makeexpr_char(ex2->val.s[0]));
+ } else {
+ return makeexpr_rel(EK_EQ,
+ makeexpr_bicall_3("strncmp", tp_int,
+ ex1,
+ ex2,
+ makeexpr_arglong(makeexpr_long(ex2->val.i), (size_t_long != 0))),
+ makeexpr_long(0));
+ }
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_strcontains(ex)
+Expr *ex;
+{
+ return makeexpr_rel(EK_NE,
+ makeexpr_bicall_2("strpbrk", tp_strptr,
+ ex->args[0],
+ ex->args[1]),
+ makeexpr_nil());
+}
+
+
+
+/* Extract a substring of a string. If arguments are out-of-range, extract
+ * an empty or shorter substring. Here, the length=infinity and constant
+ * starting index cases are handled specially.
+ */
+
+Static Expr *func_strsub(ex)
+Expr *ex;
+{
+ if (isliteralconst(ex->args[3], NULL) == 2 &&
+ ex->args[3]->val.i >= stringceiling) {
+ return makeexpr_bicall_3("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string("%s"),
+ bumpstring(ex->args[1],
+ makeexpr_unlongcast(ex->args[2]), 1));
+ }
+ if (checkconst(ex->args[2], 1)) {
+ return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1],
+ ex->args[2], ex->args[3]));
+ }
+ ex->args[2] = makeexpr_arglong(ex->args[2], 0);
+ ex->args[3] = makeexpr_arglong(ex->args[3], 0);
+ return ex;
+}
+
+
+
+Static Expr *func_strpart(ex)
+Expr *ex;
+{
+ return func_strsub(ex); /* all the special cases match */
+}
+
+
+
+Static Expr *func_strequal(ex)
+Expr *ex;
+{
+ if (!*strcicmpname)
+ return ex;
+ return makeexpr_rel(EK_EQ,
+ makeexpr_bicall_2(strcicmpname, tp_int,
+ ex->args[0], ex->args[1]),
+ makeexpr_long(0));
+}
+
+
+
+Static Expr *func_strcmp(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_2("strcmp", tp_int, ex->args[0], ex->args[1]);
+}
+
+
+
+Static Expr *func_strljust(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_4("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string("%-*s"),
+ makeexpr_longcast(ex->args[2], 0),
+ ex->args[1]);
+}
+
+
+
+Static Expr *func_strrjust(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_4("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string("%*s"),
+ makeexpr_longcast(ex->args[2], 0),
+ ex->args[1]);
+}
+
+
+
+
+/* The procedure strnew(p,s) is converted into an assignment p = strdup(s). */
+
+Static Stmt *proc_strnew(ex)
+Expr *ex;
+{
+ return makestmt_assign(makeexpr_hat(ex->args[0], 0),
+ makeexpr_bicall_1("strdup", ex->args[1]->val.type,
+ ex->args[1]));
+}
+
+
+
+/* These procedures are also changed to functions returning a result. */
+
+Static Stmt *proc_strlist_add(ex)
+Expr *ex;
+{
+ return makestmt_assign(makeexpr_hat(ex->args[1], 0),
+ makeexpr_bicall_2("strlist_add", ex->args[0]->val.type->basetype,
+ ex->args[0],
+ ex->args[2]));
+}
+
+
+
+Static Stmt *proc_strlist_append(ex)
+Expr *ex;
+{
+ return makestmt_assign(makeexpr_hat(ex->args[1], 0),
+ makeexpr_bicall_2("strlist_append", ex->args[0]->val.type->basetype,
+ ex->args[0],
+ ex->args[2]));
+}
+
+
+
+Static Stmt *proc_strlist_insert(ex)
+Expr *ex;
+{
+ return makestmt_assign(makeexpr_hat(ex->args[1], 0),
+ makeexpr_bicall_2("strlist_insert", ex->args[0]->val.type->basetype,
+ ex->args[0],
+ ex->args[2]));
+}
+
+
+
+
+
+
+
+
+
+/* NEWCI functions */
+
+
+Static Stmt *proc_fixfname(ex)
+Expr *ex;
+{
+ if (ex->args[1]->kind == EK_CONST)
+ lwc(ex->args[1]->val.s); /* Unix uses lower-case suffixes */
+ return makestmt_call(ex);
+}
+
+
+Static Stmt *proc_forcefname(ex)
+Expr *ex;
+{
+ return proc_fixfname(ex);
+}
+
+
+/* In Pascal these were variables of type pointer-to-text; we translate
+ * them as, e.g., &stdin. Note that even though &stdin is not legal in
+ * many systems, in the common usage of writeln(stdin^) the & will
+ * cancel out in a later stage of the translation.
+ */
+
+Static Expr *func_stdin()
+{
+ return makeexpr_addr(makeexpr_var(mp_input));
+}
+
+
+Static Expr *func_stdout()
+{
+ return makeexpr_addr(makeexpr_var(mp_output));
+}
+
+
+Static Expr *func_stderr()
+{
+ return makeexpr_addr(makeexpr_var(mp_stderr));
+}
+
+
+
+
+
+
+
+
+/* MYLIB functions */
+
+
+Static Stmt *proc_m_color(ex)
+Expr *ex;
+{
+ int i;
+ long val;
+
+ if (ex->kind == EK_PLUS) {
+ for (i = 0; i < ex->nargs; i++) {
+ if (isconstexpr(ex->args[i], &val)) {
+ if (val > 0 && (val & 15) == 0) {
+ note("M_COLOR called with suspicious argument [508]");
+ }
+ }
+ }
+ } else if (ex->kind == EK_CONST) {
+ if (ex->val.i >= 16 && ex->val.i < 255) { /* accept true colors and m_trans */
+ note("M_COLOR called with suspicious argument [508]");
+ }
+ }
+ return makestmt_call(ex);
+}
+
+
+
+
+
+
+
+void citmods(name, defn)
+char *name;
+int defn;
+{
+ if (!strcmp(name, "NEWASM")) {
+ makestandardproc("na_fillbyte", proc_na_fillbyte);
+ makestandardproc("na_fill", proc_na_fill);
+ makestandardproc("na_fillp", proc_na_fill);
+ makestandardproc("na_move", proc_na_move);
+ makestandardproc("na_movep", proc_na_move);
+ makestandardproc("na_exch", proc_na_exch);
+ makestandardproc("na_exchp", proc_na_exch);
+ makestandardfunc("na_comp", func_na_comp);
+ makestandardfunc("na_compp", func_na_comp);
+ makestandardfunc("na_scaneq", func_na_scaneq);
+ makestandardfunc("na_scaneqp", func_na_scaneq);
+ makestandardfunc("na_scanne", func_na_scanne);
+ makestandardfunc("na_scannep", func_na_scanne);
+ makestandardproc("na_new", proc_na_new);
+ makestandardproc("na_dispose", proc_na_dispose);
+ makestandardproc("na_alloc", proc_na_alloc);
+ makestandardproc("na_outeralloc", proc_na_outeralloc);
+ makestandardproc("na_free", proc_na_free);
+ makestandardfunc("na_memavail", func_na_memavail);
+ makestandardfunc("na_and", func_na_and);
+ makestandardfunc("na_bic", func_na_bic);
+ makestandardfunc("na_or", func_na_or);
+ makestandardfunc("na_xor", func_na_xor);
+ makestandardfunc("na_not", func_na_not);
+ makestandardfunc("na_mask", func_na_mask);
+ makestandardfunc("na_test", func_na_test);
+ makestandardproc("na_set", proc_na_set);
+ makestandardproc("na_clear", proc_na_clear);
+ makestandardfunc("na_po2", func_na_po2);
+ makestandardfunc("na_hibits", func_na_hibits);
+ makestandardfunc("na_lobits", func_na_lobits);
+ makestandardfunc("na_asl", func_na_asl);
+ makestandardfunc("na_lsl", func_na_lsl);
+ makestandardproc("na_bfand", proc_na_bfand);
+ makestandardproc("na_bfbic", proc_na_bfbic);
+ makestandardproc("na_bfor", proc_na_bfor);
+ makestandardproc("na_bfxor", proc_na_bfxor);
+ makestandardfunc("imin", func_imin);
+ makestandardfunc("imax", func_imax);
+ makestandardfunc("na_add", func_na_add);
+ makestandardfunc("na_sub", func_na_sub);
+ makestandardproc("return", proc_return);
+ makestandardfunc("charupper", func_charupper);
+ makestandardfunc("charlower", func_charlower);
+ makestandardfunc("strint", func_strint);
+ makestandardfunc("strint2", func_strint2);
+ makestandardfunc("strhex", func_strhex);
+ makestandardfunc("strreal", func_strreal);
+ makestandardfunc("strchar", func_strchar);
+ makestandardfunc("strreadint", func_strreadint);
+ makestandardfunc("strreadreal", func_strreadreal);
+ makestandardproc("strappendc", proc_strappendc);
+ makestandardfunc("strbegins", func_strbegins);
+ makestandardfunc("strcontains", func_strcontains);
+ makestandardfunc("strsub", func_strsub);
+ makestandardfunc("strpart", func_strpart);
+ makestandardfunc("strequal", func_strequal);
+ makestandardfunc("strcmp", func_strcmp);
+ makestandardfunc("strljust", func_strljust);
+ makestandardfunc("strrjust", func_strrjust);
+ makestandardproc("strnew", proc_strnew);
+ makestandardproc("strlist_add", proc_strlist_add);
+ makestandardproc("strlist_append", proc_strlist_append);
+ makestandardproc("strlist_insert", proc_strlist_insert);
+ } else if (!strcmp(name, "NEWCI")) {
+ makestandardproc("fixfname", proc_fixfname);
+ makestandardproc("forcefname", proc_forcefname);
+ makestandardfunc("stdin", func_stdin);
+ makestandardfunc("stdout", func_stdout);
+ makestandardfunc("stderr", func_stderr);
+ } else if (!strcmp(name, "MYLIB")) {
+ makestandardproc("m_color", proc_m_color);
+ }
+}
+
+
+
+
+/* End. */
+
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/comment.c b/MultiSource/Benchmarks/MallocBench/p2c/comment.c
new file mode 100644
index 00000000..8cc2d456
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/comment.c
@@ -0,0 +1,466 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_COMMENT_C
+#include "trans.h"
+
+
+
+Static int cmttablesize;
+Static uchar *cmttable;
+
+Static int grabbed_comment;
+
+
+
+
+/* Special comment forms:
+
+ \001\001\001... Blank line(s), one \001 char per blank line
+ \002text... Additional line for previous comment
+ \003text... Additional comment line, absolutely indented
+ \004text... Note or warning line, unindented
+
+*/
+
+
+
+
+void setup_comment()
+{
+ curcomments = NULL;
+ cmttablesize = 200;
+ cmttable = ALLOC(cmttablesize, uchar, misc);
+ grabbed_comment = 0;
+}
+
+
+
+
+
+int commentlen(cmt)
+Strlist *cmt;
+{
+ if (cmt)
+ if (*(cmt->s))
+ return strlen(cmt->s) + 4;
+ else
+ return 5;
+ else
+ return 0;
+}
+
+
+int commentvisible(cmt)
+Strlist *cmt;
+{
+ return (cmt &&
+ getcommentkind(cmt) != CMT_DONE &&
+ ((eatcomments != 1 && eatcomments != 2) ||
+ isembedcomment(cmt)));
+}
+
+
+
+
+
+
+/* If preceding statement's POST comments include blank lines,
+ steal all comments after longest stretch of blank lines as
+ PRE comments for the next statement. */
+
+void steal_comments(olds, news, always)
+long olds, news;
+int always;
+{
+ Strlist *cmt, *cmtfirst = NULL, *cmtblank = NULL;
+ int len, longest;
+
+ for (cmt = curcomments; cmt; cmt = cmt->next) {
+ if ((cmt->value & CMT_MASK) == olds &&
+ getcommentkind(cmt) == CMT_POST) {
+ if (!cmtfirst)
+ cmtfirst = cmt;
+ } else {
+ cmtfirst = NULL;
+ }
+ }
+ if (cmtfirst) {
+ if (!always) {
+ longest = 0;
+ for (cmt = cmtfirst; cmt; cmt = cmt->next) {
+ if (cmt->s[0] == '\001') { /* blank line(s) */
+ len = strlen(cmt->s);
+ if (len > longest) {
+ longest = len;
+ cmtblank = cmt;
+ }
+ }
+ }
+ if (longest > 0) {
+ if (blankafter)
+ cmtfirst = cmtblank->next;
+ else
+ cmtfirst = cmtblank;
+ } else if (commentafter == 1)
+ cmtfirst = NULL;
+ }
+ changecomments(cmtfirst, CMT_POST, olds, CMT_PRE, news);
+ }
+}
+
+
+
+Strlist *fixbeginendcomment(cmt)
+Strlist *cmt;
+{
+ char *cp, *cp2;
+
+ if (!cmt)
+ return NULL;
+ cp = cmt->s;
+ while (isspace(*cp))
+ cp++;
+ if (!strcincmp(cp, "procedure ", 10)) { /* remove "PROCEDURE" keyword */
+ strcpy(cp, cp+10);
+ } else if (!strcincmp(cp, "function ", 9)) {
+ strcpy(cp, cp+9);
+ }
+ while (isspace(*cp))
+ cp++;
+ if (!*cp)
+ return NULL;
+ if (getcommentkind(cmt) == CMT_ONBEGIN) {
+ cp2 = curctx->sym->name;
+ while (*cp2) {
+ if (toupper(*cp2++) != toupper(*cp++))
+ break;
+ }
+ while (isspace(*cp))
+ cp++;
+ if (!*cp2 && !*cp)
+ return NULL; /* eliminate function-begin comment */
+ }
+ return cmt;
+}
+
+
+
+
+Static void attach_mark(sp)
+Stmt *sp;
+{
+ long serial;
+
+ while (sp) {
+ serial = sp->serial;
+ if (serial >= 0 && serial < cmttablesize) {
+ cmttable[serial]++;
+ if (sp->kind == SK_IF && serial+1 < cmttablesize)
+ cmttable[serial+1]++; /* the "else" branch */
+ }
+ attach_mark(sp->stm1);
+ attach_mark(sp->stm2);
+ sp = sp->next;
+ }
+}
+
+
+
+void attach_comments(sbase)
+Stmt *sbase;
+{
+ Strlist *cmt;
+ long serial, i, j;
+ int kind;
+
+ if (spitorphancomments)
+ return;
+ if (serialcount >= cmttablesize) {
+ cmttablesize = serialcount + 100;
+ cmttable = REALLOC(cmttable, cmttablesize, uchar);
+ }
+ for (i = 0; i < cmttablesize; i++)
+ cmttable[i] = 0;
+ attach_mark(sbase);
+ for (cmt = curcomments; cmt; cmt = cmt->next) {
+ serial = cmt->value & CMT_MASK;
+ kind = getcommentkind(cmt);
+ if (serial < 0 || serial >= cmttablesize || cmttable[serial])
+ continue;
+ i = 0;
+ j = 0;
+ do {
+ if (commentafter == 1) {
+ j++;
+ if (j % 3 == 0)
+ i++;
+ } else if (commentafter == 0) {
+ i++;
+ if (i % 3 == 0)
+ j++;
+ } else {
+ i++;
+ j++;
+ }
+ if (serial+i < cmttablesize && cmttable[serial+i]) {
+ setcommentkind(cmt, CMT_PRE);
+ cmt->value += i;
+ break;
+ }
+ if (serial-j > 0 && cmttable[serial-j]) {
+ setcommentkind(cmt, CMT_POST);
+ cmt->value -= j;
+ break;
+ }
+ } while (serial+i < cmttablesize || serial-j > 0);
+ }
+}
+
+
+
+
+void setcommentkind(cmt, kind)
+Strlist *cmt;
+int kind;
+{
+ cmt->value = (cmt->value & CMT_MASK) | (kind << CMT_SHIFT);
+}
+
+
+
+void commentline(kind)
+int kind;
+{
+ char *cp;
+ Strlist *sl;
+
+ if (grabbed_comment) {
+ grabbed_comment = 0;
+ return;
+ }
+ if (blockkind == TOK_IMPORT || skipping_module)
+ return;
+ if (eatcomments == 1)
+ return;
+ for (cp = curtokbuf; (cp = my_strchr(cp, '*')) != NULL; ) {
+ if (*++cp == '/') {
+ cp[-1] = '%';
+ note("Changed \"* /\" to \"% /\" in comment [140]");
+ }
+ }
+ sl = strlist_append(&curcomments, curtokbuf);
+ sl->value = curserial;
+ setcommentkind(sl, kind);
+}
+
+
+
+void addnote(msg, serial)
+char *msg;
+long serial;
+{
+ int len1, len2, xextra, extra;
+ int defer = (notephase > 0 && spitcomments == 0);
+ Strlist *sl, *base = NULL, **pbase = (defer) ? &curcomments : &base;
+ char *prefix;
+
+ if (defer && (outf != stdout || !quietmode))
+ printf("%s, line %d: %s\n", infname, inf_lnum, msg);
+ else if (outf != stdout)
+ printf("%s, line %d/%d: %s\n", infname, inf_lnum, outf_lnum, msg);
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: %s\n", infname, inf_lnum, outf_lnum, msg);
+ if (notephase == 2 || regression)
+ prefix = format_s("\004 p2c: %s:", infname);
+ else
+ prefix = format_sd("\004 p2c: %s, line %d:", infname, inf_lnum);
+ len1 = strlen(prefix);
+ len2 = strlen(msg) + 2;
+ if (len1 + len2 < linewidth-4) {
+ msg = format_ss("%s %s ", prefix, msg);
+ } else {
+ extra = xextra = 0;
+ while (len2 - extra > linewidth-6) {
+ while (extra < len2 && !isspace(msg[extra]))
+ extra++;
+ xextra = extra;
+ while (extra < len2 && isspace(msg[extra]))
+ extra++;
+ }
+ prefix = format_sds("%s %.*s", prefix, xextra, msg);
+ msg += extra;
+ sl = strlist_append(pbase, prefix);
+ sl->value = serial;
+ setcommentkind(sl, CMT_POST);
+ msg = format_s("\003 * %s ", msg);
+ }
+ sl = strlist_append(pbase, msg);
+ sl->value = serial;
+ setcommentkind(sl, CMT_POST);
+ outputmode++;
+ outcomments(base);
+ outputmode--;
+}
+
+
+
+
+
+/* Grab a comment off the end of the current line */
+Strlist *grabcomment(kind)
+int kind;
+{
+ char *cp, *cp2;
+ Strlist *cmt, *savecmt;
+
+ if (grabbed_comment || spitcomments == 1)
+ return NULL;
+ cp = inbufptr;
+ while (isspace(*cp))
+ cp++;
+ if (*cp == ';' || *cp == ',' || *cp == '.')
+ cp++;
+ while (isspace(*cp))
+ cp++;
+ cp2 = curtokbuf;
+ if (*cp == '{') {
+ cp++;
+ while (*cp && *cp != '}')
+ *cp2++ = *cp++;
+ if (!*cp)
+ return NULL;
+ cp++;
+ } else if (*cp == '(' && cp[1] == '*') {
+ cp += 2;
+ while (*cp && (*cp != '*' || cp[1] != ')'))
+ *cp2++ = *cp++;
+ if (!*cp)
+ return NULL;
+ cp += 2;
+ } else
+ return NULL;
+ while (isspace(*cp))
+ cp++;
+ if (*cp)
+ return NULL;
+ *cp2 = 0;
+ savecmt = curcomments;
+ curcomments = NULL;
+ commentline(kind);
+ cmt = curcomments;
+ curcomments = savecmt;
+ grabbed_comment = 1;
+ if (cmtdebug > 1)
+ fprintf(outf, "Grabbed comment [%d] \"%s\"\n", cmt->value & CMT_MASK, cmt->s);
+ return cmt;
+}
+
+
+
+int matchcomment(cmt, kind, stamp)
+Strlist *cmt;
+int kind, stamp;
+{
+ if (spitcomments == 1 && (cmt->value & CMT_MASK) != 10000 &&
+ *cmt->s != '\001' && (kind >= 0 || stamp >= 0))
+ return 0;
+ if (!cmt || getcommentkind(cmt) == CMT_DONE)
+ return 0;
+ if (stamp >= 0 && (cmt->value & CMT_MASK) != stamp)
+ return 0;
+ if (kind >= 0) {
+ if (kind & CMT_NOT) {
+ if (getcommentkind(cmt) == kind - CMT_NOT)
+ return 0;
+ } else {
+ if (getcommentkind(cmt) != kind)
+ return 0;
+ }
+ }
+ return 1;
+}
+
+
+
+Strlist *findcomment(cmt, kind, stamp)
+Strlist *cmt;
+int kind, stamp;
+{
+ while (cmt && !matchcomment(cmt, kind, stamp))
+ cmt = cmt->next;
+ if (cmt && cmtdebug > 1)
+ fprintf(outf, "Found comment [%d] \"%s\"\n", cmt->value & CMT_MASK, cmt->s);
+ return cmt;
+}
+
+
+
+Strlist *extractcomment(cmt, kind, stamp)
+Strlist **cmt;
+int kind, stamp;
+{
+ Strlist *base, **last, *sl;
+
+ last = &base;
+ while ((sl = *cmt)) {
+ if (matchcomment(sl, kind, stamp)) {
+ if (cmtdebug > 1)
+ fprintf(outf, "Extracted comment [%d] \"%s\"\n",
+ sl->value & CMT_MASK, sl->s);
+ *cmt = sl->next;
+ *last = sl;
+ last = &sl->next;
+ } else
+ cmt = &sl->next;
+ }
+ *last = NULL;
+ return base;
+}
+
+
+void changecomments(cmt, okind, ostamp, kind, stamp)
+Strlist *cmt;
+int okind, ostamp, kind, stamp;
+{
+ while (cmt) {
+ if (matchcomment(cmt, okind, ostamp)) {
+ if (cmtdebug > 1)
+ fprintf(outf, "Changed comment [%s:%d] \"%s\" ",
+ CMT_NAMES[getcommentkind(cmt)],
+ cmt->value & CMT_MASK, cmt->s);
+ if (kind >= 0)
+ setcommentkind(cmt, kind);
+ if (stamp >= 0)
+ cmt->value = (cmt->value & ~CMT_MASK) | stamp;
+ if (cmtdebug > 1)
+ fprintf(outf, " to [%s:%d]\n",
+ CMT_NAMES[getcommentkind(cmt)], cmt->value & CMT_MASK);
+ }
+ cmt = cmt->next;
+ }
+}
+
+
+
+
+
+
+/* End. */
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/decl.c b/MultiSource/Benchmarks/MallocBench/p2c/decl.c
new file mode 100644
index 00000000..8769a395
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/decl.c
@@ -0,0 +1,5444 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_DECL_C
+#include "trans.h"
+
+
+
+#define MAXIMPORTS 100
+
+
+
+Static struct ptrdesc {
+ struct ptrdesc *next;
+ Symbol *sym;
+ Type *tp;
+} *ptrbase;
+
+Static struct ctxstack {
+ struct ctxstack *next;
+ Meaning *ctx, *ctxlast;
+ struct tempvarlist *tempvars;
+ int tempvarcount, importmark;
+} *ctxtop;
+
+Static struct tempvarlist {
+ struct tempvarlist *next;
+ Meaning *tvar;
+ int active;
+} *tempvars, *stmttempvars;
+
+Static int tempvarcount;
+
+Static int stringtypecachesize;
+Static Type **stringtypecache;
+
+Static Meaning *importlist[MAXIMPORTS];
+Static int firstimport;
+
+Static Type *tp_special_anyptr;
+
+Static int wasaliased;
+Static int deferallptrs;
+Static int anydeferredptrs;
+Static int silentalreadydef;
+Static int nonloclabelcount;
+
+Static Strlist *varstructdecllist;
+
+
+
+
+Static Meaning *findstandardmeaning(kind, name)
+enum meaningkind kind;
+char *name;
+{
+ Meaning *mp;
+ Symbol *sym;
+
+ sym = findsymbol(fixpascalname(name));
+ for (mp = sym->mbase; mp && mp->ctx != curctx; mp = mp->snext) ;
+ if (mp) {
+ if (mp->kind == kind)
+ mp->refcount = 1;
+ else
+ mp = NULL;
+ }
+ return mp;
+}
+
+
+Static Meaning *makestandardmeaning(kind, name)
+enum meaningkind kind;
+char *name;
+{
+ Meaning *mp;
+ Symbol *sym;
+
+ sym = findsymbol(fixpascalname(name));
+ for (mp = sym->mbase; mp && mp->ctx != curctx; mp = mp->snext) ;
+ if (!mp) {
+ mp = addmeaning(sym, kind);
+ strchange(&mp->name, name);
+ if (debug < 4)
+ mp->dumped = partialdump; /* prevent irrelevant dumping */
+ } else {
+ mp->kind = kind;
+ }
+ mp->refcount = 1;
+ return mp;
+}
+
+
+Static Type *makestandardtype(kind, mp)
+enum typekind kind;
+Meaning *mp;
+{
+ Type *tp;
+
+ tp = maketype(kind);
+ tp->meaning = mp;
+ if (mp)
+ mp->type = tp;
+ return tp;
+}
+
+
+
+
+Static Stmt *nullspecialproc(mp)
+Meaning *mp;
+{
+ warning(format_s("Procedure %s not yet supported [118]", mp->name));
+ if (curtok == TOK_LPAR)
+ skipparens();
+ return NULL;
+}
+
+Meaning *makespecialproc(name, handler)
+char *name;
+Stmt *(*handler)();
+{
+ Meaning *mp;
+
+ if (!handler)
+ handler = nullspecialproc;
+ mp = makestandardmeaning(MK_SPECIAL, name);
+ mp->handler = (Expr *(*)())handler;
+ return mp;
+}
+
+
+
+Static Stmt *nullstandardproc(ex)
+Expr *ex;
+{
+ warning(format_s("Procedure %s not yet supported [118]", ((Meaning *)ex->val.i)->name));
+ return makestmt_call(ex);
+}
+
+Meaning *makestandardproc(name, handler)
+char *name;
+Stmt *(*handler)();
+{
+ Meaning *mp;
+
+ if (!handler)
+ handler = nullstandardproc;
+ mp = findstandardmeaning(MK_FUNCTION, name);
+ if (mp) {
+ mp->handler = (Expr *(*)())handler;
+ if (mp->isfunction) {
+ warning(format_s("Procedure %s was declared as a function [119]", name));
+ mp->isfunction = 0;
+ }
+ } else if (debug > 0)
+ warning(format_s("Procedure %s was never declared [120]", name));
+ return mp;
+}
+
+
+
+Static Expr *nullspecialfunc(mp)
+Meaning *mp;
+{
+ warning(format_s("Function %s not yet supported [121]", mp->name));
+ if (curtok == TOK_LPAR)
+ skipparens();
+ return makeexpr_long(0);
+}
+
+Meaning *makespecialfunc(name, handler)
+char *name;
+Expr *(*handler)();
+{
+ Meaning *mp;
+
+ if (!handler)
+ handler = nullspecialfunc;
+ mp = makestandardmeaning(MK_SPECIAL, name);
+ mp->isfunction = 1;
+ mp->handler = handler;
+ return mp;
+}
+
+
+
+Static Expr *nullstandardfunc(ex)
+Expr *ex;
+{
+ warning(format_s("Function %s not yet supported [121]", ((Meaning *)ex->val.i)->name));
+ return ex;
+}
+
+Meaning *makestandardfunc(name, handler)
+char *name;
+Expr *(*handler)();
+{
+ Meaning *mp;
+
+ if (!handler)
+ handler = nullstandardfunc;
+ mp = findstandardmeaning(MK_FUNCTION, name);
+ if (mp) {
+ mp->handler = handler;
+ if (!mp->isfunction) {
+ warning(format_s("Function %s was declared as a procedure [122]", name));
+ mp->isfunction = 1;
+ }
+ } else if (debug > 0)
+ warning(format_s("Function %s was never declared [123]", name));
+ return mp;
+}
+
+
+
+
+Static Expr *nullspecialvar(mp)
+Meaning *mp;
+{
+ warning(format_s("Variable %s not yet supported [124]", mp->name));
+ if (curtok == TOK_LPAR || curtok == TOK_LBR)
+ skipparens();
+ return makeexpr_var(mp);
+}
+
+Meaning *makespecialvar(name, handler)
+char *name;
+Expr *(*handler)();
+{
+ Meaning *mp;
+
+ if (!handler)
+ handler = nullspecialvar;
+ mp = makestandardmeaning(MK_SPVAR, name);
+ mp->handler = handler;
+ return mp;
+}
+
+
+
+
+
+void setup_decl()
+{
+ Meaning *mp, *mp2, *mp_turbo_shortint;
+ Symbol *sym;
+ Type *tp;
+ int i;
+
+ numimports = 0;
+ firstimport = 0;
+ permimports = NULL;
+ stringceiling = stringceiling | 1; /* round up to odd */
+ stringtypecachesize = (stringceiling + 1) >> 1;
+ stringtypecache = ALLOC(stringtypecachesize, Type *, misc);
+ curctxlast = NULL;
+ curctx = NULL; /* the meta-ctx has no parent ctx */
+ curctx = nullctx = makestandardmeaning(MK_MODULE, "SYSTEM");
+ strlist_add(&permimports, "SYSTEM")->value = (long)nullctx;
+ ptrbase = NULL;
+ tempvars = NULL;
+ stmttempvars = NULL;
+ tempvarcount = 0;
+ deferallptrs = 0;
+ silentalreadydef = 0;
+ varstructdecllist = NULL;
+ nonloclabelcount = -1;
+ for (i = 0; i < stringtypecachesize; i++)
+ stringtypecache[i] = NULL;
+
+ tp_integer = makestandardtype(TK_INTEGER, makestandardmeaning(MK_TYPE,
+ (integer16) ? "LONGINT" : "INTEGER"));
+ tp_integer->smin = makeexpr_long(MININT); /* "long" */
+ tp_integer->smax = makeexpr_long(MAXINT);
+
+ if (sizeof_int >= 32) {
+ tp_int = tp_integer; /* "int" */
+ } else {
+ tp_int = makestandardtype(TK_INTEGER,
+ (integer16 > 1) ? makestandardmeaning(MK_TYPE, "INTEGER")
+ : NULL);
+ tp_int->smin = makeexpr_long(min_sshort);
+ tp_int->smax = makeexpr_long(max_sshort);
+ }
+ mp = makestandardmeaning(MK_TYPE, "C_INT");
+ mp->type = tp_int;
+ if (!tp_int->meaning)
+ tp_int->meaning = mp;
+
+ mp_unsigned = makestandardmeaning(MK_TYPE, "UNSIGNED");
+ tp_unsigned = makestandardtype(TK_INTEGER, mp_unsigned);
+ tp_unsigned->smin = makeexpr_long(0); /* "unsigned long" */
+ tp_unsigned->smax = makeexpr_long(MAXINT);
+
+ if (sizeof_int >= 32) {
+ tp_uint = tp_unsigned; /* "unsigned int" */
+ mp_uint = mp_unsigned;
+ } else {
+ mp_uint = makestandardmeaning(MK_TYPE, "C_UINT");
+ tp_uint = makestandardtype(TK_INTEGER, mp_uint);
+ tp_uint->smin = makeexpr_long(0);
+ tp_uint->smax = makeexpr_long(MAXINT);
+ }
+
+ tp_sint = makestandardtype(TK_INTEGER, NULL);
+ tp_sint->smin = copyexpr(tp_int->smin); /* "signed int" */
+ tp_sint->smax = copyexpr(tp_int->smax);
+
+ tp_char = makestandardtype(TK_CHAR, makestandardmeaning(MK_TYPE, "CHAR"));
+ if (unsignedchar == 0) {
+ tp_char->smin = makeexpr_long(-128); /* "char" */
+ tp_char->smax = makeexpr_long(127);
+ } else {
+ tp_char->smin = makeexpr_long(0);
+ tp_char->smax = makeexpr_long(255);
+ }
+
+ tp_charptr = makestandardtype(TK_POINTER, NULL); /* "unsigned char *" */
+ tp_charptr->basetype = tp_char;
+ tp_char->pointertype = tp_charptr;
+
+ mp_schar = makestandardmeaning(MK_TYPE, "SCHAR"); /* "signed char" */
+ tp_schar = makestandardtype(TK_CHAR, mp_schar);
+ tp_schar->smin = makeexpr_long(-128);
+ tp_schar->smax = makeexpr_long(127);
+
+ mp_uchar = makestandardmeaning(MK_TYPE, "UCHAR"); /* "unsigned char" */
+ tp_uchar = makestandardtype(TK_CHAR, mp_uchar);
+ tp_uchar->smin = makeexpr_long(0);
+ tp_uchar->smax = makeexpr_long(255);
+
+ tp_boolean = makestandardtype(TK_BOOLEAN, makestandardmeaning(MK_TYPE, "BOOLEAN"));
+ tp_boolean->smin = makeexpr_long(0); /* "boolean" */
+ tp_boolean->smax = makeexpr_long(1);
+
+ sym = findsymbol("Boolean");
+ sym->flags |= SSYNONYM;
+ strlist_append(&sym->symbolnames, "===")->value = (long)tp_boolean->meaning->sym;
+
+ tp_real = makestandardtype(TK_REAL, makestandardmeaning(MK_TYPE, "REAL"));
+ /* "float" or "double" */
+ mp = makestandardmeaning(MK_TYPE, "LONGREAL");
+ if (doublereals)
+ mp->type = tp_longreal = tp_real;
+ else
+ tp_longreal = makestandardtype(TK_REAL, mp);
+
+ tp_void = makestandardtype(TK_VOID, NULL); /* "void" */
+
+ mp = makestandardmeaning(MK_TYPE, "SINGLE");
+ if (doublereals)
+ makestandardtype(TK_REAL, mp);
+ else
+ mp->type = tp_real;
+ makestandardmeaning(MK_TYPE, "SHORTREAL")->type = mp->type;
+ mp = makestandardmeaning(MK_TYPE, "DOUBLE");
+ mp->type = tp_longreal;
+ mp = makestandardmeaning(MK_TYPE, "EXTENDED");
+ mp->type = tp_longreal; /* good enough */
+ mp = makestandardmeaning(MK_TYPE, "QUADRUPLE");
+ mp->type = tp_longreal; /* good enough */
+
+ tp_sshort = makestandardtype(TK_SUBR, makestandardmeaning(MK_TYPE,
+ (integer16 == 1) ? "INTEGER" : "SWORD"));
+ tp_sshort->basetype = tp_integer; /* "short" */
+ tp_sshort->smin = makeexpr_long(min_sshort);
+ tp_sshort->smax = makeexpr_long(max_sshort);
+
+ if (integer16) {
+ if (integer16 != 2) {
+ mp = makestandardmeaning(MK_TYPE, "SWORD");
+ mp->type = tp_sshort;
+ }
+ } else {
+ mp = makestandardmeaning(MK_TYPE, "LONGINT");
+ mp->type = tp_integer;
+ }
+
+ tp_ushort = makestandardtype(TK_SUBR, makestandardmeaning(MK_TYPE, modula2 ? "UWORD" : "WORD"));
+ tp_ushort->basetype = tp_integer; /* "unsigned short" */
+ tp_ushort->smin = makeexpr_long(0);
+ tp_ushort->smax = makeexpr_long(max_ushort);
+
+ mp = makestandardmeaning(MK_TYPE, "CARDINAL");
+ mp->type = (integer16) ? tp_ushort : tp_unsigned;
+ mp = makestandardmeaning(MK_TYPE, "LONGCARD");
+ mp->type = tp_unsigned;
+
+ if (modula2) {
+ mp = makestandardmeaning(MK_TYPE, "WORD");
+ mp->type = tp_integer;
+ } else {
+ makestandardmeaning(MK_TYPE, "UWORD")->type = tp_ushort;
+ }
+
+ tp_sbyte = makestandardtype(TK_SUBR, NULL); /* "signed char" */
+ tp_sbyte->basetype = tp_integer;
+ tp_sbyte->smin = makeexpr_long(min_schar);
+ tp_sbyte->smax = makeexpr_long(max_schar);
+
+ mp_turbo_shortint = (which_lang == LANG_TURBO) ? makestandardmeaning(MK_TYPE, "SHORTINT") : NULL;
+ mp = makestandardmeaning(MK_TYPE, "SBYTE");
+ if (needsignedbyte || signedchars == 1 || hassignedchar) {
+ mp->type = tp_sbyte;
+ if (mp_turbo_shortint)
+ mp_turbo_shortint->type = tp_sbyte;
+ tp_sbyte->meaning = mp_turbo_shortint ? mp_turbo_shortint : mp;
+ } else {
+ mp->type = tp_sshort;
+ if (mp_turbo_shortint)
+ mp_turbo_shortint->type = tp_sshort;
+ }
+
+ tp_ubyte = makestandardtype(TK_SUBR, makestandardmeaning(MK_TYPE, "BYTE"));
+ tp_ubyte->basetype = tp_integer; /* "unsigned char" */
+ tp_ubyte->smin = makeexpr_long(0);
+ tp_ubyte->smax = makeexpr_long(max_uchar);
+
+ if (signedchars == 1)
+ tp_abyte = tp_sbyte; /* "char" */
+ else if (signedchars == 0)
+ tp_abyte = tp_ubyte;
+ else {
+ tp_abyte = makestandardtype(TK_SUBR, NULL);
+ tp_abyte->basetype = tp_integer;
+ tp_abyte->smin = makeexpr_long(0);
+ tp_abyte->smax = makeexpr_long(max_schar);
+ }
+
+ mp = makestandardmeaning(MK_TYPE, "POINTER");
+ mp2 = makestandardmeaning(MK_TYPE, "ANYPTR");
+ tp_anyptr = makestandardtype(TK_POINTER, (which_lang == LANG_HP) ? mp2 : mp);
+ ((which_lang == LANG_HP) ? mp : mp2)->type = tp_anyptr;
+ tp_anyptr->basetype = tp_void; /* "void *" */
+ tp_void->pointertype = tp_anyptr;
+
+ if (useAnyptrMacros == 1) {
+ tp_special_anyptr = makestandardtype(TK_SUBR, NULL);
+ tp_special_anyptr->basetype = tp_integer;
+ tp_special_anyptr->smin = makeexpr_long(0);
+ tp_special_anyptr->smax = makeexpr_long(max_schar);
+ } else
+ tp_special_anyptr = NULL;
+
+ tp_proc = maketype(TK_PROCPTR);
+ tp_proc->basetype = maketype(TK_FUNCTION);
+ tp_proc->basetype->basetype = tp_void;
+ tp_proc->escale = 1; /* saved "hasstaticlinks" */
+
+ tp_str255 = makestandardtype(TK_STRING, NULL); /* "Char []" */
+ tp_str255->basetype = tp_char;
+ tp_str255->indextype = makestandardtype(TK_SUBR, NULL);
+ tp_str255->indextype->basetype = tp_integer;
+ tp_str255->indextype->smin = makeexpr_long(0);
+ tp_str255->indextype->smax = makeexpr_long(stringceiling);
+
+ tp_strptr = makestandardtype(TK_POINTER, NULL); /* "Char *" */
+ tp_str255->pointertype = tp_strptr;
+ tp_strptr->basetype = tp_str255;
+
+ mp_string = makestandardmeaning(MK_TYPE, "STRING");
+ tp = makestandardtype(TK_STRING, mp_string);
+ tp->basetype = tp_char;
+ tp->indextype = tp_str255->indextype;
+
+ tp_smallset = maketype(TK_SMALLSET);
+ tp_smallset->basetype = tp_integer;
+ tp_smallset->indextype = tp_boolean;
+
+ tp_text = makestandardtype(TK_POINTER, makestandardmeaning(MK_TYPE, "TEXT"));
+ tp_text->basetype = makestandardtype(TK_FILE, NULL); /* "FILE *" */
+ tp_text->basetype->basetype = tp_char;
+ tp_text->basetype->pointertype = tp_text;
+
+ tp_bigtext = makestandardtype(TK_BIGFILE, makestandardmeaning(MK_TYPE, "BIGTEXT"));
+ tp_bigtext->basetype = tp_char;
+ tp_bigtext->meaning->name = stralloc("_TEXT");
+ tp_bigtext->meaning->wasdeclared = 1;
+
+ tp_jmp_buf = makestandardtype(TK_SPECIAL, NULL);
+
+ mp = makestandardmeaning(MK_TYPE, "INTERACTIVE");
+ mp->type = tp_text;
+
+ mp = makestandardmeaning(MK_TYPE, "BITSET");
+ mp->type = makesettype(makesubrangetype(tp_integer, makeexpr_long(0),
+ makeexpr_long(setbits-1)));
+ mp->type->meaning = mp;
+
+ mp = makestandardmeaning(MK_TYPE, "INTSET");
+ mp->type = makesettype(makesubrangetype(tp_integer, makeexpr_long(0),
+ makeexpr_long(defaultsetsize-1)));
+ mp->type->meaning = mp;
+
+ mp_input = makestandardmeaning(MK_VAR, "INPUT");
+ mp_input->type = tp_text;
+ mp_input->name = stralloc("stdin");
+ ex_input = makeexpr_var(mp_input);
+
+ mp_output = makestandardmeaning(MK_VAR, "OUTPUT");
+ mp_output->type = tp_text;
+ mp_output->name = stralloc("stdout");
+ ex_output = makeexpr_var(mp_output);
+
+ mp_stderr = makestandardmeaning(MK_VAR, "STDERR");
+ mp_stderr->type = tp_text;
+ mp_stderr->name = stralloc("stderr");
+
+ mp_escapecode = makestandardmeaning(MK_VAR, "ESCAPECODE");
+ mp_escapecode->type = tp_sshort;
+ mp_escapecode->name = stralloc(name_ESCAPECODE);
+
+ mp_ioresult = makestandardmeaning(MK_VAR, "IORESULT");
+ mp_ioresult->type = tp_integer;
+ mp_ioresult->name = stralloc(name_IORESULT);
+
+ mp_false = makestandardmeaning(MK_CONST, "FALSE");
+ mp_false->type = mp_false->val.type = tp_boolean;
+ mp_false->val.i = 0;
+
+ mp_true = makestandardmeaning(MK_CONST, "TRUE");
+ mp_true->type = mp_true->val.type = tp_boolean;
+ mp_true->val.i = 1;
+
+ mp_maxint = makestandardmeaning(MK_CONST, "MAXINT");
+ mp_maxint->type = mp_maxint->val.type = tp_integer;
+ mp_maxint->val.i = MAXINT;
+ mp_maxint->name = stralloc((integer16) ? "SHORT_MAX" :
+ (sizeof_int >= 32) ? "INT_MAX" : "LONG_MAX");
+
+ mp = makestandardmeaning(MK_CONST, "MAXLONGINT");
+ mp->type = mp->val.type = tp_integer;
+ mp->val.i = MAXINT;
+ mp->name = stralloc("LONG_MAX");
+
+ mp_minint = makestandardmeaning(MK_CONST, "MININT");
+ mp_minint->type = mp_minint->val.type = tp_integer;
+ mp_minint->val.i = MININT;
+ mp_minint->name = stralloc((integer16) ? "SHORT_MIN" :
+ (sizeof_int >= 32) ? "INT_MIN" : "LONG_MIN");
+
+ mp = makestandardmeaning(MK_CONST, "MAXCHAR");
+ mp->type = mp->val.type = tp_char;
+ mp->val.i = 127;
+ mp->name = stralloc("CHAR_MAX");
+
+ mp = makestandardmeaning(MK_CONST, "MINCHAR");
+ mp->type = mp->val.type = tp_char;
+ mp->val.i = 0;
+ mp->anyvarflag = 1;
+
+ mp = makestandardmeaning(MK_CONST, "BELL");
+ mp->type = mp->val.type = tp_char;
+ mp->val.i = 7;
+ mp->anyvarflag = 1;
+
+ mp = makestandardmeaning(MK_CONST, "TAB");
+ mp->type = mp->val.type = tp_char;
+ mp->val.i = 9;
+ mp->anyvarflag = 1;
+
+ mp_str_hp = mp_str_turbo = NULL;
+ mp_val_modula = mp_val_turbo = NULL;
+ mp_blockread_ucsd = mp_blockread_turbo = NULL;
+ mp_blockwrite_ucsd = mp_blockwrite_turbo = NULL;
+ mp_dec_dec = mp_dec_turbo = NULL;
+}
+
+
+
+/* This makes sure that if A imports B and then C, C's interface is not
+ parsed in the environment of B */
+int push_imports()
+{
+ int mark = firstimport;
+ Meaning *mp;
+
+ while (firstimport < numimports) {
+ if (!strlist_cifind(permimports, importlist[firstimport]->sym->name)) {
+ for (mp = importlist[firstimport]->cbase; mp; mp = mp->cnext)
+ mp->isactive = 0;
+ }
+ firstimport++;
+ }
+ return mark;
+}
+
+
+
+void pop_imports(mark)
+int mark;
+{
+ Meaning *mp;
+
+ while (firstimport > mark) {
+ firstimport--;
+ for (mp = importlist[firstimport]->cbase; mp; mp = mp->cnext)
+ mp->isactive = 1;
+ }
+}
+
+
+
+void import_ctx(ctx)
+Meaning *ctx;
+{
+ Meaning *mp;
+ int i;
+
+ for (i = firstimport; i < numimports && importlist[i] != ctx; i++) ;
+ if (i >= numimports) {
+ if (numimports == MAXIMPORTS)
+ error(format_d("Maximum of %d simultaneous imports exceeded", MAXIMPORTS));
+ importlist[numimports++] = ctx;
+ }
+ for (mp = ctx->cbase; mp; mp = mp->cnext) {
+ if (mp->exported)
+ mp->isactive = 1;
+ }
+}
+
+
+
+void perm_import(ctx)
+Meaning *ctx;
+{
+ Meaning *mp;
+
+ /* Import permanently, as in Turbo's "system" unit */
+ for (mp = ctx->cbase; mp; mp = mp->cnext) {
+ if (mp->exported)
+ mp->isactive = 1;
+ }
+}
+
+
+
+void unimport(mark)
+int mark;
+{
+ Meaning *mp;
+
+ while (numimports > mark) {
+ numimports--;
+ if (!strlist_cifind(permimports, importlist[numimports]->sym->name)) {
+ for (mp = importlist[numimports]->cbase; mp; mp = mp->cnext)
+ mp->isactive = 0;
+ }
+ }
+}
+
+
+
+
+void activatemeaning(mp)
+Meaning *mp;
+{
+ Meaning *mp2;
+
+ if (debug>1) fprintf(outf, "Reviving %s\n", curctxlast->name);
+ mp->isactive = 1;
+ if (mp->sym->mbase != mp) { /* move to front of symbol list */
+ mp2 = mp->sym->mbase;
+ for (;;) {
+ if (!mp2) {
+ /* Not on symbol list: must be a special kludge meaning */
+ return;
+ }
+ if (mp2->snext == mp)
+ break;
+ mp2 = mp2->snext;
+ }
+ mp2->snext = mp->snext;
+ mp->snext = mp->sym->mbase;
+ mp->sym->mbase = mp;
+ }
+}
+
+
+
+void pushctx(ctx)
+Meaning *ctx;
+{
+ struct ctxstack *top;
+
+ top = ALLOC(1, struct ctxstack, ctxstacks);
+ top->ctx = curctx;
+ top->ctxlast = curctxlast;
+ top->tempvars = tempvars;
+ top->tempvarcount = tempvarcount;
+ top->importmark = numimports;
+ top->next = ctxtop;
+ ctxtop = top;
+ curctx = ctx;
+ curctxlast = ctx->cbase;
+ if (curctxlast) {
+ activatemeaning(curctxlast);
+ while (curctxlast->cnext) {
+ curctxlast = curctxlast->cnext;
+ activatemeaning(curctxlast);
+ }
+ }
+ tempvars = NULL;
+ tempvarcount = 0;
+ if (blockkind != TOK_IMPORT && blockkind != TOK_EXPORT)
+ progress();
+}
+
+
+
+void popctx()
+{
+ struct ctxstack *top;
+ struct tempvarlist *tv;
+ Meaning *mp;
+
+ if (!strlist_cifind(permimports, curctx->sym->name)) {
+ for (mp = curctx->cbase; mp; mp = mp->cnext) {
+ if (debug>1) fprintf(outf, "Hiding %s\n", mp->name);
+ mp->isactive = 0;
+ }
+ }
+ top = ctxtop;
+ ctxtop = top->next;
+ curctx = top->ctx;
+ curctxlast = top->ctxlast;
+ while (tempvars) {
+ tv = tempvars->next;
+ FREE(tempvars);
+ tempvars = tv;
+ }
+ tempvars = top->tempvars;
+ tempvarcount = top->tempvarcount;
+ unimport(top->importmark);
+ FREE(top);
+ if (blockkind != TOK_IMPORT && blockkind != TOK_EXPORT)
+ progress();
+}
+
+
+
+void forget_ctx(ctx, all)
+Meaning *ctx;
+int all;
+{
+ register Meaning *mp, **mpprev, *mp2, **mpp2;
+
+ if (ctx->kind == MK_FUNCTION && ctx->isfunction && ctx->cbase)
+ mpprev = &ctx->cbase->cnext; /* Skip return-value variable */
+ else
+ mpprev = &ctx->cbase;
+ while ((mp = *mpprev) != NULL) {
+ if (all ||
+ (mp->kind != MK_PARAM &&
+ mp->kind != MK_VARPARAM)) {
+ *mpprev = mp->cnext;
+ mpp2 = &mp->sym->mbase;
+ while ((mp2 = *mpp2) != NULL && mp2 != mp)
+ mpp2 = &mp2->snext;
+ if (mp2)
+ *mpp2 = mp2->snext;
+ if (mp->kind == MK_CONST)
+ free_value(&mp->val);
+ freeexpr(mp->constdefn);
+ if (mp->cbase)
+ forget_ctx(mp, 1);
+ if (mp->kind == MK_FUNCTION && mp->val.i)
+ free_stmt((Stmt *)mp->val.i);
+ strlist_empty(&mp->comments);
+ if (mp->name)
+ FREE(mp->name);
+ if (mp->othername)
+ FREE(mp->othername);
+ FREE(mp);
+ } else
+ mpprev = &mp->cnext;
+ }
+}
+
+
+
+
+void handle_nameof()
+{
+ Strlist *sl, *sl2;
+ Symbol *sp;
+ char *cp;
+
+ for (sl = nameoflist; sl; sl = sl->next) {
+ cp = my_strchr(sl->s, '.');
+ if (cp) {
+ sp = findsymbol(fixpascalname(cp + 1));
+ sl2 = strlist_add(&sp->symbolnames,
+ format_ds("%.*s", (int)(cp - sl->s), sl->s));
+ } else {
+ sp = findsymbol(fixpascalname(sl->s));
+ sl2 = strlist_add(&sp->symbolnames, "");
+ }
+ sl2->value = sl->value;
+ if (debug > 0)
+ fprintf(outf, "symbol %s gets \"%s\" -> \"%s\"\n",
+ sp->name, sl2->s, sl2->value);
+ }
+ strlist_empty(&nameoflist);
+}
+
+
+
+Static void initmeaning(mp)
+Meaning *mp;
+{
+/* mp->serial = curserial = ++serialcount; */
+ mp->cbase = NULL;
+ mp->xnext = NULL;
+ mp->othername = NULL;
+ mp->type = NULL;
+ mp->dtype = NULL;
+ mp->needvarstruct = 0;
+ mp->varstructflag = 0;
+ mp->wasdeclared = 0;
+ mp->isforward = 0;
+ mp->isfunction = 0;
+ mp->istemporary = 0;
+ mp->volatilequal = 0;
+ mp->constqual = 0;
+ mp->warnifused = (warnnames > 0);
+ mp->constdefn = NULL;
+ mp->val.i = 0;
+ mp->val.s = NULL;
+ mp->val.type = NULL;
+ mp->refcount = 1;
+ mp->anyvarflag = 0;
+ mp->isactive = 1;
+ mp->exported = 0;
+ mp->handler = NULL;
+ mp->dumped = 0;
+ mp->isreturn = 0;
+ mp->fakeparam = 0;
+ mp->namedfile = 0;
+ mp->bufferedfile = 0;
+ mp->comments = NULL;
+}
+
+
+
+int issafename(sp, isglobal, isdefine)
+Symbol *sp;
+int isglobal, isdefine;
+{
+ if (isdefine && curctx->kind != MK_FUNCTION) {
+ if (sp->flags & FWDPARAM)
+ return 0;
+ }
+ if ((sp->flags & AVOIDNAME) ||
+ (isdefine && (sp->flags & AVOIDFIELD)) ||
+ (isglobal && (sp->flags & AVOIDGLOB)))
+ return 0;
+ else
+ return 1;
+}
+
+
+
+static Meaning *enum_tname;
+
+void setupmeaning(mp, sym, kind, namekind)
+Meaning *mp;
+Symbol *sym;
+enum meaningkind kind, namekind;
+{
+ char *name, *symfmt, *editfmt, *cp, *cp2;
+ int altnum, isglobal, isdefine;
+ Symbol *sym2;
+ Strlist *sl;
+
+ if (!sym)
+ sym = findsymbol("Spam"); /* reduce crashes due to internal errors */
+ if (sym->mbase && sym->mbase->ctx == curctx &&
+ curctx != NULL && !silentalreadydef)
+ alreadydef(sym);
+ mp->sym = sym;
+ mp->snext = sym->mbase;
+ sym->mbase = mp;
+ if (sym == curtoksym) {
+ sym->kwtok = TOK_NONE;
+ sym->flags &= ~KWPOSS;
+ }
+ mp->ctx = curctx;
+ mp->kind = kind;
+ if (pascalcasesens && curctx && curctx->sym && kind != MK_SYNONYM &&
+ strlist_cifind(permimports, curctx->sym->name)) { /* a built-in name */
+ Meaning *mp2;
+ if (islower(sym->name[0]))
+ sym2 = findsymbol(strupper(sym->name));
+ else
+ sym2 = findsymbol(strlower(sym->name));
+ mp2 = addmeaning(sym2, MK_SYNONYM);
+ mp2->xnext = mp;
+ }
+ if (kind == MK_VAR) {
+ sl = strlist_find(varmacros, sym->name);
+ if (sl) {
+ kind = namekind = MK_VARMAC;
+ mp->constdefn = (Expr *)sl->value;
+ strlist_delete(&varmacros, sl);
+ }
+ }
+ if (kind == MK_FUNCTION || kind == MK_SPECIAL) {
+ sl = strlist_find(funcmacros, sym->name);
+ if (sl) {
+ mp->constdefn = (Expr *)sl->value;
+ strlist_delete(&funcmacros, sl);
+ }
+ }
+ if (kind == MK_VAR || kind == MK_VARREF || kind == MK_VARMAC ||
+ kind == MK_TYPE || kind == MK_CONST || kind == MK_FUNCTION) {
+ mp->exported = (blockkind == TOK_IMPORT || blockkind == TOK_EXPORT);
+ if (blockkind == TOK_IMPORT)
+ mp->wasdeclared = 1; /* suppress future declaration */
+ } else
+ mp->exported = 0;
+ if (sym == curtoksym)
+ name = curtokcase;
+ else
+ name = sym->name;
+ isdefine = (namekind == MK_CONST || (namekind == MK_VARIANT && !useenum));
+ isglobal = (!curctx ||
+ curctx->kind != MK_FUNCTION ||
+ namekind == MK_FUNCTION ||
+ namekind == MK_TYPE ||
+ namekind == MK_VARIANT ||
+ isdefine) &&
+ (curctx != nullctx);
+ mp->refcount = isglobal ? 1 : 0; /* make sure globals don't disappear */
+ if (namekind == MK_SYNONYM)
+ return;
+ if (!mp->exported || !*exportsymbol)
+ symfmt = "";
+ else if (*export_symbol && my_strchr(name, '_'))
+ symfmt = export_symbol;
+ else
+ symfmt = exportsymbol;
+ wasaliased = 0;
+ if (*externalias && !my_strchr(externalias, '%')) {
+ register int i;
+ name = format_s("%s", externalias);
+ i = numparams;
+ while (--i >= 0 && strcmp(rctable[i].name, "ALIAS")) ;
+ if (i < 0 || !undooption(i, ""))
+ *externalias = 0;
+ wasaliased = 1;
+ } else if (sym->symbolnames) {
+ if (curctx) {
+ if (debug > 2)
+ fprintf(outf, "checking for \"%s\" of %s\n", curctx->name, sym->name);
+ sl = strlist_cifind(sym->symbolnames, curctx->sym->name);
+ if (sl) {
+ if (debug > 2)
+ fprintf(outf, "found \"%s\"\n", sl->value);
+ name = (char *)sl->value;
+ wasaliased = 1;
+ }
+ }
+ if (!wasaliased) {
+ if (debug > 2)
+ fprintf(outf, "checking for \"\" of %s\n", sym->name);
+ sl = strlist_find(sym->symbolnames, "");
+ if (sl) {
+ if (debug > 2)
+ fprintf(outf, "found \"%s\"\n", sl->value);
+ name = (char *)sl->value;
+ wasaliased = 1;
+ }
+ }
+ }
+ if (!*symfmt || wasaliased)
+ symfmt = "%s";
+ altnum = -1;
+ do {
+ altnum++;
+ cp = format_ss(symfmt, name, curctx ? curctx->name : "");
+ switch (namekind) {
+
+ case MK_CONST:
+ editfmt = constformat;
+ break;
+
+ case MK_MODULE:
+ editfmt = moduleformat;
+ break;
+
+ case MK_FUNCTION:
+ editfmt = functionformat;
+ break;
+
+ case MK_VAR:
+ case MK_VARPARAM:
+ case MK_VARREF:
+ case MK_VARMAC:
+ case MK_SPVAR:
+ editfmt = varformat;
+ break;
+
+ case MK_TYPE:
+ editfmt = typeformat;
+ break;
+
+ case MK_VARIANT: /* A true kludge! */
+ editfmt = enumformat;
+ if (!*editfmt)
+ editfmt = useenum ? varformat : constformat;
+ break;
+
+ default:
+ editfmt = "";
+ }
+ if (!*editfmt)
+ editfmt = symbolformat;
+ if (*editfmt)
+ if (editfmt == enumformat)
+ cp = format_ss(editfmt, cp,
+ enum_tname ? enum_tname->name : "ENUM");
+ else
+ cp = format_ss(editfmt, cp,
+ curctx ? curctx->name : "");
+ if (dollar_idents == 2) {
+ for (cp2 = cp; *cp2; cp2++)
+ if (*cp2 == '$' || *cp2 == '%')
+ *cp2 = '_';
+ }
+ sym2 = findsymbol(findaltname(cp, altnum));
+ } while (!issafename(sym2, isglobal, isdefine) &&
+ namekind != MK_MODULE && !wasaliased);
+ mp->name = stralloc(sym2->name);
+ if (sym2->flags & WARNNAME)
+ note(format_s("A symbol named %s was defined [100]", mp->name));
+ if (isglobal) {
+ switch (namekind) { /* prevent further name conflicts */
+
+ case MK_CONST:
+ case MK_VARIANT:
+ case MK_TYPE:
+ sym2->flags |= AVOIDNAME;
+ break;
+
+ case MK_VAR:
+ case MK_VARREF:
+ case MK_FUNCTION:
+ sym2->flags |= AVOIDGLOB;
+ break;
+
+ default:
+ /* name is completely local */
+ break;
+ }
+ }
+ if (debug > 4)
+ fprintf(outf, "Created meaning %s\n", mp->name);
+}
+
+
+
+Meaning *addmeaningas(sym, kind, namekind)
+Symbol *sym;
+enum meaningkind kind, namekind;
+{
+ Meaning *mp;
+
+ mp = ALLOC(1, Meaning, meanings);
+ initmeaning(mp);
+ setupmeaning(mp, sym, kind, namekind);
+ mp->cnext = NULL;
+ if (curctx) {
+ if (curctxlast)
+ curctxlast->cnext = mp;
+ else
+ curctx->cbase = mp;
+ curctxlast = mp;
+ }
+ return mp;
+}
+
+
+
+Meaning *addmeaning(sym, kind)
+Symbol *sym;
+enum meaningkind kind;
+{
+ return addmeaningas(sym, kind, kind);
+}
+
+
+
+Meaning *addmeaningafter(mpprev, sym, kind)
+Meaning *mpprev;
+Symbol *sym;
+enum meaningkind kind;
+{
+ Meaning *mp;
+
+ if (!mpprev->cnext && mpprev->ctx == curctx)
+ return addmeaning(sym, kind);
+ mp = ALLOC(1, Meaning, meanings);
+ initmeaning(mp);
+ setupmeaning(mp, sym, kind, kind);
+ mp->ctx = mpprev->ctx;
+ mp->cnext = mpprev->cnext;
+ mpprev->cnext = mp;
+ return mp;
+}
+
+
+void unaddmeaning(mp)
+Meaning *mp;
+{
+ Meaning *prev;
+
+ prev = mp->ctx;
+ while (prev && prev != mp)
+ prev = prev->cnext;
+ if (prev)
+ prev->cnext = mp->cnext;
+ else
+ mp->ctx = mp->cnext;
+ if (!mp->cnext && mp->ctx == curctx)
+ curctxlast = prev;
+}
+
+
+void readdmeaning(mp)
+Meaning *mp;
+{
+ mp->cnext = NULL;
+ if (curctx) {
+ if (curctxlast)
+ curctxlast->cnext = mp;
+ else
+ curctx->cbase = mp;
+ curctxlast = mp;
+ }
+}
+
+
+Meaning *addfield(sym, flast, rectype, tname)
+Symbol *sym;
+Meaning ***flast;
+Type *rectype;
+Meaning *tname;
+{
+ Meaning *mp;
+ int altnum;
+ Symbol *sym2;
+ Strlist *sl;
+ char *name, *name2;
+
+ mp = ALLOC(1, Meaning, meanings);
+ initmeaning(mp);
+ mp->sym = sym;
+ if (sym) {
+ mp->snext = sym->fbase;
+ sym->fbase = mp;
+ if (sym == curtoksym)
+ name2 = curtokcase;
+ else
+ name2 = sym->name;
+ name = name2;
+ if (tname)
+ sl = strlist_find(fieldmacros,
+ format_ss("%s.%s", tname->sym->name, sym->name));
+ else
+ sl = NULL;
+ if (sl) {
+ mp->constdefn = (Expr *)sl->value;
+ strlist_delete(&fieldmacros, sl);
+ altnum = 0;
+ } else {
+ altnum = -1;
+ do {
+ altnum++;
+ if (*fieldformat)
+ name = format_ss(fieldformat, name2,
+ tname && tname->name ? tname->name
+ : "FIELD");
+ sym2 = findsymbol(findaltname(name, altnum));
+ } while (!issafename(sym2, 0, 0) ||
+ ((sym2->flags & AVOIDFIELD) && !reusefieldnames));
+ sym2->flags |= AVOIDFIELD;
+ }
+ mp->kind = MK_FIELD;
+ mp->name = stralloc(findaltname(name, altnum));
+ } else {
+ mp->name = stralloc("(variant)");
+ mp->kind = MK_VARIANT;
+ }
+ mp->cnext = NULL;
+ **flast = mp;
+ *flast = &(mp->cnext);
+ mp->ctx = NULL;
+ mp->rectype = rectype;
+ mp->val.i = 0;
+ return mp;
+}
+
+
+
+
+
+int isfiletype(type, big)
+Type *type;
+int big; /* 0=TK_FILE, 1=TK_BIGFILE, -1=either */
+{
+ return ((type->kind == TK_POINTER &&
+ type->basetype->kind == TK_FILE && big != 1) ||
+ (type->kind == TK_BIGFILE && big != 0));
+}
+
+
+Meaning *isfilevar(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ if (ex->kind == EK_VAR) {
+ mp = (Meaning *)ex->val.i;
+ if (mp->kind == MK_VAR)
+ return mp;
+ } else if (ex->kind == EK_DOT) {
+ mp = (Meaning *)ex->val.i;
+ if (mp && mp->kind == MK_FIELD)
+ return mp;
+ }
+ return NULL;
+}
+
+
+Type *filebasetype(type)
+Type *type;
+{
+ if (type->kind == TK_BIGFILE)
+ return type->basetype;
+ else
+ return type->basetype->basetype;
+}
+
+
+Expr *filebasename(ex)
+Expr *ex;
+{
+ if (ex->val.type->kind == TK_BIGFILE)
+ return makeexpr_dotq(ex, "f", ex->val.type);
+ else
+ return ex;
+}
+
+
+Expr *filenamepart(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ if (ex->val.type->kind == TK_BIGFILE)
+ return makeexpr_dotq(copyexpr(ex), "name", tp_str255);
+ else if ((mp = isfilevar(ex)) && mp->namedfile)
+ return makeexpr_name(format_s(name_FNVAR, mp->name), tp_str255);
+ else
+ return NULL;
+}
+
+
+int fileisbuffered(ex, maybe)
+Expr *ex;
+int maybe;
+{
+ Meaning *mp;
+
+ return (ex->val.type->kind == TK_BIGFILE ||
+ ((mp = isfilevar(ex)) && (maybe || mp->bufferedfile)));
+}
+
+
+
+Type *findbasetype_(type, flags)
+Type *type;
+int flags;
+{
+ long smin, smax;
+ static Type typename;
+
+ for (;;) {
+ if (type->preserved && (type->kind != TK_POINTER) &&
+ !(flags & ODECL_NOPRES))
+ return type;
+ switch (type->kind) {
+
+ case TK_POINTER:
+ if (type->smin) /* unresolved forward */
+ return type;
+ if (type->basetype == tp_void) { /* ANYPTR */
+ if (tp_special_anyptr)
+ return tp_special_anyptr; /* write "Anyptr" */
+ if (!voidstar)
+ return tp_abyte; /* write "char *", not "void *" */
+ }
+ switch (type->basetype->kind) {
+
+ case TK_ARRAY: /* use basetype's basetype: */
+ case TK_STRING: /* ^array[5] of array[3] of integer */
+ case TK_SET: /* => int (*a)[3]; */
+ if (stararrays == 1 ||
+ !(flags & ODECL_FREEARRAY) ||
+ type->basetype->structdefd) {
+ type = type->basetype->basetype;
+ flags &= ~ODECL_CHARSTAR;
+ continue;
+ }
+ break;
+
+ default:
+ break;
+ }
+ if (type->preserved && !(flags & ODECL_NOPRES))
+ return type;
+ if (type->fbase && type->fbase->wasdeclared &&
+ (flags & ODECL_DECL)) {
+ typename.meaning = type->fbase;
+ typename.preserved = 1;
+ return &typename;
+ }
+ break;
+
+ case TK_FUNCTION:
+ case TK_STRING:
+ case TK_SET:
+ case TK_SMALLSET:
+ case TK_SMALLARRAY:
+ if (!type->basetype)
+ return type;
+ break;
+
+ case TK_ARRAY:
+ if (type->meaning && type->meaning->kind == MK_TYPE &&
+ type->meaning->wasdeclared)
+ return type;
+ if (type->fbase && type->fbase->wasdeclared &&
+ (flags & ODECL_DECL)) {
+ typename.meaning = type->fbase;
+ typename.preserved = 1;
+ return &typename;
+ }
+ break;
+
+ case TK_FILE:
+ return tp_text->basetype;
+
+ case TK_PROCPTR:
+ return tp_proc;
+
+ case TK_CPROCPTR:
+ type = type->basetype->basetype;
+ continue;
+
+ case TK_ENUM:
+ if (useenum)
+ return type;
+ else if (!enumbyte ||
+ type->smax->kind != EK_CONST ||
+ type->smax->val.i > 255)
+ return tp_sshort;
+ else if (type->smax->val.i > 127)
+ return tp_ubyte;
+ else
+ return tp_abyte;
+
+ case TK_BOOLEAN:
+ if (*name_BOOLEAN)
+ return type;
+ else
+ return tp_ubyte;
+
+ case TK_SUBR:
+ if (type == tp_abyte || type == tp_ubyte || type == tp_sbyte ||
+ type == tp_ushort || type == tp_sshort) {
+ return type;
+ } else if ((type->basetype->kind == TK_ENUM && useenum) ||
+ type->basetype->kind == TK_BOOLEAN && *name_BOOLEAN) {
+ return type->basetype;
+ } else {
+ if (ord_range(type, &smin, &smax)) {
+ if (squeezesubr != 0) {
+ if (smin >= 0 && smax <= max_schar)
+ return tp_abyte;
+ else if (smin >= 0 && smax <= max_uchar)
+ return tp_ubyte;
+ else if (smin >= min_schar && smax <= max_schar &&
+ (signedchars == 1 || hassignedchar))
+ return tp_sbyte;
+ else if (smin >= min_sshort && smax <= max_sshort)
+ return tp_sshort;
+ else if (smin >= 0 && smax <= max_ushort)
+ return tp_ushort;
+ else
+ return tp_integer;
+ } else {
+ if (smin >= min_sshort && smax <= max_sshort)
+ return tp_sshort;
+ else
+ return tp_integer;
+ }
+ } else
+ return tp_integer;
+ }
+
+ case TK_CHAR:
+ if (type == tp_schar &&
+ (signedchars != 1 && !hassignedchar)) {
+ return tp_sshort;
+ }
+ return type;
+
+ default:
+ return type;
+ }
+ type = type->basetype;
+ }
+}
+
+
+Type *findbasetype(type, flags)
+Type *type;
+int flags;
+{
+ if (debug>1) {
+ fprintf(outf, "findbasetype(");
+ dumptypename(type, 1);
+ fprintf(outf, ",%d) = ", flags);
+ type = findbasetype_(type, flags);
+ dumptypename(type, 1);
+ fprintf(outf, "\n");
+ return type;
+ }
+ return findbasetype_(type, flags);
+}
+
+
+
+Expr *arraysize(tp, incskipped)
+Type *tp;
+int incskipped;
+{
+ Expr *ex, *minv, *maxv;
+ int denom;
+
+ ord_range_expr(tp->indextype, &minv, &maxv);
+ if (maxv->kind == EK_VAR && maxv->val.i == (long)mp_maxint &&
+ !exprdependsvar(minv, mp_maxint)) {
+ return NULL;
+ } else {
+ ex = makeexpr_plus(makeexpr_minus(copyexpr(maxv),
+ copyexpr(minv)),
+ makeexpr_long(1));
+ if (tp->smin && !incskipped) {
+ ex = makeexpr_minus(ex, copyexpr(tp->smin));
+ }
+ if (tp->smax) {
+ denom = (tp->basetype == tp_sshort) ? 16 : 8;
+ denom >>= tp->escale;
+ ex = makeexpr_div(makeexpr_plus(ex, makeexpr_long(denom-1)),
+ makeexpr_long(denom));
+ }
+ return ex;
+ }
+}
+
+
+
+Type *promote_type(tp)
+Type *tp;
+{
+ Type *tp2;
+
+ if (tp->kind == TK_ENUM) {
+ if (promote_enums == 0 ||
+ (promote_enums < 0 &&
+ (useenum)))
+ return tp;
+ }
+ if (tp->kind == TK_ENUM ||
+ tp->kind == TK_SUBR ||
+ tp->kind == TK_INTEGER ||
+ tp->kind == TK_CHAR ||
+ tp->kind == TK_BOOLEAN) {
+ tp2 = findbasetype(tp, ODECL_NOPRES);
+ if (tp2 == tp_ushort && sizeof_int == 16)
+ return tp_uint;
+ else if (tp2 == tp_sbyte || tp2 == tp_ubyte ||
+ tp2 == tp_abyte || tp2 == tp_char ||
+ tp2 == tp_sshort || tp2 == tp_ushort ||
+ tp2 == tp_boolean || tp2->kind == TK_ENUM) {
+ return tp_int;
+ }
+ }
+ if (tp == tp_real)
+ return tp_longreal;
+ return tp;
+}
+
+
+Type *promote_type_bin(t1, t2)
+Type *t1, *t2;
+{
+ t1 = promote_type(t1);
+ t2 = promote_type(t2);
+ if (t1 == tp_longreal || t2 == tp_longreal)
+ return tp_longreal;
+ if (t1 == tp_unsigned || t2 == tp_unsigned)
+ return tp_unsigned;
+ if (t1 == tp_integer || t2 == tp_integer) {
+ if ((t1 == tp_uint || t2 == tp_uint) &&
+ sizeof_int > 0 &&
+ sizeof_int < (sizeof_long > 0 ? sizeof_long : 32))
+ return tp_uint;
+ return tp_integer;
+ }
+ if (t1 == tp_uint || t2 == tp_uint)
+ return tp_uint;
+ return t1;
+}
+
+
+
+#if 0
+void predeclare_varstruct(mp)
+Meaning *mp;
+{
+ if (mp->ctx &&
+ mp->ctx->kind == MK_FUNCTION &&
+ mp->ctx->varstructflag &&
+ (usePPMacros != 0 || prototypes != 0) &&
+ !strlist_find(varstructdecllist, mp->ctx->name)) {
+ output("struct ");
+ output(format_s(name_LOC, mp->ctx->name));
+ output(" ;\n");
+ strlist_insert(&varstructdecllist, mp->ctx->name);
+ }
+}
+#endif
+
+
+Static void declare_args(type, isheader, isforward)
+Type *type;
+int isheader, isforward;
+{
+ Meaning *mp = type->fbase;
+ Type *tp;
+ int firstflag = 0;
+ int usePP, dopromote, proto, showtypes, shownames;
+ int staticlink;
+ char *name;
+
+#if 1 /* This seems to work better! */
+ isforward = !isheader;
+#endif
+ usePP = (isforward && usePPMacros != 0);
+ dopromote = (promoteargs == 1 ||
+ (promoteargs < 0 && (usePP || !fullprototyping)));
+ if (ansiC == 1 && blockkind != TOK_EXPORT)
+ usePP = 0;
+ if (usePP)
+ proto = (prototypes) ? prototypes : 1;
+ else
+ proto = (isforward || fullprototyping) ? prototypes : 0;
+ showtypes = (proto > 0);
+ shownames = (proto == 1 || isheader);
+ staticlink = (type->issigned ||
+ (type->meaning &&
+ type->meaning->ctx->kind == MK_FUNCTION &&
+ type->meaning->ctx->varstructflag));
+ if (mp || staticlink) {
+ if (usePP)
+ output(" PP(");
+ else if (spacefuncs)
+ output(" ");
+ output("(");
+ if (showtypes || shownames) {
+ firstflag = 0;
+ while (mp) {
+ if (firstflag++)
+ if (spacecommas)
+ output(",\002 ");
+ else
+ output(",\002");
+ name = (mp->othername && isheader) ? mp->othername : mp->name;
+ tp = (mp->othername) ? mp->rectype : mp->type;
+ if (!showtypes) {
+ output(name);
+ } else {
+ output(storageclassname(varstorageclass(mp)));
+ if (!shownames || (isforward && *name == '_')) {
+ out_type(tp, 1);
+ } else {
+ if (dopromote)
+ tp = promote_type(tp);
+ outbasetype(tp, ODECL_CHARSTAR|ODECL_FREEARRAY);
+ output(" ");
+ outdeclarator(tp, name,
+ ODECL_CHARSTAR|ODECL_FREEARRAY);
+ }
+ }
+ if (isheader)
+ mp->wasdeclared = showtypes;
+ if (mp->type == tp_strptr && mp->anyvarflag) { /* VAR STRING parameter */
+ if (spacecommas)
+ output(",\002 ");
+ else
+ output(",\002");
+ if (showtypes) {
+ if (useAnyptrMacros == 1 || useconsts == 2)
+ output("Const ");
+ else if (ansiC > 0)
+ output("const ");
+ output("int");
+ }
+ if (shownames) {
+ if (showtypes)
+ output(" ");
+ output(format_s(name_STRMAX, mp->name));
+ }
+ }
+ mp = mp->xnext;
+ }
+ if (staticlink) { /* sub-procedure with static link */
+ if (firstflag++)
+ if (spacecommas)
+ output(",\002 ");
+ else
+ output(",\002");
+ if (type->issigned) {
+ if (showtypes)
+ if (tp_special_anyptr)
+ output("Anyptr ");
+ else if (voidstar)
+ output("void *");
+ else
+ output("char *");
+ if (shownames)
+ output("_link");
+ } else {
+ mp = type->meaning->ctx;
+ if (showtypes) {
+ output("struct ");
+ output(format_s(name_LOC, mp->name));
+ output(" *");
+ }
+ if (shownames) {
+ output(format_s(name_LINK, mp->name));
+ }
+ }
+ }
+ }
+ output(")");
+ if (usePP)
+ output(")");
+ } else {
+ if (usePP)
+ output(" PV()");
+ else {
+ if (spacefuncs)
+ output(" ");
+ if (void_args)
+ output("(void)");
+ else
+ output("()");
+ }
+ }
+}
+
+
+
+void outdeclarator(type, name, flags)
+Type *type;
+char *name;
+int flags;
+{
+ int i, depth, anyptrs, anyarrays;
+ Expr *dimen[30];
+ Expr *ex, *maxv;
+ Type *tp, *functype, *basetype;
+ Expr funcdummy; /* yow */
+
+ anyptrs = 0;
+ anyarrays = 0;
+ functype = NULL;
+ basetype = findbasetype(type, flags);
+ for (depth = 0, tp = type; tp && tp != basetype; tp = tp->basetype) {
+ switch (tp->kind) {
+
+ case TK_POINTER:
+ if (tp->basetype) {
+ switch (tp->basetype->kind) {
+
+ case TK_VOID:
+ if (tp->basetype == tp_void &&
+ tp_special_anyptr) {
+ tp = tp_special_anyptr;
+ continue;
+ }
+ break;
+
+ case TK_ARRAY: /* ptr to array of x => ptr to x */
+ case TK_STRING: /* or => array of x */
+ case TK_SET:
+ if (stararrays == 1 ||
+ !(flags & ODECL_FREEARRAY) ||
+ (tp->basetype->structdefd &&
+ stararrays != 2)) {
+ tp = tp->basetype;
+ flags &= ~ODECL_CHARSTAR;
+ } else {
+ continue;
+ }
+ break;
+
+ default:
+ break;
+ }
+ }
+ dimen[depth++] = NULL;
+ anyptrs++;
+ if (tp->kind == TK_POINTER &&
+ tp->fbase && tp->fbase->wasdeclared)
+ break;
+ continue;
+
+ case TK_ARRAY:
+ flags &= ~ODECL_CHARSTAR;
+ if (tp->meaning && tp->meaning->kind == MK_TYPE &&
+ tp->meaning->wasdeclared)
+ break;
+ if (tp->structdefd) { /* conformant array */
+ if (!variablearrays &&
+ !(tp->basetype->kind == TK_ARRAY &&
+ tp->basetype->structdefd)) /* avoid mult. notes */
+ note("Conformant array code may not work in all compilers [101]");
+ }
+ ex = arraysize(tp, 1);
+ if (!ex)
+ ex = makeexpr_name("", tp_integer);
+ dimen[depth++] = ex;
+ anyarrays++;
+ if (tp->fbase && tp->fbase->wasdeclared)
+ break;
+ continue;
+
+ case TK_SET:
+ ord_range_expr(tp->indextype, NULL, &maxv);
+ maxv = enum_to_int(copyexpr(maxv));
+ if (ord_type(maxv->val.type)->kind == TK_CHAR)
+ maxv->val.type = tp_integer;
+ dimen[depth++] = makeexpr_plus(makeexpr_div(maxv, makeexpr_setbits()),
+ makeexpr_long(2));
+ break;
+
+ case TK_STRING:
+ if ((flags & ODECL_CHARSTAR) && stararrays == 1) {
+ dimen[depth++] = NULL;
+ } else {
+ ord_range_expr(tp->indextype, NULL, &maxv);
+ dimen[depth++] = makeexpr_plus(copyexpr(maxv), makeexpr_long(1));
+ }
+ continue;
+
+ case TK_FILE:
+ break;
+
+ case TK_CPROCPTR:
+ dimen[depth++] = NULL;
+ anyptrs++;
+ if (procptrprototypes)
+ continue;
+ dimen[depth++] = &funcdummy;
+ break;
+
+ case TK_FUNCTION:
+ dimen[depth++] = &funcdummy;
+ if (!functype)
+ functype = tp;
+ continue;
+
+ default:
+ break;
+ }
+ break;
+ }
+ if (!*name && depth && (spaceexprs > 0 ||
+ (spaceexprs != 0 && !dimen[depth-1])))
+ output(" "); /* spacing for abstract declarator */
+ if ((flags & ODECL_FUNCTION) && anyptrs)
+ output(" ");
+ if (anyarrays > 1 && !(flags & ODECL_FUNCTION))
+ output("\003");
+ for (i = depth; --i >= 0; ) {
+ if (!dimen[i])
+ output("*");
+ if (i > 0 &&
+ ((dimen[i] && !dimen[i-1]) ||
+ (dimen[i-1] && !dimen[i] && extraparens > 0)))
+ output("(");
+ }
+ if (flags & ODECL_FUNCTION)
+ output("\n");
+ if (anyarrays > 1 && (flags & ODECL_FUNCTION))
+ output("\003");
+ output(name);
+ for (i = 0; i < depth; i++) {
+ if (i > 0 &&
+ ((dimen[i] && !dimen[i-1]) ||
+ (dimen[i-1] && !dimen[i] && extraparens > 0)))
+ output(")");
+ if (dimen[i]) {
+ if (dimen[i] == &funcdummy) {
+ if (lookback(1) == ')')
+ output("\002");
+ if (functype)
+ declare_args(functype, (flags & ODECL_HEADER) != 0,
+ (flags & ODECL_FORWARD) != 0);
+ else if (spacefuncs)
+ output(" ()");
+ else
+ output("()");
+ } else {
+ if (lookback(1) == ']')
+ output("\002");
+ output("[");
+ if (!(flags & ODECL_FREEARRAY) || stararrays == 0 || i > 0)
+ out_expr(dimen[i]);
+ freeexpr(dimen[i]);
+ output("]");
+ }
+ }
+ }
+ if (anyarrays > 1)
+ output("\004");
+}
+
+
+
+
+
+
+/* Find out if types t1 and t2 will work out to be the same C type,
+ for purposes of type-casting */
+
+Type *canonicaltype(type)
+Type *type;
+{
+ if (type->kind == TK_SUBR || type->kind == TK_ENUM ||
+ type->kind == TK_PROCPTR)
+ type = findbasetype(type, 0);
+ if (type == tp_char)
+ return tp_ubyte;
+ if (type->kind == TK_POINTER) {
+ if (type->smin)
+ return type;
+ else if (type->basetype->kind == TK_ARRAY ||
+ type->basetype->kind == TK_STRING ||
+ type->basetype->kind == TK_SET)
+ return makepointertype(canonicaltype(type->basetype->basetype));
+ else if (type->basetype == tp_void)
+ return (voidstar) ? tp_anyptr : makepointertype(tp_abyte);
+ else if (type->basetype->kind == TK_FILE)
+ return tp_text;
+ else
+ return makepointertype(canonicaltype(type->basetype));
+ }
+ return type;
+}
+
+
+int identicaltypes(t1, t2)
+Type *t1, *t2;
+{
+ if (t1 == t2)
+ return 1;
+ if (t1->kind == t2->kind) {
+ if (t1->kind == TK_SUBR)
+ return (identicaltypes(t1->basetype, t2->basetype) &&
+ exprsame(t1->smin, t2->smin, 2) &&
+ exprsame(t1->smax, t2->smax, 2));
+ if (t1->kind == TK_SET ||
+ t1->kind == TK_SMALLSET)
+ return (exprsame(t1->indextype->smax,
+ t2->indextype->smax, 2));
+ if (t1->kind == TK_ARRAY ||
+ t1->kind == TK_STRING ||
+ t1->kind == TK_SMALLARRAY)
+ return (identicaltypes(t1->basetype, t2->basetype) &&
+ identicaltypes(t1->indextype, t2->indextype) &&
+ t1->structdefd == t2->structdefd &&
+ ((!t1->smin && !t2->smin) ||
+ (t1->smin && t2->smin &&
+ exprsame(t1->smin, t2->smin, 2))) &&
+ ((!t1->smax && !t2->smax) ||
+ (t1->smax && t2->smax &&
+ exprsame(t1->smax, t2->smax, 2) &&
+ t1->escale == t2->escale &&
+ t1->issigned == t2->issigned)));
+ }
+ return 0;
+}
+
+
+int similartypes(t1, t2)
+Type *t1, *t2;
+{
+ if (debug > 3) { fprintf(outf, "similartypes("); dumptypename(t1,1); fprintf(outf, ","); dumptypename(t2,1); fprintf(outf, ") = %d\n", identicaltypes(t1, t2)); }
+ if (identicaltypes(t1, t2))
+ return 1;
+ t1 = canonicaltype(t1);
+ t2 = canonicaltype(t2);
+ return (t1 == t2);
+}
+
+
+
+
+
+Static int checkstructconst(mp)
+Meaning *mp;
+{
+ return (mp->kind == MK_VAR &&
+ mp->constdefn &&
+ mp->constdefn->kind == EK_CONST &&
+ (mp->constdefn->val.type->kind == TK_ARRAY ||
+ mp->constdefn->val.type->kind == TK_RECORD));
+}
+
+
+Static int mixable(mp1, mp2, args, flags)
+Meaning *mp1, *mp2;
+int args, flags;
+{
+ Type *tp1 = mp1->type, *tp2 = mp2->type;
+
+ if (mixvars == 0)
+ return 0;
+ if (mp1->kind == MK_FIELD &&
+ (mp1->val.i || mp2->val.i) && mixfields == 0)
+ return 0;
+ if (checkstructconst(mp1) || checkstructconst(mp2))
+ return 0;
+ if (mp1->comments) {
+ if (findcomment(mp1->comments, CMT_NOT | CMT_PRE, -1))
+ return 0;
+ }
+ if (mp2->comments) {
+ if (findcomment(mp2->comments, CMT_PRE, -1))
+ return 0;
+ }
+ if ((mp1->constdefn && (mp1->kind == MK_VAR || mp1->kind == MK_VARREF)) ||
+ (mp2->constdefn && (mp2->kind == MK_VAR || mp2->kind == MK_VARREF))) {
+ if (mixinits == 0)
+ return 0;
+ if (mixinits != 1 &&
+ (!mp1->constdefn || !mp2->constdefn))
+ return 0;
+ }
+ if (args) {
+ if (mp1->kind == MK_PARAM && mp1->othername)
+ tp1 = mp1->rectype;
+ if (mp2->kind == MK_PARAM && mp2->othername)
+ tp2 = mp2->rectype;
+ }
+ if (tp1 == tp2)
+ return 1;
+ switch (mixtypes) {
+ case 0:
+ return 0;
+ case 1:
+ return (findbasetype(tp1, flags) == findbasetype(tp2, flags));
+ default:
+ if (findbasetype(tp1, flags) != findbasetype(tp2, flags))
+ return 0;
+ while (tp1->kind == TK_POINTER && !tp1->smin && tp1->basetype)
+ tp1 = tp1->basetype;
+ while (tp2->kind == TK_POINTER && !tp2->smin && tp2->basetype)
+ tp2 = tp2->basetype;
+ return (tp1 == tp2);
+ }
+}
+
+
+
+void declarefiles(fnames)
+Strlist *fnames;
+{
+ Meaning *mp;
+ char *cp;
+
+ while (fnames) {
+ mp = (Meaning *)fnames->value;
+ if (mp->kind == MK_VAR || mp->kind == MK_FIELD) {
+ if (mp->namedfile) {
+ output(storageclassname(varstorageclass(mp)));
+ output(format_ss("%s %s", charname,
+ format_s(name_FNVAR, fnames->s)));
+ output(format_s("[%s];\n", *name_FNSIZE ? name_FNSIZE : "80"));
+ }
+ if (mp->bufferedfile && *declbufname) {
+ cp = format_s("%s", storageclassname(varstorageclass(mp)));
+ if (*cp && isspace(cp[strlen(cp)-1]))
+ cp[strlen(cp)-1] = 0;
+ if (*cp || !*declbufncname) {
+ output(declbufname);
+ output("(");
+ output(fnames->s);
+ output(",");
+ output(cp);
+ } else {
+ output(declbufncname);
+ output("(");
+ output(fnames->s);
+ }
+ output(",");
+ out_type(mp->type->basetype->basetype, 1);
+ output(");\n");
+ }
+ }
+ strlist_eat(&fnames);
+ }
+}
+
+
+
+char *variantfieldname(num)
+int num;
+{
+ if (num >= 0)
+ return format_d("U%d", num);
+ else
+ return format_d("UM%d", -num);
+}
+
+
+int record_is_union(tp)
+Type *tp;
+{
+ return (tp->kind == TK_RECORD &&
+ tp->fbase && tp->fbase->kind == MK_VARIANT);
+}
+
+
+void outfieldlist(mp)
+Meaning *mp;
+{
+ Meaning *mp0;
+ int num, only_union, empty, saveindent, saveindent2;
+ Strlist *fnames, *fn;
+
+ if (!mp) {
+ output("int empty_struct; /* Pascal record was empty */\n");
+ return;
+ }
+ only_union = (mp && mp->kind == MK_VARIANT);
+ fnames = NULL;
+ while (mp && mp->kind == MK_FIELD) {
+ flushcomments(&mp->comments, CMT_PRE, -1);
+ output(storageclassname(varstorageclass(mp) & 0x10));
+ if (mp->dtype)
+ output(mp->dtype->name);
+ else
+ outbasetype(mp->type, 0);
+ output(" \005");
+ for (;;) {
+ if (mp->dtype)
+ output(mp->name);
+ else
+ outdeclarator(mp->type, mp->name, 0);
+ if (mp->val.i && (mp->type != tp_abyte || mp->val.i != 8))
+ output(format_d(" : %d", mp->val.i));
+ if (isfiletype(mp->type, 0)) {
+ fn = strlist_append(&fnames, mp->name);
+ fn->value = (long)mp;
+ }
+ mp->wasdeclared = 1;
+ if (!mp->cnext || mp->cnext->kind != MK_FIELD ||
+ mp->dtype != mp->cnext->dtype ||
+ varstorageclass(mp) != varstorageclass(mp->cnext) ||
+ !mixable(mp, mp->cnext, 0, 0))
+ break;
+ mp = mp->cnext;
+ if (spacecommas)
+ output(",\001 ");
+ else
+ output(",\001");
+ }
+ output(";");
+ outtrailcomment(mp->comments, -1, declcommentindent);
+ flushcomments(&mp->comments, -1, -1);
+ mp = mp->cnext;
+ }
+ declarefiles(fnames);
+ if (mp) {
+ saveindent = outindent;
+ empty = 1;
+ if (!only_union) {
+ output("union {\n");
+ moreindent(tabsize);
+ moreindent(structindent);
+ }
+ while (mp) {
+ mp0 = mp->ctx;
+ num = ord_value(mp->val);
+ while (mp && mp->ctx == mp0)
+ mp = mp->cnext;
+ if (mp0) {
+ empty = 0;
+ if (!mp0->cnext && mp0->kind == MK_FIELD) {
+ mp0->val.i = 0; /* no need for bit fields in a union! */
+ outfieldlist(mp0);
+ } else {
+ if (mp0->kind == MK_VARIANT)
+ output("union {\n");
+ else
+ output("struct {\n");
+ saveindent2 = outindent;
+ moreindent(tabsize);
+ moreindent(structindent);
+ outfieldlist(mp0);
+ outindent = saveindent2;
+ output("} ");
+ output(format_s(name_VARIANT, variantfieldname(num)));
+ output(";\n");
+ }
+ flushcomments(&mp0->comments, -1, -1);
+ }
+ }
+ if (empty)
+ output("int empty_union; /* Pascal variant record was empty */\n");
+ if (!only_union) {
+ outindent = saveindent;
+ output("} ");
+ output(format_s(name_UNION, ""));
+ output(";\n");
+ }
+ }
+}
+
+
+
+void declarebigfile(type)
+Type *type;
+{
+ output("FILE *f;\n");
+ if (!*declbufncname) {
+ output(declbufname);
+ output("(f,,");
+ } else {
+ output(declbufncname);
+ output("(f,");
+ }
+ out_type(type->basetype, 1);
+ output(");\n");
+ output(charname);
+ output(format_s(" name[%s];\n", *name_FNSIZE ? name_FNSIZE : "80"));
+}
+
+
+
+void outbasetype(type, flags)
+Type *type;
+int flags;
+{
+ Meaning *mp;
+ int saveindent;
+
+ type = findbasetype(type, flags | ODECL_DECL);
+ if (type->preserved && type->meaning->wasdeclared) {
+ output(type->meaning->name);
+ return;
+ }
+ switch (type->kind) {
+
+ case TK_INTEGER:
+ if (type == tp_uint) {
+ output("unsigned");
+ } else if (type == tp_sint) {
+ if (useAnyptrMacros == 1)
+ output("Signed int");
+ else if (hassignedchar)
+ output("signed int");
+ else
+ output("int"); /* will sign-extend by hand */
+ } else if (type == tp_unsigned) {
+ output("unsigned long");
+ } else if (type != tp_int)
+ output(integername);
+ else
+ output("int");
+ break;
+
+ case TK_SUBR:
+ if (type == tp_special_anyptr) {
+ output("Anyptr");
+ } else if (type == tp_abyte) {
+ output("char");
+ } else if (type == tp_ubyte) {
+ output(ucharname);
+ } else if (type == tp_sbyte) {
+ output(scharname);
+ if (signedchars != 1 && !hassignedchar)
+ note("'signed char' may not be valid in all compilers [102]");
+ } else {
+ if (type == tp_ushort)
+ output("unsigned ");
+ output("short");
+ }
+ break;
+
+ case TK_CHAR:
+ if (type == tp_uchar) {
+ output(ucharname);
+ } else if (type == tp_schar) {
+ output(scharname);
+ if (signedchars != 1 && !hassignedchar)
+ note("'signed char' may not be valid in all compilers [102]");
+ } else
+ output(charname);
+ break;
+
+ case TK_BOOLEAN:
+ output((*name_BOOLEAN) ? name_BOOLEAN : ucharname);
+ break;
+
+ case TK_REAL:
+ if (type == tp_longreal)
+ output("double");
+ else
+ output("float");
+ break;
+
+ case TK_VOID:
+ if (ansiC == 0)
+ output("int");
+ else if (useAnyptrMacros == 1)
+ output("Void");
+ else
+ output("void");
+ break;
+
+ case TK_PROCPTR:
+ output(name_PROCEDURE);
+ break;
+
+ case TK_FILE:
+ output("FILE");
+ break;
+
+ case TK_SPECIAL:
+ if (type == tp_jmp_buf)
+ output("jmp_buf");
+ break;
+
+ default:
+ if (type->kind == TK_POINTER && type->smin) {
+ note("Forward pointer reference assumes struct type [323]");
+ output("struct ");
+ output(format_s(name_STRUCT, type->smin->val.s));
+ } else if (type->meaning && type->meaning->kind == MK_TYPE &&
+ type->meaning->wasdeclared) {
+ output(type->meaning->name);
+ } else {
+ switch (type->kind) {
+
+ case TK_ENUM:
+ output("enum {\n");
+ saveindent = outindent;
+ moreindent(tabsize);
+ moreindent(structindent);
+ mp = type->fbase;
+ while (mp) {
+ output(mp->name);
+ mp = mp->xnext;
+ if (mp)
+ if (spacecommas)
+ output(",\001 ");
+ else
+ output(",\001");
+ }
+ outindent = saveindent;
+ output("\n}");
+ break;
+
+ case TK_RECORD:
+ case TK_BIGFILE:
+ if (record_is_union(type))
+ output("union ");
+ else
+ output("struct ");
+ if (type->meaning)
+ output(format_s(name_STRUCT, type->meaning->name));
+ if (!type->structdefd) {
+ if (type->meaning) {
+ type->structdefd = 1;
+ output(" ");
+ }
+ output("{\n");
+ saveindent = outindent;
+ moreindent(tabsize);
+ moreindent(structindent);
+ if (type->kind == TK_BIGFILE)
+ declarebigfile(type);
+ else
+ outfieldlist(type->fbase);
+ outindent = saveindent;
+ output("}");
+ }
+ break;
+
+ default:
+ break;
+
+ }
+ }
+ break;
+ }
+}
+
+
+
+void out_type(type, witharrays)
+Type *type;
+int witharrays;
+{
+ if (!witharrays && type->kind == TK_ARRAY)
+ type = makepointertype(type->basetype);
+ outbasetype(type, 0);
+ outdeclarator(type, "", 0); /* write an "abstract declarator" */
+}
+
+
+
+
+int varstorageclass(mp)
+Meaning *mp;
+{
+ int sclass;
+
+ if (mp->kind == MK_PARAM || mp->kind == MK_VARPARAM ||
+ mp->kind == MK_FIELD)
+ sclass = 0;
+ else if (blockkind == TOK_EXPORT)
+ if (usevextern)
+ if (mp->constdefn &&
+ (mp->kind == MK_VAR ||
+ mp->kind == MK_VARREF))
+ sclass = 2; /* extern */
+ else
+ sclass = 1; /* vextern */
+ else
+ sclass = 0; /* (plain) */
+ else if (mp->isfunction && mp->kind != MK_FUNCTION)
+ sclass = 2; /* extern */
+ else if (mp->ctx->kind == MK_MODULE &&
+ (var_static != 0 ||
+ (findsymbol(mp->name)->flags & NEEDSTATIC)) &&
+ !mp->exported && !mp->istemporary && blockkind != TOK_END)
+ sclass = (useAnyptrMacros) ? 4 : 3; /* (private) */
+ else if (mp->isforward)
+ sclass = 3; /* static */
+ else
+ sclass = 0; /* (plain) */
+ if (mp->volatilequal)
+ sclass |= 0x10;
+ if (mp->constqual)
+ sclass |= 0x20;
+ if (debug>2) fprintf(outf, "varstorageclass(%s) = %d\n", mp->name, sclass);
+ return sclass;
+}
+
+
+char *storageclassname(i)
+int i;
+{
+ char *scname;
+
+ switch (i & 0xf) {
+ case 1:
+ scname = "vextern ";
+ break;
+ case 2:
+ scname = "extern ";
+ break;
+ case 3:
+ scname = "static ";
+ break;
+ case 4:
+ scname = "Static ";
+ break;
+ default:
+ scname = "";
+ break;
+ }
+ if (i & 0x10)
+ if (useAnyptrMacros == 1)
+ scname = format_s("%sVolatile ", scname);
+ else if (ansiC > 0)
+ scname = format_s("%svolatile ", scname);
+ if (i & 0x20)
+ if (useAnyptrMacros == 1)
+ scname = format_s("%sConst ", scname);
+ else if (ansiC > 0)
+ scname = format_s("%sconst ", scname);
+ return scname;
+}
+
+
+
+Static int var_mixable;
+
+void declarevar(mp, which)
+Meaning *mp;
+int which; /* 0x1=header, 0x2=body, 0x4=trailer, 0x8=in varstruct */
+{
+ int isstatic, isstructconst, saveindent, i;
+ Strlist *sl;
+
+ isstructconst = checkstructconst(mp);
+ isstatic = varstorageclass(mp);
+ if (which & 0x8)
+ isstatic &= 0x10; /* clear all but Volatile flags */
+ flushcomments(&mp->comments, CMT_PRE, -1);
+ if (which & 0x1) {
+ if (isstructconst)
+ outsection(minorspace);
+ output(storageclassname(isstatic));
+ if (mp->dtype)
+ output(mp->dtype->name);
+ else
+ outbasetype(mp->type, 0);
+ output(" \005");
+ }
+ if (which & 0x2) {
+ if (mp->dtype)
+ output(mp->name);
+ else
+ outdeclarator(mp->type, mp->name, 0);
+ if (mp->constdefn && blockkind != TOK_EXPORT &&
+ (mp->kind == MK_VAR || mp->kind == MK_VARREF)) {
+ if (mp->varstructflag) { /* move init code into function body */
+ intwarning("declarevar",
+ format_s("Variable %s initializer not removed [125]", mp->name));
+ } else {
+ if (isstructconst) {
+ output(" = {\n");
+ saveindent = outindent;
+ moreindent(tabsize);
+ moreindent(structinitindent);
+ out_expr((Expr *)mp->constdefn->val.i);
+ outindent = saveindent;
+ output("\n}");
+ var_mixable = 0;
+ } else if (mp->type->kind == TK_ARRAY &&
+ mp->constdefn->val.type->kind == TK_STRING &&
+ !initpacstrings) {
+ if (mp->ctx->kind == MK_MODULE) {
+ sl = strlist_append(&initialcalls,
+ format_sss("memcpy(%s,\002 %s,\002 sizeof(%s))",
+ mp->name,
+ makeCstring(mp->constdefn->val.s,
+ mp->constdefn->val.i),
+ mp->name));
+ sl->value = 1;
+ } else if (mp->isforward) {
+ output(" = {\005");
+ for (i = 0; i < mp->constdefn->val.i; i++) {
+ if (i > 0)
+ output(",\001");
+ output(makeCchar(mp->constdefn->val.s[i]));
+ }
+ output("}");
+ mp->constdefn = NULL;
+ var_mixable = 0;
+ }
+ } else {
+ output(" = ");
+ out_expr(mp->constdefn);
+ }
+ }
+ }
+ }
+ if (which & 0x4) {
+ output(";");
+ outtrailcomment(mp->comments, -1, declcommentindent);
+ flushcomments(&mp->comments, -1, -1);
+ if (isstructconst)
+ outsection(minorspace);
+ }
+}
+
+
+
+
+Static int checkvarmacdef(ex, mp)
+Expr *ex;
+Meaning *mp;
+{
+ int i;
+
+ if ((ex->kind == EK_NAME || ex->kind == EK_BICALL) &&
+ !strcmp(ex->val.s, mp->name)) {
+ ex->kind = EK_VAR;
+ ex->val.i = (long)mp;
+ ex->val.type = mp->type;
+ return 1;
+ }
+ if (ex->kind == EK_VAR && ex->val.i == (long)mp)
+ return 1;
+ i = ex->nargs;
+ while (--i >= 0)
+ if (checkvarmacdef(ex->args[i], mp))
+ return 1;
+ return 0;
+}
+
+
+int checkvarmac(mp)
+Meaning *mp;
+{
+ if (mp->kind != MK_VARMAC && mp->kind != MK_FUNCTION)
+ return 0;
+ if (!mp->constdefn)
+ return 0;
+ return checkvarmacdef(mp->constdefn, mp);
+}
+
+
+
+#define varkind(k) ((k)==MK_VAR||(k)==MK_VARREF||(k)==MK_PARAM||(k)==MK_VARPARAM)
+
+int declarevars(ctx, invarstruct)
+Meaning *ctx;
+int invarstruct;
+{
+ Meaning *mp, *mp0, *mp2;
+ Strlist *fnames, *fn;
+ int flag, first;
+
+ if (ctx->kind == MK_FUNCTION && ctx->varstructflag && !invarstruct) {
+ output("struct ");
+ output(format_s(name_LOC, ctx->name));
+ output(" ");
+ output(format_s(name_VARS, ctx->name));
+ output(";\n");
+ flag = 1;
+ } else
+ flag = 0;
+ if (debug>2) {
+ fprintf(outf,"declarevars:\n");
+ for (mp = ctx->cbase; mp; mp = mp->xnext) {
+ fprintf(outf, " %-22s%-15s%3d", mp->name,
+ meaningkindname(mp->kind),
+ mp->refcount);
+ if (mp->wasdeclared)
+ fprintf(outf, " [decl]");
+ if (mp->varstructflag)
+ fprintf(outf, " [struct]");
+ fprintf(outf, "\n");
+ }
+ }
+ fnames = NULL;
+ for (;;) {
+ mp = ctx->cbase;
+ while (mp && (!(varkind(mp->kind) || checkvarmac(mp)) ||
+ mp->wasdeclared || mp->varstructflag != invarstruct ||
+ mp->refcount <= 0))
+ mp = mp->cnext;
+ if (!mp)
+ break;
+ flag = 1;
+ first = 1;
+ mp0 = mp2 = mp;
+ var_mixable = 1;
+ while (mp) {
+ if ((varkind(mp->kind) || checkvarmac(mp)) &&
+ !mp->wasdeclared && var_mixable &&
+ mp->dtype == mp0->dtype &&
+ varstorageclass(mp) == varstorageclass(mp0) &&
+ mp->varstructflag == invarstruct && mp->refcount > 0) {
+ if (mixable(mp2, mp, 0, 0) || first) {
+ if (!first)
+ if (spacecommas)
+ output(",\001 ");
+ else
+ output(",\001");
+ declarevar(mp, (first ? 0x3 : 0x2) |
+ (invarstruct ? 0x8 : 0));
+ mp2 = mp;
+ mp->wasdeclared = 1;
+ if (isfiletype(mp->type, 0)) {
+ fn = strlist_append(&fnames, mp->name);
+ fn->value = (long)mp;
+ }
+ first = 0;
+ } else
+ if (mixvars != 1)
+ break;
+ }
+ if (first) {
+ intwarning("declarevars",
+ format_s("Unable to declare %s [126]", mp->name));
+ mp->wasdeclared = 1;
+ first = 0;
+ }
+ if (mixvars == 0)
+ break;
+ mp = mp->cnext;
+ }
+ declarevar(mp2, 0x4);
+ }
+ declarefiles(fnames);
+ return flag;
+}
+
+
+
+void redeclarevars(ctx)
+Meaning *ctx;
+{
+ Meaning *mp;
+
+ for (mp = ctx->cbase; mp; mp = mp->cnext) {
+ if ((mp->kind == MK_VAR || mp->kind == MK_VARREF) &&
+ mp->constdefn) {
+ mp->wasdeclared = 0; /* mark for redeclaration, this time */
+ } /* with its initializer */
+ }
+}
+
+
+
+
+
+void out_argdecls(ftype)
+Type *ftype;
+{
+ Meaning *mp, *mp0;
+ Type *tp;
+ int done;
+ int flag = 1;
+ char *name;
+
+ done = 0;
+ do {
+ mp = ftype->fbase;
+ while (mp && mp->wasdeclared)
+ mp = mp->xnext;
+ if (mp) {
+ if (flag)
+ output("\n");
+ flag = 0;
+ mp0 = mp;
+ outbasetype(mp->othername ? mp->rectype : mp->type,
+ ODECL_CHARSTAR|ODECL_FREEARRAY);
+ output(" \005");
+ while (mp) {
+ if (!mp->wasdeclared) {
+ if (mp == mp0 ||
+ mixable(mp0, mp, 1, ODECL_CHARSTAR|ODECL_FREEARRAY)) {
+ if (mp != mp0)
+ if (spacecommas)
+ output(",\001 ");
+ else
+ output(",\001");
+ name = (mp->othername) ? mp->othername : mp->name;
+ tp = (mp->othername) ? mp->rectype : mp->type;
+ outdeclarator(tp, name,
+ ODECL_CHARSTAR|ODECL_FREEARRAY);
+ mp->wasdeclared = 1;
+ } else
+ if (mixvars != 1)
+ break;
+ }
+ mp = mp->xnext;
+ }
+ output(";\n");
+ } else
+ done = 1;
+ } while (!done);
+ for (mp0 = ftype->fbase; mp0 && (mp0->type != tp_strptr ||
+ !mp0->anyvarflag); mp0 = mp0->xnext) ;
+ if (mp0) {
+ output("int ");
+ for (mp = mp0; mp; mp = mp->xnext) {
+ if (mp->type == tp_strptr && mp->anyvarflag) {
+ if (mp != mp0) {
+ if (mixvars == 0)
+ output(";\nint ");
+ else if (spacecommas)
+ output(",\001 ");
+ else
+ output(",\001");
+ }
+ output(format_s(name_STRMAX, mp->name));
+ }
+ }
+ output(";\n");
+ }
+ if (ftype->meaning && ftype->meaning->ctx->kind == MK_FUNCTION &&
+ ftype->meaning->ctx->varstructflag) {
+ if (flag)
+ output("\n");
+ output("struct ");
+ output(format_s(name_LOC, ftype->meaning->ctx->name));
+ output(" *");
+ output(format_s(name_LINK, ftype->meaning->ctx->name));
+ output(";\n");
+ }
+}
+
+
+
+
+void makevarstruct(func)
+Meaning *func;
+{
+ int flag = 0;
+ int saveindent;
+
+ outsection(minfuncspace);
+ output(format_s("\n/* Local variables for %s: */\n", func->name));
+ output("struct ");
+ output(format_s(name_LOC, func->name));
+ output(" {\n");
+ saveindent = outindent;
+ moreindent(tabsize);
+ moreindent(structindent);
+ if (func->ctx->kind == MK_FUNCTION && func->ctx->varstructflag) {
+ output("struct ");
+ output(format_s(name_LOC, func->ctx->name));
+ output(" *");
+ output(format_s(name_LINK, func->ctx->name));
+ output(";\n");
+ flag++;
+ }
+ flag += declarevars(func, 1);
+ if (!flag) /* Avoid generating an empty struct */
+ output("int _meef_;\n"); /* (I don't think this will ever happen) */
+ outindent = saveindent;
+ output("} ;\n");
+ outsection(minfuncspace);
+ strlist_insert(&varstructdecllist, func->name);
+}
+
+
+
+
+
+
+Type *maketype(kind)
+enum typekind kind;
+{
+ Type *tp;
+ tp = ALLOC(1, Type, types);
+ tp->kind = kind;
+ tp->basetype = NULL;
+ tp->indextype = NULL;
+ tp->pointertype = NULL;
+ tp->meaning = NULL;
+ tp->fbase = NULL;
+ tp->smin = NULL;
+ tp->smax = NULL;
+ tp->issigned = 0;
+ tp->dumped = 0;
+ tp->structdefd = 0;
+ tp->preserved = 0;
+ return tp;
+}
+
+
+
+
+Type *makesubrangetype(type, smin, smax)
+Type *type;
+Expr *smin, *smax;
+{
+ Type *tp;
+
+ if (type->kind == TK_SUBR)
+ type = type->basetype;
+ tp = maketype(TK_SUBR);
+ tp->basetype = type;
+ tp->smin = smin;
+ tp->smax = smax;
+ return tp;
+}
+
+
+
+Type *makesettype(setof)
+Type *setof;
+{
+ Type *tp;
+ long smax;
+
+ if (ord_range(setof, NULL, &smax) && smax < setbits && smallsetconst >= 0)
+ tp = maketype(TK_SMALLSET);
+ else
+ tp = maketype(TK_SET);
+ tp->basetype = tp_integer;
+ tp->indextype = setof;
+ return tp;
+}
+
+
+
+Type *makestringtype(len)
+int len;
+{
+ Type *type;
+ int index;
+
+ len |= 1;
+ if (len >= stringceiling)
+ type = tp_str255;
+ else {
+ index = (len-1) / 2;
+ if (stringtypecache[index])
+ return stringtypecache[index];
+ type = maketype(TK_STRING);
+ type->basetype = tp_char;
+ type->indextype = makesubrangetype(tp_integer,
+ makeexpr_long(0),
+ makeexpr_long(len));
+ stringtypecache[index] = type;
+ }
+ return type;
+}
+
+
+
+Type *makepointertype(type)
+Type *type;
+{
+ Type *tp;
+
+ if (type->pointertype)
+ return type->pointertype;
+ tp = maketype(TK_POINTER);
+ tp->basetype = type;
+ type->pointertype = tp;
+ return tp;
+}
+
+
+
+
+
+Value p_constant(type)
+Type *type;
+{
+ Value val;
+ Expr *ex;
+
+ ex = p_expr(type);
+ if (type)
+ ex = gentle_cast(ex, type);
+ val = eval_expr(ex);
+ freeexpr(ex);
+ if (!val.type) {
+ warning("Expected a constant [127]");
+ val.type = (type) ? type : tp_integer;
+ }
+ return val;
+}
+
+
+
+
+int typebits(smin, smax)
+long smin, smax;
+{
+ unsigned long size;
+ int bits;
+
+ if (smin >= 0 || (smin == -1 && smax == 0)) {
+ bits = 1;
+ size = smax;
+ } else {
+ bits = 2;
+ smin = -1L - smin;
+ if (smin >= smax)
+ size = smin;
+ else
+ size = smax;
+ }
+ while (size > 1) {
+ bits++;
+ size >>= 1;
+ }
+ return bits;
+}
+
+
+int packedsize(fname, typep, sizep, mode)
+char *fname;
+Type **typep;
+long *sizep;
+int mode;
+{
+ Type *tp = *typep;
+ long smin, smax;
+ int res, issigned;
+ short savefold;
+ long size;
+
+ if (packing == 0) /* suppress packing */
+ return 0;
+ if (tp->kind != TK_SUBR && tp->kind != TK_INTEGER && tp->kind != TK_ENUM &&
+ tp->kind != TK_CHAR && tp->kind != TK_BOOLEAN)
+ return 0;
+ if (tp == tp_unsigned)
+ return 0;
+ if (!ord_range(tp, &smin, &smax)) {
+ savefold = foldconsts;
+ foldconsts = 1;
+ res = ord_range(tp, &smin, &smax);
+ foldconsts = savefold;
+ if (res) {
+ note(format_s("Field width for %s is based on expansion of #defines [103]",
+ fname));
+ } else {
+ note(format_ss("Cannot compute size of field %s; assuming %s [104]",
+ fname, integername));
+ return 0;
+ }
+ } else {
+ if (tp->kind == TK_ENUM)
+ note(format_ssd("Field width for %s assumes enum%s has %d elements [105]",
+ fname,
+ (tp->meaning) ? format_s(" %s", tp->meaning->name) : "",
+ smax + 1));
+ }
+ issigned = (smin < 0);
+ size = typebits(smin, smax);
+ if (size >= ((sizeof_long > 0) ? sizeof_long : 32))
+ return 0;
+ if (packing != 1) {
+ if (size <= 8)
+ size = 8;
+ else if (size <= 16)
+ size = 16;
+ else
+ return 0;
+ }
+ if (!issigned) {
+ *typep = (mode == 0) ? tp_int : tp_uint;
+ } else {
+ if (mode == 2 && !hassignedchar && !*signextname)
+ return 0;
+ *typep = (mode == 1) ? tp_int : tp_sint;
+ }
+ *sizep = size;
+ return issigned;
+}
+
+
+
+Static void fielddecl(mp, type, tp2, val, ispacked, aligned)
+Meaning *mp;
+Type **type, **tp2;
+long *val;
+int ispacked, *aligned;
+{
+ long smin, smax, smin2, smax2;
+
+ *tp2 = *type;
+ *val = 0;
+ if (ispacked && !mp->constdefn && *type != tp_unsigned) {
+ (void)packedsize(mp->sym->name, tp2, val, signedfield);
+ if (*aligned && *val &&
+ (ord_type(*type)->kind == TK_CHAR ||
+ ord_type(*type)->kind == TK_INTEGER) &&
+ ord_range(findbasetype(*type, 0), &smin, &smax)) {
+ if (ord_range(*type, &smin2, &smax2)) {
+ if (typebits(smin, smax) == 16 &&
+ typebits(smin2, smax2) == 8 && *val == 8) {
+ *tp2 = tp_abyte;
+ }
+ }
+ if (typebits(smin, smax) == *val &&
+ *val != 7) { /* don't be fooled by tp_abyte */
+ /* don't need to use a bit-field for this field */
+ /* so not specifying one may make it more efficient */
+ /* (and also helps to simulate HP's $allow_packed$ mode) */
+ *val = 0;
+ *tp2 = *type;
+ }
+ }
+ if (*aligned && *val == 8 &&
+ (ord_type(*type)->kind == TK_BOOLEAN ||
+ ord_type(*type)->kind == TK_ENUM)) {
+ *val = 0;
+ *tp2 = tp_ubyte;
+ }
+ }
+ if (*val != 8 && *val != 16)
+ *aligned = (*val == 0);
+}
+
+
+
+/* This function locates byte-sized fields which were unaligned, but which
+ are followed by aligned quantities so that they can be made aligned
+ with no loss in storage efficiency. */
+
+Static void realignfields(firstmp, stopmp)
+Meaning *firstmp, *stopmp;
+{
+ Meaning *mp;
+
+ for (mp = firstmp; mp && mp != stopmp; mp = mp->cnext) {
+ if (mp->kind == MK_FIELD) {
+ if (mp->val.i == 16) {
+ if (mp->type == tp_uint)
+ mp->type = tp_ushort;
+ else
+ mp->type = tp_sshort;
+ mp->val.i = 0;
+ } else if (mp->val.i == 8) {
+ if (mp->type == tp_uint) {
+ mp->type = tp_ubyte;
+ mp->val.i = 0;
+ } else if (hassignedchar || signedchars == 1) {
+ mp->type = tp_sbyte;
+ mp->val.i = 0;
+ } else
+ mp->type = tp_abyte;
+ }
+ }
+ }
+}
+
+static void tryrealignfields(firstmp)
+Meaning *firstmp;
+{
+ Meaning *mp, *head;
+
+ head = NULL;
+ for (mp = firstmp; mp; mp = mp->cnext) {
+ if (mp->kind == MK_FIELD) {
+ if ((mp->val.i == 8 &&
+ (mp->type == tp_uint ||
+ hassignedchar || signedchars == 1)) ||
+ mp->val.i == 16) {
+ if (!head)
+ head = mp;
+ } else {
+ if (mp->val.i == 0)
+ realignfields(head, mp);
+ head = NULL;
+ }
+ }
+ }
+ realignfields(head, NULL);
+}
+
+
+
+void decl_comments(mp)
+Meaning *mp;
+{
+ Strlist *cmt;
+
+ if (spitcomments != 1) {
+ changecomments(curcomments, -1, -1, CMT_PRE, 0);
+ strlist_mix(&mp->comments, curcomments);
+ curcomments = NULL;
+ cmt = grabcomment(CMT_TRAIL);
+ if (cmt) {
+ changecomments(mp->comments, CMT_TRAIL, -1, CMT_PRE, -1);
+ strlist_mix(&mp->comments, cmt);
+ }
+ if (mp->comments)
+ mp->refcount++; /* force it to be included if it has comments */
+ }
+}
+
+
+
+
+
+Static void p_fieldlist(tp, flast, ispacked, tname)
+Type *tp;
+Meaning **flast;
+int ispacked;
+Meaning *tname;
+{
+ Meaning *firstm, *lastm, *veryfirstm, *dtype;
+ Symbol *sym;
+ Type *type, *tp2;
+ long li1, li2;
+ int aligned, constflag, volatileflag;
+ short saveskipind;
+ Strlist *l1;
+
+ saveskipind = skipindices;
+ skipindices = 0;
+ aligned = 1;
+ lastm = NULL;
+ veryfirstm = NULL;
+ while (curtok == TOK_IDENT) {
+ firstm = addfield(curtoksym, &flast, tp, tname);
+ if (!veryfirstm)
+ veryfirstm = firstm;
+ lastm = firstm;
+ gettok();
+ decl_comments(lastm);
+ while (curtok == TOK_COMMA) {
+ gettok();
+ if (wexpecttok(TOK_IDENT))
+ lastm = addfield(curtoksym, &flast, tp, tname);
+ gettok();
+ decl_comments(lastm);
+ }
+ if (wneedtok(TOK_COLON)) {
+ constflag = volatileflag = 0;
+ p_attributes();
+ if ((l1 = strlist_find(attrlist, "READONLY")) != NULL) {
+ constflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "VOLATILE")) != NULL) {
+ volatileflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ dtype = (curtok == TOK_IDENT) ? curtokmeaning : NULL;
+ type = p_type(firstm);
+ decl_comments(lastm);
+ fielddecl(firstm, &type, &tp2, &li1, ispacked, &aligned);
+ dtype = validatedtype(dtype, type);
+ for (;;) {
+ firstm->type = tp2;
+ firstm->dtype = dtype;
+ firstm->val.type = type;
+ firstm->val.i = li1;
+ firstm->constqual = constflag;
+ firstm->volatilequal = volatileflag;
+ tp->meaning = tname;
+ setupfilevar(firstm);
+ tp->meaning = NULL;
+ if (firstm == lastm)
+ break;
+ firstm = firstm->cnext;
+ }
+ } else
+ skiptotoken2(TOK_SEMI, TOK_CASE);
+ if (curtok == TOK_SEMI)
+ gettok();
+ }
+ if (curtok == TOK_CASE) {
+ gettok();
+ if (curtok == TOK_COLON)
+ gettok();
+ wexpecttok(TOK_IDENT);
+ sym = curtoksym;
+ if (curtokmeaning)
+ type = curtokmeaning->type;
+ gettok();
+ if (curtok == TOK_COLON) {
+ firstm = addfield(sym, &flast, tp, tname);
+ if (!veryfirstm)
+ veryfirstm = firstm;
+ gettok();
+ firstm->isforward = 1;
+ firstm->val.type = type = p_type(firstm);
+ fielddecl(firstm, &firstm->val.type, &firstm->type, &firstm->val.i,
+ ispacked, &aligned);
+ } else {
+ firstm = NULL;
+ }
+ if (!wneedtok(TOK_OF)) {
+ skiptotoken2(TOK_END, TOK_RPAR);
+ goto bounce;
+ }
+ if (firstm)
+ decl_comments(firstm);
+ while (curtok == TOK_VBAR)
+ gettok();
+ while (curtok != TOK_END && curtok != TOK_RPAR) {
+ firstm = NULL;
+ for (;;) {
+ lastm = addfield(NULL, &flast, tp, tname);
+ if (!firstm)
+ firstm = lastm;
+ checkkeyword(TOK_OTHERWISE);
+ if (curtok == TOK_ELSE || curtok == TOK_OTHERWISE) {
+ lastm->val = make_ord(type, 999);
+ break;
+ } else {
+ lastm->val = p_constant(type);
+ if (curtok == TOK_DOTS) {
+ gettok();
+ li1 = ord_value(lastm->val);
+ li2 = ord_value(p_constant(type));
+ while (++li1 <= li2) {
+ lastm = addfield(NULL, &flast, tp, tname);
+ lastm->val = make_ord(type, li1);
+ }
+ }
+ }
+ if (curtok == TOK_COMMA)
+ gettok();
+ else
+ break;
+ }
+ if (curtok == TOK_ELSE || curtok == TOK_OTHERWISE) {
+ gettok();
+ } else if (!wneedtok(TOK_COLON) ||
+ (!modula2 && !wneedtok(TOK_LPAR))) {
+ skiptotoken2(TOK_END, TOK_RPAR);
+ goto bounce;
+ }
+ p_fieldlist(tp, &lastm->ctx, ispacked, tname);
+ while (firstm != lastm) {
+ firstm->ctx = lastm->ctx;
+ firstm = firstm->cnext;
+ }
+ if (modula2) {
+ while (curtok == TOK_VBAR)
+ gettok();
+ } else {
+ if (!wneedtok(TOK_RPAR))
+ skiptotoken(TOK_RPAR);
+ }
+ if (curtok == TOK_SEMI)
+ gettok();
+ }
+ if (modula2) {
+ wneedtok(TOK_END);
+ if (curtok == TOK_IDENT) {
+ note("Record variants supported only at end of record [106]");
+ p_fieldlist(tp, &lastm->ctx, ispacked, tname);
+ }
+ }
+ }
+ tryrealignfields(veryfirstm);
+ if (lastm && curtok == TOK_END) {
+ strlist_mix(&lastm->comments, curcomments);
+ curcomments = NULL;
+ }
+
+ bounce:
+ skipindices = saveskipind;
+}
+
+
+
+Static Type *p_arraydecl(tname, ispacked, confp)
+char *tname;
+int ispacked;
+Meaning ***confp;
+{
+ Type *tp, *tp2;
+ Meaning *mp;
+ Expr *ex;
+ long size, smin, smax, bitsize, fullbitsize;
+ int issigned, bpower, hasrange;
+
+ tp = maketype(TK_ARRAY);
+ if (confp == NULL) {
+ tp->indextype = p_type(NULL);
+ if (tp->indextype->kind == TK_SUBR) {
+ if (ord_range(tp->indextype, &smin, NULL) &&
+ smin > 0 && smin <= skipindices && !ispacked) {
+ tp->smin = makeexpr_val(make_ord(tp->indextype->basetype, smin));
+ ex = makeexpr_val(make_ord(tp->indextype->basetype, 0));
+ tp->indextype = makesubrangetype(tp->indextype->basetype,
+ ex,
+ copyexpr(tp->indextype->smax));
+ }
+ }
+ } else {
+ if (modula2) {
+ **confp = mp = addmeaning(findsymbol(format_s(name_ALOW, tname)), MK_PARAM);
+ mp->fakeparam = 1;
+ mp->constqual = 1;
+ mp->xnext = addmeaning(findsymbol(format_s(name_AHIGH, tname)), MK_PARAM);
+ mp->xnext->fakeparam = 1;
+ mp->xnext->constqual = 1;
+ *confp = &mp->xnext->xnext;
+ tp2 = maketype(TK_SUBR);
+ tp2->basetype = tp_integer;
+ mp->type = tp_integer;
+ mp->xnext->type = mp->type;
+ tp2->smin = makeexpr_long(0);
+ tp2->smax = makeexpr_minus(makeexpr_var(mp->xnext),
+ makeexpr_var(mp));
+ tp->indextype = tp2;
+ tp->structdefd = 1;
+ } else {
+ wexpecttok(TOK_IDENT);
+ tp2 = maketype(TK_SUBR);
+ if (peeknextchar() != ',' &&
+ (!curtokmeaning || curtokmeaning->kind != MK_TYPE)) {
+ mp = addmeaning(curtoksym, MK_PARAM);
+ gettok();
+ wneedtok(TOK_DOTS);
+ wexpecttok(TOK_IDENT);
+ mp->xnext = addmeaning(curtoksym, MK_PARAM);
+ gettok();
+ if (wneedtok(TOK_COLON)) {
+ tp2->basetype = p_type(NULL);
+ } else {
+ tp2->basetype = tp_integer;
+ }
+ } else {
+ mp = addmeaning(findsymbol(format_s(name_ALOW, tname)), MK_PARAM);
+ mp->xnext = addmeaning(findsymbol(format_s(name_AHIGH, tname)), MK_PARAM);
+ tp2->basetype = p_type(NULL);
+ }
+ mp->fakeparam = 1;
+ mp->constqual = 1;
+ mp->xnext->fakeparam = 1;
+ mp->xnext->constqual = 1;
+ **confp = mp;
+ *confp = &mp->xnext->xnext;
+ mp->type = tp2->basetype;
+ mp->xnext->type = tp2->basetype;
+ tp2->smin = makeexpr_var(mp);
+ tp2->smax = makeexpr_var(mp->xnext);
+ tp->indextype = tp2;
+ tp->structdefd = 1; /* conformant array flag */
+ }
+ }
+ if (curtok == TOK_COMMA || curtok == TOK_SEMI) {
+ gettok();
+ tp->basetype = p_arraydecl(tname, ispacked, confp);
+ return tp;
+ } else {
+ if (!modula2) {
+ if (!wneedtok(TOK_RBR))
+ skiptotoken(TOK_OF);
+ }
+ if (!wneedtok(TOK_OF))
+ skippasttotoken(TOK_OF, TOK_COMMA);
+ checkkeyword(TOK_VARYING);
+ if (confp != NULL &&
+ (curtok == TOK_ARRAY || curtok == TOK_PACKED ||
+ curtok == TOK_VARYING)) {
+ tp->basetype = p_conformant_array(tname, confp);
+ } else {
+ tp->fbase = (curtok == TOK_IDENT) ? curtokmeaning : NULL;
+ tp->basetype = p_type(NULL);
+ tp->fbase = validatedtype(tp->fbase, tp->basetype);
+ }
+ if (!ispacked)
+ return tp;
+ size = 0;
+ tp2 = tp->basetype;
+ if (!tname)
+ tname = "array";
+ issigned = packedsize(tname, &tp2, &size, 1);
+ if (!size || size > 8 ||
+ (issigned && !packsigned) ||
+ (size > 4 &&
+ (!issigned || (signedchars == 1 || hassignedchar))))
+ return tp;
+ bpower = 0;
+ while ((1<<bpower) < size)
+ bpower++; /* round size up to power of two */
+ size = 1<<bpower; /* size = # bits in an array element */
+ tp->escale = bpower;
+ tp->issigned = issigned;
+ hasrange = ord_range(tp->indextype, &smin, &smax) &&
+ (smax < 100000); /* don't be confused by giant arrays */
+ if (hasrange &&
+ (bitsize = (smax - smin + 1) * size)
+ <= ((sizeof_integer > 0) ? sizeof_integer : 32)) {
+ if (bitsize > ((sizeof_short > 0) ? sizeof_short : 16)) {
+ tp2 = (issigned) ? tp_integer : tp_unsigned;
+ fullbitsize = ((sizeof_integer > 0) ? sizeof_integer : 32);
+ } else if (bitsize > ((sizeof_char > 0) ? sizeof_char : 8) ||
+ (issigned && !(signedchars == 1 || hassignedchar))) {
+ tp2 = (issigned) ? tp_sshort : tp_ushort;
+ fullbitsize = ((sizeof_short > 0) ? sizeof_short : 16);
+ } else {
+ tp2 = (issigned) ? tp_sbyte : tp_ubyte;
+ fullbitsize = ((sizeof_char > 0) ? sizeof_char : 8);
+ }
+ tp->kind = TK_SMALLARRAY;
+ if (ord_range(tp->indextype, &smin, NULL) &&
+ smin > 0 && smin <= fullbitsize - bitsize) {
+ tp->smin = makeexpr_val(make_ord(tp->indextype->basetype, smin));
+ ex = makeexpr_val(make_ord(tp->indextype->basetype, 0));
+ tp->indextype = makesubrangetype(tp->indextype->basetype, ex,
+ copyexpr(tp->indextype->smax));
+ }
+ } else {
+ if (!issigned)
+ tp2 = tp_ubyte;
+ else if (signedchars == 1 || hassignedchar)
+ tp2 = tp_sbyte;
+ else
+ tp2 = tp_sshort;
+ }
+ tp->smax = makeexpr_type(tp->basetype);
+ tp->basetype = tp2;
+ return tp;
+ }
+}
+
+
+
+Static Type *p_conformant_array(tname, confp)
+char *tname;
+Meaning ***confp;
+{
+ int ispacked;
+ Meaning *mp;
+ Type *tp, *tp2;
+
+ p_attributes();
+ ignore_attributes();
+ if (curtok == TOK_PACKED) {
+ ispacked = 1;
+ gettok();
+ } else
+ ispacked = 0;
+ checkkeyword(TOK_VARYING);
+ if (curtok == TOK_VARYING) {
+ gettok();
+ wneedtok(TOK_LBR);
+ wexpecttok(TOK_IDENT);
+ mp = addmeaning(curtoksym, MK_PARAM);
+ mp->fakeparam = 1;
+ mp->constqual = 1;
+ **confp = mp;
+ *confp = &mp->xnext;
+ mp->type = tp_integer;
+ tp2 = maketype(TK_SUBR);
+ tp2->basetype = tp_integer;
+ tp2->smin = makeexpr_long(1);
+ tp2->smax = makeexpr_var(mp);
+ tp = maketype(TK_STRING);
+ tp->indextype = tp2;
+ tp->basetype = tp_char;
+ tp->structdefd = 1; /* conformant array flag */
+ gettok();
+ wneedtok(TOK_RBR);
+ skippasttoken(TOK_OF);
+ tp->basetype = p_type(NULL);
+ return tp;
+ }
+ if (wneedtok(TOK_ARRAY) &&
+ (modula2 || wneedtok(TOK_LBR))) {
+ return p_arraydecl(tname, ispacked, confp);
+ } else {
+ return tp_integer;
+ }
+}
+
+
+
+
+/* VAX Pascal: */
+void p_attributes()
+{
+ Strlist *l1;
+
+ if (modula2)
+ return;
+ while (curtok == TOK_LBR) {
+ implementationmodules = 1; /* auto-detect VAX Pascal */
+ do {
+ gettok();
+ if (!wexpecttok(TOK_IDENT)) {
+ skippasttoken(TOK_RBR);
+ return;
+ }
+ l1 = strlist_append(&attrlist, strupper(curtokbuf));
+ l1->value = -1;
+ gettok();
+ if (curtok == TOK_LPAR) {
+ gettok();
+ if (!strcmp(l1->s, "CHECK") ||
+ !strcmp(l1->s, "OPTIMIZE") ||
+ !strcmp(l1->s, "KEY") ||
+ !strcmp(l1->s, "COMMON") ||
+ !strcmp(l1->s, "PSECT") ||
+ !strcmp(l1->s, "EXTERNAL") ||
+ !strcmp(l1->s, "GLOBAL") ||
+ !strcmp(l1->s, "WEAK_EXTERNAL") ||
+ !strcmp(l1->s, "WEAK_GLOBAL")) {
+ l1->value = (long)stralloc(curtokbuf);
+ gettok();
+ while (curtok == TOK_COMMA) {
+ gettok();
+ gettok();
+ }
+ } else if (!strcmp(l1->s, "INHERIT") ||
+ !strcmp(l1->s, "IDENT") ||
+ !strcmp(l1->s, "ENVIRONMENT")) {
+ p_expr(NULL);
+ while (curtok == TOK_COMMA) {
+ gettok();
+ p_expr(NULL);
+ }
+ } else {
+ l1->value = ord_value(p_constant(tp_integer));
+ while (curtok == TOK_COMMA) {
+ gettok();
+ p_expr(NULL);
+ }
+ }
+ if (!wneedtok(TOK_RPAR)) {
+ skippasttotoken(TOK_RPAR, TOK_LBR);
+ }
+ }
+ } while (curtok == TOK_COMMA);
+ if (!wneedtok(TOK_RBR)) {
+ skippasttoken(TOK_RBR);
+ }
+ }
+}
+
+
+void ignore_attributes()
+{
+ while (attrlist) {
+ if (strcmp(attrlist->s, "HIDDEN") &&
+ strcmp(attrlist->s, "INHERIT") &&
+ strcmp(attrlist->s, "ENVIRONMENT"))
+ warning(format_s("Type attribute %s ignored [128]", attrlist->s));
+ strlist_eat(&attrlist);
+ }
+}
+
+
+int size_attributes()
+{
+ int size = -1;
+ Strlist *l1;
+
+ if ((l1 = strlist_find(attrlist, "BIT")) != NULL)
+ size = 1;
+ else if ((l1 = strlist_find(attrlist, "BYTE")) != NULL)
+ size = 8;
+ else if ((l1 = strlist_find(attrlist, "WORD")) != NULL)
+ size = 16;
+ else if ((l1 = strlist_find(attrlist, "LONG")) != NULL)
+ size = 32;
+ else if ((l1 = strlist_find(attrlist, "QUAD")) != NULL)
+ size = 64;
+ else if ((l1 = strlist_find(attrlist, "OCTA")) != NULL)
+ size = 128;
+ else
+ return -1;
+ if (l1->value >= 0)
+ size *= l1->value;
+ strlist_delete(&attrlist, l1);
+ return size;
+}
+
+
+void p_mech_spec(doref)
+int doref;
+{
+ if (curtok == TOK_IDENT && doref &&
+ !strcicmp(curtokbuf, "%REF")) {
+ note("Mechanism specified %REF treated like VAR [107]");
+ curtok = TOK_VAR;
+ return;
+ }
+ if (curtok == TOK_IDENT &&
+ (!strcicmp(curtokbuf, "%REF") ||
+ !strcicmp(curtokbuf, "%IMMED") ||
+ !strcicmp(curtokbuf, "%DESCR") ||
+ !strcicmp(curtokbuf, "%STDESCR"))) {
+ note(format_s("Mechanism specifier %s ignored [108]", curtokbuf));
+ gettok();
+ }
+}
+
+
+Type *p_modula_subrange(basetype)
+Type *basetype;
+{
+ Type *tp;
+ Value val;
+
+ wneedtok(TOK_LBR);
+ tp = maketype(TK_SUBR);
+ tp->smin = p_ord_expr();
+ if (basetype)
+ tp->smin = gentle_cast(tp->smin, basetype);
+ if (wexpecttok(TOK_DOTS)) {
+ gettok();
+ tp->smax = p_ord_expr();
+ if (tp->smax->val.type->kind == TK_REAL &&
+ tp->smax->kind == EK_CONST &&
+ strlen(tp->smax->val.s) == 12 &&
+ strcmp(tp->smax->val.s, "2147483648.0") >= 0 &&
+ strcmp(tp->smax->val.s, "4294967295.0") <= 0) {
+ tp = tp_unsigned;
+ } else if (basetype) {
+ tp->smin = gentle_cast(tp->smin, basetype);
+ tp->basetype = basetype;
+ } else {
+ basetype = ord_type(tp->smin->val.type);
+ if (basetype->kind == TK_INTEGER) {
+ val = eval_expr(tp->smin);
+ if (val.type && val.i >= 0)
+ basetype = tp_unsigned;
+ else
+ basetype = tp_integer;
+ }
+ tp->basetype = basetype;
+ }
+ } else {
+ tp = tp_integer;
+ }
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ return tp;
+}
+
+
+void makefakestruct(tp, tname)
+Type *tp;
+Meaning *tname;
+{
+ Symbol *sym;
+
+ if (!tname || blockkind == TOK_IMPORT)
+ return;
+ while (tp && (tp->kind == TK_ARRAY || tp->kind == TK_FILE))
+ tp = tp->basetype;
+ if (tp && tp->kind == TK_RECORD && !tp->meaning) {
+ sym = findsymbol(format_s(name_FAKESTRUCT, tname->name));
+ silentalreadydef++;
+ tp->meaning = addmeaning(sym, MK_TYPE);
+ silentalreadydef--;
+ tp->meaning->type = tp;
+ tp->meaning->refcount++;
+ declaretype(tp->meaning);
+ }
+}
+
+
+Type *p_type(tname)
+Meaning *tname;
+{
+ Type *tp;
+ int ispacked = 0;
+ Meaning **flast;
+ Meaning *mp;
+ Strlist *sl;
+ int num, isfunc, saveind, savenotephase, sizespec;
+ Expr *ex;
+ Value val;
+ static int proctypecount = 0;
+
+ p_attributes();
+ sizespec = size_attributes();
+ ignore_attributes();
+ tp = tp_integer;
+ if (curtok == TOK_PACKED) {
+ ispacked = 1;
+ gettok();
+ }
+ checkkeyword(TOK_VARYING);
+ if (modula2)
+ checkkeyword(TOK_POINTER);
+ switch (curtok) {
+
+ case TOK_RECORD:
+ gettok();
+ savenotephase = notephase;
+ notephase = 1;
+ tp = maketype(TK_RECORD);
+ p_fieldlist(tp, &(tp->fbase), ispacked, tname);
+ notephase = savenotephase;
+ if (!wneedtok(TOK_END)) {
+ skippasttoken(TOK_END);
+ }
+ break;
+
+ case TOK_ARRAY:
+ gettok();
+ if (!modula2) {
+ if (!wneedtok(TOK_LBR))
+ break;
+ }
+ tp = p_arraydecl(tname ? tname->name : NULL, ispacked, NULL);
+ makefakestruct(tp, tname);
+ break;
+
+ case TOK_VARYING:
+ gettok();
+ tp = maketype(TK_STRING);
+ if (wneedtok(TOK_LBR)) {
+ ex = p_ord_expr();
+ if (!wneedtok(TOK_RBR))
+ skippasttoken(TOK_RBR);
+ } else
+ ex = makeexpr_long(stringdefault);
+ if (wneedtok(TOK_OF))
+ tp->basetype = p_type(NULL);
+ else
+ tp->basetype = tp_char;
+ val = eval_expr(ex);
+ if (val.type) {
+ if (val.i > 255 && val.i > stringceiling) {
+ note(format_d("Strings longer than %d may have problems [109]",
+ stringceiling));
+ }
+ if (stringceiling != 255 &&
+ (val.i >= 255 || val.i > stringceiling)) {
+ freeexpr(ex);
+ ex = makeexpr_long(stringceiling);
+ }
+ }
+ tp->indextype = makesubrangetype(tp_integer, makeexpr_long(0), ex);
+ break;
+
+ case TOK_SET:
+ gettok();
+ if (!wneedtok(TOK_OF))
+ break;
+ tp = p_type(NULL);
+ if (tp == tp_integer || tp == tp_unsigned)
+ tp = makesubrangetype(tp, makeexpr_long(0),
+ makeexpr_long(defaultsetsize-1));
+ if (tp->kind == TK_ENUM && !tp->meaning && useenum) {
+ outbasetype(tp, 0);
+ output(";");
+ }
+ tp = makesettype(tp);
+ break;
+
+ case TOK_FILE:
+ gettok();
+ if (structfilesflag ||
+ (tname && strlist_cifind(structfiles, tname->name)))
+ tp = maketype(TK_BIGFILE);
+ else
+ tp = maketype(TK_FILE);
+ if (curtok == TOK_OF) {
+ gettok();
+ tp->basetype = p_type(NULL);
+ } else {
+ tp->basetype = tp_abyte;
+ }
+ if (tp->basetype->kind == TK_CHAR && charfiletext) {
+ if (tp->kind == TK_FILE)
+ tp = tp_text;
+ else
+ tp = tp_bigtext;
+ } else {
+ if (tp->kind == TK_FILE) {
+ makefakestruct(tp, tname);
+ tp = makepointertype(tp);
+ }
+ }
+ break;
+
+ case TOK_PROCEDURE:
+ case TOK_FUNCTION:
+ isfunc = (curtok == TOK_FUNCTION);
+ gettok();
+ if (curtok != TOK_LPAR && !isfunc && hasstaticlinks == 1) {
+ tp = tp_proc;
+ break;
+ }
+ proctypecount++;
+ mp = addmeaning(findsymbol(format_d("__PROCPTR%d",
+ proctypecount)),
+ MK_FUNCTION);
+ pushctx(mp);
+ tp = maketype((hasstaticlinks != 0) ? TK_PROCPTR : TK_CPROCPTR);
+ tp->basetype = p_funcdecl(&isfunc, 1);
+ tp->fbase = mp; /* (saved, but not currently used) */
+ tp->escale = hasstaticlinks;
+ popctx();
+ break;
+
+ case TOK_HAT:
+ case TOK_ADDR:
+ case TOK_POINTER:
+ if (curtok == TOK_POINTER) {
+ gettok();
+ wneedtok(TOK_TO);
+ if (curtok == TOK_IDENT && !strcmp(curtokbuf, "WORD")) {
+ tp = tp_anyptr;
+ gettok();
+ break;
+ }
+ } else
+ gettok();
+ p_attributes();
+ ignore_attributes();
+ tp = maketype(TK_POINTER);
+ if (curtok == TOK_IDENT &&
+ (!curtokmeaning || curtokmeaning->kind != MK_TYPE ||
+ (deferallptrs && curtokmeaning->ctx != curctx &&
+ curtokmeaning->ctx != nullctx))) {
+ struct ptrdesc *pd;
+ pd = ALLOC(1, struct ptrdesc, ptrdescs);
+ pd->sym = curtoksym;
+ pd->tp = tp;
+ pd->next = ptrbase;
+ ptrbase = pd;
+ tp->basetype = tp_abyte;
+ tp->smin = makeexpr_name(curtokcase, tp_integer);
+ anydeferredptrs = 1;
+ gettok();
+ } else {
+ tp->fbase = (curtok == TOK_IDENT) ? curtokmeaning : NULL;
+ tp->basetype = p_type(NULL);
+ tp->fbase = validatedtype(tp->fbase, tp->basetype);
+ if (!tp->basetype->pointertype)
+ tp->basetype->pointertype = tp;
+ }
+ break;
+
+ case TOK_LPAR:
+ if (!useenum)
+ outsection(minorspace);
+ enum_tname = tname;
+ tp = maketype(TK_ENUM);
+ flast = &(tp->fbase);
+ num = 0;
+ do {
+ gettok();
+ if (!wexpecttok(TOK_IDENT)) {
+ skiptotoken(TOK_RPAR);
+ break;
+ }
+ sl = strlist_find(constmacros, curtoksym->name);
+ mp = addmeaningas(curtoksym, MK_CONST, MK_VARIANT);
+ mp->val.type = tp;
+ mp->val.i = num++;
+ mp->type = tp;
+ if (sl) {
+ mp->constdefn = (Expr *)sl->value;
+ mp->anyvarflag = 1; /* Make sure constant is folded */
+ strlist_delete(&constmacros, sl);
+ if (mp->constdefn->kind == EK_NAME)
+ strchange(&mp->name, mp->constdefn->val.s);
+ } else {
+ if (!useenum) {
+ output(format_s("#define %s", mp->name));
+ mp->isreturn = 1;
+ out_spaces(constindent, 0, 0, 0);
+ saveind = outindent;
+ outindent = cur_column();
+ output(format_d("%d\n", mp->val.i));
+ outindent = saveind;
+ }
+ }
+ *flast = mp;
+ flast = &(mp->xnext);
+ gettok();
+ } while (curtok == TOK_COMMA);
+ if (!wneedtok(TOK_RPAR))
+ skippasttoken(TOK_RPAR);
+ tp->smin = makeexpr_long(0);
+ tp->smax = makeexpr_long(num-1);
+ if (!useenum)
+ outsection(minorspace);
+ break;
+
+ case TOK_LBR:
+ tp = p_modula_subrange(NULL);
+ break;
+
+ case TOK_IDENT:
+ if (!curtokmeaning) {
+ undefsym(curtoksym);
+ tp = tp_integer;
+ mp = addmeaning(curtoksym, MK_TYPE);
+ mp->type = tp;
+ gettok();
+ break;
+ } else if (curtokmeaning == mp_string) {
+ gettok();
+ tp = maketype(TK_STRING);
+ tp->basetype = tp_char;
+ if (curtok == TOK_LBR) {
+ gettok();
+ ex = p_ord_expr();
+ if (!wneedtok(TOK_RBR))
+ skippasttoken(TOK_RBR);
+ } else {
+ ex = makeexpr_long(stringdefault);
+ }
+ val = eval_expr(ex);
+ if (val.type && stringceiling != 255 &&
+ (val.i >= 255 || val.i > stringceiling)) {
+ freeexpr(ex);
+ ex = makeexpr_long(stringceiling);
+ }
+ tp->indextype = makesubrangetype(tp_integer, makeexpr_long(0), ex);
+ break;
+ } else if (curtokmeaning->kind == MK_TYPE) {
+ tp = curtokmeaning->type;
+ if (sizespec > 0) {
+ if (ord_type(tp)->kind == TK_INTEGER && sizespec <= 32) {
+ if (checkconst(tp->smin, 0)) {
+ if (sizespec == 32)
+ tp = tp_unsigned;
+ else
+ tp = makesubrangetype(tp_unsigned,
+ makeexpr_long(0),
+ makeexpr_long((1L << sizespec) - 1));
+ } else {
+ tp = makesubrangetype(tp_integer,
+ makeexpr_long(- ((1L << (sizespec-1)))),
+ makeexpr_long((1L << (sizespec-1)) - 1));
+ }
+ sizespec = -1;
+ }
+ }
+ gettok();
+ if (curtok == TOK_LBR) {
+ if (modula2) {
+ tp = p_modula_subrange(tp);
+ } else {
+ gettok();
+ ex = p_expr(tp_integer);
+ note("UCSD size spec ignored; using 'long int' [110]");
+ if (ord_type(tp)->kind == TK_INTEGER)
+ tp = tp_integer;
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ }
+ }
+ if (tp == tp_text &&
+ (structfilesflag ||
+ (tname && strlist_cifind(structfiles, tname->name))))
+ tp = tp_bigtext;
+ break;
+ }
+
+ /* fall through */
+ default:
+ tp = maketype(TK_SUBR);
+ tp->smin = p_ord_expr();
+ if (curtok == TOK_COLON)
+ curtok = TOK_DOTS; /* UCSD Pascal */
+ if (wexpecttok(TOK_DOTS)) {
+ gettok();
+ tp->smax = p_ord_expr();
+ if (tp->smax->val.type->kind == TK_REAL &&
+ tp->smax->kind == EK_CONST &&
+ strlen(tp->smax->val.s) == 12 &&
+ strcmp(tp->smax->val.s, "2147483648.0") >= 0 &&
+ strcmp(tp->smax->val.s, "4294967295.0") <= 0) {
+ tp = tp_unsigned;
+ break;
+ }
+ tp->basetype = ord_type(tp->smin->val.type);
+ if (sizespec >= 0) {
+ long smin, smax;
+ if (ord_range(tp, &smin, &smax) &&
+ typebits(smin, smax) == sizespec)
+ sizespec = -1;
+ }
+ } else {
+ tp = tp_integer;
+ }
+ break;
+ }
+ if (sizespec >= 0)
+ note(format_d("Don't know how to interpret size = %d bits [111]", sizespec));
+ return tp;
+}
+
+
+
+
+
+Type *p_funcdecl(isfunc, istype)
+int *isfunc, istype;
+{
+ Meaning *retmp = NULL, *mp, *firstmp, *lastmp, **prevm, **oldprevm;
+ Type *type, *tp;
+ enum meaningkind parkind;
+ int anyvarflag, constflag, volatileflag, num = 0;
+ Symbol *sym;
+ Expr *defval;
+ Token savetok;
+ Strlist *l1;
+
+ if (*isfunc || modula2) {
+ sym = findsymbol(format_s(name_RETV, curctx->name));
+ retmp = addmeaning(sym, MK_VAR);
+ retmp->isreturn = 1;
+ }
+ type = maketype(TK_FUNCTION);
+ if (curtok == TOK_LPAR) {
+ prevm = &type->fbase;
+ do {
+ gettok();
+ if (curtok == TOK_RPAR)
+ break;
+ p_mech_spec(1);
+ p_attributes();
+ checkkeyword(TOK_ANYVAR);
+ if (curtok == TOK_VAR || curtok == TOK_ANYVAR) {
+ parkind = MK_VARPARAM;
+ anyvarflag = (curtok == TOK_ANYVAR);
+ gettok();
+ } else if (curtok == TOK_PROCEDURE || curtok == TOK_FUNCTION) {
+ savetok = curtok;
+ gettok();
+ wexpecttok(TOK_IDENT);
+ *prevm = firstmp = addmeaning(curtoksym, MK_PARAM);
+ prevm = &firstmp->xnext;
+ firstmp->anyvarflag = 0;
+ curtok = savetok; /* rearrange tokens to a proc ptr type! */
+ firstmp->type = p_type(firstmp);
+ continue;
+ } else {
+ parkind = MK_PARAM;
+ anyvarflag = 0;
+ }
+ oldprevm = prevm;
+ if (modula2 && istype) {
+ firstmp = addmeaning(findsymbol(format_d("_A%d", ++num)), parkind);
+ } else {
+ wexpecttok(TOK_IDENT);
+ firstmp = addmeaning(curtoksym, parkind);
+ gettok();
+ }
+ *prevm = firstmp;
+ prevm = &firstmp->xnext;
+ firstmp->isactive = 0; /* nit-picking Turbo compatibility */
+ lastmp = firstmp;
+ while (curtok == TOK_COMMA) {
+ gettok();
+ if (wexpecttok(TOK_IDENT)) {
+ *prevm = lastmp = addmeaning(curtoksym, parkind);
+ prevm = &lastmp->xnext;
+ lastmp->isactive = 0;
+ }
+ gettok();
+ }
+ constflag = volatileflag = 0;
+ defval = NULL;
+ if (curtok != TOK_COLON && !modula2) {
+ if (parkind != MK_VARPARAM)
+ wexpecttok(TOK_COLON);
+ parkind = MK_VARPARAM;
+ tp = tp_anyptr;
+ anyvarflag = 1;
+ } else {
+ if (curtok == TOK_COLON)
+ gettok();
+ if (curtok == TOK_IDENT && !curtokmeaning &&
+ !strcicmp(curtokbuf, "UNIV")) {
+ if (parkind == MK_PARAM)
+ note("UNIV may not work for non-VAR parameters [112]");
+ anyvarflag = 1;
+ gettok();
+ }
+ p_attributes();
+ if ((l1 = strlist_find(attrlist, "READONLY")) != NULL) {
+ constflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "VOLATILE")) != NULL) {
+ volatileflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "UNSAFE")) != NULL &&
+ parkind == MK_VARPARAM) {
+ anyvarflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "REFERENCE")) != NULL) {
+ note("REFERENCE attribute treated like VAR [107]");
+ parkind = MK_VARPARAM;
+ strlist_delete(&attrlist, l1);
+ }
+ checkkeyword(TOK_VARYING);
+ if (curtok == TOK_IDENT && curtokmeaning == mp_string &&
+ !anyvarflag && parkind == MK_VARPARAM) {
+ anyvarflag = (varstrings > 0);
+ tp = tp_str255;
+ gettok();
+ if (curtok == TOK_LBR) {
+ wexpecttok(TOK_SEMI);
+ skipparens();
+ }
+ } else if (curtok == TOK_ARRAY || curtok == TOK_PACKED ||
+ curtok == TOK_VARYING) {
+ prevm = oldprevm;
+ tp = p_conformant_array(firstmp->name, &prevm);
+ *prevm = firstmp;
+ while (*prevm)
+ prevm = &(*prevm)->xnext;
+ } else {
+ tp = p_type(firstmp);
+ }
+ if (!varfiles && isfiletype(tp, 0))
+ parkind = MK_PARAM;
+ if (parkind == MK_VARPARAM)
+ tp = makepointertype(tp);
+ }
+ if (curtok == TOK_ASSIGN) { /* check for parameter default */
+ gettok();
+ p_mech_spec(0);
+ defval = gentle_cast(p_expr(tp), tp);
+ if ((tp->kind == TK_STRING || tp->kind == TK_ARRAY) &&
+ tp->basetype->kind == TK_CHAR &&
+ tp->structdefd && /* conformant string */
+ defval->val.type->kind == TK_STRING) {
+ mp = *oldprevm;
+ if (tp->kind == TK_ARRAY) {
+ mp->constdefn = makeexpr_long(1);
+ mp = mp->xnext;
+ }
+ mp->constdefn = strmax_func(defval);
+ }
+ }
+ while (firstmp) {
+ firstmp->type = tp;
+ firstmp->kind = parkind; /* in case it changed */
+ firstmp->isactive = 1;
+ firstmp->anyvarflag = anyvarflag;
+ firstmp->constqual = constflag;
+ firstmp->volatilequal = volatileflag;
+ if (defval) {
+ if (firstmp == lastmp)
+ firstmp->constdefn = defval;
+ else
+ firstmp->constdefn = copyexpr(defval);
+ }
+ if (parkind == MK_PARAM &&
+ (tp->kind == TK_STRING ||
+ tp->kind == TK_ARRAY ||
+ tp->kind == TK_SET ||
+ ((tp->kind == TK_RECORD ||
+ tp->kind == TK_BIGFILE ||
+ tp->kind == TK_PROCPTR) && copystructs < 2))) {
+ firstmp->othername = stralloc(format_s(name_COPYPAR,
+ firstmp->name));
+ firstmp->rectype = makepointertype(tp);
+ }
+ if (firstmp == lastmp)
+ break;
+ firstmp = firstmp->xnext;
+ }
+ } while (curtok == TOK_SEMI || curtok == TOK_COMMA);
+ if (!wneedtok(TOK_RPAR))
+ skippasttotoken(TOK_RPAR, TOK_SEMI);
+ }
+ if (modula2) {
+ if (curtok == TOK_COLON) {
+ *isfunc = 1;
+ } else {
+ unaddmeaning(retmp);
+ }
+ }
+ if (*isfunc) {
+ if (wneedtok(TOK_COLON)) {
+ retmp->type = type->basetype = p_type(NULL);
+ switch (retmp->type->kind) {
+
+ case TK_RECORD:
+ case TK_BIGFILE:
+ case TK_PROCPTR:
+ if (copystructs >= 3)
+ break;
+
+ /* fall through */
+ case TK_ARRAY:
+ case TK_STRING:
+ case TK_SET:
+ type->basetype = retmp->type = makepointertype(retmp->type);
+ retmp->kind = MK_VARPARAM;
+ retmp->anyvarflag = 0;
+ retmp->xnext = type->fbase;
+ type->fbase = retmp;
+ retmp->refcount++;
+ break;
+
+ default:
+ break;
+ }
+ } else
+ retmp->type = type->basetype = tp_integer;
+ } else
+ type->basetype = tp_void;
+ return type;
+}
+
+
+
+
+
+Symbol *findlabelsym()
+{
+ if (curtok == TOK_IDENT &&
+ curtokmeaning && curtokmeaning->kind == MK_LABEL) {
+#if 0
+ if (curtokmeaning->ctx != curctx && curtokmeaning->val.i != 0)
+ curtokmeaning->val.i = --nonloclabelcount;
+#endif
+ } else if (curtok == TOK_INTLIT) {
+ strcpy(curtokcase, curtokbuf);
+ curtoksym = findsymbol(curtokbuf);
+ curtokmeaning = curtoksym->mbase;
+ while (curtokmeaning && !curtokmeaning->isactive)
+ curtokmeaning = curtokmeaning->snext;
+ if (!curtokmeaning || curtokmeaning->kind != MK_LABEL)
+ return NULL;
+#if 0
+ if (curtokmeaning->ctx != curctx && curtokmeaning->val.i != 0)
+ if (curtokint == 0)
+ curtokmeaning->val.i = -1;
+ else
+ curtokmeaning->val.i = curtokint;
+#endif
+ } else
+ return NULL;
+ return curtoksym;
+}
+
+
+void p_labeldecl()
+{
+ Symbol *sp;
+ Meaning *mp;
+
+ do {
+ gettok();
+ if (curtok != TOK_IDENT)
+ wexpecttok(TOK_INTLIT);
+ sp = findlabelsym();
+ mp = addmeaning(curtoksym, MK_LABEL);
+ mp->val.i = 0;
+ mp->xnext = addmeaning(findsymbol(format_s(name_LABVAR,
+ mp->name)),
+ MK_VAR);
+ mp->xnext->type = tp_jmp_buf;
+ mp->xnext->refcount = 0;
+ gettok();
+ } while (curtok == TOK_COMMA);
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+}
+
+
+
+
+
+Meaning *findfieldname(sym, variants, nvars)
+Symbol *sym;
+Meaning **variants;
+int *nvars;
+{
+ Meaning *mp, *mp0;
+
+ mp = variants[*nvars-1];
+ while (mp && mp->kind == MK_FIELD) {
+ if (mp->sym == sym) {
+ return mp;
+ }
+ mp = mp->cnext;
+ }
+ while (mp) {
+ variants[(*nvars)++] = mp->ctx;
+ mp0 = findfieldname(sym, variants, nvars);
+ if (mp0)
+ return mp0;
+ (*nvars)--;
+ while (mp->cnext && mp->cnext->ctx == mp->ctx)
+ mp = mp->cnext;
+ mp = mp->cnext;
+ }
+ return NULL;
+}
+
+
+
+
+Expr *p_constrecord(type, style)
+Type *type;
+int style; /* 0=HP, 1=Turbo, 2=Oregon+VAX */
+{
+ Meaning *mp, *mp0, *variants[20], *newvariants[20], *curfield;
+ Symbol *sym;
+ Value val;
+ Expr *ex, *cex;
+ int i, j, nvars, newnvars, varcounts[20];
+
+ if (!wneedtok(style ? TOK_LPAR : TOK_LBR))
+ return makeexpr_long(0);
+ cex = makeexpr(EK_STRUCTCONST, 0);
+ nvars = 0;
+ varcounts[0] = 0;
+ curfield = type->fbase;
+ for (;;) {
+ if (style == 2) {
+ if (curfield) {
+ mp = curfield;
+ if (mp->kind == MK_VARIANT || mp->isforward) {
+ val = p_constant(mp->type);
+ if (mp->kind == MK_FIELD) {
+ insertarg(&cex, cex->nargs, makeexpr_val(val));
+ mp = mp->cnext;
+ }
+ val.type = mp->val.type;
+ if (!valuesame(val, mp->val)) {
+ while (mp && !valuesame(val, mp->val))
+ mp = mp->cnext;
+ if (mp) {
+ note("Attempting to initialize union member other than first [113]");
+ curfield = mp->ctx;
+ } else {
+ warning("Tag value does not exist in record [129]");
+ curfield = NULL;
+ }
+ } else
+ curfield = mp->ctx;
+ goto ignorefield;
+ } else {
+ i = cex->nargs;
+ insertarg(&cex, i, NULL);
+ if (mp->isforward && curfield->cnext)
+ curfield = curfield->cnext->ctx;
+ else
+ curfield = curfield->cnext;
+ }
+ } else {
+ warning("Too many fields in record constructor [130]");
+ ex = p_expr(NULL);
+ freeexpr(ex);
+ goto ignorefield;
+ }
+ } else {
+ if (!wexpecttok(TOK_IDENT)) {
+ skiptotoken2(TOK_RPAR, TOK_RBR);
+ break;
+ }
+ sym = curtoksym;
+ gettok();
+ if (!wneedtok(TOK_COLON)) {
+ skiptotoken2(TOK_RPAR, TOK_RBR);
+ break;
+ }
+ newnvars = 1;
+ newvariants[0] = type->fbase;
+ mp = findfieldname(sym, newvariants, &newnvars);
+ if (!mp) {
+ warning(format_s("Field %s not in record [131]", sym->name));
+ ex = p_expr(NULL); /* good enough */
+ freeexpr(ex);
+ goto ignorefield;
+ }
+ for (i = 0; i < nvars && i < newnvars; i++) {
+ if (variants[i] != newvariants[i]) {
+ warning("Fields are members of incompatible variants [132]");
+ ex = p_subconst(mp->type, style);
+ freeexpr(ex);
+ goto ignorefield;
+ }
+ }
+ while (nvars < newnvars) {
+ variants[nvars] = newvariants[nvars];
+ if (nvars > 0) {
+ for (mp0 = variants[nvars-1]; mp0->kind != MK_VARIANT; mp0 = mp0->cnext) ;
+ if (mp0->ctx != variants[nvars])
+ note("Attempting to initialize union member other than first [113]");
+ }
+ i = varcounts[nvars];
+ for (mp0 = variants[nvars]; mp0 && mp0->kind == MK_FIELD; mp0 = mp0->cnext)
+ i++;
+ nvars++;
+ varcounts[nvars] = i;
+ while (cex->nargs < i)
+ insertarg(&cex, cex->nargs, NULL);
+ }
+ i = varcounts[newnvars-1];
+ for (mp0 = variants[newnvars-1]; mp0->sym != sym; mp0 = mp0->cnext)
+ i++;
+ if (cex->args[i])
+ warning(format_s("Two constructors for %s [133]", mp->name));
+ }
+ ex = p_subconst(mp->type, style);
+ if (ex->kind == EK_CONST &&
+ (ex->val.type->kind == TK_RECORD ||
+ ex->val.type->kind == TK_ARRAY))
+ ex = (Expr *)ex->val.i;
+ cex->args[i] = ex;
+ignorefield:
+ if (curtok == TOK_COMMA || curtok == TOK_SEMI)
+ gettok();
+ else
+ break;
+ }
+ if (!wneedtok(style ? TOK_RPAR : TOK_RBR))
+ skippasttoken2(TOK_RPAR, TOK_RBR);
+ if (style != 2) {
+ j = 0;
+ mp = variants[0];
+ for (i = 0; i < cex->nargs; i++) {
+ while (!mp || mp->kind != MK_FIELD)
+ mp = variants[++j];
+ if (!cex->args[i]) {
+ warning(format_s("No constructor for %s [134]", mp->name));
+ cex->args[i] = makeexpr_name("<oops>", mp->type);
+ }
+ mp = mp->cnext;
+ }
+ }
+ val.type = type;
+ val.i = (long)cex;
+ val.s = NULL;
+ return makeexpr_val(val);
+}
+
+
+
+
+Expr *p_constarray(type, style)
+Type *type;
+int style;
+{
+ Value val;
+ Expr *ex, *cex;
+ int nvals, skipped;
+ long smin, smax;
+
+ if (type->kind == TK_SMALLARRAY)
+ warning("Small-array constructors not yet implemented [135]");
+ if (!wneedtok(style ? TOK_LPAR : TOK_LBR))
+ return makeexpr_long(0);
+ if (type->smin && type->smin->kind == EK_CONST)
+ skipped = type->smin->val.i;
+ else
+ skipped = 0;
+ cex = NULL;
+ for (;;) {
+ if (style && (curtok == TOK_LPAR || curtok == TOK_LBR)) {
+ ex = p_subconst(type->basetype, style);
+ nvals = 1;
+ } else if (curtok == TOK_REPEAT) {
+ gettok();
+ ex = p_expr(type->basetype);
+ if (ord_range(type->indextype, &smin, &smax)) {
+ nvals = smax - smin + 1;
+ if (cex)
+ nvals -= cex->nargs;
+ } else {
+ nvals = 1;
+ note("REPEAT not translatable for non-constant array bounds [114]");
+ }
+ ex = gentle_cast(ex, type->basetype);
+ } else {
+ ex = p_expr(type->basetype);
+ if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING &&
+ ex->val.i > 1 && !skipped && style == 0 && !cex &&
+ type->basetype->kind == TK_CHAR &&
+ checkconst(type->indextype->smin, 1)) {
+ if (!wneedtok(TOK_RBR))
+ skippasttoken2(TOK_RBR, TOK_RPAR);
+ return ex; /* not quite right, but close enough */
+ }
+ if (curtok == TOK_OF) {
+ ex = gentle_cast(ex, tp_integer);
+ val = eval_expr(ex);
+ freeexpr(ex);
+ if (!val.type)
+ warning("Expected a constant [127]");
+ nvals = val.i;
+ gettok();
+ ex = p_expr(type->basetype);
+ } else
+ nvals = 1;
+ ex = gentle_cast(ex, type->basetype);
+ }
+ nvals += skipped;
+ skipped = 0;
+ if (ex->kind == EK_CONST &&
+ (ex->val.type->kind == TK_RECORD ||
+ ex->val.type->kind == TK_ARRAY))
+ ex = (Expr *)ex->val.i;
+ if (nvals != 1) {
+ ex = makeexpr_un(EK_STRUCTOF, type->basetype, ex);
+ ex->val.i = nvals;
+ }
+ if (cex)
+ insertarg(&cex, cex->nargs, ex);
+ else
+ cex = makeexpr_un(EK_STRUCTCONST, type, ex);
+ if (curtok == TOK_COMMA)
+ gettok();
+ else
+ break;
+ }
+ if (!wneedtok(style ? TOK_RPAR : TOK_RBR))
+ skippasttoken2(TOK_RPAR, TOK_RBR);
+ val.type = type;
+ val.i = (long)cex;
+ val.s = NULL;
+ return makeexpr_val(val);
+}
+
+
+
+
+Expr *p_conststring(type, style)
+Type *type;
+int style;
+{
+ Expr *ex;
+ Token close = (style ? TOK_RPAR : TOK_RBR);
+
+ if (curtok != (style ? TOK_LPAR : TOK_LBR))
+ return p_expr(type);
+ gettok();
+ ex = p_expr(tp_integer); /* should handle "OF" and "," for constructors */
+ if (curtok == TOK_OF || curtok == TOK_COMMA) {
+ warning("Multi-element string constructors not yet supported [136]");
+ skiptotoken(close);
+ }
+ if (!wneedtok(close))
+ skippasttoken(close);
+ return ex;
+}
+
+
+
+
+Expr *p_subconst(type, style)
+Type *type;
+int style;
+{
+ Value val;
+
+ if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE) {
+ if (curtokmeaning->type != type)
+ warning("Type conflict in constant [137]");
+ gettok();
+ }
+ if (curtok == TOK_IDENT && !strcicmp(curtokbuf, "ZERO") &&
+ !curtokmeaning) { /* VAX Pascal foolishness */
+ gettok();
+ if (type->kind == TK_STRING)
+ return makeexpr_string("");
+ if (type->kind == TK_REAL)
+ return makeexpr_real("0.0");
+ val.type = type;
+ if (type->kind == TK_RECORD || type->kind == TK_ARRAY ||
+ type->kind == TK_SET)
+ val.i = (long)makeexpr_un(EK_STRUCTCONST, type, makeexpr_long(0));
+ else
+ val.i = 0;
+ val.s = NULL;
+ return makeexpr_val(val);
+ }
+ switch (type->kind) {
+
+ case TK_RECORD:
+ if (curtok == (style ? TOK_LPAR : TOK_LBR))
+ return p_constrecord(type, style);
+ break;
+
+ case TK_SMALLARRAY:
+ case TK_ARRAY:
+ if (curtok == (style ? TOK_LPAR : TOK_LBR))
+ return p_constarray(type, style);
+ break;
+
+ case TK_SMALLSET:
+ case TK_SET:
+ if (curtok == TOK_LBR)
+ return p_setfactor(type, 1);
+ break;
+
+ default:
+ break;
+
+ }
+ return gentle_cast(p_expr(type), type);
+}
+
+
+
+void p_constdecl()
+{
+ Meaning *mp;
+ Expr *ex, *ex2;
+ Type *oldtype;
+ char savetokcase[sizeof(curtokcase)];
+ Symbol *savetoksym;
+ Strlist *sl;
+ int i, saveindent, outflag = (blockkind != TOK_IMPORT);
+
+ if (outflag)
+ outsection(majorspace);
+ flushcomments(NULL, -1, -1);
+ gettok();
+ oldtype = NULL;
+ while (curtok == TOK_IDENT) {
+ strcpy(savetokcase, curtokcase);
+ savetoksym = curtoksym;
+ gettok();
+ strcpy(curtokcase, savetokcase); /* what a kludge! */
+ curtoksym = savetoksym;
+ if (curtok == TOK_COLON) { /* Turbo Pascal typed constant */
+ mp = addmeaning(curtoksym, MK_VAR);
+ decl_comments(mp);
+ gettok();
+ mp->type = p_type(mp);
+ if (wneedtok(TOK_EQ)) {
+ if (mp->kind == MK_VARMAC) {
+ freeexpr(p_subconst(mp->type, 1));
+ note("Initializer ignored for variable with VarMacro [115]");
+ } else {
+ mp->constdefn = p_subconst(mp->type, 1);
+ if (blockkind == TOK_EXPORT) {
+ /* nothing */
+ } else {
+ mp->isforward = 1; /* static variable */
+ }
+ }
+ }
+ decl_comments(mp);
+ } else {
+ sl = strlist_find(constmacros, curtoksym->name);
+ if (sl) {
+ mp = addmeaning(curtoksym, MK_VARMAC);
+ mp->constdefn = (Expr *)sl->value;
+ strlist_delete(&constmacros, sl);
+ } else {
+ mp = addmeaning(curtoksym, MK_CONST);
+ }
+ decl_comments(mp);
+ if (!wexpecttok(TOK_EQ)) {
+ skippasttoken(TOK_SEMI);
+ continue;
+ }
+ mp->isactive = 0; /* A fine point indeed (see below) */
+ gettok();
+ if (curtok == TOK_IDENT &&
+ curtokmeaning && curtokmeaning->kind == MK_TYPE &&
+ (curtokmeaning->type->kind == TK_RECORD ||
+ curtokmeaning->type->kind == TK_SMALLARRAY ||
+ curtokmeaning->type->kind == TK_ARRAY)) {
+ oldtype = curtokmeaning->type;
+ gettok();
+ ex = p_subconst(oldtype, (curtok == TOK_LBR) ? 0 : 2);
+ } else {
+ ex = p_expr(NULL);
+ if (charconsts)
+ ex = makeexpr_charcast(ex);
+ }
+ mp->isactive = 1; /* Re-enable visibility of the new constant */
+ if (mp->kind == MK_CONST)
+ mp->constdefn = ex;
+ if (ord_type(ex->val.type)->kind == TK_INTEGER) {
+ i = exprlongness(ex);
+ if (i > 0)
+ ex->val.type = tp_integer;
+ else if (i < 0)
+ ex->val.type = tp_int;
+ }
+ decl_comments(mp);
+ mp->type = ex->val.type;
+ mp->val = eval_expr(ex);
+ if (mp->kind == MK_CONST) {
+ switch (ex->val.type->kind) {
+
+ case TK_INTEGER:
+ case TK_BOOLEAN:
+ case TK_CHAR:
+ case TK_ENUM:
+ case TK_SUBR:
+ case TK_REAL:
+ if (foldconsts > 0)
+ mp->anyvarflag = 1;
+ break;
+
+ case TK_STRING:
+ if (foldstrconsts > 0)
+ mp->anyvarflag = 1;
+ break;
+
+ default:
+ break;
+ }
+ }
+ flushcomments(&mp->comments, CMT_PRE, -1);
+ if (ex->val.type->kind == TK_SET) {
+ mp->val.type = NULL;
+ if (mp->kind == MK_CONST) {
+ ex2 = makeexpr(EK_MACARG, 0);
+ ex2->val.type = ex->val.type;
+ mp->constdefn = makeexpr_assign(ex2, ex);
+ }
+ } else if (mp->kind == MK_CONST && outflag) {
+ if (ex->val.type != oldtype) {
+ outsection(minorspace);
+ oldtype = ex->val.type;
+ }
+ switch (ex->val.type->kind) {
+
+ case TK_ARRAY:
+ case TK_RECORD:
+ select_outfile(codef);
+ outsection(minorspace);
+ if (blockkind == TOK_IMPLEMENT || blockkind == TOK_PROGRAM)
+ output("static ");
+ if (useAnyptrMacros == 1 || useconsts == 2)
+ output("Const ");
+ else if (useconsts > 0)
+ output("const ");
+ outbasetype(mp->type, ODECL_CHARSTAR|ODECL_FREEARRAY);
+ output(" ");
+ outdeclarator(mp->type, mp->name,
+ ODECL_CHARSTAR|ODECL_FREEARRAY);
+ output(" = {");
+ outtrailcomment(mp->comments, -1, declcommentindent);
+ saveindent = outindent;
+ moreindent(tabsize);
+ moreindent(structinitindent);
+ /* if (mp->val.s)
+ output(mp->val.s);
+ else */
+ out_expr((Expr *)mp->val.i);
+ outindent = saveindent;
+ output("\n};\n");
+ outsection(minorspace);
+ if (blockkind == TOK_EXPORT) {
+ select_outfile(hdrf);
+ if (usevextern)
+ output("vextern ");
+ if (useAnyptrMacros == 1 || useconsts == 2)
+ output("Const ");
+ else if (useconsts > 0)
+ output("const ");
+ outbasetype(mp->type, ODECL_CHARSTAR);
+ output(" ");
+ outdeclarator(mp->type, mp->name, ODECL_CHARSTAR);
+ output(";\n");
+ }
+ break;
+
+ default:
+ if (foldconsts > 0) break;
+ output(format_s("#define %s", mp->name));
+ mp->isreturn = 1;
+ out_spaces(constindent, 0, 0, 0);
+ saveindent = outindent;
+ outindent = cur_column();
+ out_expr_factor(ex);
+ outindent = saveindent;
+ outtrailcomment(mp->comments, -1, declcommentindent);
+ break;
+
+ }
+ }
+ flushcomments(&mp->comments, -1, -1);
+ if (mp->kind == MK_VARMAC)
+ freeexpr(ex);
+ mp->wasdeclared = 1;
+ }
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+ }
+ if (outflag)
+ outsection(majorspace);
+}
+
+
+
+
+void declaresubtypes(mp)
+Meaning *mp;
+{
+ Meaning *mp2;
+ Type *tp;
+ struct ptrdesc *pd;
+
+ while (mp) {
+ if (mp->kind == MK_VARIANT) {
+ declaresubtypes(mp->ctx);
+ } else {
+ tp = mp->type;
+ while (tp->basetype && !tp->meaning && tp->kind != TK_POINTER)
+ tp = tp->basetype;
+ if (tp->meaning && !tp->meaning->wasdeclared &&
+ (tp->kind == TK_RECORD || tp->kind == TK_ENUM) &&
+ tp->meaning->ctx && tp->meaning->ctx != nullctx) {
+ pd = ptrbase; /* Do this now, just in case */
+ while (pd) {
+ if (pd->tp->smin && pd->tp->basetype == tp_abyte) {
+ pd->tp->smin = NULL;
+ mp2 = pd->sym->mbase;
+ while (mp2 && !mp2->isactive)
+ mp2 = mp2->snext;
+ if (mp2 && mp2->kind == MK_TYPE) {
+ pd->tp->basetype = mp2->type;
+ pd->tp->fbase = mp2;
+ if (!mp2->type->pointertype)
+ mp2->type->pointertype = pd->tp;
+ }
+ }
+ pd = pd->next;
+ }
+ declaretype(tp->meaning);
+ }
+ }
+ mp = mp->cnext;
+ }
+}
+
+
+void declaretype(mp)
+Meaning *mp;
+{
+ int saveindent, pres;
+
+ switch (mp->type->kind) {
+
+ case TK_RECORD:
+ case TK_BIGFILE:
+ if (mp->type->meaning != mp) {
+ output(format_ss("typedef %s %s;",
+ mp->type->meaning->name,
+ mp->name));
+ } else {
+ declaresubtypes(mp->type->fbase);
+ outsection(minorspace);
+ if (record_is_union(mp->type))
+ output("typedef union ");
+ else
+ output("typedef struct ");
+ output(format_s("%s {\n", format_s(name_STRUCT, mp->name)));
+ saveindent = outindent;
+ moreindent(tabsize);
+ moreindent(structindent);
+ if (mp->type->kind == TK_BIGFILE)
+ declarebigfile(mp->type);
+ else
+ outfieldlist(mp->type->fbase);
+ outindent = saveindent;
+ output(format_s("} %s;", mp->name));
+ }
+ outtrailcomment(mp->comments, -1, declcommentindent);
+ mp->type->structdefd = 1;
+ if (mp->type->meaning == mp)
+ outsection(minorspace);
+ break;
+
+ case TK_ARRAY:
+ case TK_SMALLARRAY:
+ output("typedef ");
+ if (mp->type->meaning != mp) {
+ output(format_ss("%s %s",
+ mp->type->meaning->name,
+ mp->name));
+ } else {
+ outbasetype(mp->type, 0);
+ output(" ");
+ outdeclarator(mp->type, mp->name, 0);
+ }
+ output(";");
+ outtrailcomment(mp->comments, -1, declcommentindent);
+ break;
+
+ case TK_ENUM:
+ if (useenum) {
+ output("typedef ");
+ if (mp->type->meaning != mp)
+ output(mp->type->meaning->name);
+ else
+ outbasetype(mp->type, 0);
+ output(" ");
+ output(mp->name);
+ output(";");
+ outtrailcomment(mp->comments, -1,
+ declcommentindent);
+ }
+ break;
+
+ default:
+ pres = preservetypes;
+ if (mp->type->kind == TK_POINTER && preservepointers >= 0)
+ pres = preservepointers;
+ if (mp->type->kind == TK_STRING && preservestrings >= 0)
+ if (preservestrings == 2)
+ pres = mp->type->indextype->smax->kind != EK_CONST;
+ else
+ pres = preservestrings;
+ if (pres) {
+ output("typedef ");
+ mp->type->preserved = 0;
+ outbasetype(mp->type, 0);
+ output(" ");
+ outdeclarator(mp->type, mp->name, 0);
+ output(";\n");
+ mp->type->preserved = 1;
+ outtrailcomment(mp->comments, -1, declcommentindent);
+ }
+ break;
+ }
+ mp->wasdeclared = 1;
+}
+
+
+
+void declaretypes(outflag)
+int outflag;
+{
+ Meaning *mp;
+
+ for (mp = curctx->cbase; mp; mp = mp->cnext) {
+ if (mp->kind == MK_TYPE && !mp->wasdeclared) {
+ if (outflag) {
+ flushcomments(&mp->comments, CMT_PRE, -1);
+ declaretype(mp);
+ flushcomments(&mp->comments, -1, -1);
+ }
+ mp->wasdeclared = 1;
+ }
+ }
+}
+
+
+
+void p_typedecl()
+{
+ Meaning *mp;
+ int outflag = (blockkind != TOK_IMPORT);
+ struct ptrdesc *pd;
+
+ if (outflag)
+ outsection(majorspace);
+ flushcomments(NULL, -1, -1);
+ gettok();
+ outsection(minorspace);
+ deferallptrs = 1;
+ anydeferredptrs = 0;
+ notephase = 1;
+ while (curtok == TOK_IDENT) {
+ mp = addmeaning(curtoksym, MK_TYPE);
+ mp->type = tp_integer; /* in case of syntax errors */
+ gettok();
+ decl_comments(mp);
+ if (curtok == TOK_SEMI) {
+ mp->type = tp_anyptr; /* Modula-2 opaque type */
+ } else {
+ if (!wneedtok(TOK_EQ)) {
+ skippasttoken(TOK_SEMI);
+ continue;
+ }
+ mp->type = p_type(mp);
+ decl_comments(mp);
+ if (!mp->type->meaning)
+ mp->type->meaning = mp;
+ if (mp->type->kind == TK_RECORD ||
+ mp->type->kind == TK_BIGFILE)
+ mp->type->structdefd = 1;
+ if (!anydeferredptrs)
+ declaretypes(outflag);
+ }
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+ }
+ notephase = 0;
+ deferallptrs = 0;
+ while (ptrbase) {
+ pd = ptrbase;
+ if (pd->tp->smin && pd->tp->basetype == tp_abyte) {
+ pd->tp->smin = NULL;
+ mp = pd->sym->mbase;
+ while (mp && !mp->isactive)
+ mp = mp->snext;
+ if (!mp || mp->kind != MK_TYPE) {
+ warning(format_s("Unsatisfied forward reference to type %s [138]", pd->sym->name));
+ } else {
+ pd->tp->basetype = mp->type;
+ pd->tp->fbase = mp;
+ if (!mp->type->pointertype)
+ mp->type->pointertype = pd->tp;
+ }
+ }
+ ptrbase = ptrbase->next;
+ FREE(pd);
+ }
+ declaretypes(outflag);
+ outsection(minorspace);
+ flushcomments(NULL, -1, -1);
+ if (outflag)
+ outsection(majorspace);
+}
+
+
+
+
+
+Static void nameexternalvar(mp, name)
+Meaning *mp;
+char *name;
+{
+ if (!wasaliased) {
+ if (*externalias && my_strchr(externalias, '%'))
+ strchange(&mp->name, format_s(externalias, name));
+ else
+ strchange(&mp->name, name);
+ }
+}
+
+
+Static void handlebrackets(mp, skip, wasaliased)
+Meaning *mp;
+int skip, wasaliased;
+{
+ Expr *ex;
+
+ checkkeyword(TOK_ORIGIN);
+ if (curtok == TOK_ORIGIN) {
+ gettok();
+ ex = p_expr(tp_integer);
+ mp->kind = MK_VARREF;
+ mp->constdefn = gentle_cast(ex, tp_integer);
+ } else if (curtok == TOK_LBR) {
+ gettok();
+ ex = p_expr(tp_integer);
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ if (skip) {
+ freeexpr(ex);
+ return;
+ }
+ if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING) {
+ nameexternalvar(mp, ex->val.s);
+ mp->isfunction = 1; /* make it extern */
+ } else {
+ note(format_s("Absolute-addressed variable %s was generated [116]", mp->name));
+ mp->kind = MK_VARREF;
+ mp->constdefn = gentle_cast(ex, tp_integer);
+ }
+ }
+}
+
+
+
+Static void handleabsolute(mp, skip)
+Meaning *mp;
+int skip;
+{
+ Expr *ex;
+ Value val;
+ long i;
+
+ checkkeyword(TOK_ABSOLUTE);
+ if (curtok == TOK_ABSOLUTE) {
+ gettok();
+ if (skip) {
+ freeexpr(p_expr(tp_integer));
+ if (curtok == TOK_COLON) {
+ gettok();
+ freeexpr(p_expr(tp_integer));
+ }
+ return;
+ }
+ note(format_s("Absolute-addressed variable %s was generated [116]", mp->name));
+ mp->kind = MK_VARREF;
+ if (curtok == TOK_IDENT &&
+ curtokmeaning && (curtokmeaning->kind != MK_CONST ||
+ ord_type(curtokmeaning->type)->kind != TK_INTEGER)) {
+ mp->constdefn = makeexpr_addr(p_expr(NULL));
+ mp->isfunction = 1; /* make it extern */
+ } else {
+ ex = gentle_cast(p_expr(tp_integer), tp_integer);
+ if (curtok == TOK_COLON) {
+ val = eval_expr(ex);
+ if (!val.type)
+ warning("Expected a constant [127]");
+ i = val.i & 0xffff;
+ gettok();
+ val = p_constant(tp_integer);
+ i = (i<<16) | (val.i & 0xffff); /* as good a notation as any! */
+ ex = makeexpr_long(i);
+ insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
+ }
+ mp->constdefn = ex;
+ }
+ }
+}
+
+
+
+void setupfilevar(mp)
+Meaning *mp;
+{
+ if (mp->kind != MK_VARMAC) {
+ if (isfiletype(mp->type, 0)) {
+ if (storefilenames && *name_FNVAR)
+ mp->namedfile = 1;
+ if (checkvarinlists(bufferedfiles, unbufferedfiles, 0, mp))
+ mp->bufferedfile = 1;
+ } else if (isfiletype(mp->type, 1)) {
+ mp->namedfile = 1;
+ mp->bufferedfile = 1;
+ }
+ }
+}
+
+
+
+Meaning *validatedtype(dtype, type)
+Meaning *dtype;
+Type *type;
+{
+ if (dtype &&
+ (!type->preserved || !type->meaning ||
+ dtype->kind != MK_TYPE || dtype->type != type ||
+ type->meaning == dtype))
+ return NULL;
+ return dtype;
+}
+
+
+void p_vardecl()
+{
+ Meaning *firstmp, *lastmp, *dtype;
+ Type *tp;
+ int aliasflag, volatileflag, constflag, staticflag, globalflag, externflag;
+ Strlist *l1;
+ Expr *initexpr;
+
+ gettok();
+ notephase = 1;
+ while (curtok == TOK_IDENT) {
+ firstmp = lastmp = addmeaning(curtoksym, MK_VAR);
+ lastmp->type = tp_integer; /* in case of syntax errors */
+ aliasflag = wasaliased;
+ gettok();
+ handlebrackets(lastmp, (lastmp->kind != MK_VAR), aliasflag);
+ decl_comments(lastmp);
+ while (curtok == TOK_COMMA) {
+ gettok();
+ if (wexpecttok(TOK_IDENT)) {
+ lastmp = addmeaning(curtoksym, MK_VAR);
+ lastmp->type = tp_integer;
+ aliasflag = wasaliased;
+ gettok();
+ handlebrackets(lastmp, (lastmp->kind != MK_VAR), aliasflag);
+ decl_comments(lastmp);
+ }
+ }
+ if (!wneedtok(TOK_COLON)) {
+ skippasttoken(TOK_SEMI);
+ continue;
+ }
+ p_attributes();
+ volatileflag = constflag = staticflag = globalflag = externflag = 0;
+ if ((l1 = strlist_find(attrlist, "READONLY")) != NULL) {
+ constflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "VOLATILE")) != NULL) {
+ volatileflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "STATIC")) != NULL) {
+ staticflag = 1;
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "AUTOMATIC")) != NULL) {
+ /* This is the default! */
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "AT")) != NULL) {
+ note(format_s("Absolute-addressed variable %s was generated [116]", lastmp->name));
+ lastmp->kind = MK_VARREF;
+ lastmp->constdefn = makeexpr_long(l1->value);
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "GLOBAL")) != NULL ||
+ (l1 = strlist_find(attrlist, "WEAK_GLOBAL")) != NULL) {
+ globalflag = 1;
+ if (l1->value != -1)
+ nameexternalvar(lastmp, (char *)l1->value);
+ if (l1->s[0] != 'W')
+ strlist_delete(&attrlist, l1);
+ }
+ if ((l1 = strlist_find(attrlist, "EXTERNAL")) != NULL ||
+ (l1 = strlist_find(attrlist, "WEAK_EXTERNAL")) != NULL) {
+ externflag = 1;
+ if (l1->value != -1)
+ nameexternalvar(lastmp, (char *)l1->value);
+ if (l1->s[0] != 'W')
+ strlist_delete(&attrlist, l1);
+ }
+ dtype = (curtok == TOK_IDENT) ? curtokmeaning : NULL;
+ tp = p_type(firstmp);
+ decl_comments(lastmp);
+ handleabsolute(lastmp, (lastmp->kind != MK_VAR));
+ initexpr = NULL;
+ if (curtok == TOK_ASSIGN) { /* VAX Pascal initializer */
+ gettok();
+ initexpr = p_subconst(tp, 2);
+ if (lastmp->kind == MK_VARMAC) {
+ freeexpr(initexpr);
+ initexpr = NULL;
+ note("Initializer ignored for variable with VarMacro [115]");
+ }
+ }
+ dtype = validatedtype(dtype, tp);
+ for (;;) {
+ if (firstmp->kind == MK_VARREF) {
+ firstmp->type = makepointertype(tp);
+ firstmp->constdefn = makeexpr_cast(firstmp->constdefn, firstmp->type);
+ } else {
+ firstmp->type = tp;
+ setupfilevar(firstmp);
+ if (initexpr) {
+ if (firstmp == lastmp)
+ firstmp->constdefn = initexpr;
+ else
+ firstmp->constdefn = copyexpr(initexpr);
+ }
+ }
+ firstmp->dtype = dtype;
+ firstmp->volatilequal = volatileflag;
+ firstmp->constqual = constflag;
+ firstmp->isforward |= staticflag;
+ firstmp->isfunction |= externflag;
+ firstmp->exported |= globalflag;
+ if (globalflag && (curctx->kind != MK_MODULE || mainlocals))
+ declarevar(firstmp, -1);
+ if (firstmp == lastmp)
+ break;
+ firstmp = firstmp->cnext;
+ }
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+ }
+ notephase = 0;
+}
+
+
+
+
+void p_valuedecl()
+{
+ Meaning *mp;
+
+ gettok();
+ while (curtok == TOK_IDENT) {
+ if (!curtokmeaning ||
+ curtokmeaning->kind != MK_VAR) {
+ warning(format_s("Initializer ignored for variable %s [139]",
+ curtokbuf));
+ skippasttoken(TOK_SEMI);
+ } else {
+ mp = curtokmeaning;
+ gettok();
+ if (curtok == TOK_DOT || curtok == TOK_LBR) {
+ note("Partial structure initialization not supported [117]");
+ skippasttoken(TOK_SEMI);
+ } else if (wneedtok(TOK_ASSIGN)) {
+ mp->constdefn = p_subconst(mp->type, 2);
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+ } else
+ skippasttoken(TOK_SEMI);
+ }
+ }
+}
+
+
+
+
+
+
+
+/* Make a temporary variable that must be freed manually (or at the end of
+ the current function by default) */
+
+Meaning *maketempvar(type, name)
+Type *type;
+char *name;
+{
+ struct tempvarlist *tv, **tvp;
+ Symbol *sym;
+ Meaning *mp;
+ char *fullname;
+
+ tvp = &tempvars; /* find a freed but allocated temporary */
+ while ((tv = *tvp) && (!similartypes(tv->tvar->type, type) ||
+ tv->tvar->refcount == 0 ||
+ strcmp(tv->tvar->val.s, name)))
+ tvp = &(tv->next);
+ if (!tv) {
+ tvp = &tempvars; /* take over a now-cancelled temporary */
+ while ((tv = *tvp) && (tv->tvar->refcount > 0 ||
+ strcmp(tv->tvar->val.s, name)))
+ tvp = &(tv->next);
+ }
+ if (tv) {
+ tv->tvar->type = type;
+ *tvp = tv->next;
+ mp = tv->tvar;
+ FREE(tv);
+ mp->refcount++;
+ if (debug>1) { fprintf(outf,"maketempvar revives %s\n", mp->name); }
+ } else {
+ tempvarcount = 0; /***/ /* experimental... */
+ for (;;) {
+ if (tempvarcount)
+ fullname = format_s(name, format_d("%d", tempvarcount));
+ else
+ fullname = format_s(name, "");
+ ++tempvarcount;
+ sym = findsymbol(fullname);
+ mp = sym->mbase;
+ while (mp && !mp->isactive)
+ mp = mp->snext;
+ if (!mp)
+ break;
+ if (debug>1) { fprintf(outf,"maketempvar rejects %s\n", fullname); }
+ }
+ mp = addmeaning(sym, MK_VAR);
+ mp->istemporary = 1;
+ mp->type = type;
+ mp->refcount = 1;
+ mp->val.s = stralloc(name);
+ if (debug>1) { fprintf(outf,"maketempvar creates %s\n", mp->name); }
+ }
+ return mp;
+}
+
+
+
+/* Make a temporary variable that will be freed at the end of this statement
+ (rather than at the end of the function) by default */
+
+Meaning *makestmttempvar(type, name)
+Type *type;
+char *name;
+{
+ struct tempvarlist *tv;
+ Meaning *tvar;
+
+ tvar = maketempvar(type, name);
+ tv = ALLOC(1, struct tempvarlist, tempvars);
+ tv->tvar = tvar;
+ tv->active = 1;
+ tv->next = stmttempvars;
+ stmttempvars = tv;
+ return tvar;
+}
+
+
+
+Meaning *markstmttemps()
+{
+ return (stmttempvars) ? stmttempvars->tvar : NULL;
+}
+
+
+void freestmttemps(mark)
+Meaning *mark;
+{
+ struct tempvarlist *tv;
+
+ while ((tv = stmttempvars) && tv->tvar != mark) {
+ if (tv->active)
+ freetempvar(tv->tvar);
+ stmttempvars = tv->next;
+ FREE(tv);
+ }
+}
+
+
+
+/* This temporary variable is no longer used */
+
+void freetempvar(tvar)
+Meaning *tvar;
+{
+ struct tempvarlist *tv;
+
+ if (debug>1) { fprintf(outf,"freetempvar frees %s\n", tvar->name); }
+ tv = stmttempvars;
+ while (tv && tv->tvar != tvar)
+ tv = tv->next;
+ if (tv)
+ tv->active = 0;
+ tv = ALLOC(1, struct tempvarlist, tempvars);
+ tv->tvar = tvar;
+ tv->next = tempvars;
+ tempvars = tv;
+}
+
+
+
+/* The code that used this temporary variable has been deleted */
+
+void canceltempvar(tvar)
+Meaning *tvar;
+{
+ if (debug>1) { fprintf(outf,"canceltempvar cancels %s\n", tvar->name); }
+ tvar->refcount--;
+ freetempvar(tvar);
+}
+
+
+
+
+
+
+
+
+/* End. */
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/dir.c b/MultiSource/Benchmarks/MallocBench/p2c/dir.c
new file mode 100644
index 00000000..82ec98ca
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/dir.c
@@ -0,0 +1,257 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define define_parameters
+#define PROTO_DIR_C
+#include "trans.h"
+
+
+/* This file is user-modifiable. It is the "directory" of C functions
+ for compiling in-line various Pascal library routines. */
+
+
+
+extern void setup_module_hp();
+extern void setup_module_cit();
+extern void setup_module_tanner();
+
+
+
+
+/* This function is called once when p2c is starting up, before
+ the p2crc file has been read.
+*/
+
+void init_dir()
+{
+
+
+}
+
+
+
+
+
+/* This function is called once when p2c is starting up, after
+ the p2crc file has been read.
+*/
+
+void setup_dir()
+{
+
+
+}
+
+
+
+
+
+/* This procedure is called after reading the import text for a module,
+ where "name" is the module name, in upper-case letters. Calls to
+ "addmeaning", "makestandardfunc", etc. will annotate the context of
+ the module. Note that this will be called if the module is searched,
+ even if it is never actually imported.
+*/
+
+#if 0
+Static void _setup(name, defn)
+char *name;
+int defn;
+{
+ /* this is a dummy procedure which may be called by setup_module */
+}
+#endif
+
+#define _setup(a,b)
+
+void setup_module(name, defn)
+char *name;
+int defn;
+{
+ if (!strcicmp(name, "SYSTEM"))
+ decl_builtins();
+#ifdef CUST1
+ CUST1(name, defn);
+#endif
+#ifdef CUST2
+ CUST2(name, defn);
+#endif
+#ifdef CUST3
+ CUST3(name, defn);
+#endif
+#ifdef CUST4
+ CUST4(name, defn);
+#endif
+#ifdef CUST5
+ CUST5(name, defn);
+#endif
+}
+
+
+
+
+
+/* This procedure is called once after the p2crc file has been
+ read and the built-in parameters have been "fixed". It should
+ check ranges and add defaults for any newly introduced parameters
+ in the "rctable" (see "trans.h").
+*/
+
+void fix_parameters()
+{
+
+
+}
+
+
+
+
+
+/* This function is called during a traversal of the tree of statements for
+ a procedure. Ordinarily it returns its argument; it may instead return
+ an arbitrary other statement or sequence of statements, which will then
+ be spliced in to replace the original one. It may return NULL to delete
+ the statement altogether.
+*/
+
+Stmt *fix_statement(sp)
+Stmt *sp;
+{
+ return sp;
+}
+
+
+
+
+
+/* This is the analogous function for expression traversals. It is
+ called after the arguments have been (recursively) fixed and all
+ built-in fixes have been performed.
+*/
+
+Expr *fix_expression(ex, env)
+Expr *ex;
+int env;
+{
+ return ex;
+}
+
+
+
+
+
+/* This procedure is called when fixing an expression of type
+ EK_BICALL. It is called before the arguments are fixed. If
+ it recognizes the BICALL, it should fix the arguments, then
+ return a (possibly modified) fixed expression, which may or
+ may not be a BICALL. That expression will then be sent to
+ fix_expression() as usual, but other standard fixes will not
+ automatically be performed on it. If the BICALL is not
+ recognized, the function should return NULL.
+*/
+
+Expr *fix_bicall(ex, env)
+Expr *ex;
+int env;
+{
+ return NULL;
+}
+
+
+
+
+
+/* This function returns nonzero if the built-in function "name"
+ should be written "if (f(x))" rather than "if (f(x) != 0)"
+ when used as a boolean. The call does *not* necessarily have
+ to return a 1-or-0 value.
+*/
+
+int boolean_bicall(name)
+char *name;
+{
+ return (!strcmp(name, "strcmp") ||
+ !strcmp(name, "strncmp") ||
+ !strcmp(name, "memcmp") ||
+ !strcmp(name, "feof") ||
+ !strcmp(name, "feoln"));
+}
+
+
+
+
+
+/* The function "name" promises not to change certain of its
+ VAR-style parameters. For each of arguments i = 0 through 15,
+ if bit 1<<i of the return value of this function is set, and
+ the i'th parameter is a pointer to an object, then the function
+ guarantees not to change that object.
+*/
+
+unsigned int safemask_bicall(name)
+char *name;
+{
+ Symbol *sp;
+
+ sp = findsymbol_opt(name);
+ if (sp) {
+ if (sp->flags & (STRUCTF|STRLAPF))
+ return ~1;
+ if (sp->flags & (NOSIDEEFF|DETERMF))
+ return ~0;
+ }
+ if (!strcmp(name, "fwrite") ||
+ !strcmp(name, "memchr"))
+ return 1;
+ if (!strcmp(name, "memcpy") ||
+ !strcmp(name, "memmove"))
+ return 2;
+ if (!strcmp(name, "memcmp"))
+ return 3;
+ if (!strcmp(name, "sprintf") ||
+ !strcmp(name, "fprintf"))
+ return ~1;
+ if (!strcmp(name, "printf"))
+ return ~0;
+ return 0;
+}
+
+
+
+
+
+/* The function "name" has side effects that could affect other variables
+ in the program besides those that are explicitly mentioned.
+*/
+
+int sideeffects_bicall(name)
+char *name;
+{
+ return 0;
+}
+
+
+
+
+
+
+/* End. */
+
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/expr.c b/MultiSource/Benchmarks/MallocBench/p2c/expr.c
new file mode 100644
index 00000000..4aabd75c
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/expr.c
@@ -0,0 +1,5574 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_EXPR_C
+#include "trans.h"
+
+
+
+
+
+void free_value(val)
+Value *val;
+{
+ if (!val || !val->type)
+ return;
+ switch (val->type->kind) {
+
+ case TK_STRING:
+ case TK_REAL:
+ case TK_ARRAY:
+ case TK_RECORD:
+ case TK_SET:
+ if (val->s)
+ FREE(val->s);
+ break;
+
+ default:
+ break;
+ }
+}
+
+
+Value copyvalue(val)
+Value val;
+{
+ char *cp;
+
+ switch (val.type->kind) {
+
+ case TK_STRING:
+ case TK_SET:
+ if (val.s) {
+ cp = ALLOC(val.i+1, char, literals);
+ memcpy(cp, val.s, val.i);
+ cp[val.i] = 0;
+ val.s = cp;
+ }
+ break;
+
+ case TK_REAL:
+ case TK_ARRAY:
+ case TK_RECORD:
+ if (val.s)
+ val.s = stralloc(val.s);
+ break;
+
+ default:
+ break;
+ }
+ return val;
+}
+
+
+int valuesame(a, b)
+Value a, b;
+{
+ if (a.type != b.type)
+ return 0;
+ switch (a.type->kind) {
+
+ case TK_INTEGER:
+ case TK_CHAR:
+ case TK_BOOLEAN:
+ case TK_ENUM:
+ case TK_SMALLSET:
+ case TK_SMALLARRAY:
+ return (a.i == b.i);
+
+ case TK_STRING:
+ case TK_SET:
+ return (a.i == b.i && !memcmp(a.s, b.s, a.i));
+
+ case TK_REAL:
+ case TK_ARRAY:
+ case TK_RECORD:
+ return (!strcmp(a.s, b.s));
+
+ default:
+ return 1;
+ }
+}
+
+
+
+char *value_name(val, intfmt, islong)
+Value val;
+char *intfmt;
+int islong;
+{
+ Meaning *mp;
+ Type *type = val.type;
+
+ if (type->kind == TK_SUBR)
+ type = type->basetype;
+ switch (type->kind) {
+
+ case TK_INTEGER:
+ case TK_SMALLSET:
+ case TK_SMALLARRAY:
+ if (!intfmt)
+ intfmt = "%ld";
+ if (*intfmt == '\'') {
+ if (val.i >= -'~' && val.i <= -' ') {
+ intfmt = format_s("-%s", intfmt);
+ val.i = -val.i;
+ }
+ if (val.i < ' ' || val.i > '~' || islong)
+ intfmt = "%ld";
+ }
+ if (islong)
+ intfmt = format_s("%sL", intfmt);
+ return format_d(intfmt, val.i);
+
+ case TK_REAL:
+ return val.s;
+
+ case TK_ARRAY: /* obsolete */
+ case TK_RECORD: /* obsolete */
+ return val.s;
+
+ case TK_STRING:
+ return makeCstring(val.s, val.i);
+
+ case TK_BOOLEAN:
+ if (!intfmt)
+ if (val.i == 1 && *name_TRUE &&
+ strcmp(name_TRUE, "1") && !islong)
+ intfmt = name_TRUE;
+ else if (val.i == 0 && *name_FALSE &&
+ strcmp(name_FALSE, "0") && !islong)
+ intfmt = name_FALSE;
+ else
+ intfmt = "%ld";
+ if (islong)
+ intfmt = format_s("%sL", intfmt);
+ return format_d(intfmt, val.i);
+
+ case TK_CHAR:
+ if (islong)
+ return format_d("%ldL", val.i);
+ else if ((val.i < 0 || val.i > 127) && highcharints)
+ return format_d("%ld", val.i);
+ else
+ return makeCchar(val.i);
+
+ case TK_POINTER:
+ return (*name_NULL) ? name_NULL : "NULL";
+
+ case TK_ENUM:
+ mp = val.type->fbase;
+ while (mp && mp->val.i != val.i)
+ mp = mp->xnext;
+ if (!mp) {
+ intwarning("value_name", "bad enum value [152]");
+ return format_d("%ld", val.i);
+ }
+ return mp->name;
+
+ default:
+ intwarning("value_name", format_s("bad type for constant: %s [153]",
+ typekindname(type->kind)));
+ return "<spam>";
+ }
+}
+
+
+
+
+Value value_cast(val, type)
+Value val;
+Type *type;
+{
+ char buf[20];
+
+ if (type->kind == TK_SUBR)
+ type = type->basetype;
+ if (val.type == type)
+ return val;
+ if (type && val.type) {
+ switch (type->kind) {
+
+ case TK_REAL:
+ if (ord_type(val.type)->kind == TK_INTEGER) {
+ sprintf(buf, "%d.0", val.i);
+ val.s = stralloc(buf);
+ val.type = tp_real;
+ return val;
+ }
+ break;
+
+ case TK_CHAR:
+ if (val.type->kind == TK_STRING) {
+ if (val.i != 1)
+ if (val.i > 0)
+ warning("Char constant with more than one character [154]");
+ else
+ warning("Empty char constant [155]");
+ val.i = val.s[0] & 0xff;
+ val.s = NULL;
+ val.type = tp_char;
+ return val;
+ }
+
+ case TK_POINTER:
+ if (val.type == tp_anyptr && castnull != 1) {
+ val.type = type;
+ return val;
+ }
+
+ default:
+ break;
+ }
+ }
+ val.type = NULL;
+ return val;
+}
+
+
+
+Type *ord_type(tp)
+Type *tp;
+{
+ if (!tp) {
+ warning("Expected a constant [127]");
+ return tp_integer;
+ }
+ switch (tp->kind) {
+
+ case TK_SUBR:
+ tp = tp->basetype;
+ break;
+
+ case TK_STRING:
+ if (!CHECKORDEXPR(tp->indextype->smax, 1))
+ tp = tp_char;
+ break;
+
+ default:
+ break;
+
+ }
+ return tp;
+}
+
+
+
+int long_type(tp)
+Type *tp;
+{
+ switch (tp->kind) {
+
+ case TK_INTEGER:
+ return (tp != tp_int && tp != tp_uint && tp != tp_sint);
+
+ case TK_SUBR:
+ return (findbasetype(tp, ODECL_NOPRES) == tp_integer);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+Value make_ord(type, i)
+Type *type;
+long i;
+{
+ Value val;
+
+ if (type->kind == TK_ENUM)
+ type = findbasetype(type, ODECL_NOPRES);
+ if (type->kind == TK_SUBR)
+ type = type->basetype;
+ val.type = type;
+ val.i = i;
+ val.s = NULL;
+ return val;
+}
+
+
+
+long ord_value(val)
+Value val;
+{
+ switch (val.type->kind) {
+
+ case TK_INTEGER:
+ case TK_ENUM:
+ case TK_CHAR:
+ case TK_BOOLEAN:
+ return val.i;
+
+ case TK_STRING:
+ if (val.i == 1)
+ return val.s[0] & 0xff;
+
+ /* fall through */
+ default:
+ warning("Expected an ordinal type [156]");
+ return 0;
+ }
+}
+
+
+
+void ord_range_expr(type, smin, smax)
+Type *type;
+Expr **smin, **smax;
+{
+ if (!type) {
+ warning("Expected a constant [127]");
+ type = tp_integer;
+ }
+ if (type->kind == TK_STRING)
+ type = tp_char;
+ switch (type->kind) {
+
+ case TK_SUBR:
+ case TK_INTEGER:
+ case TK_ENUM:
+ case TK_CHAR:
+ case TK_BOOLEAN:
+ if (smin) *smin = type->smin;
+ if (smax) *smax = type->smax;
+ break;
+
+ default:
+ warning("Expected an ordinal type [156]");
+ if (smin) *smin = makeexpr_long(0);
+ if (smax) *smax = makeexpr_long(1);
+ break;
+ }
+}
+
+
+int ord_range(type, smin, smax)
+Type *type;
+long *smin, *smax;
+{
+ Expr *emin, *emax;
+ Value vmin, vmax;
+
+ ord_range_expr(type, &emin, &emax);
+ if (smin) {
+ vmin = eval_expr(emin);
+ if (!vmin.type)
+ return 0;
+ }
+ if (smax) {
+ vmax = eval_expr(emax);
+ if (!vmax.type)
+ return 0;
+ }
+ if (smin) *smin = ord_value(vmin);
+ if (smax) *smax = ord_value(vmax);
+ return 1;
+}
+
+
+
+
+
+
+
+void freeexpr(ex)
+register Expr *ex;
+{
+ register int i;
+
+ if (ex) {
+ for (i = 0; i < ex->nargs; i++)
+ freeexpr(ex->args[i]);
+ switch (ex->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ free_value(&ex->val);
+ break;
+
+ case EK_DOT:
+ case EK_NAME:
+ case EK_BICALL:
+ if (ex->val.s)
+ FREE(ex->val.s);
+ break;
+
+ default:
+ break;
+ }
+ FREE(ex);
+ }
+}
+
+
+
+
+Expr *makeexpr(kind, n)
+enum exprkind kind;
+int n;
+{
+ Expr *ex;
+
+ ex = ALLOCV(sizeof(Expr) + (n-1)*sizeof(Expr *), Expr, exprs);
+ ex->val.i = 0;
+ ex->val.s = NULL;
+ ex->kind = kind;
+ ex->nargs = n;
+ return ex;
+}
+
+
+Expr *makeexpr_un(kind, type, arg1)
+enum exprkind kind;
+Type *type;
+Expr *arg1;
+{
+ Expr *ex;
+
+ ex = makeexpr(kind, 1);
+ ex->val.type = type;
+ ex->args[0] = arg1;
+ if (debug>2) { fprintf(outf,"makeexpr_un returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+Expr *makeexpr_bin(kind, type, arg1, arg2)
+enum exprkind kind;
+Type *type;
+Expr *arg1, *arg2;
+{
+ Expr *ex;
+
+ ex = makeexpr(kind, 2);
+ ex->val.type = type;
+ ex->args[0] = arg1;
+ ex->args[1] = arg2;
+ if (debug>2) { fprintf(outf,"makeexpr_bin returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+
+Expr *makeexpr_val(val)
+Value val;
+{
+ Expr *ex;
+
+ if (val.type->kind == TK_INTEGER &&
+ (val.i < -32767 || val.i > 32767) &&
+ sizeof_int < 32)
+ ex = makeexpr(EK_LONGCONST, 0);
+ else
+ ex = makeexpr(EK_CONST, 0);
+ ex->val = val;
+ if (debug>2) { fprintf(outf,"makeexpr_val returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+
+Expr *makeexpr_char(c)
+int c;
+{
+ return makeexpr_val(make_ord(tp_char, c));
+}
+
+
+Expr *makeexpr_long(i)
+long i;
+{
+ return makeexpr_val(make_ord(tp_integer, i));
+}
+
+
+Expr *makeexpr_real(r)
+char *r;
+{
+ Value val;
+
+ val.type = tp_real;
+ val.i = 0;
+ val.s = stralloc(r);
+ return makeexpr_val(val);
+}
+
+
+Expr *makeexpr_lstring(msg, len)
+char *msg;
+int len;
+{
+ Value val;
+
+ val.type = tp_str255;
+ val.i = len;
+ val.s = ALLOC(len+1, char, literals);
+ memcpy(val.s, msg, len);
+ val.s[len] = 0;
+ return makeexpr_val(val);
+}
+
+
+Expr *makeexpr_string(msg)
+char *msg;
+{
+ Value val;
+
+ val.type = tp_str255;
+ val.i = strlen(msg);
+ val.s = stralloc(msg);
+ return makeexpr_val(val);
+}
+
+
+int checkstring(ex, msg)
+Expr *ex;
+char *msg;
+{
+ if (!ex || ex->val.type->kind != TK_STRING || ex->kind != EK_CONST)
+ return 0;
+ if (ex->val.i != strlen(msg))
+ return 0;
+ return memcmp(ex->val.s, msg, ex->val.i) == 0;
+}
+
+
+
+Expr *makeexpr_var(mp)
+Meaning *mp;
+{
+ Expr *ex;
+
+ ex = makeexpr(EK_VAR, 0);
+ ex->val.i = (long) mp;
+ ex->val.type = mp->type;
+ if (debug>2) { fprintf(outf,"makeexpr_var returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+
+Expr *makeexpr_name(name, type)
+char *name;
+Type *type;
+{
+ Expr *ex;
+
+ ex = makeexpr(EK_NAME, 0);
+ ex->val.s = stralloc(name);
+ ex->val.type = type;
+ if (debug>2) { fprintf(outf,"makeexpr_name returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+
+Expr *makeexpr_setbits()
+{
+ if (*name_SETBITS)
+ return makeexpr_name(name_SETBITS, tp_integer);
+ else
+ return makeexpr_long(setbits);
+}
+
+
+
+/* Note: BICALL's to the following functions should obey the ANSI standard. */
+/* Non-ANSI transformations occur while writing the expression. */
+/* char *sprintf(buf, fmt, ...) [returns buf] */
+/* void *memcpy(dest, src, size) [returns dest] */
+
+Expr *makeexpr_bicall_0(name, type)
+char *name;
+Type *type;
+{
+ Expr *ex;
+
+ if (!name || !*name) {
+ intwarning("makeexpr_bicall_0", "Required name of built-in procedure is missing [157]");
+ name = "MissingProc";
+ }
+ ex = makeexpr(EK_BICALL, 0);
+ ex->val.s = stralloc(name);
+ ex->val.type = type;
+ if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+Expr *makeexpr_bicall_1(name, type, arg1)
+char *name;
+Type *type;
+Expr *arg1;
+{
+ Expr *ex;
+
+ if (!name || !*name) {
+ intwarning("makeexpr_bicall_1", "Required name of built-in procedure is missing [157]");
+ name = "MissingProc";
+ }
+ ex = makeexpr(EK_BICALL, 1);
+ ex->val.s = stralloc(name);
+ ex->val.type = type;
+ ex->args[0] = arg1;
+ if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+Expr *makeexpr_bicall_2(name, type, arg1, arg2)
+char *name;
+Type *type;
+Expr *arg1, *arg2;
+{
+ Expr *ex;
+
+ if (!name || !*name) {
+ intwarning("makeexpr_bicall_2", "Required name of built-in procedure is missing [157]");
+ name = "MissingProc";
+ }
+ ex = makeexpr(EK_BICALL, 2);
+ if (!strcmp(name, "~SETIO"))
+ name = (iocheck_flag) ? "~~SETIO" : name_SETIO;
+ ex->val.s = stralloc(name);
+ ex->val.type = type;
+ ex->args[0] = arg1;
+ ex->args[1] = arg2;
+ if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+Expr *makeexpr_bicall_3(name, type, arg1, arg2, arg3)
+char *name;
+Type *type;
+Expr *arg1, *arg2, *arg3;
+{
+ Expr *ex;
+
+ if (!name || !*name) {
+ intwarning("makeexpr_bicall_3", "Required name of built-in procedure is missing [157]");
+ name = "MissingProc";
+ }
+ ex = makeexpr(EK_BICALL, 3);
+ ex->val.s = stralloc(name);
+ ex->val.type = type;
+ ex->args[0] = arg1;
+ ex->args[1] = arg2;
+ ex->args[2] = arg3;
+ if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+Expr *makeexpr_bicall_4(name, type, arg1, arg2, arg3, arg4)
+char *name;
+Type *type;
+Expr *arg1, *arg2, *arg3, *arg4;
+{
+ Expr *ex;
+
+ if (!name || !*name) {
+ intwarning("makeexpr_bicall_4", "Required name of built-in procedure is missing [157]");
+ name = "MissingProc";
+ }
+ ex = makeexpr(EK_BICALL, 4);
+ if (!strcmp(name, "~CHKIO"))
+ name = (iocheck_flag) ? "~~CHKIO" : name_CHKIO;
+ ex->val.s = stralloc(name);
+ ex->val.type = type;
+ ex->args[0] = arg1;
+ ex->args[1] = arg2;
+ ex->args[2] = arg3;
+ ex->args[3] = arg4;
+ if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+Expr *makeexpr_bicall_5(name, type, arg1, arg2, arg3, arg4, arg5)
+char *name;
+Type *type;
+Expr *arg1, *arg2, *arg3, *arg4, *arg5;
+{
+ Expr *ex;
+
+ if (!name || !*name) {
+ intwarning("makeexpr_bicall_5", "Required name of built-in procedure is missing [157]");
+ name = "MissingProc";
+ }
+ ex = makeexpr(EK_BICALL, 5);
+ ex->val.s = stralloc(name);
+ ex->val.type = type;
+ ex->args[0] = arg1;
+ ex->args[1] = arg2;
+ ex->args[2] = arg3;
+ ex->args[3] = arg4;
+ ex->args[4] = arg5;
+ if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+
+
+Expr *copyexpr(ex)
+register Expr *ex;
+{
+ register int i;
+ register Expr *ex2;
+
+ if (ex) {
+ ex2 = makeexpr(ex->kind, ex->nargs);
+ for (i = 0; i < ex->nargs; i++)
+ ex2->args[i] = copyexpr(ex->args[i]);
+ switch (ex->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ ex2->val = copyvalue(ex->val);
+ break;
+
+ case EK_DOT:
+ case EK_NAME:
+ case EK_BICALL:
+ ex2->val.type = ex->val.type;
+ ex2->val.i = ex->val.i;
+ if (ex->val.s)
+ ex2->val.s = stralloc(ex->val.s);
+ break;
+
+ default:
+ ex2->val = ex->val;
+ break;
+ }
+ return ex2;
+ } else
+ return NULL;
+}
+
+
+
+int exprsame(a, b, strict)
+register Expr *a, *b;
+int strict;
+{
+ register int i;
+
+ if (!a)
+ return (!b);
+ if (!b)
+ return 0;
+ if (a->val.type != b->val.type && strict != 2) {
+ if (strict ||
+ !((a->val.type->kind == TK_POINTER &&
+ a->val.type->basetype == b->val.type) ||
+ (b->val.type->kind == TK_POINTER &&
+ b->val.type->basetype == a->val.type)))
+ return 0;
+ }
+ if (a->kind != b->kind || a->nargs != b->nargs)
+ return 0;
+ switch (a->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ if (!valuesame(a->val, b->val))
+ return 0;
+ break;
+
+ case EK_BICALL:
+ case EK_NAME:
+ if (strcmp(a->val.s, b->val.s))
+ return 0;
+ break;
+
+ case EK_VAR:
+ case EK_FUNCTION:
+ case EK_CTX:
+ case EK_MACARG:
+ if (a->val.i != b->val.i)
+ return 0;
+ break;
+
+ case EK_DOT:
+ if (a->val.i != b->val.i ||
+ (!a->val.i && strcmp(a->val.s, b->val.s)))
+ return 0;
+ break;
+
+ default:
+ break;
+ }
+ i = a->nargs;
+ while (--i >= 0)
+ if (!exprsame(a->args[i], b->args[i], (strict == 2) ? 1 : strict))
+ return 0;
+ return 1;
+}
+
+
+
+int exprequiv(a, b)
+register Expr *a, *b;
+{
+ register int i, j, k;
+ enum exprkind kind2;
+
+ if (!a)
+ return (!b);
+ if (!b)
+ return 0;
+ switch (a->kind) {
+
+ case EK_PLUS:
+ case EK_TIMES:
+ case EK_BAND:
+ case EK_BOR:
+ case EK_BXOR:
+ case EK_EQ:
+ case EK_NE:
+ if (b->kind != a->kind || b->nargs != a->nargs ||
+ b->val.type != a->val.type)
+ return 0;
+ if (a->nargs > 3)
+ break;
+ for (i = 0; i < b->nargs; i++) {
+ if (exprequiv(a->args[0], b->args[i])) {
+ for (j = 0; j < b->nargs; j++) {
+ if (j != i &&
+ exprequiv(a->args[1], b->args[i])) {
+ if (a->nargs == 2)
+ return 1;
+ for (k = 0; k < b->nargs; k++) {
+ if (k != i && k != j &&
+ exprequiv(a->args[2], b->args[k]))
+ return 1;
+ }
+ }
+ }
+ }
+ }
+ break;
+
+ case EK_LT:
+ case EK_GT:
+ case EK_LE:
+ case EK_GE:
+ switch (a->kind) {
+ case EK_LT: kind2 = EK_GT; break;
+ case EK_GT: kind2 = EK_LT; break;
+ case EK_LE: kind2 = EK_GE; break;
+ default: kind2 = EK_LE; break;
+ }
+ if (b->kind != kind2 || b->val.type != a->val.type)
+ break;
+ if (exprequiv(a->args[0], b->args[1]) &&
+ exprequiv(a->args[1], b->args[0])) {
+ return 1;
+ }
+ break;
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ case EK_BICALL:
+ case EK_NAME:
+ case EK_VAR:
+ case EK_FUNCTION:
+ case EK_CTX:
+ case EK_DOT:
+ return exprsame(a, b, 0);
+
+ default:
+ break;
+ }
+ if (b->kind != a->kind || b->nargs != a->nargs ||
+ b->val.type != a->val.type)
+ return 0;
+ i = a->nargs;
+ while (--i >= 0)
+ if (!exprequiv(a->args[i], b->args[i]))
+ return 0;
+ return 1;
+}
+
+
+
+void deletearg(ex, n)
+Expr **ex;
+register int n;
+{
+ register Expr *ex1 = *ex, *ex2;
+ register int i;
+
+ if (debug>2) { fprintf(outf,"deletearg("); dumpexpr(*ex); fprintf(outf,", %d)\n", n); }
+ if (n < 0 || n >= (*ex)->nargs) {
+ intwarning("deletearg", "argument number out of range [158]");
+ return;
+ }
+ ex2 = makeexpr(ex1->kind, ex1->nargs-1);
+ ex2->val = ex1->val;
+ for (i = 0; i < n; i++)
+ ex2->args[i] = ex1->args[i];
+ for (; i < ex2->nargs; i++)
+ ex2->args[i] = ex1->args[i+1];
+ *ex = ex2;
+ FREE(ex1);
+ if (debug>2) { fprintf(outf,"deletearg returns "); dumpexpr(*ex); fprintf(outf,"\n"); }
+}
+
+
+
+void insertarg(ex, n, arg)
+Expr **ex;
+Expr *arg;
+register int n;
+{
+ register Expr *ex1 = *ex, *ex2;
+ register int i;
+
+ if (debug>2) { fprintf(outf,"insertarg("); dumpexpr(*ex); fprintf(outf,", %d)\n", n); }
+ if (n < 0 || n > (*ex)->nargs) {
+ intwarning("insertarg", "argument number out of range [159]");
+ return;
+ }
+ ex2 = makeexpr(ex1->kind, ex1->nargs+1);
+ ex2->val = ex1->val;
+ for (i = 0; i < n; i++)
+ ex2->args[i] = ex1->args[i];
+ ex2->args[n] = arg;
+ for (; i < ex1->nargs; i++)
+ ex2->args[i+1] = ex1->args[i];
+ *ex = ex2;
+ FREE(ex1);
+ if (debug>2) { fprintf(outf,"insertarg returns "); dumpexpr(*ex); fprintf(outf,"\n"); }
+}
+
+
+
+Expr *grabarg(ex, n)
+Expr *ex;
+int n;
+{
+ Expr *ex2;
+
+ if (n < 0 || n >= ex->nargs) {
+ intwarning("grabarg", "argument number out of range [160]");
+ return ex;
+ }
+ ex2 = ex->args[n];
+ ex->args[n] = makeexpr_long(0); /* placeholder */
+ freeexpr(ex);
+ return ex2;
+}
+
+
+
+void delsimparg(ep, n)
+Expr **ep;
+int n;
+{
+ if (n < 0 || n >= (*ep)->nargs) {
+ intwarning("delsimparg", "argument number out of range [161]");
+ return;
+ }
+ deletearg(ep, n);
+ switch ((*ep)->kind) {
+
+ case EK_PLUS:
+ case EK_TIMES:
+ case EK_COMMA:
+ if ((*ep)->nargs == 1)
+ *ep = grabarg(*ep, 0);
+ break;
+
+ default:
+ break;
+
+ }
+}
+
+
+
+
+Expr *resimplify(ex)
+Expr *ex;
+{
+ Expr *ex2;
+ Type *type;
+ int i;
+
+ if (debug>2) { fprintf(outf,"resimplify("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (!ex)
+ return NULL;
+ type = ex->val.type;
+ switch (ex->kind) {
+
+ case EK_PLUS:
+ ex2 = ex->args[0];
+ for (i = 1; i < ex->nargs; i++)
+ ex2 = makeexpr_plus(ex2, ex->args[i]);
+ FREE(ex);
+ return ex2;
+
+ case EK_TIMES:
+ ex2 = ex->args[0];
+ for (i = 1; i < ex->nargs; i++)
+ ex2 = makeexpr_times(ex2, ex->args[i]);
+ FREE(ex);
+ return ex2;
+
+ case EK_NEG:
+ ex = makeexpr_neg(grabarg(ex, 0));
+ ex->val.type = type;
+ return ex;
+
+ case EK_NOT:
+ ex = makeexpr_not(grabarg(ex, 0));
+ ex->val.type = type;
+ return ex;
+
+ case EK_HAT:
+ ex = makeexpr_hat(grabarg(ex, 0), 0);
+ if (ex->kind == EK_HAT)
+ ex->val.type = type;
+ return ex;
+
+ case EK_ADDR:
+ ex = makeexpr_addr(grabarg(ex, 0));
+ ex->val.type = type;
+ return ex;
+
+ case EK_ASSIGN:
+ ex2 = makeexpr_assign(ex->args[0], ex->args[1]);
+ FREE(ex);
+ return ex2;
+
+ default:
+ break;
+ }
+ return ex;
+}
+
+
+
+
+
+
+int realzero(s)
+register char *s;
+{
+ if (*s == '-') s++;
+ while (*s == '0' || *s == '.') s++;
+ return (!isdigit(*s));
+}
+
+int realint(s, i)
+register char *s;
+int i;
+{
+ if (i == 0)
+ return realzero(s);
+ if (*s == '-') {
+ s++;
+ i = -i;
+ }
+ if (i < 0 || i > 9) return 0; /* we don't care about large values here */
+ while (*s == '0') s++;
+ if (*s++ != i + '0') return 0;
+ if (*s == '.')
+ while (*++s == '0') ;
+ return (!isdigit(*s));
+}
+
+
+int checkconst(ex, val)
+Expr *ex;
+long val;
+{
+ Meaning *mp;
+ Value exval;
+
+ if (!ex)
+ return 0;
+ if (ex->kind == EK_CAST || ex->kind == EK_ACTCAST)
+ ex = ex->args[0];
+ if (ex->kind == EK_CONST || ex->kind == EK_LONGCONST)
+ exval = ex->val;
+ else if (ex->kind == EK_VAR &&
+ (mp = (Meaning *)ex->val.i)->kind == MK_CONST &&
+ mp->val.type &&
+ foldconsts != 0)
+ exval = mp->val;
+ else
+ return 0;
+ switch (exval.type->kind) {
+
+ case TK_BOOLEAN:
+ case TK_INTEGER:
+ case TK_CHAR:
+ case TK_ENUM:
+ case TK_SUBR:
+ case TK_SMALLSET:
+ case TK_SMALLARRAY:
+ return exval.i == val;
+
+ case TK_POINTER:
+ case TK_STRING:
+ return (val == 0 && exval.i == 0);
+
+ case TK_REAL:
+ return realint(exval.s, val);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+int isliteralconst(ex, valp)
+Expr *ex;
+Value *valp;
+{
+ Meaning *mp;
+
+ if (ex) {
+ switch (ex->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ if (valp)
+ *valp = ex->val;
+ return 2;
+
+ case EK_VAR:
+ mp = (Meaning *)ex->val.i;
+ if (mp->kind == MK_CONST) {
+ if (valp) {
+ if (foldconsts == 0)
+ valp->type = NULL;
+ else
+ *valp = mp->val;
+ }
+ return 1;
+ }
+ break;
+
+ default:
+ break;
+ }
+ }
+ if (valp)
+ valp->type = NULL;
+ return 0;
+}
+
+
+
+int isconstexpr(ex, valp)
+Expr *ex;
+long *valp;
+{
+ Value exval;
+
+ if (debug>2) { fprintf(outf,"isconstexpr("); dumpexpr(ex); fprintf(outf,")\n"); }
+ exval = eval_expr(ex);
+ if (exval.type) {
+ if (valp)
+ *valp = exval.i;
+ return 1;
+ } else
+ return 0;
+}
+
+
+
+int isconstantexpr(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ int i;
+
+ switch (ex->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ case EK_SIZEOF:
+ return 1;
+
+ case EK_ADDR:
+ if (ex->args[0]->kind == EK_VAR) {
+ mp = (Meaning *)ex->val.i;
+ return (!mp->ctx || mp->ctx->kind == MK_MODULE);
+ }
+ return 0;
+
+ case EK_VAR:
+ mp = (Meaning *)ex->val.i;
+ return (mp->kind == MK_CONST);
+
+ case EK_BICALL:
+ case EK_FUNCTION:
+ if (!deterministic_func(ex))
+ return 0;
+
+ /* fall through */
+ case EK_EQ:
+ case EK_NE:
+ case EK_LT:
+ case EK_GT:
+ case EK_LE:
+ case EK_GE:
+ case EK_PLUS:
+ case EK_NEG:
+ case EK_TIMES:
+ case EK_DIVIDE:
+ case EK_DIV:
+ case EK_MOD:
+ case EK_AND:
+ case EK_OR:
+ case EK_NOT:
+ case EK_BAND:
+ case EK_BOR:
+ case EK_BXOR:
+ case EK_BNOT:
+ case EK_LSH:
+ case EK_RSH:
+ case EK_CAST:
+ case EK_ACTCAST:
+ case EK_COND:
+ for (i = 0; i < ex->nargs; i++) {
+ if (!isconstantexpr(ex->args[i]))
+ return 0;
+ }
+ return 1;
+
+ case EK_COMMA:
+ return isconstantexpr(ex->args[ex->nargs-1]);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+
+
+Static Expr *docast(a, type)
+Expr *a;
+Type *type;
+{
+ Value val;
+ Meaning *mp;
+ int i;
+ Expr *ex;
+
+ if (a->val.type->kind == TK_SMALLSET && type->kind == TK_SET) {
+ mp = makestmttempvar(type, name_SET);
+ return makeexpr_bicall_2(setexpandname, type,
+ makeexpr_var(mp),
+ makeexpr_arglong(a, 1));
+ } else if (a->val.type->kind == TK_SET && type->kind == TK_SMALLSET) {
+ return packset(a, type);
+ }
+ switch (a->kind) {
+
+ case EK_VAR:
+ mp = (Meaning *) a->val.i;
+ if (mp->kind == MK_CONST) {
+ if (mp->val.type && mp->val.type->kind == TK_STRING &&
+ type->kind == TK_CHAR) {
+ val = value_cast(mp->val, type);
+ a->kind = EK_CONST;
+ a->val = val;
+ return a;
+ }
+ }
+ break;
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ val = value_cast(a->val, type);
+ if (val.type) {
+ a->val = val;
+ return a;
+ }
+ break;
+
+ case EK_PLUS:
+ case EK_NEG:
+ case EK_TIMES:
+ if (type->kind == TK_REAL) {
+ for (i = 0; i < a->nargs; i++) {
+ ex = docast(a->args[i], type);
+ if (ex) {
+ a->args[i] = ex;
+ a->val.type = type;
+ return a;
+ }
+ }
+ }
+ break;
+
+ default:
+ break;
+ }
+ return NULL;
+}
+
+
+
+/* Make an "active" cast, i.e., one that performs an explicit operation */
+Expr *makeexpr_actcast(a, type)
+Expr *a;
+Type *type;
+{
+ if (debug>2) { fprintf(outf,"makeexpr_actcast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
+
+ if (similartypes(a->val.type, type)) {
+ a->val.type = type;
+ return a;
+ }
+ return makeexpr_un(EK_ACTCAST, type, a);
+}
+
+
+
+Expr *makeexpr_cast(a, type)
+Expr *a;
+Type *type;
+{
+ Expr *ex;
+
+ if (debug>2) { fprintf(outf,"makeexpr_cast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
+ if (a->val.type == type)
+ return a;
+ ex = docast(a, type);
+ if (ex)
+ return ex;
+ if (a->kind == EK_CAST &&
+ a->args[0]->val.type->kind == TK_POINTER &&
+ similartypes(type, a->args[0]->val.type)) {
+ a = grabarg(a, 0);
+ a->val.type = type;
+ return a;
+ }
+ if ((a->kind == EK_CAST &&
+ ((a->val.type->kind == TK_POINTER && type->kind == TK_POINTER) ||
+ (ord_type(a->val.type)->kind == TK_INTEGER && ord_type(type)->kind == TK_INTEGER))) ||
+ similartypes(type, a->val.type)) {
+ a->val.type = type;
+ return a;
+ }
+ return makeexpr_un(EK_CAST, type, a);
+}
+
+
+
+Expr *gentle_cast(a, type)
+Expr *a;
+Type *type;
+{
+ Expr *ex;
+ Type *btype;
+ long smin, smax;
+ Value val;
+ char c;
+
+ if (debug>2) { fprintf(outf,"gentle_cast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
+ if (!type) {
+ intwarning("gentle_cast", "type == NULL");
+ return a;
+ }
+ if (a->val.type->kind == TK_POINTER && type->kind == TK_POINTER) {
+ if (voidstar && (type == tp_anyptr || a->val.type == tp_anyptr)) {
+ if (type == tp_anyptr && a->kind == EK_CAST &&
+ a->args[0]->val.type->kind == TK_POINTER)
+ return a->args[0]; /* remove explicit cast since casting implicitly */
+ return a; /* casting to/from "void *" */
+ }
+ return makeexpr_cast(a, type);
+ }
+ if (type->kind == TK_STRING)
+ return makeexpr_stringify(a);
+ if (type->kind == TK_ARRAY &&
+ (a->val.type->kind == TK_STRING ||
+ a->val.type->kind == TK_CHAR) &&
+ isliteralconst(a, &val) && val.type &&
+ ord_range(type->indextype, &smin, &smax)) {
+ smax = smax - smin + 1;
+ if (a->val.type->kind == TK_CHAR) {
+ val.s = &c;
+ c = val.i;
+ val.i = 1;
+ }
+ if (val.i > smax) {
+ warning("Too many characters for packed array of char [162]");
+ } else if (val.i < smax || a->val.type->kind == TK_CHAR) {
+ ex = makeexpr_lstring(val.s, smax);
+ while (smax > val.i)
+ ex->val.s[--smax] = ' ';
+ freeexpr(a);
+ return ex;
+ }
+ }
+ btype = (type->kind == TK_SUBR) ? type->basetype : type;
+ if ((a->kind == EK_CAST || a->kind == EK_ACTCAST) &&
+ btype->kind == TK_INTEGER &&
+ ord_type(a->val.type)->kind == TK_INTEGER)
+ return makeexpr_longcast(a, long_type(type));
+ if (a->val.type == btype)
+ return a;
+ ex = docast(a, btype);
+ if (ex)
+ return ex;
+ if (btype->kind == TK_CHAR && a->val.type->kind == TK_STRING)
+ return makeexpr_hat(a, 0);
+ return a;
+}
+
+
+
+Expr *makeexpr_charcast(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING &&
+ ex->val.i == 1) {
+ ex->val.type = tp_char;
+ ex->val.i = ex->val.s[0] & 0xff;
+ ex->val.s = NULL;
+ }
+ if (ex->kind == EK_VAR &&
+ (mp = (Meaning *)ex->val.i)->kind == MK_CONST &&
+ mp->val.type &&
+ mp->val.type->kind == TK_STRING &&
+ mp->val.i == 1) {
+ ex->kind = EK_CONST;
+ ex->val.type = tp_char;
+ ex->val.i = mp->val.s[0] & 0xff;
+ ex->val.s = NULL;
+ }
+ return ex;
+}
+
+
+
+Expr *makeexpr_stringcast(ex)
+Expr *ex;
+{
+ char ch;
+
+ if (ex->kind == EK_CONST && ord_type(ex->val.type)->kind == TK_CHAR) {
+ ch = ex->val.i;
+ freeexpr(ex);
+ ex = makeexpr_lstring(&ch, 1);
+ }
+ return ex;
+}
+
+
+
+
+
+/* 0/1 = force to int/long, 2/3 = check if int/long */
+
+Static Expr *dolongcast(a, tolong)
+Expr *a;
+int tolong;
+{
+ Meaning *mp;
+ Expr *ex;
+ Type *type;
+ int i;
+
+ switch (a->kind) {
+
+ case EK_DOT:
+ if (!a->val.i) {
+ if (long_type(a->val.type) == (tolong&1))
+ return a;
+ break;
+ }
+
+ /* fall through */
+ case EK_VAR:
+ mp = (Meaning *)a->val.i;
+ if (mp->kind == MK_FIELD && mp->val.i) {
+ if (mp->val.i <= ((sizeof_int > 0) ? sizeof_int : 16) &&
+ !(tolong&1))
+ return a;
+ } else if (mp->kind == MK_VAR ||
+ mp->kind == MK_VARREF ||
+ mp->kind == MK_PARAM ||
+ mp->kind == MK_VARPARAM ||
+ mp->kind == MK_FIELD) {
+ if (long_type(mp->type) == (tolong&1))
+ return a;
+ }
+ break;
+
+ case EK_FUNCTION:
+ mp = (Meaning *)a->val.i;
+ if (long_type(mp->type->basetype) == (tolong&1))
+ return a;
+ break;
+
+ case EK_BICALL:
+ if (!strcmp(a->val.s, signextname) && *signextname) {
+ i = 0;
+ goto unary;
+ }
+ if (!strcmp(a->val.s, "strlen"))
+ goto size_t_case;
+ /* fall through */
+
+ case EK_HAT: /* get true type from a->val.type */
+ case EK_INDEX:
+ case EK_SPCALL:
+ case EK_NAME:
+ if (long_type(a->val.type) == (tolong&1))
+ return a;
+ break;
+
+ case EK_ASSIGN: /* destination determines type, */
+ case EK_POSTINC: /* but must not be changed */
+ case EK_POSTDEC:
+ return dolongcast(a->args[0], tolong|2);
+
+ case EK_CAST:
+ if (ord_type(a->val.type)->kind == TK_INTEGER &&
+ long_type(a->val.type) == (tolong&1))
+ return a;
+ if (tolong == 0) {
+ a->val.type = tp_int;
+ return a;
+ } else if (tolong == 1) {
+ a->val.type = tp_integer;
+ return a;
+ }
+ break;
+
+ case EK_ACTCAST:
+ if (ord_type(a->val.type)->kind == TK_INTEGER &&
+ long_type(a->val.type) == (tolong&1))
+ return a;
+ break;
+
+ case EK_CONST:
+ type = ord_type(a->val.type);
+ if (type->kind == TK_INTEGER || type->kind == TK_SMALLSET) {
+ if (tolong == 1)
+ a->kind = EK_LONGCONST;
+ if (tolong != 3)
+ return a;
+ }
+ break;
+
+ case EK_LONGCONST:
+ if (tolong == 0) {
+ if (a->val.i >= -32767 && a->val.i <= 32767)
+ a->kind = EK_CONST;
+ else
+ return NULL;
+ }
+ if (tolong != 2)
+ return a;
+ break;
+
+ case EK_SIZEOF:
+ size_t_case:
+ if (size_t_long > 0 && tolong&1)
+ return a;
+ if (size_t_long == 0 && !(tolong&1))
+ return a;
+ break;
+
+ case EK_PLUS: /* usual arithmetic conversions apply */
+ case EK_TIMES:
+ case EK_DIV:
+ case EK_MOD:
+ case EK_BAND:
+ case EK_BOR:
+ case EK_BXOR:
+ case EK_COND:
+ i = (a->kind == EK_COND) ? 1 : 0;
+ if (tolong&1) {
+ for (; i < a->nargs; i++) {
+ ex = dolongcast(a->args[i], tolong);
+ if (ex) {
+ a->args[i] = ex;
+ return a;
+ }
+ }
+ } else {
+ for (; i < a->nargs; i++) {
+ if (!dolongcast(a->args[i], tolong))
+ return NULL;
+ }
+ return a;
+ }
+ break;
+
+ case EK_BNOT: /* single argument defines result type */
+ case EK_NEG:
+ case EK_LSH:
+ case EK_RSH:
+ case EK_COMMA:
+ i = (a->kind == EK_COMMA) ? a->nargs-1 : 0;
+unary:
+ if (tolong&1) {
+ ex = dolongcast(a->args[i], tolong);
+ if (ex) {
+ a->args[i] = ex;
+ return a;
+ }
+ } else {
+ if (dolongcast(a->args[i], tolong))
+ return a;
+ }
+ break;
+
+ case EK_AND: /* operators which always return int */
+ case EK_OR:
+ case EK_EQ:
+ case EK_NE:
+ case EK_LT:
+ case EK_GT:
+ case EK_LE:
+ case EK_GE:
+ if (tolong&1)
+ break;
+ return a;
+
+ default:
+ break;
+ }
+ return NULL;
+}
+
+
+/* Return -1 if short int or plain int, 1 if long, 0 if can't tell */
+int exprlongness(ex)
+Expr *ex;
+{
+ if (sizeof_int >= 32)
+ return -1;
+ return (dolongcast(ex, 3) != NULL) -
+ (dolongcast(ex, 2) != NULL);
+}
+
+
+Expr *makeexpr_longcast(a, tolong)
+Expr *a;
+int tolong;
+{
+ Expr *ex;
+ Type *type;
+
+ if (sizeof_int >= 32)
+ return a;
+ type = ord_type(a->val.type);
+ if (type->kind != TK_INTEGER && type->kind != TK_SMALLSET)
+ return a;
+ a = makeexpr_unlongcast(a);
+ if (tolong) {
+ ex = dolongcast(a, 1);
+ } else {
+ ex = dolongcast(copyexpr(a), 0);
+ if (ex) {
+ if (!dolongcast(ex, 2)) {
+ freeexpr(ex);
+ ex = NULL;
+ }
+ }
+ }
+ if (ex)
+ return ex;
+ return makeexpr_un(EK_CAST, (tolong) ? tp_integer : tp_int, a);
+}
+
+
+Expr *makeexpr_arglong(a, tolong)
+Expr *a;
+int tolong;
+{
+ int cast = castlongargs;
+ if (cast < 0)
+ cast = castargs;
+ if (cast > 0 || (cast < 0 && prototypes == 0)) {
+ return makeexpr_longcast(a, tolong);
+ }
+ return a;
+}
+
+
+
+Expr *makeexpr_unlongcast(a)
+Expr *a;
+{
+ switch (a->kind) {
+
+ case EK_LONGCONST:
+ if (a->val.i >= -32767 && a->val.i <= 32767)
+ a->kind = EK_CONST;
+ break;
+
+ case EK_CAST:
+ if ((a->val.type == tp_integer ||
+ a->val.type == tp_int) &&
+ ord_type(a->args[0]->val.type)->kind == TK_INTEGER) {
+ a = grabarg(a, 0);
+ }
+ break;
+
+ default:
+ break;
+
+ }
+ return a;
+}
+
+
+
+Expr *makeexpr_forcelongness(a) /* force a to have a definite longness */
+Expr *a;
+{
+ Expr *ex;
+
+ ex = makeexpr_unlongcast(copyexpr(a));
+ if (exprlongness(ex)) {
+ freeexpr(a);
+ return ex;
+ }
+ freeexpr(ex);
+ if (exprlongness(a) == 0)
+ return makeexpr_longcast(a, 1);
+ else
+ return a;
+}
+
+
+
+Expr *makeexpr_ord(ex)
+Expr *ex;
+{
+ ex = makeexpr_charcast(ex);
+ switch (ord_type(ex->val.type)->kind) {
+
+ case TK_ENUM:
+ return makeexpr_cast(ex, tp_int);
+
+ case TK_CHAR:
+ if (ex->kind == EK_CONST &&
+ (ex->val.i >= 32 && ex->val.i < 127)) {
+ insertarg(&ex, 0, makeexpr_name("'%lc'", tp_integer));
+ }
+ ex->val.type = tp_int;
+ return ex;
+
+ case TK_BOOLEAN:
+ ex->val.type = tp_int;
+ return ex;
+
+ case TK_POINTER:
+ return makeexpr_cast(ex, tp_integer);
+
+ default:
+ return ex;
+ }
+}
+
+
+
+
+/* Tell whether an expression "looks" negative */
+int expr_looks_neg(ex)
+Expr *ex;
+{
+ int i;
+
+ switch (ex->kind) {
+
+ case EK_NEG:
+ return 1;
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ switch (ord_type(ex->val.type)->kind) {
+ case TK_INTEGER:
+ case TK_CHAR:
+ return (ex->val.i < 0);
+ case TK_REAL:
+ return (ex->val.s && ex->val.s[0] == '-');
+ default:
+ return 0;
+ }
+
+ case EK_TIMES:
+ case EK_DIVIDE:
+ for (i = 0; i < ex->nargs; i++) {
+ if (expr_looks_neg(ex->args[i]))
+ return 1;
+ }
+ return 0;
+
+ case EK_CAST:
+ return expr_looks_neg(ex->args[0]);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+/* Tell whether an expression is probably negative */
+int expr_is_neg(ex)
+Expr *ex;
+{
+ int i;
+
+ i = possiblesigns(ex) & (1|4);
+ if (i == 1)
+ return 1; /* if expression really is negative! */
+ if (i == 4)
+ return 0; /* if expression is definitely positive. */
+ return expr_looks_neg(ex);
+}
+
+
+
+int expr_neg_cost(a)
+Expr *a;
+{
+ int i, c;
+
+ switch (a->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ switch (ord_type(a->val.type)->kind) {
+ case TK_INTEGER:
+ case TK_CHAR:
+ case TK_REAL:
+ return 0;
+ default:
+ return 1;
+ }
+
+ case EK_NEG:
+ return -1;
+
+ case EK_TIMES:
+ case EK_DIVIDE:
+ for (i = 0; i < a->nargs; i++) {
+ c = expr_neg_cost(a->args[i]);
+ if (c <= 0)
+ return c;
+ }
+ return 1;
+
+ case EK_PLUS:
+ for (i = 0; i < a->nargs; i++) {
+ if (expr_looks_neg(a->args[i]))
+ return 0;
+ }
+ return 1;
+
+ default:
+ return 1;
+ }
+}
+
+
+
+Expr *enum_to_int(a)
+Expr *a;
+{
+ if (ord_type(a->val.type)->kind == TK_ENUM) {
+ if (a->kind == EK_CAST &&
+ ord_type(a->args[0]->val.type)->kind == TK_INTEGER)
+ return grabarg(a, 0);
+ else
+ return makeexpr_cast(a, tp_integer);
+ } else
+ return a;
+}
+
+
+
+Expr *neg_inside_sum(a)
+Expr *a;
+{
+ int i;
+
+ for (i = 0; i < a->nargs; i++)
+ a->args[i] = makeexpr_neg(a->args[i]);
+ return a;
+}
+
+
+
+Expr *makeexpr_neg(a)
+Expr *a;
+{
+ int i;
+
+ if (debug>2) { fprintf(outf,"makeexpr_neg("); dumpexpr(a); fprintf(outf,")\n"); }
+ a = enum_to_int(a);
+ switch (a->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ switch (ord_type(a->val.type)->kind) {
+
+ case TK_INTEGER:
+ case TK_CHAR:
+ if (a->val.i == MININT)
+ valrange();
+ else
+ a->val.i = - a->val.i;
+ return a;
+
+ case TK_REAL:
+ if (!realzero(a->val.s)) {
+ if (a->val.s[0] == '-')
+ strchange(&a->val.s, a->val.s+1);
+ else
+ strchange(&a->val.s, format_s("-%s", a->val.s));
+ }
+ return a;
+
+ default:
+ break;
+ }
+ break;
+
+ case EK_PLUS:
+ if (expr_neg_cost(a) <= 0)
+ return neg_inside_sum(a);
+ break;
+
+ case EK_TIMES:
+ case EK_DIVIDE:
+ for (i = 0; i < a->nargs; i++) {
+ if (expr_neg_cost(a->args[i]) <= 0) {
+ a->args[i] = makeexpr_neg(a->args[i]);
+ return a;
+ }
+ }
+ break;
+
+ case EK_CAST:
+ if (a->val.type != tp_unsigned &&
+ a->val.type != tp_uint &&
+ a->val.type != tp_ushort &&
+ a->val.type != tp_ubyte &&
+ a->args[0]->val.type != tp_unsigned &&
+ a->args[0]->val.type != tp_uint &&
+ a->args[0]->val.type != tp_ushort &&
+ a->args[0]->val.type != tp_ubyte &&
+ expr_looks_neg(a->args[0])) {
+ a->args[0] = makeexpr_neg(a->args[0]);
+ return a;
+ }
+ break;
+
+ case EK_NEG:
+ return grabarg(a, 0);
+
+ default:
+ break;
+ }
+ return makeexpr_un(EK_NEG, promote_type(a->val.type), a);
+}
+
+
+
+
+#define ISCONST(kind) ((kind)==EK_CONST || (kind)==EK_LONGCONST)
+#define MOVCONST(ex) (ISCONST((ex)->kind) && (ex)->val.type->kind != TK_STRING)
+#define COMMUTATIVE (kind != EK_COMMA && type->kind != TK_REAL)
+
+Type *true_type(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ Type *type, *tp;
+
+ while (ex->kind == EK_CAST)
+ ex = ex->args[0];
+ type = ex->val.type;
+ if (ex->kind == EK_VAR || ex->kind == EK_FUNCTION || ex->kind == EK_DOT) {
+ mp = (Meaning *)ex->val.i;
+ if (mp && mp->type && mp->type->kind != TK_VOID)
+ type = mp->type;
+ }
+ if (ex->kind == EK_INDEX) {
+ tp = true_type(ex->args[0]);
+ if ((tp->kind == TK_ARRAY || tp->kind == TK_SMALLARRAY ||
+ tp->kind == TK_STRING) &&
+ tp->basetype && tp->basetype->kind != TK_VOID)
+ type = tp->basetype;
+ }
+ if (type->kind == TK_SUBR)
+ type = findbasetype(type, ODECL_NOPRES);
+ return type;
+}
+
+int ischartype(ex)
+Expr *ex;
+{
+ if (ord_type(ex->val.type)->kind == TK_CHAR)
+ return 1;
+ if (true_type(ex)->kind == TK_CHAR)
+ return 1;
+ if (ISCONST(ex->kind) && ex->nargs > 0 &&
+ ex->args[0]->kind == EK_NAME &&
+ ex->args[0]->val.s[0] == '\'')
+ return 1;
+ return 0;
+}
+
+Static Expr *commute(a, b, kind)
+Expr *a, *b;
+enum exprkind kind;
+{
+ int i, di;
+ Type *type;
+
+ if (debug>2) { fprintf(outf,"commute("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+#if 1
+ type = promote_type_bin(a->val.type, b->val.type);
+#else
+ type = a->val.type;
+ if (b->val.type->kind == TK_REAL)
+ type = b->val.type;
+#endif
+ if (MOVCONST(a) && !MOVCONST(b) && COMMUTATIVE)
+ swapexprs(a, b); /* put constant last */
+ if (a->kind == kind) {
+ di = (MOVCONST(a->args[a->nargs-1]) && COMMUTATIVE) ? -1 : 0;
+ if (b->kind == kind) {
+ for (i = 0; i < b->nargs; i++)
+ insertarg(&a, a->nargs + di, b->args[i]);
+ FREE(b);
+ } else
+ insertarg(&a, a->nargs + di, b);
+ a->val.type = type;
+ } else if (b->kind == kind) {
+ if (MOVCONST(a) && COMMUTATIVE)
+ insertarg(&b, b->nargs, a);
+ else
+ insertarg(&b, 0, a);
+ a = b;
+ a->val.type = type;
+ } else {
+ a = makeexpr_bin(kind, type, a, b);
+ }
+ if (debug>2) { fprintf(outf,"commute returns "); dumpexpr(a); fprintf(outf,"\n"); }
+ return a;
+}
+
+
+Expr *makeexpr_plus(a, b)
+Expr *a, *b;
+{
+ int i, j, k, castdouble = 0;
+ Type *type;
+
+ if (debug>2) { fprintf(outf,"makeexpr_plus("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+ if (!a)
+ return b;
+ if (!b)
+ return a;
+ if (a->kind == EK_NEG && a->args[0]->kind == EK_PLUS)
+ a = neg_inside_sum(grabarg(a, 0));
+ if (b->kind == EK_NEG && b->args[0]->kind == EK_PLUS)
+ b = neg_inside_sum(grabarg(b, 0));
+ a = commute(enum_to_int(a), enum_to_int(b), EK_PLUS);
+ type = NULL;
+ for (i = 0; i < a->nargs; i++) {
+ if (ord_type(a->args[i]->val.type)->kind == TK_CHAR ||
+ a->args[i]->val.type->kind == TK_POINTER ||
+ a->args[i]->val.type->kind == TK_STRING) { /* for string literals */
+ if (type == ord_type(a->args[i]->val.type))
+ type = tp_integer; /* 'z'-'a' and p1-p2 are integers */
+ else
+ type = ord_type(a->args[i]->val.type);
+ }
+ }
+ if (type)
+ a->val.type = type;
+ for (i = 0; i < a->nargs && !ISCONST(a->args[i]->kind); i++) ;
+ if (i < a->nargs-1) {
+ for (j = i+1; j < a->nargs; j++) {
+ if (ISCONST(a->args[j]->kind)) {
+ if ((ord_type(a->args[i]->val.type) == ord_type(a->args[j]->val.type) ||
+ ord_type(a->args[i]->val.type)->kind == TK_INTEGER ||
+ ord_type(a->args[j]->val.type)->kind == TK_INTEGER) &&
+ (!(ischartype(a->args[i]) || ischartype(a->args[j])) ||
+ a->args[i]->val.i == - a->args[j]->val.i ||
+ a->args[i]->val.i == 0 || a->args[j]->val.i == 0) &&
+ (a->args[i]->val.type->kind != TK_REAL &&
+ a->args[i]->val.type->kind != TK_STRING &&
+ a->args[j]->val.type->kind != TK_REAL &&
+ a->args[j]->val.type->kind != TK_STRING)) {
+ a->args[i]->val.i += a->args[j]->val.i;
+ delfreearg(&a, j);
+ j--;
+ } else if (a->args[i]->val.type->kind == TK_STRING &&
+ ord_type(a->args[j]->val.type)->kind == TK_INTEGER &&
+ a->args[j]->val.i < 0 &&
+ a->args[j]->val.i >= -stringleaders) {
+ /* strictly speaking, the following is illegal pointer arithmetic */
+ a->args[i] = makeexpr_lstring(a->args[i]->val.s + a->args[j]->val.i,
+ a->args[i]->val.i - a->args[j]->val.i);
+ for (k = 0; k < - a->args[j]->val.i; k++)
+ a->args[i]->val.s[k] = '>';
+ delfreearg(&a, j);
+ j--;
+ }
+ }
+ }
+ }
+ if (checkconst(a->args[a->nargs-1], 0)) {
+ if (a->args[a->nargs-1]->val.type->kind == TK_REAL &&
+ a->args[0]->val.type->kind != TK_REAL)
+ castdouble = 1;
+ delfreearg(&a, a->nargs-1);
+ }
+ for (i = 0; i < a->nargs; i++) {
+ if (a->args[i]->kind == EK_NEG && nosideeffects(a->args[i], 1)) {
+ for (j = 0; j < a->nargs; j++) {
+ if (exprsame(a->args[j], a->args[i]->args[0], 1)) {
+ delfreearg(&a, i);
+ if (i < j) j--; else i--;
+ delfreearg(&a, j);
+ i--;
+ break;
+ }
+ }
+ }
+ }
+ if (a->nargs == 0) {
+ type = a->val.type;
+ FREE(a);
+ a = gentle_cast(makeexpr_long(0), type);
+ a->val.type = type;
+ return a;
+ } else if (a->nargs == 1) {
+ b = a->args[0];
+ FREE(a);
+ a = b;
+ } else {
+ if (a->nargs == 2 && ISCONST(a->args[1]->kind) &&
+ a->args[1]->val.i <= -127 &&
+ true_type(a->args[0]) == tp_char && signedchars != 0) {
+ a->args[0] = force_unsigned(a->args[0]);
+ }
+ if (a->nargs > 2 &&
+ ISCONST(a->args[a->nargs-1]->kind) &&
+ ISCONST(a->args[a->nargs-2]->kind) &&
+ ischartype(a->args[a->nargs-1]) &&
+ ischartype(a->args[a->nargs-2])) {
+ i = a->args[a->nargs-1]->val.i;
+ j = a->args[a->nargs-2]->val.i;
+ if ((i == 'a' || i == 'A' || i == -'a' || i == -'A') &&
+ (j == 'a' || j == 'A' || j == -'a' || j == -'A')) {
+ if (abs(i+j) == 32) {
+ delfreearg(&a, a->nargs-1);
+ delsimpfreearg(&a, a->nargs-1);
+ a = makeexpr_bicall_1((i+j > 0) ? "_tolower" : "_toupper",
+ tp_char, a);
+ }
+ }
+ }
+ }
+ if (castdouble)
+ a = makeexpr_cast(a, tp_real);
+ return a;
+}
+
+
+Expr *makeexpr_minus(a, b)
+Expr *a, *b;
+{
+ int okneg;
+
+ if (debug>2) { fprintf(outf,"makeexpr_minus("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+ if (ISCONST(b->kind) && b->val.i == 0 && /* kludge for array indexing */
+ ord_type(b->val.type)->kind == TK_ENUM) {
+ b->val.type = tp_integer;
+ }
+ okneg = (a->kind != EK_PLUS && b->kind != EK_PLUS);
+ a = makeexpr_plus(a, makeexpr_neg(b));
+ if (okneg && a->kind == EK_PLUS)
+ a->val.i = 1; /* this flag says to write as "a-b" if possible */
+ return a;
+}
+
+
+Expr *makeexpr_inc(a, b)
+Expr *a, *b;
+{
+ Type *type;
+
+ type = a->val.type;
+ a = makeexpr_plus(makeexpr_charcast(a), b);
+ if (ord_type(type)->kind != TK_INTEGER &&
+ ord_type(type)->kind != TK_CHAR)
+ a = makeexpr_cast(a, type);
+ return a;
+}
+
+
+
+/* Apply the distributive law for a sum of products */
+Expr *distribute_plus(ex)
+Expr *ex;
+{
+ int i, j, icom;
+ Expr *common, *outer, *ex2, **exp;
+
+ if (debug>2) { fprintf(outf,"distribute_plus("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (ex->kind != EK_PLUS)
+ return ex;
+ for (i = 0; i < ex->nargs; i++)
+ if (ex->args[i]->kind == EK_TIMES)
+ break;
+ if (i == ex->nargs)
+ return ex;
+ outer = NULL;
+ icom = 0;
+ for (;;) {
+ ex2 = ex->args[0];
+ if (ex2->kind == EK_NEG)
+ ex2 = ex2->args[0];
+ if (ex2->kind == EK_TIMES) {
+ if (icom >= ex2->nargs)
+ break;
+ common = ex2->args[icom];
+ if (common->kind == EK_NEG)
+ common = common->args[0];
+ } else {
+ if (icom > 0)
+ break;
+ common = ex2;
+ icom++;
+ }
+ for (i = 1; i < ex->nargs; i++) {
+ ex2 = ex->args[i];
+ if (ex2->kind == EK_NEG)
+ ex2 = ex2->args[i];
+ if (ex2->kind == EK_TIMES) {
+ for (j = ex2->nargs; --j >= 0; ) {
+ if (exprsame(ex2->args[j], common, 1) ||
+ (ex2->args[j]->kind == EK_NEG &&
+ exprsame(ex2->args[j]->args[0], common, 1)))
+ break;
+ }
+ if (j < 0)
+ break;
+ } else {
+ if (!exprsame(ex2, common, 1))
+ break;
+ }
+ }
+ if (i == ex->nargs) {
+ if (debug>2) { fprintf(outf,"distribute_plus does "); dumpexpr(common); fprintf(outf,"\n"); }
+ common = copyexpr(common);
+ for (i = 0; i < ex->nargs; i++) {
+ if (ex->args[i]->kind == EK_NEG)
+ ex2 = *(exp = &ex->args[i]->args[0]);
+ else
+ ex2 = *(exp = &ex->args[i]);
+ if (ex2->kind == EK_TIMES) {
+ for (j = ex2->nargs; --j >= 0; ) {
+ if (exprsame(ex2->args[j], common, 1)) {
+ delsimpfreearg(exp, j);
+ break;
+ } else if (ex2->args[j]->kind == EK_NEG &&
+ exprsame(ex2->args[j]->args[0], common,1)) {
+ freeexpr(ex2->args[j]);
+ ex2->args[j] = makeexpr_long(-1);
+ break;
+ }
+ }
+ } else {
+ freeexpr(ex2);
+ *exp = makeexpr_long(1);
+ }
+ ex->args[i] = resimplify(ex->args[i]);
+ }
+ outer = makeexpr_times(common, outer);
+ } else
+ icom++;
+ }
+ return makeexpr_times(resimplify(ex), outer);
+}
+
+
+
+
+
+Expr *makeexpr_times(a, b)
+Expr *a, *b;
+{
+ int i, n, castdouble = 0;
+ Type *type;
+
+ if (debug>2) { fprintf(outf,"makeexpr_times("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+ if (!a)
+ return b;
+ if (!b)
+ return a;
+ a = commute(a, b, EK_TIMES);
+ if (a->val.type->kind == TK_INTEGER) {
+ i = a->nargs-1;
+ if (i > 0 && ISCONST(a->args[i-1]->kind)) {
+ a->args[i-1]->val.i *= a->args[i]->val.i;
+ delfreearg(&a, i);
+ }
+ }
+ for (i = n = 0; i < a->nargs; i++) {
+ if (expr_neg_cost(a->args[i]) < 0)
+ n++;
+ }
+ if (n & 1) {
+ for (i = 0; i < a->nargs; i++) {
+ if (ISCONST(a->args[i]->kind) &&
+ expr_neg_cost(a->args[i]) >= 0) {
+ a->args[i] = makeexpr_neg(a->args[i]);
+ n++;
+ break;
+ }
+ }
+ } else
+ n++;
+ for (i = 0; i < a->nargs && n >= 2; i++) {
+ if (expr_neg_cost(a->args[i]) < 0) {
+ a->args[i] = makeexpr_neg(a->args[i]);
+ n--;
+ }
+ }
+ if (checkconst(a->args[a->nargs-1], 1)) {
+ if (a->args[a->nargs-1]->val.type->kind == TK_REAL &&
+ a->args[0]->val.type->kind != TK_REAL)
+ castdouble = 1;
+ delfreearg(&a, a->nargs-1);
+ } else if (checkconst(a->args[a->nargs-1], -1)) {
+ if (a->args[a->nargs-1]->val.type->kind == TK_REAL &&
+ a->args[0]->val.type->kind != TK_REAL)
+ castdouble = 1;
+ delfreearg(&a, a->nargs-1);
+ a->args[0] = makeexpr_neg(a->args[0]);
+ } else if (checkconst(a->args[a->nargs-1], 0) && nosideeffects(a, 1)) {
+ if (a->args[a->nargs-1]->val.type->kind == TK_REAL)
+ type = a->args[a->nargs-1]->val.type;
+ else
+ type = a->val.type;
+ return makeexpr_cast(grabarg(a, a->nargs-1), type);
+ }
+ if (a->nargs < 2) {
+ if (a->nargs < 1) {
+ FREE(a);
+ a = makeexpr_long(1);
+ } else {
+ b = a->args[0];
+ FREE(a);
+ a = b;
+ }
+ }
+ if (castdouble)
+ a = makeexpr_cast(a, tp_real);
+ return a;
+}
+
+
+
+Expr *makeexpr_sqr(ex, cube)
+Expr *ex;
+int cube;
+{
+ Expr *ex2;
+ Meaning *tvar;
+ Type *type;
+
+ if (exprspeed(ex) <= 2 && nosideeffects(ex, 0)) {
+ ex2 = NULL;
+ } else {
+ type = (ex->val.type->kind == TK_REAL) ? tp_longreal : tp_integer;
+ tvar = makestmttempvar(type, name_TEMP);
+ ex2 = makeexpr_assign(makeexpr_var(tvar), ex);
+ ex = makeexpr_var(tvar);
+ }
+ if (cube)
+ ex = makeexpr_times(ex, makeexpr_times(copyexpr(ex), copyexpr(ex)));
+ else
+ ex = makeexpr_times(ex, copyexpr(ex));
+ return makeexpr_comma(ex2, ex);
+}
+
+
+
+Expr *makeexpr_divide(a, b)
+Expr *a, *b;
+{
+ Expr *ex;
+ int p;
+
+ if (debug>2) { fprintf(outf,"makeexpr_divide("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+ if (a->val.type->kind != TK_REAL &&
+ b->val.type->kind != TK_REAL) { /* must do a real division */
+ ex = docast(a, tp_longreal);
+ if (ex)
+ a = ex;
+ else {
+ ex = docast(b, tp_longreal);
+ if (ex)
+ b = ex;
+ else
+ a = makeexpr_cast(a, tp_longreal);
+ }
+ }
+ if (a->kind == EK_TIMES) {
+ for (p = 0; p < a->nargs; p++)
+ if (exprsame(a->args[p], b, 1))
+ break;
+ if (p < a->nargs) {
+ delfreearg(&a, p);
+ freeexpr(b);
+ if (a->nargs == 1)
+ return grabarg(a, 0);
+ else
+ return a;
+ }
+ }
+ if (expr_neg_cost(a) < 0 && expr_neg_cost(b) < 0) {
+ a = makeexpr_neg(a);
+ b = makeexpr_neg(b);
+ }
+ if (checkconst(b, 0))
+ warning("Division by zero [163]");
+ return makeexpr_bin(EK_DIVIDE, tp_longreal, a, b);
+}
+
+
+
+
+int gcd(a, b)
+int a, b;
+{
+ if (a < 0) a = -a;
+ if (b < 0) b = -b;
+ while (a != 0) {
+ b %= a;
+ if (b != 0)
+ a %= b;
+ else
+ return a;
+ }
+ return b;
+}
+
+
+
+/* possible signs of ex: 1=may be neg, 2=may be zero, 4=may be pos */
+
+int negsigns(mask)
+int mask;
+{
+ return (mask & 2) |
+ ((mask & 1) << 2) |
+ ((mask & 4) >> 2);
+}
+
+
+int possiblesigns(ex)
+Expr *ex;
+{
+ Value val;
+ Type *tp;
+ char *cp;
+ int i, mask, mask2;
+
+ if (isliteralconst(ex, &val) && val.type) {
+ if (val.type == tp_real || val.type == tp_longreal) {
+ if (realzero(val.s))
+ return 2;
+ if (*val.s == '-')
+ return 1;
+ return 4;
+ } else
+ return (val.i < 0) ? 1 : (val.i == 0) ? 2 : 4;
+ }
+ if (ex->kind == EK_CAST &&
+ similartypes(ex->val.type, ex->args[0]->val.type))
+ return possiblesigns(ex->args[0]);
+ if (ex->kind == EK_NEG)
+ return negsigns(possiblesigns(ex->args[0]));
+ if (ex->kind == EK_TIMES || ex->kind == EK_DIVIDE) {
+ mask = possiblesigns(ex->args[0]);
+ for (i = 1; i < ex->nargs; i++) {
+ mask2 = possiblesigns(ex->args[i]);
+ if (mask2 & 2)
+ mask |= 2;
+ if ((mask2 & (1|4)) == 1)
+ mask = negsigns(mask);
+ else if ((mask2 & (1|4)) != 4)
+ mask = 1|2|4;
+ }
+ return mask;
+ }
+ if (ex->kind == EK_DIV || ex->kind == EK_MOD) {
+ mask = possiblesigns(ex->args[0]);
+ mask2 = possiblesigns(ex->args[1]);
+ if (!((mask | mask2) & 1))
+ return 2|4;
+ }
+ if (ex->kind == EK_PLUS) {
+ mask = 0;
+ for (i = 0; i < ex->nargs; i++) {
+ mask2 = possiblesigns(ex->args[i]);
+ if ((mask & negsigns(mask2)) & (1|4))
+ mask |= (1|2|4);
+ else
+ mask |= mask2;
+ }
+ return mask;
+ }
+ if (ex->kind == EK_COND) {
+ return possiblesigns(ex->args[1]) | possiblesigns(ex->args[2]);
+ }
+ if (ex->kind == EK_EQ || ex->kind == EK_LT || ex->kind == EK_GT ||
+ ex->kind == EK_NE || ex->kind == EK_LE || ex->kind == EK_GE ||
+ ex->kind == EK_AND || ex->kind == EK_OR || ex->kind == EK_NOT)
+ return 2|4;
+ if (ex->kind == EK_BICALL) {
+ cp = ex->val.s;
+ if (!strcmp(cp, "strlen") ||
+ !strcmp(cp, "abs") ||
+ !strcmp(cp, "labs") ||
+ !strcmp(cp, "fabs"))
+ return 2|4;
+ }
+ tp = (ex->kind == EK_VAR) ? ((Meaning *)ex->val.i)->type : ex->val.type;
+ if (ord_range(ex->val.type, &val.i, NULL)) {
+ if (val.i > 0)
+ return 4;
+ if (val.i >= 0)
+ return 2|4;
+ }
+ if (ord_range(ex->val.type, NULL, &val.i)) {
+ if (val.i < 0)
+ return 1;
+ if (val.i <= 0)
+ return 1|2;
+ }
+ return 1|2|4;
+}
+
+
+
+
+
+Expr *dodivmod(funcname, ekind, a, b)
+char *funcname;
+enum exprkind ekind;
+Expr *a, *b;
+{
+ Meaning *tvar;
+ Type *type;
+ Expr *asn;
+ int sa, sb;
+
+ type = promote_type_bin(a->val.type, b->val.type);
+ tvar = NULL;
+ sa = possiblesigns(a);
+ sb = possiblesigns(b);
+ if ((sa & 1) || (sb & 1)) {
+ if (*funcname) {
+ asn = NULL;
+ if (*funcname == '*') {
+ if (exprspeed(a) >= 5 || !nosideeffects(a, 0)) {
+ tvar = makestmttempvar(a->val.type, name_TEMP);
+ asn = makeexpr_assign(makeexpr_var(tvar), a);
+ a = makeexpr_var(tvar);
+ }
+ if (exprspeed(b) >= 5 || !nosideeffects(b, 0)) {
+ tvar = makestmttempvar(b->val.type, name_TEMP);
+ asn = makeexpr_comma(asn,
+ makeexpr_assign(makeexpr_var(tvar),
+ b));
+ b = makeexpr_var(tvar);
+ }
+ }
+ return makeexpr_comma(asn,
+ makeexpr_bicall_2(funcname, type, a, b));
+ } else {
+ if ((sa & 1) && (ekind == EK_MOD))
+ note("Using % for possibly-negative arguments [317]");
+ return makeexpr_bin(ekind, type, a, b);
+ }
+ } else
+ return makeexpr_bin(ekind, type, a, b);
+}
+
+
+
+Expr *makeexpr_div(a, b)
+Expr *a, *b;
+{
+ Meaning *mp;
+ Type *type;
+ long i;
+ int p;
+
+ if (ISCONST(a->kind) && ISCONST(b->kind)) {
+ if (a->val.i >= 0 && b->val.i > 0) {
+ a->val.i /= b->val.i;
+ freeexpr(b);
+ return a;
+ }
+ i = gcd(a->val.i, b->val.i);
+ if (i >= 0) {
+ a->val.i /= i;
+ b->val.i /= i;
+ }
+ }
+ if (((b->kind == EK_CONST && (i = b->val.i)) ||
+ (b->kind == EK_VAR && (mp = (Meaning *)b->val.i)->kind == MK_CONST &&
+ mp->val.type && (i = mp->val.i) && foldconsts != 0)) && i > 0) {
+ if (i == 1)
+ return a;
+ if (div_po2 > 0) {
+ p = 0;
+ while (!(i&1))
+ p++, i >>= 1;
+ if (i == 1) {
+ type = promote_type_bin(a->val.type, b->val.type);
+ return makeexpr_bin(EK_RSH, type, a, makeexpr_long(p));
+ }
+ }
+ }
+ if (a->kind == EK_TIMES) {
+ for (p = 0; p < a->nargs; p++) {
+ if (exprsame(a->args[p], b, 1)) {
+ delfreearg(&a, p);
+ freeexpr(b);
+ if (a->nargs == 1)
+ return grabarg(a, 0);
+ else
+ return a;
+ } else if (ISCONST(a->args[p]->kind) && ISCONST(b->kind)) {
+ i = gcd(a->args[p]->val.i, b->val.i);
+ if (i > 1) {
+ a->args[p]->val.i /= i;
+ b->val.i /= i;
+ i = a->args[p]->val.i;
+ delfreearg(&a, p);
+ a = makeexpr_times(a, makeexpr_long(i)); /* resimplify */
+ p = -1; /* start the loop over */
+ }
+ }
+ }
+ }
+ if (checkconst(b, 1)) {
+ freeexpr(b);
+ return a;
+ } else if (checkconst(b, -1)) {
+ freeexpr(b);
+ return makeexpr_neg(a);
+ } else {
+ if (checkconst(b, 0))
+ warning("Division by zero [163]");
+ return dodivmod(divname, EK_DIV, a, b);
+ }
+}
+
+
+
+Expr *makeexpr_mod(a, b)
+Expr *a, *b;
+{
+ Meaning *mp;
+ Type *type;
+ long i;
+
+ if (a->kind == EK_CONST && b->kind == EK_CONST &&
+ a->val.i >= 0 && b->val.i > 0) {
+ a->val.i %= b->val.i;
+ freeexpr(b);
+ return a;
+ }
+ if (((b->kind == EK_CONST && (i = b->val.i)) ||
+ (b->kind == EK_VAR && (mp = (Meaning *)b->val.i)->kind == MK_CONST &&
+ mp->val.type && (i = mp->val.i) && foldconsts != 0)) && i > 0) {
+ if (i == 1)
+ return makeexpr_long(0);
+ if (mod_po2 != 0) {
+ while (!(i&1))
+ i >>= 1;
+ if (i == 1) {
+ type = promote_type_bin(a->val.type, b->val.type);
+ return makeexpr_bin(EK_BAND, type, a,
+ makeexpr_minus(b, makeexpr_long(1)));
+ }
+ }
+ }
+ if (checkconst(b, 0))
+ warning("Division by zero [163]");
+ return dodivmod(modname, EK_MOD, a, b);
+}
+
+
+
+Expr *makeexpr_rem(a, b)
+Expr *a, *b;
+{
+ if (!(possiblesigns(a) & 1) && !(possiblesigns(b) & 1))
+ return makeexpr_mod(a, b);
+ if (checkconst(b, 0))
+ warning("Division by zero [163]");
+ if (!*remname)
+ note("Translating REM same as MOD [141]");
+ return dodivmod(*remname ? remname : modname, EK_MOD, a, b);
+}
+
+
+
+
+
+int expr_not_cost(a)
+Expr *a;
+{
+ int i, c;
+
+ switch (a->kind) {
+
+ case EK_CONST:
+ return 0;
+
+ case EK_NOT:
+ return -1;
+
+ case EK_EQ:
+ case EK_NE:
+ case EK_LT:
+ case EK_GT:
+ case EK_LE:
+ case EK_GE:
+ return 0;
+
+ case EK_AND:
+ case EK_OR:
+ c = 0;
+ for (i = 0; i < a->nargs; i++)
+ c += expr_not_cost(a->args[i]);
+ return (c > 1) ? 1 : c;
+
+ case EK_BICALL:
+ if (!strcmp(a->val.s, oddname) ||
+ !strcmp(a->val.s, evenname))
+ return 0;
+ return 1;
+
+ default:
+ return 1;
+ }
+}
+
+
+
+Expr *makeexpr_not(a)
+Expr *a;
+{
+ Expr *ex;
+ int i;
+
+ if (debug>2) { fprintf(outf,"makeexpr_not("); dumpexpr(a); fprintf(outf,")\n"); }
+ switch (a->kind) {
+
+ case EK_CONST:
+ if (a->val.type == tp_boolean) {
+ a->val.i = !a->val.i;
+ return a;
+ }
+ break;
+
+ case EK_EQ:
+ a->kind = EK_NE;
+ return a;
+
+ case EK_NE:
+ a->kind = EK_EQ;
+ return a;
+
+ case EK_LT:
+ a->kind = EK_GE;
+ return a;
+
+ case EK_GT:
+ a->kind = EK_LE;
+ return a;
+
+ case EK_LE:
+ a->kind = EK_GT;
+ return a;
+
+ case EK_GE:
+ a->kind = EK_LT;
+ return a;
+
+ case EK_AND:
+ case EK_OR:
+ if (expr_not_cost(a) > 0)
+ break;
+ a->kind = (a->kind == EK_OR) ? EK_AND : EK_OR;
+ for (i = 0; i < a->nargs; i++)
+ a->args[i] = makeexpr_not(a->args[i]);
+ return a;
+
+ case EK_NOT:
+ ex = a->args[0];
+ FREE(a);
+ ex->val.type = tp_boolean;
+ return ex;
+
+ case EK_BICALL:
+ if (!strcmp(a->val.s, oddname) && *evenname) {
+ strchange(&a->val.s, evenname);
+ return a;
+ } else if (!strcmp(a->val.s, evenname)) {
+ strchange(&a->val.s, oddname);
+ return a;
+ }
+ break;
+
+ default:
+ break;
+ }
+ return makeexpr_un(EK_NOT, tp_boolean, a);
+}
+
+
+
+
+Type *mixsets(ep1, ep2)
+Expr **ep1, **ep2;
+{
+ Expr *ex1 = *ep1, *ex2 = *ep2;
+ Meaning *tvar;
+ long min1, max1, min2, max2;
+ Type *type;
+
+ if (ex1->val.type->kind == TK_SMALLSET &&
+ ex2->val.type->kind == TK_SMALLSET)
+ return ex1->val.type;
+ if (ex1->val.type->kind == TK_SMALLSET) {
+ tvar = makestmttempvar(ex2->val.type, name_SET);
+ ex1 = makeexpr_bicall_2(setexpandname, ex2->val.type,
+ makeexpr_var(tvar),
+ makeexpr_arglong(ex1, 1));
+ }
+ if (ex2->val.type->kind == TK_SMALLSET) {
+ tvar = makestmttempvar(ex1->val.type, name_SET);
+ ex2 = makeexpr_bicall_2(setexpandname, ex1->val.type,
+ makeexpr_var(tvar),
+ makeexpr_arglong(ex2, 1));
+ }
+ if (ord_range(ex1->val.type->indextype, &min1, &max1) &&
+ ord_range(ex2->val.type->indextype, &min2, &max2)) {
+ if (min1 <= min2 && max1 >= max2)
+ type = ex1->val.type;
+ else if (min2 <= min1 && max2 >= max1)
+ type = ex2->val.type;
+ else {
+ if (min2 < min1) min1 = min2;
+ if (max2 > max1) max1 = max2;
+ type = maketype(TK_SET);
+ type->basetype = tp_integer;
+ type->indextype = maketype(TK_SUBR);
+ type->indextype->basetype = ord_type(ex1->val.type->indextype);
+ type->indextype->smin = makeexpr_long(min1);
+ type->indextype->smax = makeexpr_long(max1);
+ }
+ } else
+ type = ex1->val.type;
+ *ep1 = ex1, *ep2 = ex2;
+ return type;
+}
+
+
+
+Meaning *istempprocptr(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ if (debug>2) { fprintf(outf,"istempprocptr("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (ex->kind == EK_COMMA && ex->nargs == 3) {
+ if ((mp = istempvar(ex->args[2])) != NULL &&
+ mp->type->kind == TK_PROCPTR &&
+ ex->args[0]->kind == EK_ASSIGN &&
+ ex->args[0]->args[0]->kind == EK_DOT &&
+ exprsame(ex->args[0]->args[0]->args[0], ex->args[2], 1) &&
+ ex->args[1]->kind == EK_ASSIGN &&
+ ex->args[1]->args[0]->kind == EK_DOT &&
+ exprsame(ex->args[1]->args[0]->args[0], ex->args[2], 1))
+ return mp;
+ }
+ if (ex->kind == EK_COMMA && ex->nargs == 2) {
+ if ((mp = istempvar(ex->args[1])) != NULL &&
+ mp->type->kind == TK_CPROCPTR &&
+ ex->args[0]->kind == EK_ASSIGN &&
+ exprsame(ex->args[0]->args[0], ex->args[1], 1))
+ return mp;
+ }
+ return NULL;
+}
+
+
+
+
+Expr *makeexpr_stringify(ex)
+Expr *ex;
+{
+ ex = makeexpr_stringcast(ex);
+ if (ex->val.type->kind == TK_STRING)
+ return ex;
+ return makeexpr_sprintfify(ex);
+}
+
+
+
+Expr *makeexpr_rel(rel, a, b)
+enum exprkind rel;
+Expr *a, *b;
+{
+ int i, sign;
+ Expr *ex, *ex2;
+ Meaning *mp;
+ char *name;
+
+ if (debug>2) { fprintf(outf,"makeexpr_rel(%s,", exprkindname(rel)); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+
+ a = makeexpr_unlongcast(a);
+ b = makeexpr_unlongcast(b);
+ if ((compenums == 0 || (compenums < 0 && ansiC <= 0)) &&
+ (rel != EK_EQ && rel != EK_NE)){
+ a = enum_to_int(a);
+ b = enum_to_int(b);
+ }
+ if (a->val.type != b->val.type) {
+ if (a->val.type->kind == TK_STRING &&
+ a->kind != EK_CONST) {
+ b = makeexpr_stringify(b);
+ } else if (b->val.type->kind == TK_STRING &&
+ b->kind != EK_CONST) {
+ a = makeexpr_stringify(a);
+ } else if (ord_type(a->val.type)->kind == TK_CHAR ||
+ a->val.type->kind == TK_ARRAY) {
+ b = gentle_cast(b, ord_type(a->val.type));
+ } else if (ord_type(b->val.type)->kind == TK_CHAR ||
+ b->val.type->kind == TK_ARRAY) {
+ a = gentle_cast(a, ord_type(b->val.type));
+ } else if (a->val.type == tp_anyptr && !voidstar) {
+ a = gentle_cast(a, b->val.type);
+ } else if (b->val.type == tp_anyptr && !voidstar) {
+ b = gentle_cast(b, a->val.type);
+ }
+ }
+ if (useisspace && b->val.type->kind == TK_CHAR && checkconst(b, ' ')) {
+ if (rel == EK_EQ) {
+ freeexpr(b);
+ return makeexpr_bicall_1("isspace", tp_boolean, a);
+ } else if (rel == EK_NE) {
+ freeexpr(b);
+ return makeexpr_not(makeexpr_bicall_1("isspace", tp_boolean, a));
+ }
+ }
+ if (rel == EK_LT || rel == EK_GE)
+ sign = 1;
+ else if (rel == EK_GT || rel == EK_LE)
+ sign = -1;
+ else
+ sign = 0;
+ if (ord_type(b->val.type)->kind == TK_INTEGER ||
+ ord_type(b->val.type)->kind == TK_CHAR) {
+ for (;;) {
+ if (a->kind == EK_PLUS && ISCONST(a->args[a->nargs-1]->kind) &&
+ a->args[a->nargs-1]->val.i &&
+ (ISCONST(b->kind) ||
+ (b->kind == EK_PLUS && ISCONST(b->args[b->nargs-1]->kind)))) {
+ b = makeexpr_minus(b, copyexpr(a->args[a->nargs-1]));
+ a = makeexpr_minus(a, copyexpr(a->args[a->nargs-1]));
+ continue;
+ }
+ if (b->kind == EK_PLUS && ISCONST(b->args[b->nargs-1]->kind) &&
+ b->args[b->nargs-1]->val.i &&
+ ISCONST(a->kind)) {
+ a = makeexpr_minus(a, copyexpr(b->args[b->nargs-1]));
+ b = makeexpr_minus(b, copyexpr(b->args[b->nargs-1]));
+ continue;
+ }
+ if (b->kind == EK_PLUS && sign &&
+ ISCONST(b->args[b->nargs-1]->kind) &&
+ checkconst(b->args[b->nargs-1], sign)) {
+ b = makeexpr_plus(b, makeexpr_long(-sign));
+ switch (rel) {
+ case EK_LT:
+ rel = EK_LE;
+ break;
+ case EK_GT:
+ rel = EK_GE;
+ break;
+ case EK_LE:
+ rel = EK_LT;
+ break;
+ case EK_GE:
+ rel = EK_GT;
+ break;
+ default:
+ break;
+ }
+ sign = -sign;
+ continue;
+ }
+ if (a->kind == EK_TIMES && checkconst(b, 0) && !sign) {
+ for (i = 0; i < a->nargs; i++) {
+ if (ISCONST(a->args[i]->kind) && a->args[i]->val.i)
+ break;
+ if (a->args[i]->kind == EK_SIZEOF)
+ break;
+ }
+ if (i < a->nargs) {
+ delfreearg(&a, i);
+ continue;
+ }
+ }
+ break;
+ }
+ if (a->kind == EK_BICALL && !strcmp(a->val.s, "strlen") &&
+ checkconst(b, 0)) {
+ if (rel == EK_LT || rel == EK_GE) {
+ note("Unusual use of STRLEN encountered [142]");
+ } else {
+ freeexpr(b);
+ a = makeexpr_hat(grabarg(a, 0), 0);
+ b = makeexpr_char(0); /* "strlen(a) = 0" => "*a == 0" */
+ if (rel == EK_EQ || rel == EK_LE)
+ return makeexpr_rel(EK_EQ, a, b);
+ else
+ return makeexpr_rel(EK_NE, a, b);
+ }
+ }
+ if (ISCONST(a->kind) && ISCONST(b->kind)) {
+ if ((a->val.i == b->val.i && (rel == EK_EQ || rel == EK_GE || rel == EK_LE)) ||
+ (a->val.i < b->val.i && (rel == EK_NE || rel == EK_LE || rel == EK_LT)) ||
+ (a->val.i > b->val.i && (rel == EK_NE || rel == EK_GE || rel == EK_GT)))
+ return makeexpr_val(make_ord(tp_boolean, 1));
+ else
+ return makeexpr_val(make_ord(tp_boolean, 0));
+ }
+ if ((a->val.type == tp_char || true_type(a) == tp_char) &&
+ ISCONST(b->kind) && signedchars != 0) {
+ i = (b->val.i == 128 && sign == 1) ||
+ (b->val.i == 127 && sign == -1);
+ if (highcharbits && (highcharbits > 0 || signedchars < 0) && i) {
+ if (highcharbits == 2)
+ b = makeexpr_long(128);
+ else
+ b = makeexpr_un(EK_BNOT, tp_integer, makeexpr_long(127));
+ return makeexpr_rel((rel == EK_GE || rel == EK_GT)
+ ? EK_NE : EK_EQ,
+ makeexpr_bin(EK_BAND, tp_integer,
+ eatcasts(a), b),
+ makeexpr_long(0));
+ } else if (signedchars == 1 && i) {
+ return makeexpr_rel((rel == EK_GE || rel == EK_GT)
+ ? EK_LT : EK_GE,
+ eatcasts(a), makeexpr_long(0));
+ } else if (signedchars == 1 && b->val.i >= 128 && sign == 0) {
+ b->val.i -= 256;
+ } else if (b->val.i >= 128 ||
+ (b->val.i == 127 && sign != 0)) {
+ if (highcharbits && (highcharbits > 0 || signedchars < 0))
+ a = makeexpr_bin(EK_BAND, a->val.type, eatcasts(a),
+ makeexpr_long(255));
+ else
+ a = force_unsigned(a);
+ }
+ }
+ } else if (a->val.type->kind == TK_STRING &&
+ b->val.type->kind == TK_STRING) {
+ if (b->kind == EK_CONST && b->val.i == 0 && !sign) {
+ a = makeexpr_hat(a, 0);
+ b = makeexpr_char(0); /* "a = ''" => "*a == 0" */
+ } else {
+ a = makeexpr_bicall_2("strcmp", tp_int, a, b);
+ b = makeexpr_long(0);
+ }
+ } else if ((a->val.type->kind == TK_ARRAY ||
+ a->val.type->kind == TK_STRING ||
+ a->val.type->kind == TK_RECORD) &&
+ (b->val.type->kind == TK_ARRAY ||
+ b->val.type->kind == TK_STRING ||
+ b->val.type->kind == TK_RECORD)) {
+ if (a->val.type->kind == TK_ARRAY) {
+ if (b->val.type->kind == TK_ARRAY) {
+ ex = makeexpr_sizeof(copyexpr(a), 0);
+ ex2 = makeexpr_sizeof(copyexpr(b), 0);
+ if (!exprsame(ex, ex2, 1))
+ warning("Incompatible array sizes [164]");
+ freeexpr(ex2);
+ } else {
+ ex = makeexpr_sizeof(copyexpr(a), 0);
+ }
+ } else
+ ex = makeexpr_sizeof(copyexpr(b), 0);
+ name = (usestrncmp &&
+ a->val.type->kind == TK_ARRAY &&
+ a->val.type->basetype->kind == TK_CHAR) ? "strncmp" : "memcmp";
+ a = makeexpr_bicall_3(name, tp_int,
+ makeexpr_addr(a),
+ makeexpr_addr(b), ex);
+ b = makeexpr_long(0);
+ } else if (a->val.type->kind == TK_SET ||
+ a->val.type->kind == TK_SMALLSET) {
+ if (rel == EK_GE) {
+ swapexprs(a, b);
+ rel = EK_LE;
+ }
+ if (mixsets(&a, &b)->kind == TK_SMALLSET) {
+ if (rel == EK_LE) {
+ a = makeexpr_bin(EK_BAND, tp_integer,
+ a, makeexpr_un(EK_BNOT, tp_integer, b));
+ b = makeexpr_long(0);
+ rel = EK_EQ;
+ }
+ } else if (b->kind == EK_BICALL &&
+ !strcmp(b->val.s, setexpandname) &&
+ (mp = istempvar(b->args[0])) != NULL &&
+ checkconst(b->args[1], 0)) {
+ canceltempvar(mp);
+ a = makeexpr_hat(a, 0);
+ b = grabarg(b, 1);
+ if (rel == EK_LE)
+ rel = EK_EQ;
+ } else {
+ ex = makeexpr_bicall_2((rel == EK_LE) ? subsetname : setequalname,
+ tp_boolean, a, b);
+ return (rel == EK_NE) ? makeexpr_not(ex) : ex;
+ }
+ } else if (a->val.type->kind == TK_PROCPTR ||
+ a->val.type->kind == TK_CPROCPTR) {
+ /* we compare proc only (not link) -- same as Pascal compiler! */
+ if (a->val.type->kind == TK_PROCPTR)
+ a = makeexpr_dotq(a, "proc", tp_anyptr);
+ if ((mp = istempprocptr(b)) != NULL) {
+ canceltempvar(mp);
+ b = grabarg(grabarg(b, 0), 1);
+ if (!voidstar)
+ b = makeexpr_cast(b, tp_anyptr);
+ } else if (b->val.type->kind == TK_PROCPTR)
+ b = makeexpr_dotq(b, "proc", tp_anyptr);
+ }
+ return makeexpr_bin(rel, tp_boolean, a, b);
+}
+
+
+
+
+Expr *makeexpr_and(a, b)
+Expr *a, *b;
+{
+ Expr *ex, **exp, *low;
+
+ if (!a)
+ return b;
+ if (!b)
+ return a;
+ for (exp = &a; (ex = *exp)->kind == EK_AND; exp = &ex->args[1]) ;
+ if ((b->kind == EK_LT || b->kind == EK_LE) &&
+ ((ex->kind == EK_LE && exprsame(ex->args[1], b->args[0], 1)) ||
+ (ex->kind == EK_GE && exprsame(ex->args[0], b->args[0], 1)))) {
+ low = (ex->kind == EK_LE) ? ex->args[0] : ex->args[1];
+ if (unsignedtrick && checkconst(low, 0)) {
+ freeexpr(ex);
+ b->args[0] = force_unsigned(b->args[0]);
+ *exp = b;
+ return a;
+ }
+ if (b->args[1]->val.type->kind == TK_CHAR && useisalpha) {
+ if (checkconst(low, 'A') && checkconst(b->args[1], 'Z')) {
+ freeexpr(ex);
+ *exp = makeexpr_bicall_1("isupper", tp_boolean, grabarg(b, 0));
+ return a;
+ }
+ if (checkconst(low, 'a') && checkconst(b->args[1], 'z')) {
+ freeexpr(ex);
+ *exp = makeexpr_bicall_1("islower", tp_boolean, grabarg(b, 0));
+ return a;
+ }
+ if (checkconst(low, '0') && checkconst(b->args[1], '9')) {
+ freeexpr(ex);
+ *exp = makeexpr_bicall_1("isdigit", tp_boolean, grabarg(b, 0));
+ return a;
+ }
+ }
+ }
+ return makeexpr_bin(EK_AND, tp_boolean, a, b);
+}
+
+
+
+Expr *makeexpr_or(a, b)
+Expr *a, *b;
+{
+ Expr *ex, **exp, *low;
+
+ if (!a)
+ return b;
+ if (!b)
+ return a;
+ for (exp = &a; (ex = *exp)->kind == EK_OR; exp = &ex->args[1]) ;
+ if (((b->kind == EK_BICALL && !strcmp(b->val.s, "isdigit") &&
+ ex->kind == EK_BICALL && !strcmp(ex->val.s, "isalpha")) ||
+ (b->kind == EK_BICALL && !strcmp(b->val.s, "isalpha") &&
+ ex->kind == EK_BICALL && !strcmp(ex->val.s, "isdigit"))) &&
+ exprsame(ex->args[0], b->args[0], 1)) {
+ strchange(&ex->val.s, "isalnum");
+ freeexpr(b);
+ return a;
+ }
+ if (((b->kind == EK_BICALL && !strcmp(b->val.s, "islower") &&
+ ex->kind == EK_BICALL && !strcmp(ex->val.s, "isupper")) ||
+ (b->kind == EK_BICALL && !strcmp(b->val.s, "isupper") &&
+ ex->kind == EK_BICALL && !strcmp(ex->val.s, "islower"))) &&
+ exprsame(ex->args[0], b->args[0], 1)) {
+ strchange(&ex->val.s, "isalpha");
+ freeexpr(b);
+ return a;
+ }
+ if ((b->kind == EK_GT || b->kind == EK_GE) &&
+ ((ex->kind == EK_GT && exprsame(ex->args[1], b->args[0], 1)) ||
+ (ex->kind == EK_LT && exprsame(ex->args[0], b->args[0], 1)))) {
+ low = (ex->kind == EK_GT) ? ex->args[0] : ex->args[1];
+ if (unsignedtrick && checkconst(low, 0)) {
+ freeexpr(ex);
+ b->args[0] = force_unsigned(b->args[0]);
+ *exp = b;
+ return a;
+ }
+ }
+ return makeexpr_bin(EK_OR, tp_boolean, a, b);
+}
+
+
+
+Expr *makeexpr_range(ex, exlow, exhigh, higheq)
+Expr *ex, *exlow, *exhigh;
+int higheq;
+{
+ Expr *ex2;
+ enum exprkind rel = (higheq) ? EK_LE : EK_LT;
+
+ if (exprsame(exlow, exhigh, 1) && higheq)
+ return makeexpr_rel(EK_EQ, ex, exlow);
+ ex2 = makeexpr_rel(rel, copyexpr(ex), exhigh);
+ if (lelerange)
+ return makeexpr_and(makeexpr_rel(EK_LE, exlow, ex), ex2);
+ else
+ return makeexpr_and(makeexpr_rel(EK_GE, ex, exlow), ex2);
+}
+
+
+
+
+Expr *makeexpr_cond(c, a, b)
+Expr *c, *a, *b;
+{
+ Expr *ex;
+
+ ex = makeexpr(EK_COND, 3);
+ ex->val.type = a->val.type;
+ ex->args[0] = c;
+ ex->args[1] = a;
+ ex->args[2] = b;
+ if (debug>2) { fprintf(outf,"makeexpr_cond returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+
+
+int expr_is_lvalue(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ switch (ex->kind) {
+
+ case EK_VAR:
+ mp = (Meaning *)ex->val.i;
+ return (mp->kind == MK_VAR || mp->kind == MK_PARAM ||
+ mp->kind == MK_VARPARAM ||
+ (mp->kind == MK_CONST &&
+ (mp->type->kind == TK_ARRAY ||
+ mp->type->kind == TK_RECORD ||
+ mp->type->kind == TK_SET)));
+
+ case EK_HAT:
+ case EK_NAME:
+ return 1;
+
+ case EK_INDEX:
+ case EK_DOT:
+ return expr_is_lvalue(ex->args[0]);
+
+ case EK_COMMA:
+ return expr_is_lvalue(ex->args[ex->nargs-1]);
+
+ default:
+ return 0;
+ }
+}
+
+
+int expr_has_address(ex)
+Expr *ex;
+{
+ if (ex->kind == EK_DOT &&
+ ((Meaning *)ex->val.i)->val.i)
+ return 0; /* bit fields do not have an address */
+ return expr_is_lvalue(ex);
+}
+
+
+
+Expr *checknil(ex)
+Expr *ex;
+{
+ if (nilcheck == 1) {
+ if (singlevar(ex)) {
+ ex = makeexpr_un(EK_CHECKNIL, ex->val.type, ex);
+ } else {
+ ex = makeexpr_bin(EK_CHECKNIL, ex->val.type, ex,
+ makeexpr_var(makestmttempvar(ex->val.type,
+ name_PTR)));
+ }
+ }
+ return ex;
+}
+
+
+int checkvarinlists(yes, no, def, mp)
+Strlist *yes, *no;
+int def;
+Meaning *mp;
+{
+ char *cp;
+ Meaning *ctx;
+
+ if (mp->kind == MK_FIELD)
+ ctx = mp->rectype->meaning;
+ else
+ ctx = mp->ctx;
+ if (ctx && ctx->name)
+ cp = format_ss("%s.%s", ctx->name, mp->name);
+ else
+ cp = NULL;
+ if (strlist_cifind(yes, cp))
+ return 1;
+ if (strlist_cifind(no, cp))
+ return 0;
+ if (strlist_cifind(yes, mp->name))
+ return 1;
+ if (strlist_cifind(no, mp->name))
+ return 0;
+ if (strlist_cifind(yes, "1"))
+ return 1;
+ if (strlist_cifind(no, "1"))
+ return 0;
+ return def;
+}
+
+
+void requirefilebuffer(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ if (!isfiletype(ex->val.type, 0))
+ return;
+ mp = isfilevar(ex);
+ if (!mp) {
+ if (ex->kind == EK_HAT)
+ ex = ex->args[0];
+ if (ex->kind == EK_VAR) {
+ mp = (Meaning *)ex->val.i;
+ if (mp->kind == MK_PARAM || mp->kind == MK_VARPARAM)
+ note(format_s("File parameter %s can't access buffers (try StructFiles = 1) [318]",
+ mp->name));
+ }
+ } else if (!mp->bufferedfile &&
+ checkvarinlists(bufferedfiles, unbufferedfiles, 1, mp)) {
+ if (mp->wasdeclared)
+ note(format_s("Discovered too late that %s should be buffered [143]",
+ mp->name));
+ mp->bufferedfile = 1;
+ }
+}
+
+
+Expr *makeexpr_hat(a, check)
+Expr *a;
+int check;
+{
+ Expr *ex;
+
+ if (debug>2) { fprintf(outf,"makeexpr_hat("); dumpexpr(a); fprintf(outf,")\n"); }
+ if (isfiletype(a->val.type, -1)) {
+ requirefilebuffer(a);
+ if (*chargetfbufname &&
+ filebasetype(a->val.type)->kind == TK_CHAR)
+ return makeexpr_bicall_1(chargetfbufname,
+ filebasetype(a->val.type),
+ filebasename(a));
+ else if (*arraygetfbufname &&
+ filebasetype(a->val.type)->kind == TK_ARRAY)
+ return makeexpr_bicall_2(arraygetfbufname,
+ filebasetype(a->val.type),
+ filebasename(a),
+ makeexpr_type(filebasetype(a->val.type)));
+ else
+ return makeexpr_bicall_2(getfbufname,
+ filebasetype(a->val.type),
+ filebasename(a),
+ makeexpr_type(filebasetype(a->val.type)));
+ }
+ if (a->kind == EK_PLUS &&
+ (ex = a->args[0])->val.type->kind == TK_POINTER &&
+ (ex->val.type->basetype->kind == TK_ARRAY ||
+ ex->val.type->basetype->kind == TK_STRING ||
+ ex->val.type->basetype->kind == TK_SET)) {
+ ex->val.type = ex->val.type->basetype; /* convert *(a+n) to a[n] */
+ deletearg(&a, 0);
+ if (a->nargs == 1)
+ a = grabarg(a, 0);
+ return makeexpr_bin(EK_INDEX, ex->val.type->basetype, ex, a);
+ }
+ if (a->val.type->kind == TK_STRING ||
+ a->val.type->kind == TK_ARRAY ||
+ a->val.type->kind == TK_SET) {
+ if (starindex == 0)
+ return makeexpr_bin(EK_INDEX, a->val.type->basetype, a, makeexpr_long(0));
+ else
+ return makeexpr_un(EK_HAT, a->val.type->basetype, a);
+ }
+ if (a->val.type->kind != TK_POINTER || !a->val.type->basetype) {
+ warning("bad pointer dereference [165]");
+ return a;
+ }
+ if (a->kind == EK_CAST &&
+ a->val.type->basetype->kind == TK_POINTER &&
+ a->args[0]->val.type->kind == TK_POINTER &&
+ a->args[0]->val.type->basetype->kind == TK_POINTER) {
+ return makeexpr_cast(makeexpr_hat(a->args[0], 0),
+ a->val.type->basetype);
+ }
+ switch (a->val.type->basetype->kind) {
+
+ case TK_ARRAY:
+ case TK_STRING:
+ case TK_SET:
+ if (a->kind != EK_HAT || 1 ||
+ a->val.type == a->args[0]->val.type->basetype) {
+ a->val.type = a->val.type->basetype;
+ return a;
+ }
+
+ default:
+ if (a->kind == EK_ADDR) {
+ ex = a->args[0];
+ FREE(a);
+ return ex;
+ } else {
+ if (check)
+ ex = checknil(a);
+ else
+ ex = a;
+ return makeexpr_un(EK_HAT, a->val.type->basetype, ex);
+ }
+ }
+}
+
+
+
+Expr *un_sign_extend(a)
+Expr *a;
+{
+ if (a->kind == EK_BICALL &&
+ !strcmp(a->val.s, signextname) && *signextname) {
+ return grabarg(a, 0);
+ }
+ return a;
+}
+
+
+
+Expr *makeexpr_addr(a)
+Expr *a;
+{
+ Expr *ex;
+ Type *type;
+ Meaning *mp;
+
+ a = un_sign_extend(a);
+ type = makepointertype(a->val.type);
+ if (debug>2) { fprintf(outf,"makeexpr_addr("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
+ if (a->kind == EK_CONST && a->val.type->kind == TK_STRING) {
+ return a; /* kludge to help assignments */
+ } else if (a->kind == EK_INDEX &&
+ (a->val.type->kind != TK_ARRAY &&
+ a->val.type->kind != TK_SET &&
+ a->val.type->kind != TK_STRING) &&
+ (addindex == 1 ||
+ (addindex != 0 && checkconst(a->args[1], 0)))) {
+ ex = makeexpr_plus(makeexpr_addr(a->args[0]), a->args[1]);
+ FREE(a);
+ ex->val.type = type;
+ return ex;
+ } else if (a->kind == EK_CAST) {
+ return makeexpr_cast(makeexpr_addr(a->args[0]), type);
+ } else if (a->kind == EK_ACTCAST) {
+ return makeexpr_actcast(makeexpr_addr(a->args[0]), type);
+ } else if (a->kind == EK_LITCAST) {
+ if (a->args[0]->kind == EK_NAME) {
+ if (my_strchr(a->args[0]->val.s, '(') ||
+ my_strchr(a->args[0]->val.s, '['))
+ note("Constructing pointer type by adding '*' may be incorrect [322]");
+ return makeexpr_bin(EK_LITCAST, tp_integer,
+ makeexpr_name(format_s("%s*",
+ a->args[0]->val.s),
+ tp_integer),
+ makeexpr_addr(a->args[1]));
+ } else
+ return makeexpr_bin(EK_LITCAST, tp_integer, makeexpr_type(type),
+ makeexpr_addr(a->args[1]));
+ } else {
+ switch (a->val.type->kind) {
+
+ case TK_ARRAY:
+ case TK_STRING:
+ case TK_SET:
+ if (a->val.type->smin) {
+ return makeexpr_un(EK_ADDR, type,
+ makeexpr_index(a,
+ copyexpr(a->val.type->smin),
+ NULL));
+ }
+ a->val.type = type;
+ return a;
+
+ default:
+ if (a->kind == EK_HAT) {
+ ex = a->args[0];
+ FREE(a);
+ return ex;
+ } else if (a->kind == EK_ACTCAST)
+ return makeexpr_actcast(makeexpr_addr(grabarg(a, 0)), type);
+ else if (a->kind == EK_CAST)
+ return makeexpr_cast(makeexpr_addr(grabarg(a, 0)), type);
+ else {
+ if (a->kind == EK_VAR &&
+ (mp = (Meaning *)a->val.i)->kind == MK_PARAM &&
+ mp->type != promote_type(mp->type) &&
+ fixpromotedargs) {
+ note(format_s("Taking & of possibly promoted param %s [324]",
+ mp->name));
+ if (fixpromotedargs == 1) {
+ mp->varstructflag = 1;
+ mp->ctx->varstructflag = 1;
+ }
+ }
+ return makeexpr_un(EK_ADDR, type, a);
+ }
+ }
+ }
+}
+
+
+
+Expr *makeexpr_addrstr(a)
+Expr *a;
+{
+ if (debug>2) { fprintf(outf,"makeexpr_addrstr("); dumpexpr(a); fprintf(outf,")\n"); }
+ if (a->val.type->kind == TK_POINTER)
+ return a;
+ return makeexpr_addr(a);
+}
+
+
+
+Expr *makeexpr_addrf(a)
+Expr *a;
+{
+ Meaning *mp, *tvar;
+
+ mp = (Meaning *)a->val.i;
+ if (is_std_file(a)) {
+ if (addrstdfiles == 0) {
+ note(format_s("Taking address of %s; consider setting VarFiles = 0 [144]",
+ (a->kind == EK_VAR) ? ((Meaning *)a->val.i)->name
+ : a->val.s));
+ tvar = makestmttempvar(tp_text, name_TEMP);
+ return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), a),
+ makeexpr_addr(makeexpr_var(tvar)));
+ }
+ }
+ if ((a->kind == EK_VAR &&
+ mp->kind == MK_FIELD && mp->val.i) ||
+ (a->kind == EK_BICALL &&
+ !strcmp(a->val.s, getbitsname))) {
+ warning("Can't take the address of a bit-field [166]");
+ }
+ return makeexpr_addr(a);
+}
+
+
+
+Expr *makeexpr_index(a, b, offset)
+Expr *a, *b, *offset;
+{
+ Type *indextype, *btype;
+
+ if (debug>2) { fprintf(outf,"makeexpr_index("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b);
+ fprintf(outf,", "); dumpexpr(offset); fprintf(outf,")\n"); }
+ indextype = (a->val.type->kind == TK_ARRAY) ? a->val.type->indextype
+ : tp_integer;
+ b = gentle_cast(b, indextype);
+ if (!offset)
+ offset = makeexpr_long(0);
+ b = makeexpr_minus(b, gentle_cast(offset, indextype));
+ btype = a->val.type;
+ if (btype->basetype)
+ btype = btype->basetype;
+ if (checkconst(b, 0) && starindex == 1)
+ return makeexpr_un(EK_HAT, btype, a);
+ else
+ return makeexpr_bin(EK_INDEX, btype, a,
+ gentle_cast(b, indextype));
+}
+
+
+
+Expr *makeexpr_type(type)
+Type *type;
+{
+ Expr *ex;
+
+ ex = makeexpr(EK_TYPENAME, 0);
+ ex->val.type = type;
+ return ex;
+}
+
+
+Expr *makeexpr_sizeof(ex, incskipped)
+Expr *ex;
+int incskipped;
+{
+ Expr *ex2, *ex3;
+ Type *btype;
+ char *name;
+
+ if (ex->val.type->meaning) {
+ name = find_special_variant(ex->val.type->meaning->name,
+ "SpecialSizeOf", specialsizeofs, 1);
+ if (name) {
+ freeexpr(ex);
+ return pc_expr_str(name);
+ }
+ }
+ switch (ex->val.type->kind) {
+
+ case TK_CHAR:
+ case TK_BOOLEAN:
+ freeexpr(ex);
+ return makeexpr_long(1);
+
+ case TK_SUBR:
+ btype = findbasetype(ex->val.type, ODECL_NOPRES);
+ if (btype->kind == TK_CHAR || btype == tp_abyte) {
+ freeexpr(ex);
+ return makeexpr_long(1);
+ }
+ break;
+
+ case TK_STRING:
+ case TK_ARRAY:
+ if (!ex->val.type->meaning || ex->val.type->kind == TK_STRING ||
+ (!incskipped && ex->val.type->smin)) {
+ ex3 = arraysize(ex->val.type, incskipped);
+ return makeexpr_times(ex3,
+ makeexpr_sizeof(makeexpr_type(
+ ex->val.type->basetype), 1));
+ }
+ break;
+
+ case TK_SET:
+ ord_range_expr(ex->val.type->indextype, NULL, &ex2);
+ freeexpr(ex);
+ return makeexpr_times(makeexpr_plus(makeexpr_div(copyexpr(ex2),
+ makeexpr_setbits()),
+ makeexpr_long(2)),
+ makeexpr_sizeof(makeexpr_type(tp_integer), 0));
+
+ default:
+ break;
+ }
+ if (ex->kind != EK_CONST &&
+ (findbasetype(ex->val.type,0)->meaning || /* if type has a name... */
+ ex->val.type->kind == TK_STRING || /* if C sizeof(expr) will give wrong answer */
+ ex->val.type->kind == TK_ARRAY ||
+ ex->val.type->kind == TK_SET)) {
+ ex2 = makeexpr_type(ex->val.type);
+ freeexpr(ex);
+ ex = ex2;
+ }
+ return makeexpr_un(EK_SIZEOF, tp_integer, ex);
+}
+
+
+
+
+/* Compute a measure of how fast or slow the expression is likely to be.
+ 0 is a constant, 1 is a variable, extra points added per "operation". */
+
+int exprspeed(ex)
+Expr *ex;
+{
+ Meaning *mp, *mp2;
+ int i, cost, speed;
+
+ switch (ex->kind) {
+
+ case EK_VAR:
+ mp = (Meaning *)ex->val.i;
+ if (mp->kind == MK_CONST)
+ return 0;
+ if (!mp->ctx || mp->ctx->kind == MK_FUNCTION)
+ return 1;
+ i = 1;
+ for (mp2 = curctx; mp2 && mp2 != mp->ctx; mp2 = mp2->ctx)
+ i++; /* cost of following static links */
+ return (i);
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ case EK_SIZEOF:
+ return 0;
+
+ case EK_ADDR:
+ speed = exprspeed(ex->args[0]);
+ return (speed > 1) ? speed : 0;
+
+ case EK_DOT:
+ return exprspeed(ex->args[0]);
+
+ case EK_NEG:
+ return exprspeed(ex->args[0]) + 1;
+
+ case EK_CAST:
+ case EK_ACTCAST:
+ i = (ord_type(ex->val.type)->kind == TK_REAL) !=
+ (ord_type(ex->args[0]->val.type)->kind == TK_REAL);
+ return (i + exprspeed(ex->args[0]));
+
+ case EK_COND:
+ return 2 + exprspeed(ex->args[0]) +
+ MAX(exprspeed(ex->args[1]), exprspeed(ex->args[2]));
+
+ case EK_AND:
+ case EK_OR:
+ case EK_COMMA:
+ speed = 2;
+ for (i = 0; i < ex->nargs; i++)
+ speed += exprspeed(ex->args[i]);
+ return speed;
+
+ case EK_FUNCTION:
+ case EK_BICALL:
+ case EK_SPCALL:
+ return 1000;
+
+ case EK_ASSIGN:
+ case EK_POSTINC:
+ case EK_POSTDEC:
+ return 100 + exprspeed(ex->args[0]) + exprspeed(ex->args[1]);
+
+ default:
+ cost = (ex->kind == EK_PLUS) ? 1 : 2;
+ if (ex->val.type->kind == TK_REAL)
+ cost *= 2;
+ speed = -cost;
+ for (i = 0; i < ex->nargs; i++) {
+ if (!isliteralconst(ex->args[i], NULL) ||
+ ex->val.type->kind == TK_REAL)
+ speed += exprspeed(ex->args[i]) + cost;
+ }
+ return MAX(speed, 0);
+ }
+}
+
+
+
+
+int noargdependencies(ex, vars)
+Expr *ex;
+int vars;
+{
+ int i;
+
+ for (i = 0; i < ex->nargs; i++) {
+ if (!nodependencies(ex->args[i], vars))
+ return 0;
+ }
+ return 1;
+}
+
+
+int nodependencies(ex, vars)
+Expr *ex;
+int vars; /* 1 if explicit dependencies on vars count as dependencies */
+{ /* 2 if global but not local vars count as dependencies */
+ Meaning *mp;
+
+ if (debug>2) { fprintf(outf,"nodependencies("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (!noargdependencies(ex, vars))
+ return 0;
+ switch (ex->kind) {
+
+ case EK_VAR:
+ mp = (Meaning *)ex->val.i;
+ if (mp->kind == MK_CONST)
+ return 1;
+ if (vars == 2 &&
+ mp->ctx == curctx &&
+ mp->ctx->kind == MK_FUNCTION &&
+ !mp->varstructflag)
+ return 1;
+ return (mp->kind == MK_CONST ||
+ (!vars &&
+ (mp->kind == MK_VAR || mp->kind == MK_VARREF ||
+ mp->kind == MK_PARAM || mp->kind == MK_VARPARAM)));
+
+ case EK_BICALL:
+ return nosideeffects_func(ex);
+
+ case EK_FUNCTION:
+ case EK_SPCALL:
+ case EK_ASSIGN:
+ case EK_POSTINC:
+ case EK_POSTDEC:
+ case EK_HAT:
+ case EK_INDEX:
+ return 0;
+
+ default:
+ return 1;
+ }
+}
+
+
+
+int exprdependsvar(ex, mp)
+Expr *ex;
+Meaning *mp;
+{
+ int i;
+
+ i = ex->nargs;
+ while (--i >= 0)
+ if (exprdependsvar(ex->args[i], mp))
+ return 1;
+ switch (ex->kind) {
+
+ case EK_VAR:
+ return ((Meaning *)ex->val.i == mp);
+
+ case EK_BICALL:
+ if (nodependencies(ex, 1))
+ return 0;
+
+ /* fall through */
+ case EK_FUNCTION:
+ case EK_SPCALL:
+ return (mp->ctx != curctx ||
+ mp->ctx->kind != MK_FUNCTION ||
+ mp->varstructflag);
+
+ case EK_HAT:
+ return 1;
+
+ default:
+ return 0;
+ }
+}
+
+
+int exprdepends(ex, ex2)
+Expr *ex, *ex2; /* Expression ex somehow depends on value of ex2 */
+{
+ switch (ex2->kind) {
+
+ case EK_VAR:
+ return exprdependsvar(ex, (Meaning *)ex2->val.i);
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ return 0;
+
+ case EK_INDEX:
+ case EK_DOT:
+ return exprdepends(ex, ex2->args[0]);
+
+ default:
+ return !nodependencies(ex, 1);
+ }
+}
+
+
+int nosideeffects_func(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ Symbol *sp;
+
+ switch (ex->kind) {
+
+ case EK_FUNCTION:
+ mp = (Meaning *)ex->val.i;
+ sp = findsymbol_opt(mp->name);
+ return sp && (sp->flags & (NOSIDEEFF|DETERMF));
+
+ case EK_BICALL:
+ sp = findsymbol_opt(ex->val.s);
+ return sp && (sp->flags & (NOSIDEEFF|DETERMF));
+
+ default:
+ return 0;
+ }
+}
+
+
+
+int deterministic_func(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ Symbol *sp;
+
+ switch (ex->kind) {
+
+ case EK_FUNCTION:
+ mp = (Meaning *)ex->val.i;
+ sp = findsymbol_opt(mp->name);
+ return sp && (sp->flags & DETERMF);
+
+ case EK_BICALL:
+ sp = findsymbol_opt(ex->val.s);
+ return sp && (sp->flags & DETERMF);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+
+int noargsideeffects(ex, mode)
+Expr *ex;
+int mode;
+{
+ int i;
+
+ for (i = 0; i < ex->nargs; i++) {
+ if (!nosideeffects(ex->args[i], mode))
+ return 0;
+ }
+ return 1;
+}
+
+
+/* mode=0: liberal about bicall's: safe unless sideeffects_bicall() */
+/* mode=1: conservative about bicall's: must be explicitly NOSIDEEFF */
+
+int nosideeffects(ex, mode)
+Expr *ex;
+int mode;
+{
+ if (debug>2) { fprintf(outf,"nosideeffects("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (!noargsideeffects(ex, mode))
+ return 0;
+ switch (ex->kind) {
+
+ case EK_BICALL:
+ if (mode == 0)
+ return !sideeffects_bicall(ex->val.s);
+
+ /* fall through */
+ case EK_FUNCTION:
+ return nosideeffects_func(ex);
+
+ case EK_SPCALL:
+ case EK_ASSIGN:
+ case EK_POSTINC:
+ case EK_POSTDEC:
+ return 0;
+
+ default:
+ return 1;
+ }
+}
+
+
+
+int exproccurs(ex, ex2)
+Expr *ex, *ex2;
+{
+ int i, count = 0;
+
+ if (debug>2) { fprintf(outf,"exproccurs("); dumpexpr(ex); fprintf(outf,", "); dumpexpr(ex2); fprintf(outf,")\n"); }
+ for (i = 0; i < ex->nargs; i++)
+ count += exproccurs(ex->args[i], ex2);
+ if (exprsame(ex, ex2, 0))
+ count++;
+ return count;
+}
+
+
+
+Expr *singlevar(ex)
+Expr *ex;
+{
+ if (debug>2) { fprintf(outf,"singlevar("); dumpexpr(ex); fprintf(outf,")\n"); }
+ switch (ex->kind) {
+
+ case EK_VAR:
+ case EK_MACARG:
+ return ex;
+
+ case EK_HAT:
+ case EK_ADDR:
+ case EK_DOT:
+ return singlevar(ex->args[0]);
+
+ case EK_INDEX:
+#if 0
+ if (!nodependencies(ex->args[1], 1))
+ return NULL;
+#endif
+ return singlevar(ex->args[0]);
+
+ default:
+ return NULL;
+ }
+}
+
+
+
+/* Is "ex" a function which takes a return buffer pointer as its
+ first argument, and returns a copy of that pointer? */
+
+int structuredfunc(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ Symbol *sp;
+
+ if (debug>2) { fprintf(outf,"structuredfunc("); dumpexpr(ex); fprintf(outf,")\n"); }
+ switch (ex->kind) {
+
+ case EK_FUNCTION:
+ mp = (Meaning *)ex->val.i;
+ if (mp->isfunction && mp->cbase && mp->cbase->kind == MK_VARPARAM)
+ return 1;
+ sp = findsymbol_opt(mp->name);
+ return sp && (sp->flags & (STRUCTF|STRLAPF));
+
+ case EK_BICALL:
+ sp = findsymbol_opt(ex->val.s);
+ return sp && (sp->flags & (STRUCTF|STRLAPF));
+
+ default:
+ return 0;
+ }
+}
+
+
+
+int strlapfunc(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ Symbol *sp;
+
+ switch (ex->kind) {
+
+ case EK_FUNCTION:
+ mp = (Meaning *)ex->val.i;
+ sp = findsymbol_opt(mp->name);
+ return sp && (sp->flags & STRLAPF);
+
+ case EK_BICALL:
+ sp = findsymbol_opt(ex->val.s);
+ return sp && (sp->flags & STRLAPF);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+Meaning *istempvar(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ if (debug>2) { fprintf(outf,"istempvar("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (ex->kind == EK_VAR) {
+ mp = (Meaning *)ex->val.i;
+ if (mp->istemporary)
+ return mp;
+ else
+ return NULL;
+ }
+ return NULL;
+}
+
+
+Meaning *totempvar(ex)
+Expr *ex;
+{
+ while (structuredfunc(ex))
+ ex = ex->args[0];
+ return istempvar(ex);
+}
+
+
+
+Meaning *isretvar(ex)
+Expr *ex;
+{
+ Meaning *mp;
+
+ if (debug>2) { fprintf(outf,"isretvar("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (ex->kind == EK_HAT)
+ ex = ex->args[0];
+ if (ex->kind == EK_VAR) {
+ mp = (Meaning *)ex->val.i;
+ if (mp->ctx && mp->ctx->kind == MK_FUNCTION &&
+ mp->ctx->isfunction && mp == mp->ctx->cbase)
+ return mp;
+ else
+ return NULL;
+ }
+ return NULL;
+}
+
+
+
+Expr *bumpstring(ex, index, offset)
+Expr *ex, *index;
+int offset;
+{
+ if (checkconst(index, offset)) {
+ freeexpr(index);
+ return ex;
+ }
+ if (addindex != 0)
+ ex = makeexpr_plus(makeexpr_addrstr(ex),
+ makeexpr_minus(index, makeexpr_long(offset)));
+ else
+ ex = makeexpr_addr(makeexpr_index(ex, index, makeexpr_long(offset)));
+ ex->val.type = tp_str255;
+ return ex;
+}
+
+
+
+long po2m1(n)
+int n;
+{
+ if (n == 32)
+ return -1;
+ else if (n == 31)
+ return 0x7fffffff;
+ else
+ return (1<<n) - 1;
+}
+
+
+
+int isarithkind(kind)
+enum exprkind kind;
+{
+ return (kind == EK_EQ || kind == EK_LT || kind == EK_GT ||
+ kind == EK_NE || kind == EK_LE || kind == EK_GE ||
+ kind == EK_PLUS || kind == EK_TIMES || kind == EK_DIVIDE ||
+ kind == EK_DIV || kind == EK_MOD || kind == EK_NEG ||
+ kind == EK_AND || kind == EK_OR || kind == EK_NOT ||
+ kind == EK_BAND || kind == EK_BOR || kind == EK_BXOR ||
+ kind == EK_LSH || kind == EK_RSH || kind == EK_BNOT ||
+ kind == EK_FUNCTION || kind == EK_BICALL);
+}
+
+
+Expr *makeexpr_assign(a, b)
+Expr *a, *b;
+{
+ int i, j;
+ Expr *ex, *ex2, *ex3, **ep;
+ Meaning *mp;
+ Type *tp;
+
+ if (debug>2) { fprintf(outf,"makeexpr_assign("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+ if (stringtrunclimit > 0 &&
+ a->val.type->kind == TK_STRING &&
+ (i = strmax(a)) <= stringtrunclimit &&
+ strmax(b) > i) {
+ note("Possible string truncation in assignment [145]");
+ }
+ a = un_sign_extend(a);
+ b = gentle_cast(b, a->val.type);
+ if (b->kind == EK_BICALL && !strcmp(b->val.s, "sprintf") &&
+ (mp = istempvar(b->args[0])) != NULL &&
+ b->nargs >= 2 &&
+ b->args[1]->kind == EK_CONST && /* all this handles string appending */
+ b->args[1]->val.i > 2 && /* of the form, "s := s + ..." */
+ !strncmp(b->args[1]->val.s, "%s", 2) &&
+ exprsame(a, b->args[2], 1) &&
+ nosideeffects(a, 0) &&
+ (ex = singlevar(a)) != NULL) {
+ ex2 = copyexpr(b);
+ delfreearg(&ex2, 2);
+ freeexpr(ex2->args[1]);
+ ex2->args[1] = makeexpr_lstring(b->args[1]->val.s+2,
+ b->args[1]->val.i-2);
+ if (/*(ex = singlevar(a)) != NULL && */
+ /* noargdependencies(ex2) && */ !exproccurs(ex2, ex)) {
+ freeexpr(b);
+ if (ex2->args[1]->val.i == 2 && /* s := s + s2 */
+ !strncmp(ex2->args[1]->val.s, "%s", 2)) {
+ canceltempvar(mp);
+ tp = ex2->val.type;
+ return makeexpr_bicall_2("strcat", tp,
+ makeexpr_addrstr(a), grabarg(ex2, 2));
+ } else if (sprintflength(ex2, 0) >= 0) { /* s := s + 's2' */
+ tp = ex2->val.type;
+ return makeexpr_bicall_2("strcat", tp,
+ makeexpr_addrstr(a),
+ makeexpr_unsprintfify(ex2));
+ } else { /* general case */
+ canceltempvar(mp);
+ freeexpr(ex2->args[0]);
+ ex = makeexpr_bicall_1("strlen", tp_int, copyexpr(a));
+ ex2->args[0] = bumpstring(a, ex, 0);
+ return ex2;
+ }
+ } else
+ freeexpr(ex2);
+ }
+ if (b->kind == EK_BICALL && !strcmp(b->val.s, "sprintf") &&
+ istempvar(b->args[0]) &&
+ (ex = singlevar(a)) != NULL) {
+ j = -1; /* does lhs var appear exactly once on rhs? */
+ for (i = 2; i < b->nargs; i++) {
+ if (exprsame(b->args[i], ex, 1) && j < 0)
+ j = i;
+ else if (exproccurs(b->args[i], ex))
+ break;
+ }
+ if (i == b->nargs && j > 0) {
+ b->args[j] = makeexpr_bicall_2("strcpy", tp_str255,
+ makeexpr_addrstr(b->args[0]),
+ makeexpr_addrstr(b->args[j]));
+ b->args[0] = makeexpr_addrstr(a);
+ return b;
+ }
+ }
+ if (structuredfunc(b) && (ex2 = singlevar(a)) != NULL) {
+ ep = &b->args[0];
+ i = strlapfunc(b);
+ while (structuredfunc((ex = *ep))) {
+ i = i && strlapfunc(ex);
+ ep = &ex->args[0];
+ }
+ if ((mp = istempvar(ex)) != NULL &&
+ (i || !exproccurs(b, ex2))) {
+ canceltempvar(mp);
+ freeexpr(*ep);
+ *ep = makeexpr_addrstr(a);
+ return b;
+ }
+ }
+ if (a->val.type->kind == TK_PROCPTR &&
+ (mp = istempprocptr(b)) != NULL &&
+ nosideeffects(a, 0)) {
+ freeexpr(b->args[0]->args[0]->args[0]);
+ b->args[0]->args[0]->args[0] = copyexpr(a);
+ if (b->nargs == 3) {
+ freeexpr(b->args[1]->args[0]->args[0]);
+ b->args[1]->args[0]->args[0] = a;
+ delfreearg(&b, 2);
+ } else {
+ freeexpr(b->args[1]);
+ b->args[1] = makeexpr_assign(makeexpr_dotq(a, "link", tp_anyptr),
+ makeexpr_nil());
+ }
+ canceltempvar(mp);
+ return b;
+ }
+ if (a->val.type->kind == TK_PROCPTR &&
+ (b->val.type->kind == TK_CPROCPTR ||
+ checkconst(b, 0))) {
+ ex = makeexpr_dotq(copyexpr(a), "proc", tp_anyptr);
+ b = makeexpr_comma(makeexpr_assign(ex, b),
+ makeexpr_assign(makeexpr_dotq(a, "link", tp_anyptr),
+ makeexpr_nil()));
+ return b;
+ }
+ if (a->val.type->kind == TK_CPROCPTR &&
+ (mp = istempprocptr(b)) != NULL &&
+ nosideeffects(a, 0)) {
+ freeexpr(b->args[0]->args[0]);
+ b->args[0]->args[0] = a;
+ if (b->nargs == 3)
+ delfreearg(&b, 1);
+ delfreearg(&b, 1);
+ canceltempvar(mp);
+ return b;
+ }
+ if (a->val.type->kind == TK_CPROCPTR &&
+ b->val.type->kind == TK_PROCPTR) {
+ b = makeexpr_dotq(b, "proc", tp_anyptr);
+ }
+ if (a->val.type->kind == TK_STRING) {
+ if (b->kind == EK_CONST && b->val.i == 0 && !isretvar(a)) {
+ /* optimizing retvar would mess up "return" optimization */
+ return makeexpr_assign(makeexpr_hat(a, 0),
+ makeexpr_char(0));
+ }
+ a = makeexpr_addrstr(a);
+ b = makeexpr_addrstr(b);
+ return makeexpr_bicall_2("strcpy", a->val.type, a, b);
+ }
+ if (a->kind == EK_BICALL && !strcmp(a->val.s, "strlen")) {
+ if (b->kind == EK_CAST &&
+ ord_type(b->args[0]->val.type)->kind == TK_INTEGER) {
+ b = grabarg(b, 0);
+ }
+ j = (b->kind == EK_PLUS && /* handle "s[0] := xxx" */
+ b->args[0]->kind == EK_BICALL &&
+ !strcmp(b->args[0]->val.s, "strlen") &&
+ exprsame(a->args[0], b->args[0]->args[0], 0) &&
+ isliteralconst(b->args[1], NULL) == 2);
+ if (j && b->args[1]->val.i > 0 &&
+ b->args[1]->val.i <= 5) { /* lengthening the string */
+ a = grabarg(a, 0);
+ i = b->args[1]->val.i;
+ freeexpr(b);
+ if (i == 1)
+ b = makeexpr_string(" ");
+ else
+ b = makeexpr_lstring("12345", i);
+ return makeexpr_bicall_2("strcat", a->val.type, a, b);
+ } else { /* maybe shortening the string */
+ if (!j && !isconstexpr(b, NULL))
+ note("Modification of string length may translate incorrectly [146]");
+ a = grabarg(a, 0);
+ b = makeexpr_ord(b);
+ return makeexpr_assign(makeexpr_index(a, b, NULL),
+ makeexpr_char(0));
+ }
+ }
+ if (a->val.type->kind == TK_ARRAY ||
+ (a->val.type->kind == TK_PROCPTR && copystructs < 1) ||
+ (a->val.type->kind == TK_RECORD &&
+ (copystructs < 1 || a->val.type != b->val.type))) {
+ ex = makeexpr_sizeof(copyexpr(a), 0);
+ ex2 = makeexpr_sizeof(copyexpr(b), 0);
+ if (!exprsame(ex, ex2, 1)) {
+ if (a->val.type->kind == TK_ARRAY &&
+ b->val.type->kind == TK_ARRAY &&
+ a->val.type->basetype->kind == TK_CHAR &&
+ (!ISCONST(ex->kind) || !ISCONST(ex2->kind) ||
+ ex->val.i > ex2->val.i)) {
+ ex = makeexpr_arglong(ex, (size_t_long != 0));
+ ex2 = makeexpr_arglong(ex2, (size_t_long != 0));
+ a = makeexpr_addrstr(a);
+ b = makeexpr_addrstr(b);
+ b = makeexpr_bicall_3("memcpy", a->val.type,
+ copyexpr(a), b, copyexpr(ex2));
+ ex3 = copyexpr(ex2);
+ return makeexpr_comma(b,
+ makeexpr_bicall_3("memset", a->val.type,
+ makeexpr_plus(a, ex3),
+ makeexpr_char(' '),
+ makeexpr_minus(ex,
+ ex2)));
+ } else if (!(a->val.type->kind == TK_ARRAY &&
+ b->val.type->kind != TK_ARRAY))
+ warning("Incompatible types or sizes [167]");
+ }
+ freeexpr(ex2);
+ ex = makeexpr_arglong(ex, (size_t_long != 0));
+ a = makeexpr_addrstr(a);
+ b = makeexpr_addrstr(b);
+ return makeexpr_bicall_3("memcpy", a->val.type, a, b, ex);
+ }
+ if (a->val.type->kind == TK_SET) {
+ a = makeexpr_addrstr(a);
+ b = makeexpr_addrstr(b);
+ return makeexpr_bicall_2(setcopyname, a->val.type, a, b);
+ }
+ for (ep = &a; (ex3 = *ep); ) {
+ if (ex3->kind == EK_COMMA)
+ ep = &ex3->args[ex3->nargs-1];
+ else if (ex3->kind == EK_CAST || ex3->kind == EK_ACTCAST)
+ ep = &ex3->args[0];
+ else
+ break;
+ }
+ if (ex3->kind == EK_BICALL) {
+ if (!strcmp(ex3->val.s, getbitsname)) {
+ tp = ex3->args[0]->val.type;
+ if (tp->kind == TK_ARRAY)
+ ex3->args[0] = makeexpr_addr(ex3->args[0]);
+ ex3->val.type = tp_void;
+ if (checkconst(b, 0) && *clrbitsname) {
+ strchange(&ex3->val.s, clrbitsname);
+ } else if (*putbitsname &&
+ ((ISCONST(b->kind) &&
+ (b->val.i | ~((1 << (1 << tp->escale)) - 1)) == -1) ||
+ checkconst(b, (1 << (1 << tp->escale)) - 1))) {
+ strchange(&ex3->val.s, putbitsname);
+ insertarg(ep, 2, makeexpr_arglong(makeexpr_ord(b), 0));
+ } else {
+ b = makeexpr_arglong(makeexpr_ord(b), 0);
+ if (*storebitsname) {
+ strchange(&ex3->val.s, storebitsname);
+ insertarg(ep, 2, b);
+ } else {
+ if (exproccurs(b, ex3->args[0])) {
+ mp = makestmttempvar(b->val.type, name_TEMP);
+ ex2 = makeexpr_assign(makeexpr_var(mp), b);
+ b = makeexpr_var(mp);
+ } else
+ ex2 = NULL;
+ ex = copyexpr(ex3);
+ strchange(&ex3->val.s, putbitsname);
+ insertarg(&ex3, 2, b);
+ strchange(&ex->val.s, clrbitsname);
+ *ep = makeexpr_comma(ex2, makeexpr_comma(ex, ex3));
+ }
+ }
+ return a;
+ } else if (!strcmp(ex3->val.s, getfbufname)) {
+ ex3->val.type = tp_void;
+ strchange(&ex3->val.s, putfbufname);
+ insertarg(ep, 2, b);
+ return a;
+ } else if (!strcmp(ex3->val.s, chargetfbufname)) {
+ ex3->val.type = tp_void;
+ if (*charputfbufname) {
+ strchange(&ex3->val.s, charputfbufname);
+ insertarg(ep, 1, b);
+ } else {
+ strchange(&ex3->val.s, putfbufname);
+ insertarg(ep, 1, makeexpr_type(ex3->val.type->basetype->basetype));
+ insertarg(ep, 2, b);
+ }
+ return a;
+ } else if (!strcmp(ex3->val.s, arraygetfbufname)) {
+ ex3->val.type = tp_void;
+ if (*arrayputfbufname) {
+ strchange(&ex3->val.s, arrayputfbufname);
+ insertarg(ep, 1, b);
+ } else {
+ strchange(&ex3->val.s, putfbufname);
+ insertarg(ep, 1, makeexpr_type(ex3->val.type->basetype->basetype));
+ insertarg(ep, 2, b);
+ }
+ return a;
+ }
+ }
+ while (a->kind == EK_CAST || a->kind == EK_ACTCAST ||
+ a->kind == EK_LITCAST) {
+ if (a->kind == EK_LITCAST) {
+ b = makeexpr_cast(b, a->args[1]->val.type);
+ a = grabarg(a, 1);
+ } else if (ansiC < 2 || /* in GNU C, a cast is an lvalue */
+ isarithkind(a->args[0]->kind) ||
+ (a->val.type->kind == TK_POINTER &&
+ a->args[0]->val.type->kind == TK_POINTER)) {
+ if (a->kind == EK_CAST)
+ b = makeexpr_cast(b, a->args[0]->val.type);
+ else
+ b = makeexpr_actcast(b, a->args[0]->val.type);
+ a = grabarg(a, 0);
+ } else
+ break;
+ }
+ if (a->kind == EK_NEG)
+ return makeexpr_assign(grabarg(a, 0), makeexpr_neg(b));
+ if (a->kind == EK_NOT)
+ return makeexpr_assign(grabarg(a, 0), makeexpr_not(b));
+ if (a->kind == EK_BNOT)
+ return makeexpr_assign(grabarg(a, 0),
+ makeexpr_un(EK_BNOT, b->val.type, b));
+ if (a->kind == EK_PLUS) {
+ for (i = 0; i < a->nargs && a->nargs > 1; ) {
+ if (isconstantexpr(a->args[i])) {
+ b = makeexpr_minus(b, a->args[i]);
+ deletearg(&a, i);
+ } else
+ i++;
+ }
+ if (a->nargs == 1)
+ return makeexpr_assign(grabarg(a, 0), b);
+ }
+ if (a->kind == EK_TIMES) {
+ for (i = 0; i < a->nargs && a->nargs > 1; ) {
+ if (isconstantexpr(a->args[i])) {
+ if (a->val.type->kind == TK_REAL)
+ b = makeexpr_divide(b, a->args[i]);
+ else {
+ if (ISCONST(b->kind) && ISCONST(a->args[i]->kind) &&
+ (b->val.i % a->args[i]->val.i) != 0) {
+ break;
+ }
+ b = makeexpr_div(b, a->args[i]);
+ }
+ deletearg(&a, i);
+ } else
+ i++;
+ }
+ if (a->nargs == 1)
+ return makeexpr_assign(grabarg(a, 0), b);
+ }
+ if ((a->kind == EK_DIVIDE || a->kind == EK_DIV) &&
+ isconstantexpr(a->args[1])) {
+ b = makeexpr_times(b, a->args[1]);
+ return makeexpr_assign(a->args[0], b);
+ }
+ if (a->kind == EK_LSH && isconstantexpr(a->args[1])) {
+ if (ISCONST(b->kind) && ISCONST(a->args[1]->kind)) {
+ if ((b->val.i & ((1L << a->args[1]->val.i)-1)) == 0) {
+ b->val.i >>= a->args[1]->val.i;
+ return makeexpr_assign(grabarg(a, 0), b);
+ }
+ } else {
+ b = makeexpr_bin(EK_RSH, b->val.type, b, a->args[1]);
+ return makeexpr_assign(a->args[0], b);
+ }
+ }
+ if (a->kind == EK_RSH && isconstantexpr(a->args[1])) {
+ if (ISCONST(b->kind) && ISCONST(a->args[1]->kind))
+ b->val.i <<= a->args[1]->val.i;
+ else
+ b = makeexpr_bin(EK_LSH, b->val.type, b, a->args[1]);
+ return makeexpr_assign(a->args[0], b);
+ }
+ if (isarithkind(a->kind))
+ warning("Invalid assignment [168]");
+ return makeexpr_bin(EK_ASSIGN, a->val.type, a, makeexpr_unlongcast(b));
+}
+
+
+
+
+Expr *makeexpr_comma(a, b)
+Expr *a, *b;
+{
+ Type *type;
+
+ if (!a || nosideeffects(a, 1))
+ return b;
+ if (!b)
+ return a;
+ type = b->val.type;
+ a = commute(a, b, EK_COMMA);
+ a->val.type = type;
+ return a;
+}
+
+
+
+
+int strmax(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ long smin, smax;
+ Value val;
+ Type *type;
+
+ type = ex->val.type;
+ if (type->kind == TK_POINTER)
+ type = type->basetype;
+ if (type->kind == TK_CHAR)
+ return 1;
+ if (type->kind == TK_ARRAY && type->basetype->kind == TK_CHAR) {
+ if (ord_range(type->indextype, &smin, &smax))
+ return smax - smin + 1;
+ else
+ return stringceiling;
+ }
+ if (type->kind != TK_STRING) {
+ intwarning("strmax", "strmax encountered a non-string value [169]");
+ return stringceiling;
+ }
+ if (ex->kind == EK_CONST)
+ return ex->val.i;
+ if (ex->kind == EK_VAR && foldstrconsts != 0 &&
+ (mp = (Meaning *)(ex->val.i))->kind == MK_CONST && mp->val.type)
+ return mp->val.i;
+ if (ex->kind == EK_BICALL) {
+ if (!strcmp(ex->val.s, strsubname)) {
+ if (isliteralconst(ex->args[3], &val) && val.type)
+ return val.i;
+ }
+ }
+ if (ord_range(type->indextype, NULL, &smax))
+ return smax;
+ else
+ return stringceiling;
+}
+
+
+
+
+int strhasnull(val)
+Value val;
+{
+ int i;
+
+ for (i = 0; i < val.i; i++) {
+ if (!val.s[i])
+ return (i == val.i-1) ? 1 : 2;
+ }
+ return 0;
+}
+
+
+
+int istempsprintf(ex)
+Expr *ex;
+{
+ return (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
+ ex->nargs >= 2 &&
+ istempvar(ex->args[0]) &&
+ ex->args[1]->kind == EK_CONST &&
+ ex->args[1]->val.type->kind == TK_STRING);
+}
+
+
+
+Expr *makeexpr_sprintfify(ex)
+Expr *ex;
+{
+ Meaning *tvar;
+ char stringbuf[500];
+ char *cp, ch;
+ int j, nnulls;
+ Expr *ex2;
+
+ if (debug>2) { fprintf(outf,"makeexpr_sprintfify("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (istempsprintf(ex))
+ return ex;
+ ex = makeexpr_stringcast(ex);
+ tvar = makestmttempvar(tp_str255, name_STRING);
+ if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING) {
+ cp = stringbuf;
+ nnulls = 0;
+ for (j = 0; j < ex->val.i; j++) {
+ ch = ex->val.s[j];
+ if (!ch) {
+ if (j < ex->val.i-1)
+ note("Null character in sprintf control string [147]");
+ else
+ note("Null character at end of sprintf control string [148]");
+ if (keepnulls) {
+ *cp++ = '%';
+ *cp++ = 'c';
+ nnulls++;
+ }
+ } else {
+ *cp++ = ch;
+ if (ch == '%')
+ *cp++ = ch;
+ }
+ }
+ *cp = 0;
+ ex = makeexpr_bicall_2("sprintf", tp_str255,
+ makeexpr_var(tvar),
+ makeexpr_string(stringbuf));
+ while (--nnulls >= 0)
+ insertarg(&ex, 2, makeexpr_char(0));
+ return ex;
+ } else if (ex->val.type->kind == TK_ARRAY &&
+ ex->val.type->basetype->kind == TK_CHAR) {
+ ex2 = arraysize(ex->val.type, 0);
+ return cleansprintf(
+ makeexpr_bicall_4("sprintf", tp_str255,
+ makeexpr_var(tvar),
+ makeexpr_string("%.*s"),
+ ex2,
+ makeexpr_addrstr(ex)));
+ } else {
+ if (ord_type(ex->val.type)->kind == TK_CHAR)
+ cp = "%c";
+ else if (ex->val.type->kind == TK_STRING)
+ cp = "%s";
+ else {
+ warning("Mixing non-strings with strings [170]");
+ return ex;
+ }
+ return makeexpr_bicall_3("sprintf", tp_str255,
+ makeexpr_var(tvar),
+ makeexpr_string(cp),
+ ex);
+ }
+}
+
+
+
+Expr *makeexpr_unsprintfify(ex)
+Expr *ex;
+{
+ char stringbuf[500];
+ char *cp, ch;
+ int i;
+
+ if (debug>2) { fprintf(outf,"makeexpr_unsprintfify("); dumpexpr(ex); fprintf(outf,")\n"); }
+ if (!istempsprintf(ex))
+ return ex;
+ canceltempvar(istempvar(ex->args[0]));
+ for (i = 2; i < ex->nargs; i++) {
+ if (ex->args[i]->val.type->kind != TK_CHAR ||
+ !checkconst(ex, 0))
+ return ex;
+ }
+ cp = stringbuf;
+ for (i = 0; i < ex->args[1]->val.i; i++) {
+ ch = ex->args[1]->val.s[i];
+ *cp++ = ch;
+ if (ch == '%') {
+ if (++i == ex->args[1]->val.i)
+ return ex;
+ ch = ex->args[1]->val.s[i];
+ if (ch == 'c')
+ cp[-1] = 0;
+ else if (ch != '%')
+ return ex;
+ }
+ }
+ freeexpr(ex);
+ return makeexpr_lstring(stringbuf, cp - stringbuf);
+}
+
+
+
+/* Returns >= 0 iff unsprintfify would return a string constant */
+
+int sprintflength(ex, allownulls)
+Expr *ex;
+int allownulls;
+{
+ int i, len;
+
+ if (!istempsprintf(ex))
+ return -1;
+ for (i = 2; i < ex->nargs; i++) {
+ if (!allownulls ||
+ ex->args[i]->val.type->kind != TK_CHAR ||
+ !checkconst(ex, 0))
+ return -1;
+ }
+ len = 0;
+ for (i = 0; i < ex->args[1]->val.i; i++) {
+ len++;
+ if (ex->args[1]->val.s[i] == '%') {
+ if (++i == ex->args[1]->val.i)
+ return -1;
+ if (ex->args[1]->val.s[i] != 'c' &&
+ ex->args[1]->val.s[i] != '%')
+ return -1;
+ }
+ }
+ return len;
+}
+
+
+
+Expr *makeexpr_concat(a, b, usesprintf)
+Expr *a, *b;
+int usesprintf;
+{
+ int i, ii, j, len, nargs;
+ Type *type;
+ Meaning *mp, *tvar;
+ Expr *ex, *args[2];
+ int akind[2];
+ Value val, val1, val2;
+ char formatstr[300];
+
+ if (debug>2) { fprintf(outf,"makeexpr_concat("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
+ if (!a)
+ return b;
+ if (!b)
+ return a;
+ a = makeexpr_stringcast(a);
+ b = makeexpr_stringcast(b);
+ if (checkconst(a, 0)) {
+ freeexpr(a);
+ return b;
+ }
+ if (checkconst(b, 0)) {
+ freeexpr(b);
+ return a;
+ }
+ len = strmax(a) + strmax(b);
+ type = makestringtype(len);
+ if (a->kind == EK_CONST && b->kind == EK_CONST) {
+ val1 = a->val;
+ val2 = b->val;
+ val.i = val1.i + val2.i;
+ val.s = ALLOC(val.i+1, char, literals);
+ val.s[val.i] = 0;
+ val.type = type;
+ memcpy(val.s, val1.s, val1.i);
+ memcpy(val.s + val1.i, val2.s, val2.i);
+ freeexpr(a);
+ freeexpr(b);
+ return makeexpr_val(val);
+ }
+ tvar = makestmttempvar(type, name_STRING);
+ if (sprintf_value != 2 || usesprintf) {
+ nargs = 2; /* Generate a call to sprintf(), unfolding */
+ args[0] = a; /* nested sprintf()'s. */
+ args[1] = b;
+ *formatstr = 0;
+ for (i = 0; i < 2; i++) {
+#if 1
+ ex = args[i] = makeexpr_sprintfify(args[i]);
+ if (!ex->args[1] || !ex->args[1]->val.s)
+ intwarning("makeexpr_concat", "NULL in ex->args[1]");
+ else
+ strncat(formatstr, ex->args[1]->val.s, ex->args[1]->val.i);
+ canceltempvar(istempvar(ex->args[0]));
+ nargs += (ex->nargs - 2);
+ akind[i] = 0; /* now obsolete */
+#else
+ ex = args[i];
+ if (ex->kind == EK_CONST)
+ ex = makeexpr_sprintfify(ex);
+ if (istempsprintf(ex)) {
+ strncat(formatstr, ex->args[1]->val.s, ex->args[1]->val.i);
+ canceltempvar(istempvar(ex->args[0]));
+ nargs += (ex->nargs - 2);
+ akind[i] = 0;
+ } else {
+ strcat(formatstr, "%s");
+ nargs++;
+ akind[i] = 1;
+ }
+#endif
+ }
+ ex = makeexpr(EK_BICALL, nargs);
+ ex->val.type = type;
+ ex->val.s = stralloc("sprintf");
+ ex->args[0] = makeexpr_var(tvar);
+ ex->args[1] = makeexpr_string(formatstr);
+ j = 2;
+ for (i = 0; i < 2; i++) {
+ switch (akind[i]) {
+ case 0: /* flattened sub-sprintf */
+ for (ii = 2; ii < args[i]->nargs; ii++)
+ ex->args[j++] = copyexpr(args[i]->args[ii]);
+ freeexpr(args[i]);
+ break;
+ case 1: /* included string expr */
+ ex->args[j++] = args[i];
+ break;
+ }
+ }
+ } else {
+ ex = a;
+ while (ex->kind == EK_BICALL && !strcmp(ex->val.s, "strcat"))
+ ex = ex->args[0];
+ if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "strcpy") &&
+ (mp = istempvar(ex->args[0])) != NULL) {
+ canceltempvar(mp);
+ freeexpr(ex->args[0]);
+ ex->args[0] = makeexpr_var(tvar);
+ } else {
+ a = makeexpr_bicall_2("strcpy", type, makeexpr_var(tvar), a);
+ }
+ ex = makeexpr_bicall_2("strcat", type, a, b);
+ }
+ if (debug>2) { fprintf(outf,"makeexpr_concat returns "); dumpexpr(ex); fprintf(outf,"\n"); }
+ return ex;
+}
+
+
+
+Expr *cleansprintf(ex)
+Expr *ex;
+{
+ int fidx, i, j, k, len, changed = 0;
+ char *cp, *bp;
+ char fmtbuf[300];
+
+ if (ex->kind != EK_BICALL)
+ return ex;
+ if (!strcmp(ex->val.s, "printf"))
+ fidx = 0;
+ else if (!strcmp(ex->val.s, "sprintf") ||
+ !strcmp(ex->val.s, "fprintf"))
+ fidx = 1;
+ else
+ return ex;
+ len = ex->args[fidx]->val.i;
+ cp = ex->args[fidx]->val.s; /* printf("%*d",17,x) => printf("%17d",x) */
+ bp = fmtbuf;
+ j = fidx + 1;
+ for (i = 0; i < len; i++) {
+ *bp++ = cp[i];
+ if (cp[i] == '%') {
+ if (cp[i+1] == 's' && ex->args[j]->kind == EK_CONST) {
+ bp--;
+ for (k = 0; k < ex->args[j]->val.i; k++)
+ *bp++ = ex->args[j]->val.s[k];
+ delfreearg(&ex, j);
+ changed = 1;
+ i++;
+ continue;
+ }
+ for (i++; i < len &&
+ !(isalpha(cp[i]) && cp[i] != 'l'); i++) {
+ if (cp[i] == '*') {
+ if (isliteralconst(ex->args[j], NULL) == 2) {
+ sprintf(bp, "%ld", ex->args[j]->val.i);
+ bp += strlen(bp);
+ delfreearg(&ex, j);
+ changed = 1;
+ } else {
+ *bp++ = cp[i];
+ j++;
+ }
+ } else
+ *bp++ = cp[i];
+ }
+ if (i < len)
+ *bp++ = cp[i];
+ j++;
+ }
+ }
+ *bp = 0;
+ if (changed) {
+ freeexpr(ex->args[fidx]);
+ ex->args[fidx] = makeexpr_string(fmtbuf);
+ }
+ return ex;
+}
+
+
+
+Expr *makeexpr_substring(vex, ex, exi, exj)
+Expr *vex, *ex, *exi, *exj;
+{
+ exi = makeexpr_unlongcast(exi);
+ exj = makeexpr_longcast(exj, 0);
+ ex = bumpstring(ex, exi, 1);
+ return cleansprintf(makeexpr_bicall_4("sprintf", tp_str255,
+ vex,
+ makeexpr_string("%.*s"),
+ exj,
+ ex));
+}
+
+
+
+
+Expr *makeexpr_dot(ex, mp)
+Expr *ex;
+Meaning *mp;
+{
+ Type *ot1, *ot2;
+ Expr *ex2, *ex3, *nex;
+ Meaning *tvar;
+
+ if (ex->kind == EK_FUNCTION && copystructfuncs > 0) {
+ tvar = makestmttempvar(ex->val.type, name_TEMP);
+ ex2 = makeexpr_assign(makeexpr_var(tvar), ex);
+ ex = makeexpr_var(tvar);
+ } else
+ ex2 = NULL;
+ if (mp->constdefn) {
+ nex = makeexpr(EK_MACARG, 0);
+ nex->val.type = tp_integer;
+ ex3 = replaceexprexpr(copyexpr(mp->constdefn), nex, ex, 0);
+ freeexpr(ex);
+ freeexpr(nex);
+ ex = gentle_cast(ex3, mp->val.type);
+ } else {
+ ex = makeexpr_un(EK_DOT, mp->type, ex);
+ ex->val.i = (long)mp;
+ ot1 = ord_type(mp->type);
+ ot2 = ord_type(mp->val.type);
+ if (ot1->kind != ot2->kind && ot2->kind == TK_ENUM && ot2->meaning && useenum)
+ ex = makeexpr_cast(ex, mp->val.type);
+ else if (mp->val.i && !hassignedchar &&
+ (mp->type == tp_sint || mp->type == tp_abyte)) {
+ if (*signextname) {
+ ex = makeexpr_bicall_2(signextname, tp_integer,
+ ex, makeexpr_long(mp->val.i));
+ } else
+ note(format_s("Unable to sign-extend field %s [149]", mp->name));
+ }
+ }
+ ex->val.type = mp->val.type;
+ return makeexpr_comma(ex2, ex);
+}
+
+
+
+Expr *makeexpr_dotq(ex, name, type)
+Expr *ex;
+char *name;
+Type *type;
+{
+ ex = makeexpr_un(EK_DOT, type, ex);
+ ex->val.s = stralloc(name);
+ return ex;
+}
+
+
+
+Expr *strmax_func(ex)
+Expr *ex;
+{
+ Meaning *mp;
+ Expr *ex2;
+ Type *type;
+
+ type = ex->val.type;
+ if (type->kind == TK_POINTER) {
+ intwarning("strmax_func", "got a pointer instead of a string [171]");
+ type = type->basetype;
+ }
+ if (type->kind == TK_CHAR)
+ return makeexpr_long(1);
+ if (type->kind != TK_STRING) {
+ warning("STRMAX of non-string value [172]");
+ return makeexpr_long(stringceiling);
+ }
+ if (ex->kind == EK_CONST)
+ return makeexpr_long(ex->val.i);
+ if (ex->kind == EK_VAR &&
+ (mp = (Meaning *)ex->val.i)->kind == MK_CONST &&
+ mp->type == tp_str255 && mp->val.type)
+ return makeexpr_long(mp->val.i);
+ if (ex->kind == EK_VAR &&
+ (mp = (Meaning *)ex->val.i)->kind == MK_VARPARAM &&
+ mp->type == tp_strptr) {
+ if (mp->anyvarflag) {
+ if (mp->ctx != curctx && mp->ctx->kind == MK_FUNCTION)
+ note(format_s("Reference to STRMAX of parent proc's \"%s\" must be fixed [150]",
+ mp->name));
+ return makeexpr_name(format_s(name_STRMAX, mp->name), tp_int);
+ } else
+ note(format_s("STRMAX of \"%s\" wants VarStrings=1 [151]", mp->name));
+ }
+ ord_range_expr(type->indextype, NULL, &ex2);
+ return copyexpr(ex2);
+}
+
+
+
+
+Expr *makeexpr_nil()
+{
+ Expr *ex;
+
+ ex = makeexpr(EK_CONST, 0);
+ ex->val.type = tp_anyptr;
+ ex->val.i = 0;
+ ex->val.s = NULL;
+ return ex;
+}
+
+
+
+Expr *makeexpr_ctx(ctx)
+Meaning *ctx;
+{
+ Expr *ex;
+
+ ex = makeexpr(EK_CTX, 0);
+ ex->val.type = tp_text; /* handy pointer type */
+ ex->val.i = (long)ctx;
+ return ex;
+}
+
+
+
+
+Expr *force_signed(ex)
+Expr *ex;
+{
+ Type *tp;
+
+ if (isliteralconst(ex, NULL) == 2 && ex->nargs == 0)
+ return ex;
+ tp = true_type(ex);
+ if (tp == tp_ushort || tp == tp_ubyte || tp == tp_uchar)
+ return makeexpr_cast(ex, tp_sshort);
+ else if (tp == tp_unsigned || tp == tp_uint) {
+ if (exprlongness(ex) < 0)
+ return makeexpr_cast(ex, tp_sint);
+ else
+ return makeexpr_cast(ex, tp_integer);
+ }
+ return ex;
+}
+
+
+
+Expr *force_unsigned(ex)
+Expr *ex;
+{
+ Type *tp;
+
+ if (isliteralconst(ex, NULL) == 2 && !expr_is_neg(ex))
+ return ex;
+ tp = true_type(ex);
+ if (tp == tp_unsigned || tp == tp_uint || tp == tp_ushort ||
+ tp == tp_ubyte || tp == tp_uchar)
+ return ex;
+ if (tp->kind == TK_CHAR)
+ return makeexpr_actcast(ex, tp_uchar);
+ else if (exprlongness(ex) < 0)
+ return makeexpr_cast(ex, tp_uint);
+ else
+ return makeexpr_cast(ex, tp_unsigned);
+}
+
+
+
+
+#define CHECKSIZE(size) (((size) > 0 && (size)%charsize == 0) ? (size)/charsize : 0)
+
+long type_sizeof(type, pasc)
+Type *type;
+int pasc;
+{
+ long s1, smin, smax;
+ int charsize = (sizeof_char) ? sizeof_char : CHAR_BIT; /* from <limits.h> */
+
+ switch (type->kind) {
+
+ case TK_INTEGER:
+ if (type == tp_integer ||
+ type == tp_unsigned)
+ return pasc ? 4 : CHECKSIZE(sizeof_integer);
+ else
+ return pasc ? 2 : CHECKSIZE(sizeof_short);
+
+ case TK_CHAR:
+ case TK_BOOLEAN:
+ return 1;
+
+ case TK_SUBR:
+ type = findbasetype(type, ODECL_NOPRES);
+ if (pasc) {
+ if (type == tp_integer || type == tp_unsigned)
+ return 4;
+ else
+ return 2;
+ } else {
+ if (type == tp_abyte || type == tp_ubyte || type == tp_sbyte)
+ return 1;
+ else if (type == tp_ushort || type == tp_sshort)
+ return CHECKSIZE(sizeof_short);
+ else
+ return CHECKSIZE(sizeof_integer);
+ }
+
+ case TK_POINTER:
+ return pasc ? 4 : CHECKSIZE(sizeof_pointer);
+
+ case TK_REAL:
+ if (type == tp_longreal)
+ return pasc ? (which_lang == LANG_TURBO ? 6 : 8) : CHECKSIZE(sizeof_double);
+ else
+ return pasc ? 4 : CHECKSIZE(sizeof_float);
+
+ case TK_ENUM:
+ if (!pasc)
+ return CHECKSIZE(sizeof_enum);
+ type = findbasetype(type, ODECL_NOPRES);
+ return type->kind != TK_ENUM ? type_sizeof(type, pasc)
+ : CHECKSIZE(pascalenumsize);
+
+ case TK_SMALLSET:
+ case TK_SMALLARRAY:
+ return pasc ? 0 : type_sizeof(type->basetype, pasc);
+
+ case TK_ARRAY:
+ s1 = type_sizeof(type->basetype, pasc);
+ if (s1 && ord_range(type->indextype, &smin, &smax))
+ return s1 * (smax - smin + 1);
+ else
+ return 0;
+
+ case TK_RECORD:
+ if (pasc && type->meaning) {
+ if (!strcmp(type->meaning->sym->name, "NA_WORD"))
+ return 2;
+ else if (!strcmp(type->meaning->sym->name, "NA_LONGWORD"))
+ return 4;
+ else if (!strcmp(type->meaning->sym->name, "NA_QUADWORD"))
+ return 8;
+ else
+ return 0;
+ } else
+ return 0;
+
+ default:
+ return 0;
+ }
+}
+
+
+
+Static Value eval_expr_either(ex, pasc)
+Expr *ex;
+int pasc;
+{
+ Value val, val2;
+ Meaning *mp;
+ int i;
+
+ if (debug>2) { fprintf(outf,"eval_expr("); dumpexpr(ex); fprintf(outf,")\n"); }
+ switch (ex->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ return ex->val;
+
+ case EK_VAR:
+ mp = (Meaning *) ex->val.i;
+ if (mp->kind == MK_CONST &&
+ (foldconsts != 0 ||
+ mp == mp_maxint || mp == mp_minint))
+ return mp->val;
+ break;
+
+ case EK_SIZEOF:
+ i = type_sizeof(ex->args[0]->val.type, pasc);
+ if (i)
+ return make_ord(tp_integer, i);
+ break;
+
+ case EK_PLUS:
+ val = eval_expr_either(ex->args[0], pasc);
+ if (!val.type || ord_type(val.type)->kind != TK_INTEGER)
+ val.type = NULL;
+ for (i = 1; val.type && i < ex->nargs; i++) {
+ val2 = eval_expr_either(ex->args[i], pasc);
+ if (!val2.type || ord_type(val2.type)->kind != TK_INTEGER)
+ val.type = NULL;
+ else {
+ val.i += val2.i;
+ val.type = tp_integer;
+ }
+ }
+ return val;
+
+ case EK_TIMES:
+ val = eval_expr_either(ex->args[0], pasc);
+ if (!val.type || ord_type(val.type)->kind != TK_INTEGER)
+ val.type = NULL;
+ for (i = 1; val.type && i < ex->nargs; i++) {
+ val2 = eval_expr_either(ex->args[i], pasc);
+ if (!val2.type || ord_type(val2.type)->kind != TK_INTEGER)
+ val.type = NULL;
+ else {
+ val.i *= val2.i;
+ val.type = tp_integer;
+ }
+ }
+ return val;
+
+ case EK_DIV:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type && ord_type(val.type)->kind == TK_INTEGER &&
+ val2.type && ord_type(val2.type)->kind == TK_INTEGER &&
+ val2.i) {
+ val.i /= val2.i;
+ val.type = tp_integer;
+ return val;
+ }
+ break;
+
+ case EK_MOD:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type && ord_type(val.type)->kind == TK_INTEGER &&
+ val2.type && ord_type(val2.type)->kind == TK_INTEGER &&
+ val2.i) {
+ val.i %= val2.i;
+ val.type = tp_integer;
+ return val;
+ }
+ break;
+
+ case EK_NEG:
+ val = eval_expr_either(ex->args[0], pasc);
+ if (val.type) {
+ val.i = -val.i;
+ return val;
+ }
+ break;
+
+ case EK_LSH:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type && val2.type) {
+ val.i <<= val2.i;
+ return val;
+ }
+ break;
+
+ case EK_RSH:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type && val2.type) {
+ val.i >>= val2.i;
+ return val;
+ }
+ break;
+
+ case EK_BAND:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type && val2.type) {
+ val.i &= val2.i;
+ return val;
+ }
+ break;
+
+ case EK_BOR:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type && val2.type) {
+ val.i |= val2.i;
+ return val;
+ }
+ break;
+
+ case EK_BXOR:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type && val2.type) {
+ val.i ^= val2.i;
+ return val;
+ }
+ break;
+
+ case EK_BNOT:
+ val = eval_expr_either(ex->args[0], pasc);
+ if (val.type) {
+ val.i = ~val.i;
+ return val;
+ }
+ break;
+
+ case EK_EQ:
+ case EK_NE:
+ case EK_GT:
+ case EK_LT:
+ case EK_GE:
+ case EK_LE:
+ val = eval_expr_either(ex->args[0], pasc);
+ val2 = eval_expr_either(ex->args[1], pasc);
+ if (val.type) {
+ if (val.i == val2.i)
+ val.i = (ex->kind == EK_EQ || ex->kind == EK_GE || ex->kind == EK_LE);
+ else if (val.i < val2.i)
+ val.i = (ex->kind == EK_LT || ex->kind == EK_LE || ex->kind == EK_NE);
+ else
+ val.i = (ex->kind == EK_GT || ex->kind == EK_GE || ex->kind == EK_NE);
+ val.type = tp_boolean;
+ return val;
+ }
+ break;
+
+ case EK_NOT:
+ val = eval_expr_either(ex->args[0], pasc);
+ if (val.type)
+ val.i = !val.i;
+ return val;
+
+ case EK_AND:
+ for (i = 0; i < ex->nargs; i++) {
+ val = eval_expr_either(ex->args[i], pasc);
+ if (!val.type || !val.i)
+ return val;
+ }
+ return val;
+
+ case EK_OR:
+ for (i = 0; i < ex->nargs; i++) {
+ val = eval_expr_either(ex->args[i], pasc);
+ if (!val.type || val.i)
+ return val;
+ }
+ return val;
+
+ case EK_COMMA:
+ return eval_expr_either(ex->args[ex->nargs-1], pasc);
+
+ default:
+ break;
+ }
+ val.type = NULL;
+ return val;
+}
+
+
+Value eval_expr(ex)
+Expr *ex;
+{
+ return eval_expr_either(ex, 0);
+}
+
+
+Value eval_expr_consts(ex)
+Expr *ex;
+{
+ Value val;
+ short save_fold = foldconsts;
+
+ foldconsts = 1;
+ val = eval_expr_either(ex, 0);
+ foldconsts = save_fold;
+ return val;
+}
+
+
+Value eval_expr_pasc(ex)
+Expr *ex;
+{
+ return eval_expr_either(ex, 1);
+}
+
+
+
+int expr_is_const(ex)
+Expr *ex;
+{
+ int i;
+
+ switch (ex->kind) {
+
+ case EK_CONST:
+ case EK_LONGCONST:
+ case EK_SIZEOF:
+ return 1;
+
+ case EK_VAR:
+ return (((Meaning *)ex->val.i)->kind == MK_CONST);
+
+ case EK_HAT:
+ case EK_ASSIGN:
+ case EK_POSTINC:
+ case EK_POSTDEC:
+ return 0;
+
+ case EK_ADDR:
+ if (ex->args[0]->kind == EK_VAR)
+ return 1;
+ return 0; /* conservative */
+
+ case EK_FUNCTION:
+ if (!nosideeffects_func(ex))
+ return 0;
+ break;
+
+ case EK_BICALL:
+ if (!nosideeffects_func(ex))
+ return 0;
+ break;
+
+ default:
+ break;
+ }
+ for (i = 0; i < ex->nargs; i++) {
+ if (!expr_is_const(ex->args[i]))
+ return 0;
+ }
+ return 1;
+}
+
+
+
+
+
+Expr *eatcasts(ex)
+Expr *ex;
+{
+ while (ex->kind == EK_CAST)
+ ex = grabarg(ex, 0);
+ return ex;
+}
+
+
+
+
+
+/* End. */
+
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/funcs.c b/MultiSource/Benchmarks/MallocBench/p2c/funcs.c
new file mode 100644
index 00000000..5ec410d7
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/funcs.c
@@ -0,0 +1,5405 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_FUNCS_C
+#include "trans.h"
+
+
+
+
+Static Strlist *enumnames;
+Static int enumnamecount;
+
+
+
+void setup_funcs()
+{
+ enumnames = NULL;
+ enumnamecount = 0;
+}
+
+
+
+
+
+int isvar(ex, mp)
+Expr *ex;
+Meaning *mp;
+{
+ return (ex->kind == EK_VAR && (Meaning *)ex->val.i == mp);
+}
+
+
+
+
+char *getstring(ex)
+Expr *ex;
+{
+ ex = makeexpr_stringify(ex);
+ if (ex->kind != EK_CONST || ex->val.type->kind != TK_STRING) {
+ intwarning("getstring", "Not a string literal [206]");
+ return "";
+ }
+ return ex->val.s;
+}
+
+
+
+
+Expr *p_parexpr(target)
+Type *target;
+{
+ Expr *ex;
+
+ if (wneedtok(TOK_LPAR)) {
+ ex = p_expr(target);
+ if (!wneedtok(TOK_RPAR))
+ skippasttotoken(TOK_RPAR, TOK_SEMI);
+ } else
+ ex = p_expr(target);
+ return ex;
+}
+
+
+
+Type *argbasetype(ex)
+Expr *ex;
+{
+ if (ex->kind == EK_CAST)
+ ex = ex->args[0];
+ if (ex->val.type->kind == TK_POINTER)
+ return ex->val.type->basetype;
+ else
+ return ex->val.type;
+}
+
+
+
+Type *choosetype(t1, t2)
+Type *t1, *t2;
+{
+ if (t1 == tp_void ||
+ (type_sizeof(t2, 1) && !type_sizeof(t1, 1)))
+ return t2;
+ else
+ return t1;
+}
+
+
+
+Expr *convert_offset(type, ex2)
+Type *type;
+Expr *ex2;
+{
+ long size;
+ int i;
+ Value val;
+ Expr *ex3;
+
+ if (type->kind == TK_POINTER ||
+ type->kind == TK_ARRAY ||
+ type->kind == TK_SET ||
+ type->kind == TK_STRING)
+ type = type->basetype;
+ size = type_sizeof(type, 1);
+ if (size == 1)
+ return ex2;
+ val = eval_expr_pasc(ex2);
+ if (val.type) {
+ if (val.i == 0)
+ return ex2;
+ if (size && val.i % size == 0) {
+ freeexpr(ex2);
+ return makeexpr_long(val.i / size);
+ }
+ } else { /* look for terms like "n*sizeof(foo)" */
+ while (ex2->kind == EK_CAST || ex2->kind == EK_ACTCAST)
+ ex2 = ex2->args[0];
+ if (ex2->kind == EK_TIMES) {
+ for (i = 0; i < ex2->nargs; i++) {
+ ex3 = convert_offset(type, ex2->args[i]);
+ if (ex3) {
+ ex2->args[i] = ex3;
+ return resimplify(ex2);
+ }
+ }
+ for (i = 0;
+ i < ex2->nargs && ex2->args[i]->kind != EK_SIZEOF;
+ i++) ;
+ if (i < ex2->nargs) {
+ if (ex2->args[i]->args[0]->val.type == type) {
+ delfreearg(&ex2, i);
+ if (ex2->nargs == 1)
+ return ex2->args[0];
+ else
+ return ex2;
+ }
+ }
+ } else if (ex2->kind == EK_PLUS) {
+ ex3 = copyexpr(ex2);
+ for (i = 0; i < ex2->nargs; i++) {
+ ex3->args[i] = convert_offset(type, ex3->args[i]);
+ if (!ex3->args[i]) {
+ freeexpr(ex3);
+ return NULL;
+ }
+ }
+ freeexpr(ex2);
+ return resimplify(ex3);
+ } else if (ex2->kind == EK_SIZEOF) {
+ if (ex2->args[0]->val.type == type) {
+ freeexpr(ex2);
+ return makeexpr_long(1);
+ }
+ } else if (ex2->kind == EK_NEG) {
+ ex3 = convert_offset(type, ex2->args[0]);
+ if (ex3)
+ return makeexpr_neg(ex3);
+ }
+ }
+ return NULL;
+}
+
+
+
+Expr *convert_size(type, ex, name)
+Type *type;
+Expr *ex;
+char *name;
+{
+ long size;
+ Expr *ex2;
+ int i, okay;
+ Value val;
+
+ if (debug>2) { fprintf(outf,"convert_size("); dumpexpr(ex); fprintf(outf,")\n"); }
+ while (type->kind == TK_ARRAY || type->kind == TK_STRING)
+ type = type->basetype;
+ if (type == tp_void)
+ return ex;
+ size = type_sizeof(type, 1);
+ if (size == 1)
+ return ex;
+ while (ex->kind == EK_CAST || ex->kind == EK_ACTCAST)
+ ex = ex->args[0];
+ switch (ex->kind) {
+
+ case EK_TIMES:
+ for (i = 0; i < ex->nargs; i++) {
+ ex2 = convert_size(type, ex->args[i], NULL);
+ if (ex2) {
+ ex->args[i] = ex2;
+ return resimplify(ex);
+ }
+ }
+ break;
+
+ case EK_PLUS:
+ okay = 1;
+ for (i = 0; i < ex->nargs; i++) {
+ ex2 = convert_size(type, ex->args[i], NULL);
+ if (ex2)
+ ex->args[i] = ex2;
+ else
+ okay = 0;
+ }
+ ex = distribute_plus(ex);
+ if ((ex->kind != EK_TIMES || !okay) && name)
+ note(format_s("Suspicious mixture of sizes in %s [173]", name));
+ return ex;
+
+ case EK_SIZEOF:
+ return ex;
+
+ default:
+ break;
+ }
+ val = eval_expr_pasc(ex);
+ if (val.type) {
+ if (val.i == 0)
+ return ex;
+ if (size && val.i % size == 0) {
+ freeexpr(ex);
+ return makeexpr_times(makeexpr_long(val.i / size),
+ makeexpr_sizeof(makeexpr_type(type), 0));
+ }
+ }
+ if (name) {
+ note(format_s("Can't interpret size in %s [174]", name));
+ return ex;
+ } else
+ return NULL;
+}
+
+
+
+
+
+
+
+
+
+
+
+
+Static Expr *func_abs()
+{
+ Expr *ex;
+ Meaning *tvar;
+ int lness;
+
+ ex = p_parexpr(tp_integer);
+ if (ex->val.type->kind == TK_REAL)
+ return makeexpr_bicall_1("fabs", tp_longreal, ex);
+ else {
+ lness = exprlongness(ex);
+ if (lness < 0)
+ return makeexpr_bicall_1("abs", tp_int, ex);
+ else if (lness > 0 && *absname) {
+ if (ansiC > 0) {
+ return makeexpr_bicall_1("labs", tp_integer, ex);
+ } else if (*absname == '*' && (exprspeed(ex) >= 5 || !nosideeffects(ex, 0))) {
+ tvar = makestmttempvar(tp_integer, name_TEMP);
+ return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar),
+ ex),
+ makeexpr_bicall_1(absname, tp_integer,
+ makeexpr_var(tvar)));
+ } else {
+ return makeexpr_bicall_1(absname, tp_integer, ex);
+ }
+ } else if (exprspeed(ex) < 5 && nosideeffects(ex, 0)) {
+ return makeexpr_cond(makeexpr_rel(EK_LT, copyexpr(ex),
+ makeexpr_long(0)),
+ makeexpr_neg(copyexpr(ex)),
+ ex);
+ } else {
+ tvar = makestmttempvar(tp_integer, name_TEMP);
+ return makeexpr_cond(makeexpr_rel(EK_LT, makeexpr_assign(makeexpr_var(tvar),
+ ex),
+ makeexpr_long(0)),
+ makeexpr_neg(makeexpr_var(tvar)),
+ makeexpr_var(tvar));
+ }
+ }
+}
+
+
+
+Static Expr *func_addr()
+{
+ Expr *ex, *ex2, *ex3;
+ Type *type, *tp2;
+ int haspar;
+
+ haspar = wneedtok(TOK_LPAR);
+ ex = p_expr(tp_proc);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ ex2 = p_expr(tp_integer);
+ ex3 = convert_offset(ex->val.type, ex2);
+ if (checkconst(ex3, 0)) {
+ ex = makeexpr_addrf(ex);
+ } else {
+ ex = makeexpr_addrf(ex);
+ if (ex3) {
+ ex = makeexpr_plus(ex, ex3);
+ } else {
+ note("Don't know how to reduce offset for ADDR [175]");
+ type = makepointertype(tp_abyte);
+ tp2 = ex->val.type;
+ ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
+ }
+ }
+ } else {
+ if ((ex->val.type->kind != TK_PROCPTR &&
+ ex->val.type->kind != TK_CPROCPTR) ||
+ (ex->kind == EK_VAR &&
+ ex->val.type == ((Meaning *)ex->val.i)->type))
+ ex = makeexpr_addrf(ex);
+ }
+ if (haspar) {
+ if (!wneedtok(TOK_RPAR))
+ skippasttotoken(TOK_RPAR, TOK_SEMI);
+ }
+ return ex;
+}
+
+
+Static Expr *func_iaddress()
+{
+ return makeexpr_cast(func_addr(), tp_integer);
+}
+
+
+
+Static Expr *func_addtopointer()
+{
+ Expr *ex, *ex2, *ex3;
+ Type *type, *tp2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_anyptr);
+ if (skipcomma()) {
+ ex2 = p_expr(tp_integer);
+ } else
+ ex2 = makeexpr_long(0);
+ skipcloseparen();
+ ex3 = convert_offset(ex->val.type, ex2);
+ if (!checkconst(ex3, 0)) {
+ if (ex3) {
+ ex = makeexpr_plus(ex, ex3);
+ } else {
+ note("Don't know how to reduce offset for ADDTOPOINTER [175]");
+ type = makepointertype(tp_abyte);
+ tp2 = ex->val.type;
+ ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
+ }
+ }
+ return ex;
+}
+
+
+
+Stmt *proc_assert()
+{
+ Expr *ex;
+
+ ex = p_parexpr(tp_boolean);
+ return makestmt_call(makeexpr_bicall_1("assert", tp_void, ex));
+}
+
+
+
+Stmt *wrapopencheck(sp, fex)
+Stmt *sp;
+Expr *fex;
+{
+ Stmt *sp2;
+
+ if (FCheck(checkfileisopen) && !is_std_file(fex)) {
+ sp2 = makestmt(SK_IF);
+ sp2->exp1 = makeexpr_rel(EK_NE, filebasename(fex), makeexpr_nil());
+ sp2->stm1 = sp;
+ if (iocheck_flag) {
+ sp2->stm2 = makestmt_call(makeexpr_bicall_1(name_ESCIO, tp_integer,
+ makeexpr_name(filenotopenname, tp_int)));
+ } else {
+ sp2->stm2 = makestmt_assign(makeexpr_var(mp_ioresult),
+ makeexpr_name(filenotopenname, tp_int));
+ }
+ return sp2;
+ } else {
+ freeexpr(fex);
+ return sp;
+ }
+}
+
+
+
+Static Expr *checkfilename(nex)
+Expr *nex;
+{
+ Expr *ex;
+
+ nex = makeexpr_stringcast(nex);
+ if (nex->kind == EK_CONST && nex->val.type->kind == TK_STRING) {
+ switch (which_lang) {
+
+ case LANG_HP:
+ if (!strncmp(nex->val.s, "#1:", 3) ||
+ !strncmp(nex->val.s, "console:", 8) ||
+ !strncmp(nex->val.s, "CONSOLE:", 8)) {
+ freeexpr(nex);
+ nex = makeexpr_string("/dev/tty");
+ } else if (!strncmp(nex->val.s, "#2:", 3) ||
+ !strncmp(nex->val.s, "systerm:", 8) ||
+ !strncmp(nex->val.s, "SYSTERM:", 8)) {
+ freeexpr(nex);
+ nex = makeexpr_string("/dev/tty"); /* should do more? */
+ } else if (!strncmp(nex->val.s, "#6:", 3) ||
+ !strncmp(nex->val.s, "printer:", 8) ||
+ !strncmp(nex->val.s, "PRINTER:", 8)) {
+ note("Opening a file named PRINTER: [176]");
+ } else if (my_strchr(nex->val.s, ':')) {
+ note("Opening a file whose name contains a ':' [177]");
+ }
+ break;
+
+ case LANG_TURBO:
+ if (checkstring(nex, "con") ||
+ checkstring(nex, "CON") ||
+ checkstring(nex, "")) {
+ freeexpr(nex);
+ nex = makeexpr_string("/dev/tty");
+ } else if (checkstring(nex, "nul") ||
+ checkstring(nex, "NUL")) {
+ freeexpr(nex);
+ nex = makeexpr_string("/dev/null");
+ } else if (checkstring(nex, "lpt1") ||
+ checkstring(nex, "LPT1") ||
+ checkstring(nex, "lpt2") ||
+ checkstring(nex, "LPT2") ||
+ checkstring(nex, "lpt3") ||
+ checkstring(nex, "LPT3") ||
+ checkstring(nex, "com1") ||
+ checkstring(nex, "COM1") ||
+ checkstring(nex, "com2") ||
+ checkstring(nex, "COM2")) {
+ note("Opening a DOS device file name [178]");
+ }
+ break;
+
+ default:
+ break;
+ }
+ } else {
+ if (*filenamefilter && strcmp(filenamefilter, "0")) {
+ ex = makeexpr_sizeof(copyexpr(nex), 0);
+ nex = makeexpr_bicall_2(filenamefilter, tp_str255, nex, ex);
+ } else
+ nex = makeexpr_stringify(nex);
+ }
+ return nex;
+}
+
+
+
+Static Stmt *assignfilename(fex, nex)
+Expr *fex, *nex;
+{
+ Meaning *mp;
+ Expr *nvex;
+
+ nvex = filenamepart(fex);
+ if (nvex) {
+ freeexpr(fex);
+ return makestmt_call(makeexpr_assign(nvex, nex));
+ } else {
+ mp = isfilevar(fex);
+ if (mp)
+ warning("Don't know how to ASSIGN to a non-explicit file variable [207]");
+ else
+ note("Encountered an ASSIGN statement [179]");
+ return makestmt_call(makeexpr_bicall_2("assign", tp_void, fex, nex));
+ }
+}
+
+
+
+Static Stmt *proc_assign()
+{
+ Expr *fex, *nex;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ nex = checkfilename(p_expr(tp_str255));
+ skipcloseparen();
+ return assignfilename(fex, nex);
+}
+
+
+
+Static Stmt *handleopen(code)
+int code;
+{
+ Stmt *sp, *sp1, *sp2, *spassign;
+ Expr *fex, *nex, *ex, *truenex, *nvex;
+ Meaning *fmp;
+ int needcheckopen = 1;
+ char modebuf[5], *cp;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ fmp = isfilevar(fex);
+ nvex = filenamepart(fex);
+ truenex = NULL;
+ spassign = NULL;
+ if (curtok == TOK_COMMA) {
+ gettok();
+ ex = p_expr(tp_str255);
+ } else
+ ex = NULL;
+ if (ex && (ex->val.type->kind == TK_STRING ||
+ ex->val.type->kind == TK_ARRAY)) {
+ nex = checkfilename(ex);
+ if (nvex) {
+ spassign = assignfilename(copyexpr(fex), nex);
+ nex = nvex;
+ }
+ truenex = nex;
+ if (curtok == TOK_COMMA) {
+ gettok();
+ ex = p_expr(tp_str255);
+ } else
+ ex = NULL;
+ } else if (nvex) {
+ nex = nvex;
+ } else {
+ switch (code) {
+ case 0:
+ if (ex)
+ note("Can't interpret name argument in RESET [180]");
+ break;
+ case 1:
+ note("REWRITE does not specify a name [181]");
+ break;
+ case 2:
+ note("OPEN does not specify a name [181]");
+ break;
+ case 3:
+ note("APPEND does not specify a name [181]");
+ break;
+ }
+ nex = NULL;
+ }
+ if (ex) {
+ if (ord_type(ex->val.type)->kind == TK_INTEGER) {
+ if (!checkconst(ex, 1))
+ note("Ignoring block size in binary file [182]");
+ freeexpr(ex);
+ } else {
+ if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING) {
+ cp = getstring(ex);
+ if (strcicmp(cp, "SHARED"))
+ note(format_s("Ignoring option string \"%s\" in open [183]", cp));
+ } else
+ note("Ignoring option string in open [183]");
+ }
+ }
+ switch (code) {
+
+ case 0: /* reset */
+ strcpy(modebuf, "r");
+ break;
+
+ case 1: /* rewrite */
+ strcpy(modebuf, "w");
+ break;
+
+ case 2: /* open */
+ strcpy(modebuf, openmode);
+ break;
+
+ case 3: /* append */
+ strcpy(modebuf, "a");
+ break;
+
+ }
+ if (!*modebuf) {
+ strcpy(modebuf, "r+");
+ }
+ if (readwriteopen == 2 ||
+ (readwriteopen &&
+ fex->val.type != tp_text &&
+ fex->val.type != tp_bigtext)) {
+ if (!my_strchr(modebuf, '+'))
+ strcat(modebuf, "+");
+ }
+ if (fex->val.type != tp_text &&
+ fex->val.type != tp_bigtext &&
+ binarymode != 0) {
+ if (binarymode == 1)
+ strcat(modebuf, "b");
+ else
+ note("Opening a binary file [184]");
+ }
+ if (!nex && fmp &&
+ !is_std_file(fex) &&
+ literalfilesflag > 0 &&
+ (literalfilesflag == 1 ||
+ strlist_cifind(literalfiles, fmp->name))) {
+ nex = makeexpr_string(fmp->name);
+ }
+ sp1 = NULL;
+ sp2 = NULL;
+ if (!nex || (isfiletype(fex->val.type, 1) && !truenex)) {
+ if (isvar(fex, mp_output)) {
+ note("RESET/REWRITE ignored for file OUTPUT [319]");
+ } else {
+ sp1 = makestmt_call(makeexpr_bicall_1("rewind", tp_void,
+ filebasename(copyexpr(fex))));
+ if (code == 0 || is_std_file(fex)) {
+ sp1 = wrapopencheck(sp1, copyexpr(fex));
+ needcheckopen = 0;
+ } else
+ sp1 = makestmt_if(makeexpr_rel(EK_NE,
+ filebasename(copyexpr(fex)),
+ makeexpr_nil()),
+ sp1,
+ makestmt_assign(filebasename(copyexpr(fex)),
+ makeexpr_bicall_0("tmpfile",
+ tp_text)));
+ }
+ }
+ if (nex || isfiletype(fex->val.type, 1)) {
+ needcheckopen = 1;
+ if (!strcmp(freopenname, "fclose") ||
+ !strcmp(freopenname, "fopen")) {
+ sp2 = makestmt_assign(filebasename(copyexpr(fex)),
+ makeexpr_bicall_2("fopen", tp_text,
+ copyexpr(nex),
+ makeexpr_string(modebuf)));
+ if (!strcmp(freopenname, "fclose")) {
+ sp2 = makestmt_seq(makestmt_if(makeexpr_rel(EK_NE,
+ filebasename(copyexpr(fex)),
+ makeexpr_nil()),
+ makestmt_call(makeexpr_bicall_1("fclose", tp_void,
+ filebasename(copyexpr(fex)))),
+ NULL),
+ sp2);
+ }
+ } else {
+ sp2 = makestmt_assign(filebasename(copyexpr(fex)),
+ makeexpr_bicall_3((*freopenname) ? freopenname : "freopen",
+ tp_text,
+ copyexpr(nex),
+ makeexpr_string(modebuf),
+ filebasename(copyexpr(fex))));
+ if (!*freopenname) {
+ sp2 = makestmt_if(makeexpr_rel(EK_NE, filebasename(copyexpr(fex)),
+ makeexpr_nil()),
+ sp2,
+ makestmt_assign(filebasename(copyexpr(fex)),
+ makeexpr_bicall_2("fopen", tp_text,
+ copyexpr(nex),
+ makeexpr_string(modebuf))));
+ }
+ }
+ }
+ if (!sp1)
+ sp = sp2;
+ else if (!sp2)
+ sp = sp1;
+ else {
+ sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(nex),
+ makeexpr_string("")),
+ sp2, sp1);
+ }
+ if (code == 2 && !*openmode && nex) {
+ sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ,
+ filebasename(copyexpr(fex)),
+ makeexpr_nil()),
+ makestmt_assign(filebasename(copyexpr(fex)),
+ makeexpr_bicall_2("fopen", tp_text,
+ copyexpr(nex),
+ makeexpr_string("w+"))),
+ NULL));
+ }
+ if (nex)
+ freeexpr(nex);
+ if (FCheck(checkfileopen) && needcheckopen) {
+ sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_NE, filebasename(copyexpr(fex)), makeexpr_nil()),
+ makeexpr_name(filenotfoundname, tp_int))));
+ }
+ sp = makestmt_seq(spassign, sp);
+ cp = (code == 0) ? resetbufname : setupbufname;
+ if (*cp && /* (may be eaten later, if buffering isn't needed) */
+ fileisbuffered(fex, 1))
+ sp = makestmt_seq(sp,
+ makestmt_call(
+ makeexpr_bicall_2(cp, tp_void, filebasename(fex),
+ makeexpr_type(filebasetype(fex->val.type)))));
+ else
+ freeexpr(fex);
+ skipcloseparen();
+ return sp;
+}
+
+
+
+Static Stmt *proc_append()
+{
+ return handleopen(3);
+}
+
+
+
+Static Expr *func_arccos(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("acos", tp_longreal, grabarg(ex, 0));
+}
+
+
+Static Expr *func_arcsin(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("asin", tp_longreal, grabarg(ex, 0));
+}
+
+
+Static Expr *func_arctan(ex)
+Expr *ex;
+{
+ ex = grabarg(ex, 0);
+ if (atan2flag && ex->kind == EK_DIVIDE)
+ return makeexpr_bicall_2("atan2", tp_longreal,
+ ex->args[0], ex->args[1]);
+ return makeexpr_bicall_1("atan", tp_longreal, ex);
+}
+
+
+Static Expr *func_arctanh(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("atanh", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Stmt *proc_argv()
+{
+ Expr *ex, *aex, *lex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (skipcomma()) {
+ aex = p_expr(tp_str255);
+ } else
+ return NULL;
+ skipcloseparen();
+ lex = makeexpr_sizeof(copyexpr(aex), 0);
+ aex = makeexpr_addrstr(aex);
+ return makestmt_call(makeexpr_bicall_3("P_sun_argv", tp_void,
+ aex, lex, makeexpr_arglong(ex, 0)));
+}
+
+
+Static Expr *func_asr()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (skipcomma()) {
+ if (signedshift == 0 || signedshift == 2) {
+ ex = makeexpr_bicall_2("P_asr", ex->val.type, ex,
+ p_expr(tp_unsigned));
+ } else {
+ ex = force_signed(ex);
+ ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
+ if (signedshift != 1)
+ note("Assuming >> is an arithmetic shift [320]");
+ }
+ skipcloseparen();
+ }
+ return ex;
+}
+
+
+Static Expr *func_lsl()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (skipcomma()) {
+ ex = makeexpr_bin(EK_LSH, ex->val.type, ex, p_expr(tp_unsigned));
+ skipcloseparen();
+ }
+ return ex;
+}
+
+
+Static Expr *func_lsr()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (skipcomma()) {
+ ex = force_unsigned(ex);
+ ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
+ skipcloseparen();
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_bin()
+{
+ note("Using %b for binary printf format [185]");
+ return handle_vax_hex(NULL, "b", 1);
+}
+
+
+
+Static Expr *func_binary(ex)
+Expr *ex;
+{
+ char *cp;
+
+ ex = grabarg(ex, 0);
+ if (ex->kind == EK_CONST) {
+ cp = getstring(ex);
+ ex = makeexpr_long(my_strtol(cp, NULL, 2));
+ insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
+ return ex;
+ } else {
+ return makeexpr_bicall_3("strtol", tp_integer,
+ ex, makeexpr_nil(), makeexpr_long(2));
+ }
+}
+
+
+
+Static Expr *handle_bitsize(next)
+int next;
+{
+ Expr *ex;
+ Type *type;
+ int lpar;
+ long psize;
+
+ lpar = (curtok == TOK_LPAR);
+ if (lpar)
+ gettok();
+ if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE) {
+ ex = makeexpr_type(curtokmeaning->type);
+ gettok();
+ } else
+ ex = p_expr(NULL);
+ type = ex->val.type;
+ if (lpar)
+ skipcloseparen();
+ psize = 0;
+ packedsize(NULL, &type, &psize, 0);
+ if (psize > 0 && psize < 32 && next) {
+ if (psize > 16)
+ psize = 32;
+ else if (psize > 8)
+ psize = 16;
+ else if (psize > 4)
+ psize = 8;
+ else if (psize > 2)
+ psize = 4;
+ else if (psize > 1)
+ psize = 2;
+ else
+ psize = 1;
+ }
+ if (psize)
+ return makeexpr_long(psize);
+ else
+ return makeexpr_times(makeexpr_sizeof(ex, 0),
+ makeexpr_long(sizeof_char ? sizeof_char : 8));
+}
+
+
+Static Expr *func_bitsize()
+{
+ return handle_bitsize(0);
+}
+
+
+Static Expr *func_bitnext()
+{
+ return handle_bitsize(1);
+}
+
+
+
+Static Expr *func_blockread()
+{
+ Expr *ex, *ex2, *vex, *sex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ sex = p_expr(tp_integer);
+ sex = doseek(copyexpr(fex),
+ makeexpr_times(sex, makeexpr_long(512)))->exp1;
+ } else
+ sex = NULL;
+ skipcloseparen();
+ type = vex->val.type;
+ ex = makeexpr_bicall_4("fread", tp_integer,
+ makeexpr_addr(vex),
+ makeexpr_long(512),
+ convert_size(type, ex2, "BLOCKREAD"),
+ filebasename(copyexpr(fex)));
+ return makeexpr_comma(sex, ex);
+}
+
+
+
+Static Expr *func_blockwrite()
+{
+ Expr *ex, *ex2, *vex, *sex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ sex = p_expr(tp_integer);
+ sex = doseek(copyexpr(fex),
+ makeexpr_times(sex, makeexpr_long(512)))->exp1;
+ } else
+ sex = NULL;
+ skipcloseparen();
+ type = vex->val.type;
+ ex = makeexpr_bicall_4("fwrite", tp_integer,
+ makeexpr_addr(vex),
+ makeexpr_long(512),
+ convert_size(type, ex2, "BLOCKWRITE"),
+ filebasename(copyexpr(fex)));
+ return makeexpr_comma(sex, ex);
+}
+
+
+
+
+Static Stmt *proc_blockread()
+{
+ Expr *ex, *ex2, *vex, *rex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ rex = p_expr(tp_integer);
+ } else
+ rex = NULL;
+ skipcloseparen();
+ type = vex->val.type;
+ if (rex) {
+ ex = makeexpr_bicall_4("fread", tp_integer,
+ makeexpr_addr(vex),
+ makeexpr_long(1),
+ convert_size(type, ex2, "BLOCKREAD"),
+ filebasename(copyexpr(fex)));
+ ex = makeexpr_assign(rex, ex);
+ if (!iocheck_flag)
+ ex = makeexpr_comma(ex,
+ makeexpr_assign(makeexpr_var(mp_ioresult),
+ makeexpr_long(0)));
+ } else {
+ ex = makeexpr_bicall_4("fread", tp_integer,
+ makeexpr_addr(vex),
+ convert_size(type, ex2, "BLOCKREAD"),
+ makeexpr_long(1),
+ filebasename(copyexpr(fex)));
+ if (checkeof(fex)) {
+ ex = makeexpr_bicall_2(name_SETIO, tp_void,
+ makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
+ makeexpr_name(endoffilename, tp_int));
+ }
+ }
+ return wrapopencheck(makestmt_call(ex), fex);
+}
+
+
+
+
+Static Stmt *proc_blockwrite()
+{
+ Expr *ex, *ex2, *vex, *rex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ rex = p_expr(tp_integer);
+ } else
+ rex = NULL;
+ skipcloseparen();
+ type = vex->val.type;
+ if (rex) {
+ ex = makeexpr_bicall_4("fwrite", tp_integer,
+ makeexpr_addr(vex),
+ makeexpr_long(1),
+ convert_size(type, ex2, "BLOCKWRITE"),
+ filebasename(copyexpr(fex)));
+ ex = makeexpr_assign(rex, ex);
+ if (!iocheck_flag)
+ ex = makeexpr_comma(ex,
+ makeexpr_assign(makeexpr_var(mp_ioresult),
+ makeexpr_long(0)));
+ } else {
+ ex = makeexpr_bicall_4("fwrite", tp_integer,
+ makeexpr_addr(vex),
+ convert_size(type, ex2, "BLOCKWRITE"),
+ makeexpr_long(1),
+ filebasename(copyexpr(fex)));
+ if (FCheck(checkfilewrite)) {
+ ex = makeexpr_bicall_2(name_SETIO, tp_void,
+ makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
+ makeexpr_name(filewriteerrorname, tp_int));
+ }
+ }
+ return wrapopencheck(makestmt_call(ex), fex);
+}
+
+
+
+Static Stmt *proc_bclr()
+{
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ return makestmt_assign(ex,
+ makeexpr_bin(EK_BAND, ex->val.type,
+ copyexpr(ex),
+ makeexpr_un(EK_BNOT, ex->val.type,
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_arglong(
+ makeexpr_long(1), 1),
+ ex2))));
+}
+
+
+
+Static Stmt *proc_bset()
+{
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ return makestmt_assign(ex,
+ makeexpr_bin(EK_BOR, ex->val.type,
+ copyexpr(ex),
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_arglong(
+ makeexpr_long(1), 1),
+ ex2)));
+}
+
+
+
+Static Expr *func_bsl()
+{
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ return makeexpr_bin(EK_LSH, tp_integer, ex, ex2);
+}
+
+
+
+Static Expr *func_bsr()
+{
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ return makeexpr_bin(EK_RSH, tp_integer, force_unsigned(ex), ex2);
+}
+
+
+
+Static Expr *func_btst()
+{
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ return makeexpr_rel(EK_NE,
+ makeexpr_bin(EK_BAND, tp_integer,
+ ex,
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_arglong(
+ makeexpr_long(1), 1),
+ ex2)),
+ makeexpr_long(0));
+}
+
+
+
+Static Expr *func_byteread()
+{
+ Expr *ex, *ex2, *vex, *sex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ sex = p_expr(tp_integer);
+ sex = doseek(copyexpr(fex), sex)->exp1;
+ } else
+ sex = NULL;
+ skipcloseparen();
+ type = vex->val.type;
+ ex = makeexpr_bicall_4("fread", tp_integer,
+ makeexpr_addr(vex),
+ makeexpr_long(1),
+ convert_size(type, ex2, "BYTEREAD"),
+ filebasename(copyexpr(fex)));
+ return makeexpr_comma(sex, ex);
+}
+
+
+
+Static Expr *func_bytewrite()
+{
+ Expr *ex, *ex2, *vex, *sex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ sex = p_expr(tp_integer);
+ sex = doseek(copyexpr(fex), sex)->exp1;
+ } else
+ sex = NULL;
+ skipcloseparen();
+ type = vex->val.type;
+ ex = makeexpr_bicall_4("fwrite", tp_integer,
+ makeexpr_addr(vex),
+ makeexpr_long(1),
+ convert_size(type, ex2, "BYTEWRITE"),
+ filebasename(copyexpr(fex)));
+ return makeexpr_comma(sex, ex);
+}
+
+
+
+Static Expr *func_byte_offset()
+{
+ Type *tp;
+ Meaning *mp;
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ tp = p_type(NULL);
+ if (!skipcomma())
+ return NULL;
+ if (!wexpecttok(TOK_IDENT))
+ return NULL;
+ mp = curtoksym->fbase;
+ while (mp && mp->rectype != tp)
+ mp = mp->snext;
+ if (!mp)
+ ex = makeexpr_name(curtokcase, tp_integer);
+ else
+ ex = makeexpr_name(mp->name, tp_integer);
+ gettok();
+ skipcloseparen();
+ return makeexpr_bicall_2("OFFSETOF", (size_t_long) ? tp_integer : tp_int,
+ makeexpr_type(tp), ex);
+}
+
+
+
+Static Stmt *proc_call()
+{
+ Expr *ex, *ex2, *ex3;
+ Type *type, *tp;
+ Meaning *mp;
+
+ if (!skipopenparen())
+ return NULL;
+ ex2 = p_expr(tp_proc);
+ type = ex2->val.type;
+ if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
+ warning("CALL requires a procedure variable [208]");
+ type = tp_proc;
+ }
+ ex = makeexpr(EK_SPCALL, 1);
+ ex->val.type = tp_void;
+ ex->args[0] = copyexpr(ex2);
+ if (type->escale != 0)
+ ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
+ makepointertype(type->basetype));
+ mp = type->basetype->fbase;
+ if (mp) {
+ if (wneedtok(TOK_COMMA))
+ ex = p_funcarglist(ex, mp, 0, 0);
+ }
+ skipcloseparen();
+ if (type->escale != 1 || hasstaticlinks == 2) {
+ freeexpr(ex2);
+ return makestmt_call(ex);
+ }
+ ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
+ ex3 = copyexpr(ex);
+ insertarg(&ex3, ex3->nargs, copyexpr(ex2));
+ tp = maketype(TK_FUNCTION);
+ tp->basetype = type->basetype->basetype;
+ tp->fbase = type->basetype->fbase;
+ tp->issigned = 1;
+ ex3->args[0]->val.type = makepointertype(tp);
+ return makestmt_if(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
+ makestmt_call(ex3),
+ makestmt_call(ex));
+}
+
+
+
+Static Expr *func_chr()
+{
+ Expr *ex;
+
+ ex = p_expr(tp_integer);
+ if ((exprlongness(ex) < 0 || ex->kind == EK_CAST) && ex->kind != EK_ACTCAST)
+ ex->val.type = tp_char;
+ else
+ ex = makeexpr_cast(ex, tp_char);
+ return ex;
+}
+
+
+
+Static Stmt *proc_close()
+{
+ Stmt *sp;
+ Expr *fex, *ex;
+ char *opt;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ sp = makestmt_if(makeexpr_rel(EK_NE, filebasename(copyexpr(fex)),
+ makeexpr_nil()),
+ makestmt_call(makeexpr_bicall_1("fclose", tp_void,
+ filebasename(copyexpr(fex)))),
+ (FCheck(checkfileisopen))
+ ? makestmt_call(
+ makeexpr_bicall_1(name_ESCIO,
+ tp_integer,
+ makeexpr_name(filenotopenname,
+ tp_int)))
+ : NULL);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ opt = "";
+ if (curtok == TOK_IDENT &&
+ (!strcicmp(curtokbuf, "LOCK") ||
+ !strcicmp(curtokbuf, "PURGE") ||
+ !strcicmp(curtokbuf, "NORMAL") ||
+ !strcicmp(curtokbuf, "CRUNCH"))) {
+ opt = stralloc(curtokbuf);
+ gettok();
+ } else {
+ ex = p_expr(tp_str255);
+ if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING)
+ opt = ex->val.s;
+ }
+ if (!strcicmp(opt, "PURGE")) {
+ note("File is being closed with PURGE option [186]");
+ }
+ }
+ sp = makestmt_seq(sp, makestmt_assign(filebasename(fex), makeexpr_nil()));
+ skipcloseparen();
+ return sp;
+}
+
+
+
+Static Expr *func_concat()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return makeexpr_string("oops");
+ ex = p_expr(tp_str255);
+ while (curtok == TOK_COMMA) {
+ gettok();
+ ex = makeexpr_concat(ex, p_expr(tp_str255), 0);
+ }
+ skipcloseparen();
+ return ex;
+}
+
+
+
+Static Expr *func_copy(ex)
+Expr *ex;
+{
+ if (isliteralconst(ex->args[3], NULL) == 2 &&
+ ex->args[3]->val.i >= stringceiling) {
+ return makeexpr_bicall_3("sprintf", ex->val.type,
+ ex->args[0],
+ makeexpr_string("%s"),
+ bumpstring(ex->args[1],
+ makeexpr_unlongcast(ex->args[2]), 1));
+ }
+ if (checkconst(ex->args[2], 1)) {
+ return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1],
+ ex->args[2], ex->args[3]));
+ }
+ return makeexpr_bicall_4(strsubname, ex->val.type,
+ ex->args[0],
+ ex->args[1],
+ makeexpr_arglong(ex->args[2], 0),
+ makeexpr_arglong(ex->args[3], 0));
+}
+
+
+
+Static Expr *func_cos(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("cos", tp_longreal, grabarg(ex, 0));
+}
+
+
+Static Expr *func_cosh(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("cosh", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Stmt *proc_cycle()
+{
+ return makestmt(SK_CONTINUE);
+}
+
+
+
+Static Stmt *proc_date()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_str255);
+ skipcloseparen();
+ return makestmt_call(makeexpr_bicall_1("VAXdate", tp_integer, ex));
+}
+
+
+Static Stmt *proc_dec()
+{
+ Expr *vex, *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(NULL);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ ex = p_expr(tp_integer);
+ } else
+ ex = makeexpr_long(1);
+ skipcloseparen();
+ return makestmt_assign(vex, makeexpr_minus(copyexpr(vex), ex));
+}
+
+
+
+Static Expr *func_dec()
+{
+ return handle_vax_hex(NULL, "d", 0);
+}
+
+
+
+Static Stmt *proc_delete(ex)
+Expr *ex;
+{
+ if (ex->nargs == 1) /* Kludge for Oregon Software Pascal's delete(f) */
+ return makestmt_call(makeexpr_bicall_1(strdeletename, tp_void, ex->args[0]));
+ return makestmt_call(makeexpr_bicall_3(strdeletename, tp_void,
+ ex->args[0],
+ makeexpr_arglong(ex->args[1], 0),
+ makeexpr_arglong(ex->args[2], 0)));
+}
+
+
+
+void parse_special_variant(tp, buf)
+Type *tp;
+char *buf;
+{
+ char *cp;
+ Expr *ex;
+
+ if (!tp)
+ intwarning("parse_special_variant", "tp == NULL");
+ if (!tp || tp->meaning == NULL) {
+ *buf = 0;
+ if (curtok == TOK_COMMA) {
+ skiptotoken(TOK_RPAR);
+ }
+ return;
+ }
+ strcpy(buf, tp->meaning->name);
+ while (curtok == TOK_COMMA) {
+ gettok();
+ cp = buf + strlen(buf);
+ *cp++ = '.';
+ if (curtok == TOK_MINUS) {
+ *cp++ = '-';
+ gettok();
+ }
+ if (curtok == TOK_INTLIT ||
+ curtok == TOK_HEXLIT ||
+ curtok == TOK_OCTLIT) {
+ sprintf(cp, "%ld", curtokint);
+ gettok();
+ } else if (curtok == TOK_HAT || curtok == TOK_STRLIT) {
+ ex = makeexpr_charcast(accumulate_strlit());
+ if (ex->kind == EK_CONST) {
+ if (ex->val.i <= 32 || ex->val.i > 126 ||
+ ex->val.i == '\'' || ex->val.i == '\\' ||
+ ex->val.i == '=' || ex->val.i == '}')
+ sprintf(cp, "%ld", ex->val.i);
+ else
+ strcpy(cp, makeCchar(ex->val.i));
+ } else {
+ *buf = 0;
+ *cp = 0;
+ }
+ freeexpr(ex);
+ } else {
+ if (!wexpecttok(TOK_IDENT)) {
+ skiptotoken(TOK_RPAR);
+ return;
+ }
+ if (curtokmeaning)
+ strcpy(cp, curtokmeaning->name);
+ else
+ strcpy(cp, curtokbuf);
+ gettok();
+ }
+ }
+}
+
+
+char *find_special_variant(buf, spname, splist, need)
+char *buf, *spname;
+Strlist *splist;
+int need;
+{
+ Strlist *best = NULL;
+ int len, bestlen = -1;
+ char *cp, *cp2;
+
+ if (!*buf)
+ return NULL;
+ while (splist) {
+ cp = splist->s;
+ cp2 = buf;
+ while (*cp && toupper(*cp) == toupper(*cp2))
+ cp++, cp2++;
+ len = cp2 - buf;
+ if (!*cp && (!*cp2 || *cp2 == '.') && len > bestlen) {
+ best = splist;
+ bestlen = len;
+ }
+ splist = splist->next;
+ }
+ if (bestlen != strlen(buf) && my_strchr(buf, '.')) {
+ if ((need & 1) || bestlen >= 0) {
+ if (need & 2)
+ return NULL;
+ if (spname)
+ note(format_ss("No %s form known for %s [187]",
+ spname, strupper(buf)));
+ }
+ }
+ if (bestlen >= 0)
+ return (char *)best->value;
+ else
+ return NULL;
+}
+
+
+
+Static char *choose_free_func(ex)
+Expr *ex;
+{
+ if (!*freename) {
+ if (!*freervaluename)
+ return "free";
+ else
+ return freervaluename;
+ }
+ if (!*freervaluename)
+ return freervaluename;
+ if (expr_is_lvalue(ex))
+ return freename;
+ else
+ return freervaluename;
+}
+
+
+Static Stmt *proc_dispose()
+{
+ Expr *ex;
+ Type *type;
+ char *name, vbuf[1000];
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_anyptr);
+ type = ex->val.type->basetype;
+ parse_special_variant(type, vbuf);
+ skipcloseparen();
+ name = find_special_variant(vbuf, "SpecialFree", specialfrees, 0);
+ if (!name)
+ name = choose_free_func(ex);
+ return makestmt_call(makeexpr_bicall_1(name, tp_void, ex));
+}
+
+
+
+Static Expr *func_exp(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("exp", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_expo(ex)
+Expr *ex;
+{
+ Meaning *tvar;
+
+ tvar = makestmttempvar(tp_int, name_TEMP);
+ return makeexpr_comma(makeexpr_bicall_2("frexp", tp_longreal,
+ grabarg(ex, 0),
+ makeexpr_addr(makeexpr_var(tvar))),
+ makeexpr_var(tvar));
+}
+
+
+
+int is_std_file(ex)
+Expr *ex;
+{
+ return isvar(ex, mp_input) || isvar(ex, mp_output) ||
+ isvar(ex, mp_stderr);
+}
+
+
+
+Static Expr *iofunc(ex, code)
+Expr *ex;
+int code;
+{
+ Expr *ex2 = NULL, *ex3 = NULL;
+ Meaning *tvar = NULL;
+
+ if (FCheck(checkfileisopen) && !is_std_file(ex)) {
+ if (isfiletype(ex->val.type, 1) ||
+ (exprspeed(ex) < 5 && nosideeffects(ex, 0))) {
+ ex2 = filebasename(copyexpr(ex));
+ } else {
+ ex3 = ex;
+ tvar = makestmttempvar(ex->val.type, name_TEMP);
+ ex2 = makeexpr_var(tvar);
+ ex = makeexpr_var(tvar);
+ }
+ }
+ ex = filebasename(ex);
+ switch (code) {
+
+ case 0: /* eof */
+ if (fileisbuffered(ex, 0) && *eofbufname)
+ ex = makeexpr_bicall_1(eofbufname, tp_boolean, ex);
+ else if (*eofname)
+ ex = makeexpr_bicall_1(eofname, tp_boolean, ex);
+ else
+ ex = makeexpr_rel(EK_NE, makeexpr_bicall_1("feof", tp_int, ex),
+ makeexpr_long(0));
+ break;
+
+ case 1: /* eoln */
+ ex = makeexpr_bicall_1(eolnname, tp_boolean, ex);
+ break;
+
+ case 2: /* position or filepos */
+ if (fileisbuffered(ex, 0) && *fileposbufname)
+ ex = makeexpr_bicall_1(fileposbufname, tp_integer, ex);
+ else
+ ex = makeexpr_bicall_1(fileposname, tp_integer, ex);
+ break;
+
+ case 3: /* maxpos or filesize */
+ ex = makeexpr_bicall_1(maxposname, tp_integer, ex);
+ break;
+
+ }
+ if (ex2) {
+ ex = makeexpr_bicall_4("~CHKIO",
+ (code == 0 || code == 1) ? tp_boolean : tp_integer,
+ makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
+ makeexpr_name("FileNotOpen", tp_int),
+ ex, makeexpr_long(0));
+ }
+ if (ex3)
+ ex = makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), ex3), ex);
+ return ex;
+}
+
+
+
+Static Expr *func_eof()
+{
+ Expr *ex;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_text);
+ else
+ ex = makeexpr_var(mp_input);
+ return iofunc(ex, 0);
+}
+
+
+
+Static Expr *func_eoln()
+{
+ Expr *ex;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_text);
+ else
+ ex = makeexpr_var(mp_input);
+ return iofunc(ex, 1);
+}
+
+
+
+Static Stmt *proc_escape()
+{
+ Expr *ex;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_integer);
+ else
+ ex = makeexpr_long(0);
+ return makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int,
+ makeexpr_arglong(ex, 0)));
+}
+
+
+
+Static Stmt *proc_excl()
+{
+ Expr *vex, *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex = p_expr(vex->val.type->indextype);
+ skipcloseparen();
+ if (vex->val.type->kind == TK_SMALLSET)
+ return makestmt_assign(vex, makeexpr_bin(EK_BAND, vex->val.type,
+ copyexpr(vex),
+ makeexpr_un(EK_BNOT, vex->val.type,
+ makeexpr_bin(EK_LSH, vex->val.type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ ex))));
+ else
+ return makestmt_call(makeexpr_bicall_2(setremname, tp_void, vex,
+ makeexpr_arglong(enum_to_int(ex), 0)));
+}
+
+
+
+Stmt *proc_exit()
+{
+ Stmt *sp;
+
+ if (modula2) {
+ return makestmt(SK_BREAK);
+ }
+ if (curtok == TOK_LPAR) {
+ gettok();
+ if (curtok == TOK_PROGRAM ||
+ (curtok == TOK_IDENT && curtokmeaning->kind == MK_MODULE)) {
+ gettok();
+ skipcloseparen();
+ return makestmt_call(makeexpr_bicall_1("exit", tp_void,
+ makeexpr_name("EXIT_SUCCESS",
+ tp_integer)));
+ }
+ if (curtok != TOK_IDENT || !curtokmeaning || curtokmeaning != curctx)
+ note("Attempting to EXIT beyond this function [188]");
+ gettok();
+ skipcloseparen();
+ }
+ sp = makestmt(SK_RETURN);
+ if (curctx->kind == MK_FUNCTION && curctx->isfunction) {
+ sp->exp1 = makeexpr_var(curctx->cbase);
+ curctx->cbase->refcount++;
+ }
+ return sp;
+}
+
+
+
+Static Expr *file_iofunc(code, base)
+int code;
+long base;
+{
+ Expr *ex;
+ Type *basetype;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_text);
+ else
+ ex = makeexpr_var(mp_input);
+ if (!ex->val.type || !ex->val.type->basetype ||
+ !filebasetype(ex->val.type))
+ basetype = tp_char;
+ else
+ basetype = filebasetype(ex->val.type);
+ return makeexpr_plus(makeexpr_div(iofunc(ex, code),
+ makeexpr_sizeof(makeexpr_type(basetype), 0)),
+ makeexpr_long(base));
+}
+
+
+
+Static Expr *func_fcall()
+{
+ Expr *ex, *ex2, *ex3;
+ Type *type, *tp;
+ Meaning *mp, *tvar = NULL;
+ int firstarg = 0;
+
+ if (!skipopenparen())
+ return NULL;
+ ex2 = p_expr(tp_proc);
+ type = ex2->val.type;
+ if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
+ warning("FCALL requires a function variable [209]");
+ type = tp_proc;
+ }
+ ex = makeexpr(EK_SPCALL, 1);
+ ex->val.type = type->basetype->basetype;
+ ex->args[0] = copyexpr(ex2);
+ if (type->escale != 0)
+ ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
+ makepointertype(type->basetype));
+ mp = type->basetype->fbase;
+ if (mp && mp->isreturn) { /* pointer to buffer for return value */
+ tvar = makestmttempvar(ex->val.type->basetype,
+ (ex->val.type->basetype->kind == TK_STRING) ? name_STRING : name_TEMP);
+ insertarg(&ex, 1, makeexpr_addr(makeexpr_var(tvar)));
+ mp = mp->xnext;
+ firstarg++;
+ }
+ if (mp) {
+ if (wneedtok(TOK_COMMA))
+ ex = p_funcarglist(ex, mp, 0, 0);
+ }
+ if (tvar)
+ ex = makeexpr_hat(ex, 0); /* returns pointer to structured result */
+ skipcloseparen();
+ if (type->escale != 1 || hasstaticlinks == 2) {
+ freeexpr(ex2);
+ return ex;
+ }
+ ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
+ ex3 = copyexpr(ex);
+ insertarg(&ex3, ex3->nargs, copyexpr(ex2));
+ tp = maketype(TK_FUNCTION);
+ tp->basetype = type->basetype->basetype;
+ tp->fbase = type->basetype->fbase;
+ tp->issigned = 1;
+ ex3->args[0]->val.type = makepointertype(tp);
+ return makeexpr_cond(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
+ ex3, ex);
+}
+
+
+
+Static Expr *func_filepos()
+{
+ return file_iofunc(2, seek_base);
+}
+
+
+
+Static Expr *func_filesize()
+{
+ return file_iofunc(3, 1L);
+}
+
+
+
+Static Stmt *proc_fillchar()
+{
+ Expr *vex, *ex, *cex;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = gentle_cast(makeexpr_addr(p_expr(NULL)), tp_anyptr);
+ if (!skipcomma())
+ return NULL;
+ ex = convert_size(argbasetype(vex), p_expr(tp_integer), "FILLCHAR");
+ if (!skipcomma())
+ return NULL;
+ cex = makeexpr_charcast(p_expr(tp_integer));
+ skipcloseparen();
+ return makestmt_call(makeexpr_bicall_3("memset", tp_void,
+ vex,
+ makeexpr_arglong(cex, 0),
+ makeexpr_arglong(ex, (size_t_long != 0))));
+}
+
+
+
+Static Expr *func_sngl()
+{
+ Expr *ex;
+
+ ex = p_parexpr(tp_real);
+ return makeexpr_cast(ex, tp_real);
+}
+
+
+
+Static Expr *func_float()
+{
+ Expr *ex;
+
+ ex = p_parexpr(tp_longreal);
+ return makeexpr_cast(ex, tp_longreal);
+}
+
+
+
+Static Stmt *proc_flush()
+{
+ Expr *ex;
+ Stmt *sp;
+
+ ex = p_parexpr(tp_text);
+ sp = makestmt_call(makeexpr_bicall_1("fflush", tp_void, filebasename(ex)));
+ if (iocheck_flag)
+ sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(mp_ioresult),
+ makeexpr_long(0)));
+ return sp;
+}
+
+
+
+Static Expr *func_frac(ex)
+Expr *ex;
+{
+ Meaning *tvar;
+
+ tvar = makestmttempvar(tp_longreal, name_DUMMY);
+ return makeexpr_bicall_2("modf", tp_longreal,
+ grabarg(ex, 0),
+ makeexpr_addr(makeexpr_var(tvar)));
+}
+
+
+
+Static Stmt *proc_freemem(ex)
+Expr *ex;
+{
+ Stmt *sp;
+ Expr *vex;
+
+ vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
+ sp = makestmt_call(makeexpr_bicall_1(choose_free_func(vex),
+ tp_void, copyexpr(vex)));
+ if (alloczeronil) {
+ sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
+ sp, NULL);
+ } else
+ freeexpr(vex);
+ return sp;
+}
+
+
+
+Static Stmt *proc_get()
+{
+ Expr *ex;
+ Type *type;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_text);
+ else
+ ex = makeexpr_var(mp_input);
+ requirefilebuffer(ex);
+ type = ex->val.type;
+ if (isfiletype(type, -1) && *chargetname &&
+ filebasetype(type)->kind == TK_CHAR)
+ return makestmt_call(makeexpr_bicall_1(chargetname, tp_void,
+ filebasename(ex)));
+ else if (isfiletype(type, -1) && *arraygetname &&
+ filebasetype(type)->kind == TK_ARRAY)
+ return makestmt_call(makeexpr_bicall_2(arraygetname, tp_void,
+ filebasename(ex),
+ makeexpr_type(filebasetype(type))));
+ else
+ return makestmt_call(makeexpr_bicall_2(getname, tp_void,
+ filebasename(ex),
+ makeexpr_type(filebasetype(type))));
+}
+
+
+
+Static Stmt *proc_getmem(ex)
+Expr *ex;
+{
+ Expr *vex, *ex2, *sz = NULL;
+ Stmt *sp;
+
+ vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
+ ex2 = ex->args[1];
+ if (vex->val.type->kind == TK_POINTER)
+ ex2 = convert_size(vex->val.type->basetype, ex2, "GETMEM");
+ if (alloczeronil)
+ sz = copyexpr(ex2);
+ ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, ex2);
+ sp = makestmt_assign(copyexpr(vex), ex2);
+ if (malloccheck) {
+ sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(vex), makeexpr_nil()),
+ makestmt_call(makeexpr_bicall_0(name_OUTMEM, tp_int)),
+ NULL));
+ }
+ if (sz && !isconstantexpr(sz)) {
+ if (alloczeronil == 2)
+ note("Called GETMEM with variable argument [189]");
+ sp = makestmt_if(makeexpr_rel(EK_NE, sz, makeexpr_long(0)),
+ sp,
+ makestmt_assign(vex, makeexpr_nil()));
+ } else
+ freeexpr(vex);
+ return sp;
+}
+
+
+
+Static Stmt *proc_gotoxy(ex)
+Expr *ex;
+{
+ return makestmt_call(makeexpr_bicall_2("gotoxy", tp_void,
+ makeexpr_arglong(ex->args[0], 0),
+ makeexpr_arglong(ex->args[1], 0)));
+}
+
+
+
+Static Expr *handle_vax_hex(ex, fmt, scale)
+Expr *ex;
+char *fmt;
+int scale;
+{
+ Expr *lex, *dex, *vex;
+ Meaning *tvar;
+ Type *tp;
+ long smin, smax;
+ int bits;
+
+ if (!ex) {
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ }
+ tp = true_type(ex);
+ if (ord_range(tp, &smin, &smax))
+ bits = typebits(smin, smax);
+ else
+ bits = 32;
+ if (curtok == TOK_COMMA) {
+ gettok();
+ if (curtok != TOK_COMMA)
+ lex = makeexpr_arglong(p_expr(tp_integer), 0);
+ else
+ lex = NULL;
+ } else
+ lex = NULL;
+ if (!lex) {
+ if (!scale)
+ lex = makeexpr_long(11);
+ else
+ lex = makeexpr_long((bits+scale-1) / scale + 1);
+ }
+ if (curtok == TOK_COMMA) {
+ gettok();
+ dex = makeexpr_arglong(p_expr(tp_integer), 0);
+ } else {
+ if (!scale)
+ dex = makeexpr_long(10);
+ else
+ dex = makeexpr_long((bits+scale-1) / scale);
+ }
+ if (lex->kind == EK_CONST && dex->kind == EK_CONST &&
+ lex->val.i < dex->val.i)
+ lex = NULL;
+ skipcloseparen();
+ tvar = makestmttempvar(tp_str255, name_STRING);
+ vex = makeexpr_var(tvar);
+ ex = makeexpr_forcelongness(ex);
+ if (exprlongness(ex) > 0)
+ fmt = format_s("l%s", fmt);
+ if (checkconst(lex, 0) || checkconst(lex, 1))
+ lex = NULL;
+ if (checkconst(dex, 0) || checkconst(dex, 1))
+ dex = NULL;
+ if (lex) {
+ if (dex)
+ ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
+ makeexpr_string(format_s("%%*.*%s", fmt)),
+ lex, dex, ex);
+ else
+ ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
+ makeexpr_string(format_s("%%*%s", fmt)),
+ lex, ex);
+ } else {
+ if (dex)
+ ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
+ makeexpr_string(format_s("%%.*%s", fmt)),
+ dex, ex);
+ else
+ ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
+ makeexpr_string(format_s("%%%s", fmt)),
+ ex);
+ }
+ return ex;
+}
+
+
+
+
+Static Expr *func_hex()
+{
+ Expr *ex;
+ char *cp;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = makeexpr_stringcast(p_expr(tp_integer));
+ if ((ex->val.type->kind == TK_STRING ||
+ ex->val.type == tp_strptr) &&
+ curtok != TOK_COMMA) {
+ skipcloseparen();
+ if (ex->kind == EK_CONST) { /* HP Pascal */
+ cp = getstring(ex);
+ ex = makeexpr_long(my_strtol(cp, NULL, 16));
+ insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
+ return ex;
+ } else {
+ return makeexpr_bicall_3("strtol", tp_integer,
+ ex, makeexpr_nil(), makeexpr_long(16));
+ }
+ } else { /* VAX Pascal */
+ return handle_vax_hex(ex, "x", 4);
+ }
+}
+
+
+
+Static Expr *func_hi()
+{
+ Expr *ex;
+
+ ex = force_unsigned(p_parexpr(tp_integer));
+ return makeexpr_bin(EK_RSH, tp_ubyte,
+ ex, makeexpr_long(8));
+}
+
+
+
+Static Expr *func_high()
+{
+ Expr *ex;
+ Type *type;
+
+ ex = p_parexpr(tp_integer);
+ type = ex->val.type;
+ if (type->kind == TK_POINTER)
+ type = type->basetype;
+ if (type->kind == TK_ARRAY ||
+ type->kind == TK_SMALLARRAY) {
+ ex = makeexpr_minus(copyexpr(type->indextype->smax),
+ copyexpr(type->indextype->smin));
+ } else {
+ warning("HIGH requires an array name parameter [210]");
+ ex = makeexpr_bicall_1("HIGH", tp_int, ex);
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_hiword()
+{
+ Expr *ex;
+
+ ex = force_unsigned(p_parexpr(tp_unsigned));
+ return makeexpr_bin(EK_RSH, tp_unsigned,
+ ex, makeexpr_long(16));
+}
+
+
+
+Static Stmt *proc_inc()
+{
+ Expr *vex, *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(NULL);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ ex = p_expr(tp_integer);
+ } else
+ ex = makeexpr_long(1);
+ skipcloseparen();
+ return makestmt_assign(vex, makeexpr_plus(copyexpr(vex), ex));
+}
+
+
+
+Static Stmt *proc_incl()
+{
+ Expr *vex, *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex = p_expr(vex->val.type->indextype);
+ skipcloseparen();
+ if (vex->val.type->kind == TK_SMALLSET)
+ return makestmt_assign(vex, makeexpr_bin(EK_BOR, vex->val.type,
+ copyexpr(vex),
+ makeexpr_bin(EK_LSH, vex->val.type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ ex)));
+ else
+ return makestmt_call(makeexpr_bicall_2(setaddname, tp_void, vex,
+ makeexpr_arglong(enum_to_int(ex), 0)));
+}
+
+
+
+Static Stmt *proc_insert(ex)
+Expr *ex;
+{
+ return makestmt_call(makeexpr_bicall_3(strinsertname, tp_void,
+ ex->args[0],
+ ex->args[1],
+ makeexpr_arglong(ex->args[2], 0)));
+}
+
+
+
+Static Expr *func_int()
+{
+ Expr *ex;
+ Meaning *tvar;
+
+ ex = p_parexpr(tp_integer);
+ if (ex->val.type->kind == TK_REAL) { /* Turbo Pascal INT */
+ tvar = makestmttempvar(tp_longreal, name_TEMP);
+ return makeexpr_comma(makeexpr_bicall_2("modf", tp_longreal,
+ grabarg(ex, 0),
+ makeexpr_addr(makeexpr_var(tvar))),
+ makeexpr_var(tvar));
+ } else { /* VAX Pascal INT */
+ return makeexpr_ord(ex);
+ }
+}
+
+
+Static Expr *func_uint()
+{
+ Expr *ex;
+
+ ex = p_parexpr(tp_integer);
+ return makeexpr_cast(ex, tp_unsigned);
+}
+
+
+
+Static Stmt *proc_leave()
+{
+ return makestmt(SK_BREAK);
+}
+
+
+
+Static Expr *func_lo()
+{
+ Expr *ex;
+
+ ex = gentle_cast(p_parexpr(tp_integer), tp_ushort);
+ return makeexpr_bin(EK_BAND, tp_ubyte,
+ ex, makeexpr_long(255));
+}
+
+
+Static Expr *func_loophole()
+{
+ Type *type;
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ type = p_type(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex = p_expr(tp_integer);
+ skipcloseparen();
+ return pascaltypecast(type, ex);
+}
+
+
+
+Static Expr *func_lower()
+{
+ Expr *ex;
+ Value val;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ val = p_constant(tp_integer);
+ if (!val.type || val.i != 1)
+ note("LOWER(v,n) not supported for n>1 [190]");
+ }
+ skipcloseparen();
+ return copyexpr(ex->val.type->indextype->smin);
+}
+
+
+
+Static Expr *func_loword()
+{
+ Expr *ex;
+
+ ex = p_parexpr(tp_integer);
+ return makeexpr_bin(EK_BAND, tp_ushort,
+ ex, makeexpr_long(65535));
+}
+
+
+
+Static Expr *func_ln(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("log", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_log(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("log10", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_max()
+{
+ Type *tp;
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE) {
+ tp = curtokmeaning->type;
+ gettok();
+ skipcloseparen();
+ return copyexpr(tp->smax);
+ }
+ ex = p_expr(tp_integer);
+ while (curtok == TOK_COMMA) {
+ gettok();
+ ex2 = p_expr(ex->val.type);
+ if (ex->val.type->kind == TK_REAL) {
+ tp = ex->val.type;
+ if (ex2->val.type->kind != TK_REAL)
+ ex2 = makeexpr_cast(ex2, tp);
+ } else {
+ tp = ex2->val.type;
+ if (ex->val.type->kind != TK_REAL)
+ ex = makeexpr_cast(ex, tp);
+ }
+ ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmax" : "P_imax",
+ tp, ex, ex2);
+ }
+ skipcloseparen();
+ return ex;
+}
+
+
+
+Static Expr *func_maxavail(ex)
+Expr *ex;
+{
+ freeexpr(ex);
+ return makeexpr_bicall_0("maxavail", tp_integer);
+}
+
+
+
+Static Expr *func_maxpos()
+{
+ return file_iofunc(3, seek_base);
+}
+
+
+
+Static Expr *func_memavail(ex)
+Expr *ex;
+{
+ freeexpr(ex);
+ return makeexpr_bicall_0("memavail", tp_integer);
+}
+
+
+
+Static Expr *var_mem()
+{
+ Expr *ex, *ex2;
+
+ if (!wneedtok(TOK_LBR))
+ return makeexpr_name("MEM", tp_integer);
+ ex = p_expr(tp_integer);
+ if (curtok == TOK_COLON) {
+ gettok();
+ ex2 = p_expr(tp_integer);
+ ex = makeexpr_bicall_2("MEM", tp_ubyte, ex, ex2);
+ } else {
+ ex = makeexpr_bicall_1("MEM", tp_ubyte, ex);
+ }
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ note("Reference to MEM [191]");
+ return ex;
+}
+
+
+
+Static Expr *var_memw()
+{
+ Expr *ex, *ex2;
+
+ if (!wneedtok(TOK_LBR))
+ return makeexpr_name("MEMW", tp_integer);
+ ex = p_expr(tp_integer);
+ if (curtok == TOK_COLON) {
+ gettok();
+ ex2 = p_expr(tp_integer);
+ ex = makeexpr_bicall_2("MEMW", tp_ushort, ex, ex2);
+ } else {
+ ex = makeexpr_bicall_1("MEMW", tp_ushort, ex);
+ }
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ note("Reference to MEMW [191]");
+ return ex;
+}
+
+
+
+Static Expr *var_meml()
+{
+ Expr *ex, *ex2;
+
+ if (!wneedtok(TOK_LBR))
+ return makeexpr_name("MEML", tp_integer);
+ ex = p_expr(tp_integer);
+ if (curtok == TOK_COLON) {
+ gettok();
+ ex2 = p_expr(tp_integer);
+ ex = makeexpr_bicall_2("MEML", tp_integer, ex, ex2);
+ } else {
+ ex = makeexpr_bicall_1("MEML", tp_integer, ex);
+ }
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ note("Reference to MEML [191]");
+ return ex;
+}
+
+
+
+Static Expr *func_min()
+{
+ Type *tp;
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE) {
+ tp = curtokmeaning->type;
+ gettok();
+ skipcloseparen();
+ return copyexpr(tp->smin);
+ }
+ ex = p_expr(tp_integer);
+ while (curtok == TOK_COMMA) {
+ gettok();
+ ex2 = p_expr(ex->val.type);
+ if (ex->val.type->kind == TK_REAL) {
+ tp = ex->val.type;
+ if (ex2->val.type->kind != TK_REAL)
+ ex2 = makeexpr_cast(ex2, tp);
+ } else {
+ tp = ex2->val.type;
+ if (ex->val.type->kind != TK_REAL)
+ ex = makeexpr_cast(ex, tp);
+ }
+ ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmin" : "P_imin",
+ tp, ex, ex2);
+ }
+ skipcloseparen();
+ return ex;
+}
+
+
+
+Static Stmt *proc_move(ex)
+Expr *ex;
+{
+ ex->args[0] = gentle_cast(ex->args[0], tp_anyptr); /* source */
+ ex->args[1] = gentle_cast(ex->args[1], tp_anyptr); /* dest */
+ ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
+ argbasetype(ex->args[1])), ex->args[2], "MOVE");
+ return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
+ ex->args[1],
+ ex->args[0],
+ makeexpr_arglong(ex->args[2], (size_t_long != 0))));
+}
+
+
+
+Static Stmt *proc_move_fast()
+{
+ Expr *ex, *ex2, *ex3, *ex4;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ord_range_expr(ex2->val.type->indextype, &ex4, NULL);
+ ex2 = makeexpr_index(ex2, p_expr(tp_integer), copyexpr(ex4));
+ if (!skipcomma())
+ return NULL;
+ ex3 = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ ord_range_expr(ex3->val.type->indextype, &ex4, NULL);
+ ex3 = makeexpr_index(ex3, p_expr(tp_integer), copyexpr(ex4));
+ skipcloseparen();
+ ex = convert_size(choosetype(argbasetype(ex2),
+ argbasetype(ex3)), ex, "MOVE_FAST");
+ return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
+ makeexpr_addr(ex3),
+ makeexpr_addr(ex2),
+ makeexpr_arglong(ex, (size_t_long != 0))));
+}
+
+
+
+Static Stmt *proc_new()
+{
+ Expr *ex, *ex2;
+ Stmt *sp, **spp;
+ Type *type;
+ char *name, *name2 = NULL, vbuf[1000];
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_anyptr);
+ type = ex->val.type;
+ if (type->kind == TK_POINTER)
+ type = type->basetype;
+ parse_special_variant(type, vbuf);
+ skipcloseparen();
+ name = find_special_variant(vbuf, NULL, specialmallocs, 3);
+ if (!name) {
+ name2 = find_special_variant(vbuf, NULL, specialsizeofs, 3);
+ if (!name2) {
+ name = find_special_variant(vbuf, NULL, specialmallocs, 1);
+ name2 = find_special_variant(vbuf, NULL, specialsizeofs, 1);
+ if (name || !name2)
+ name = find_special_variant(vbuf, "SpecialMalloc", specialmallocs, 1);
+ else
+ name2 = find_special_variant(vbuf, "SpecialSizeOf", specialsizeofs, 1);
+ }
+ }
+ if (name) {
+ ex2 = makeexpr_bicall_0(name, ex->val.type);
+ } else if (name2) {
+ ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, pc_expr_str(name2));
+ } else {
+ ex2 = makeexpr_bicall_1(mallocname, tp_anyptr,
+ makeexpr_sizeof(makeexpr_type(type), 1));
+ }
+ sp = makestmt_assign(copyexpr(ex), ex2);
+ if (malloccheck) {
+ sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ,
+ copyexpr(ex),
+ makeexpr_nil()),
+ makestmt_call(makeexpr_bicall_0(name_OUTMEM, tp_int)),
+ NULL));
+ }
+ spp = &sp->next;
+ while (*spp)
+ spp = &(*spp)->next;
+ if (type->kind == TK_RECORD)
+ initfilevars(type->fbase, &spp, makeexpr_hat(ex, 0));
+ else if (isfiletype(type, -1))
+ sp = makestmt_seq(sp, makestmt_call(initfilevar(makeexpr_hat(ex, 0))));
+ else
+ freeexpr(ex);
+ return sp;
+}
+
+
+
+Static Expr *func_oct()
+{
+ return handle_vax_hex(NULL, "o", 3);
+}
+
+
+
+Static Expr *func_octal(ex)
+Expr *ex;
+{
+ char *cp;
+
+ ex = grabarg(ex, 0);
+ if (ex->kind == EK_CONST) {
+ cp = getstring(ex);
+ ex = makeexpr_long(my_strtol(cp, NULL, 8));
+ insertarg(&ex, 0, makeexpr_name("0%lo", tp_integer));
+ return ex;
+ } else {
+ return makeexpr_bicall_3("strtol", tp_integer,
+ ex, makeexpr_nil(), makeexpr_long(8));
+ }
+}
+
+
+
+Static Expr *func_odd(ex)
+Expr *ex;
+{
+ ex = makeexpr_unlongcast(grabarg(ex, 0));
+ if (*oddname)
+ return makeexpr_bicall_1(oddname, tp_boolean, ex);
+ else
+ return makeexpr_bin(EK_BAND, tp_boolean, ex, makeexpr_long(1));
+}
+
+
+
+Static Stmt *proc_open()
+{
+ return handleopen(2);
+}
+
+
+
+Static Expr *func_ord()
+{
+ Expr *ex;
+
+ if (wneedtok(TOK_LPAR)) {
+ ex = p_ord_expr();
+ skipcloseparen();
+ } else
+ ex = p_ord_expr();
+ return makeexpr_ord(ex);
+}
+
+
+
+Static Expr *func_ord4()
+{
+ Expr *ex;
+
+ if (wneedtok(TOK_LPAR)) {
+ ex = p_ord_expr();
+ skipcloseparen();
+ } else
+ ex = p_ord_expr();
+ return makeexpr_longcast(makeexpr_ord(ex), 1);
+}
+
+
+
+Static Stmt *proc_pack()
+{
+ Expr *exs, *exd, *exi, *mind;
+ Meaning *tvar;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ exs = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ exi = p_ord_expr();
+ if (!skipcomma())
+ return NULL;
+ exd = p_expr(NULL);
+ skipcloseparen();
+ if (exs->val.type->kind != TK_ARRAY ||
+ (exd->val.type->kind != TK_ARRAY &&
+ exd->val.type->kind != TK_SMALLARRAY)) {
+ warning("Bad argument types for PACK/UNPACK [325]");
+ return makestmt_call(makeexpr_bicall_3("pack", tp_void,
+ exs, exi, exd));
+ }
+ if (exs->val.type->smax || exd->val.type->smax) {
+ tvar = makestmttempvar(exd->val.type->indextype, name_TEMP);
+ sp = makestmt(SK_FOR);
+ if (exd->val.type->smin)
+ mind = exd->val.type->smin;
+ else
+ mind = exd->val.type->indextype->smin;
+ sp->exp1 = makeexpr_assign(makeexpr_var(tvar),
+ copyexpr(mind));
+ sp->exp2 = makeexpr_rel(EK_LE, makeexpr_var(tvar),
+ copyexpr(exd->val.type->indextype->smax));
+ sp->exp3 = makeexpr_assign(makeexpr_var(tvar),
+ makeexpr_plus(makeexpr_var(tvar),
+ makeexpr_long(1)));
+ exi = makeexpr_minus(exi, copyexpr(mind));
+ sp->stm1 = makestmt_assign(p_index(exd, makeexpr_var(tvar)),
+ p_index(exs,
+ makeexpr_plus(makeexpr_var(tvar),
+ exi)));
+ return sp;
+ } else {
+ exi = gentle_cast(exi, exs->val.type->indextype);
+ return makestmt_call(makeexpr_bicall_3("memcpy", exd->val.type,
+ exd,
+ makeexpr_addr(p_index(exs, exi)),
+ makeexpr_sizeof(copyexpr(exd), 0)));
+ }
+}
+
+
+
+Static Expr *func_pad(ex)
+Expr *ex;
+{
+ if (checkconst(ex->args[1], 0) || /* "s" is null string */
+ checkconst(ex->args[2], ' ')) {
+ return makeexpr_bicall_4("sprintf", tp_strptr, ex->args[0],
+ makeexpr_string("%*s"),
+ makeexpr_longcast(ex->args[3], 0),
+ makeexpr_string(""));
+ }
+ return makeexpr_bicall_4(strpadname, tp_strptr,
+ ex->args[0], ex->args[1], ex->args[2],
+ makeexpr_arglong(ex->args[3], 0));
+}
+
+
+
+Static Stmt *proc_page()
+{
+ Expr *fex, *ex;
+
+ if (curtok == TOK_LPAR) {
+ fex = p_parexpr(tp_text);
+ ex = makeexpr_bicall_2("fprintf", tp_int,
+ filebasename(copyexpr(fex)),
+ makeexpr_string("\f"));
+ } else {
+ fex = makeexpr_var(mp_output);
+ ex = makeexpr_bicall_1("printf", tp_int,
+ makeexpr_string("\f"));
+ }
+ if (FCheck(checkfilewrite)) {
+ ex = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_GE, ex, makeexpr_long(0)),
+ makeexpr_name(filewriteerrorname, tp_int));
+ }
+ return wrapopencheck(makestmt_call(ex), fex);
+}
+
+
+
+Static Expr *func_paramcount(ex)
+Expr *ex;
+{
+ freeexpr(ex);
+ return makeexpr_minus(makeexpr_name(name_ARGC, tp_int),
+ makeexpr_long(1));
+}
+
+
+
+Static Expr *func_paramstr(ex)
+Expr *ex;
+{
+ Expr *ex2;
+
+ ex2 = makeexpr_index(makeexpr_name(name_ARGV,
+ makepointertype(tp_strptr)),
+ makeexpr_unlongcast(ex->args[1]),
+ makeexpr_long(0));
+ ex2->val.type = tp_str255;
+ return makeexpr_bicall_3("sprintf", tp_strptr,
+ ex->args[0],
+ makeexpr_string("%s"),
+ ex2);
+}
+
+
+
+Static Expr *func_pi()
+{
+ return makeexpr_name("M_PI", tp_longreal);
+}
+
+
+
+Static Expr *var_port()
+{
+ Expr *ex;
+
+ if (!wneedtok(TOK_LBR))
+ return makeexpr_name("PORT", tp_integer);
+ ex = p_expr(tp_integer);
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ note("Reference to PORT [191]");
+ return makeexpr_bicall_1("PORT", tp_ubyte, ex);
+}
+
+
+
+Static Expr *var_portw()
+{
+ Expr *ex;
+
+ if (!wneedtok(TOK_LBR))
+ return makeexpr_name("PORTW", tp_integer);
+ ex = p_expr(tp_integer);
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ note("Reference to PORTW [191]");
+ return makeexpr_bicall_1("PORTW", tp_ushort, ex);
+}
+
+
+
+Static Expr *func_pos(ex)
+Expr *ex;
+{
+ char *cp;
+
+ cp = strposname;
+ if (!*cp) {
+ note("POS function used [192]");
+ cp = "POS";
+ }
+ return makeexpr_bicall_3(cp, tp_int,
+ ex->args[1],
+ ex->args[0],
+ makeexpr_long(1));
+}
+
+
+
+Static Expr *func_ptr(ex)
+Expr *ex;
+{
+ note("PTR function was used [193]");
+ return ex;
+}
+
+
+
+Static Expr *func_position()
+{
+ return file_iofunc(2, seek_base);
+}
+
+
+
+Static Expr *func_pred()
+{
+ Expr *ex;
+
+ if (wneedtok(TOK_LPAR)) {
+ ex = p_ord_expr();
+ skipcloseparen();
+ } else
+ ex = p_ord_expr();
+#if 1
+ ex = makeexpr_inc(ex, makeexpr_long(-1));
+#else
+ ex = makeexpr_cast(makeexpr_plus(ex, makeexpr_long(-1)), ex->val.type);
+#endif
+ return ex;
+}
+
+
+
+Static Stmt *proc_put()
+{
+ Expr *ex;
+ Type *type;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_text);
+ else
+ ex = makeexpr_var(mp_output);
+ requirefilebuffer(ex);
+ type = ex->val.type;
+ if (isfiletype(type, -1) && *charputname &&
+ filebasetype(type)->kind == TK_CHAR)
+ return makestmt_call(makeexpr_bicall_1(charputname, tp_void,
+ filebasename(ex)));
+ else if (isfiletype(type, -1) && *arrayputname &&
+ filebasetype(type)->kind == TK_ARRAY)
+ return makestmt_call(makeexpr_bicall_2(arrayputname, tp_void,
+ filebasename(ex),
+ makeexpr_type(filebasetype(type))));
+ else
+ return makestmt_call(makeexpr_bicall_2(putname, tp_void,
+ filebasename(ex),
+ makeexpr_type(filebasetype(type))));
+}
+
+
+
+Static Expr *func_pwroften(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_2("pow", tp_longreal,
+ makeexpr_real("10.0"), grabarg(ex, 0));
+}
+
+
+
+Static Stmt *proc_reset()
+{
+ return handleopen(0);
+}
+
+
+
+Static Stmt *proc_rewrite()
+{
+ return handleopen(1);
+}
+
+
+
+
+Stmt *doseek(fex, ex)
+Expr *fex, *ex;
+{
+ Expr *ex2;
+ Type *basetype = filebasetype(fex->val.type);
+
+ if (ansiC == 1)
+ ex2 = makeexpr_name("SEEK_SET", tp_int);
+ else
+ ex2 = makeexpr_long(0);
+ ex = makeexpr_bicall_3("fseek", tp_int,
+ filebasename(copyexpr(fex)),
+ makeexpr_arglong(
+ makeexpr_times(makeexpr_minus(ex,
+ makeexpr_long(seek_base)),
+ makeexpr_sizeof(makeexpr_type(basetype), 0)),
+ 1),
+ ex2);
+ if (FCheck(checkfileseek)) {
+ ex = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_EQ, ex, makeexpr_long(0)),
+ makeexpr_name(endoffilename, tp_int));
+ }
+ return makestmt_call(ex);
+}
+
+
+
+
+Static Expr *makegetchar(fex)
+Expr *fex;
+{
+ if (isvar(fex, mp_input))
+ return makeexpr_bicall_0("getchar", tp_char);
+ else
+ return makeexpr_bicall_1("getc", tp_char, filebasename(copyexpr(fex)));
+}
+
+
+
+Static Stmt *fixscanf(sp, fex)
+Stmt *sp;
+Expr *fex;
+{
+ int nargs, i, isstrread;
+ char *cp;
+ Expr *ex;
+ Stmt *sp2;
+
+ isstrread = (fex->val.type->kind == TK_STRING);
+ if (sp->kind == SK_ASSIGN && sp->exp1->kind == EK_BICALL &&
+ !strcmp(sp->exp1->val.s, "scanf")) {
+ if (sp->exp1->args[0]->kind == EK_CONST &&
+ !(sp->exp1->args[0]->val.i&1) && !isstrread) {
+ cp = sp->exp1->args[0]->val.s; /* scanf("%c%c") -> getchar;getchar */
+ for (i = 0; cp[i] == '%' && cp[i+1] == 'c'; ) {
+ i += 2;
+ if (i == sp->exp1->args[0]->val.i) {
+ sp2 = NULL;
+ for (i = 1; i < sp->exp1->nargs; i++) {
+ ex = makeexpr_hat(sp->exp1->args[i], 0);
+ sp2 = makestmt_seq(sp2,
+ makestmt_assign(copyexpr(ex),
+ makegetchar(fex)));
+ if (checkeof(fex)) {
+ sp2 = makestmt_seq(sp2,
+ makestmt_call(makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_NE,
+ ex,
+ makeexpr_name("EOF", tp_char)),
+ makeexpr_name(endoffilename, tp_int))));
+ } else
+ freeexpr(ex);
+ }
+ return sp2;
+ }
+ }
+ }
+ nargs = sp->exp1->nargs - 1;
+ if (isstrread) {
+ strchange(&sp->exp1->val.s, "sscanf");
+ insertarg(&sp->exp1, 0, copyexpr(fex));
+ } else if (!isvar(fex, mp_input)) {
+ strchange(&sp->exp1->val.s, "fscanf");
+ insertarg(&sp->exp1, 0, filebasename(copyexpr(fex)));
+ }
+ if (FCheck(checkreadformat)) {
+ if (checkeof(fex) && !isstrread)
+ ex = makeexpr_cond(makeexpr_rel(EK_NE,
+ makeexpr_bicall_1("feof",
+ tp_int,
+ filebasename(copyexpr(fex))),
+ makeexpr_long(0)),
+ makeexpr_name(endoffilename, tp_int),
+ makeexpr_name(badinputformatname, tp_int));
+ else
+ ex = makeexpr_name(badinputformatname, tp_int);
+ sp->exp1 = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_EQ,
+ sp->exp1,
+ makeexpr_long(nargs)),
+ ex);
+ } else if (checkeof(fex) && !isstrread) {
+ sp->exp1 = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_NE,
+ sp->exp1,
+ makeexpr_name("EOF", tp_int)),
+ makeexpr_name(endoffilename, tp_int));
+ }
+ }
+ return sp;
+}
+
+
+
+Static Expr *makefgets(vex, lex, fex)
+Expr *vex, *lex, *fex;
+{
+ Expr *ex;
+
+ ex = makeexpr_bicall_3("fgets", tp_strptr,
+ vex,
+ lex,
+ filebasename(copyexpr(fex)));
+ if (checkeof(fex)) {
+ ex = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_NE, ex, makeexpr_nil()),
+ makeexpr_name(endoffilename, tp_int));
+ }
+ return ex;
+}
+
+
+
+Static Stmt *skipeoln(fex)
+Expr *fex;
+{
+ Meaning *tvar;
+ Expr *ex;
+
+ if (!strcmp(readlnname, "fgets")) {
+ tvar = makestmttempvar(tp_str255, name_STRING);
+ return makestmt_call(makefgets(makeexpr_var(tvar),
+ makeexpr_long(stringceiling+1),
+ filebasename(fex)));
+ } else if (!strcmp(readlnname, "scanf") || !*readlnname) {
+ if (checkeof(fex))
+ ex = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_NE,
+ makegetchar(fex),
+ makeexpr_name("EOF", tp_char)),
+ makeexpr_name(endoffilename, tp_int));
+ else
+ ex = makegetchar(fex);
+ return makestmt_seq(fixscanf(
+ makestmt_call(makeexpr_bicall_1("scanf", tp_int,
+ makeexpr_string("%*[^\n]"))), fex),
+ makestmt_call(ex));
+ } else {
+ return makestmt_call(makeexpr_bicall_1(readlnname, tp_void,
+ filebasename(copyexpr(fex))));
+ }
+}
+
+
+
+Static Stmt *handleread_text(fex, var, isreadln)
+Expr *fex, *var;
+int isreadln;
+{
+ Stmt *spbase, *spafter, *sp;
+ Expr *ex = NULL, *exj = NULL;
+ Type *type;
+ Meaning *tvar, *tempcp, *mp;
+ int i, isstrread, scanfmode, readlnflag, varstring, maxstring;
+ int longstrsize = (longstringsize > 0) ? longstringsize : stringceiling;
+ long rmin, rmax;
+ char *fmt;
+
+ spbase = NULL;
+ spafter = NULL;
+ sp = NULL;
+ tempcp = NULL;
+ if (fex->val.type->kind == TK_ARRAY)
+ fex = makeexpr_sprintfify(fex);
+ isstrread = (fex->val.type->kind == TK_STRING);
+ if (isstrread) {
+ exj = var;
+ var = p_expr(NULL);
+ }
+ scanfmode = !strcmp(readlnname, "scanf") || !*readlnname || isstrread;
+ for (;;) {
+ readlnflag = isreadln && curtok == TOK_RPAR;
+ if (var->val.type->kind == TK_STRING && !isstrread) {
+ if (sp)
+ spbase = makestmt_seq(spbase, fixscanf(sp, fex));
+ spbase = makestmt_seq(spbase, spafter);
+ varstring = (varstrings && var->kind == EK_VAR &&
+ (mp = (Meaning *)var->val.i)->kind == MK_VARPARAM &&
+ mp->type == tp_strptr);
+ maxstring = (strmax(var) >= longstrsize && !varstring);
+ if (isvar(fex, mp_input) && maxstring && usegets && readlnflag) {
+ spbase = makestmt_seq(spbase,
+ makestmt_call(makeexpr_bicall_1("gets", tp_str255,
+ makeexpr_addr(var))));
+ isreadln = 0;
+ } else if (scanfmode && !varstring &&
+ (*readlnname || !isreadln)) {
+ spbase = makestmt_seq(spbase, makestmt_assign(makeexpr_hat(copyexpr(var), 0),
+ makeexpr_char(0)));
+ if (maxstring && usegets)
+ ex = makeexpr_string("%[^\n]");
+ else
+ ex = makeexpr_string(format_d("%%%d[^\n]", strmax(var)));
+ ex = makeexpr_bicall_2("scanf", tp_int, ex, makeexpr_addr(var));
+ spbase = makestmt_seq(spbase, fixscanf(makestmt_call(ex), fex));
+ if (readlnflag && maxstring && usegets) {
+ spbase = makestmt_seq(spbase, makestmt_call(makegetchar(fex)));
+ isreadln = 0;
+ }
+ } else {
+ ex = makeexpr_plus(strmax_func(var), makeexpr_long(1));
+ spbase = makestmt_seq(spbase,
+ makestmt_call(makefgets(makeexpr_addr(copyexpr(var)),
+ ex,
+ fex)));
+ if (!tempcp)
+ tempcp = makestmttempvar(tp_charptr, name_TEMP);
+ spbase = makestmt_seq(spbase,
+ makestmt_assign(makeexpr_var(tempcp),
+ makeexpr_bicall_2("strchr", tp_charptr,
+ makeexpr_addr(copyexpr(var)),
+ makeexpr_char('\n'))));
+ sp = makestmt_assign(makeexpr_hat(makeexpr_var(tempcp), 0),
+ makeexpr_long(0));
+ if (readlnflag)
+ isreadln = 0;
+ else
+ sp = makestmt_seq(sp,
+ makestmt_call(makeexpr_bicall_2("ungetc", tp_void,
+ makeexpr_char('\n'),
+ filebasename(copyexpr(fex)))));
+ spbase = makestmt_seq(spbase, makestmt_if(makeexpr_rel(EK_NE,
+ makeexpr_var(tempcp),
+ makeexpr_nil()),
+ sp,
+ NULL));
+ }
+ sp = NULL;
+ spafter = NULL;
+ } else if (var->val.type->kind == TK_ARRAY && !isstrread) {
+ if (sp)
+ spbase = makestmt_seq(spbase, fixscanf(sp, fex));
+ spbase = makestmt_seq(spbase, spafter);
+ ex = makeexpr_sizeof(copyexpr(var), 0);
+ if (readlnflag) {
+ spbase = makestmt_seq(spbase,
+ makestmt_call(
+ makeexpr_bicall_3("P_readlnpaoc", tp_void,
+ filebasename(copyexpr(fex)),
+ makeexpr_addr(var),
+ makeexpr_arglong(ex, 0))));
+ isreadln = 0;
+ } else {
+ spbase = makestmt_seq(spbase,
+ makestmt_call(
+ makeexpr_bicall_3("P_readpaoc", tp_void,
+ filebasename(copyexpr(fex)),
+ makeexpr_addr(var),
+ makeexpr_arglong(ex, 0))));
+ }
+ sp = NULL;
+ spafter = NULL;
+ } else {
+ switch (ord_type(var->val.type)->kind) {
+
+ case TK_INTEGER:
+ fmt = "d";
+ if (curtok == TOK_COLON) {
+ gettok();
+ if (curtok == TOK_IDENT &&
+ !strcicmp(curtokbuf, "HEX")) {
+ fmt = "x";
+ } else if (curtok == TOK_IDENT &&
+ !strcicmp(curtokbuf, "OCT")) {
+ fmt = "o";
+ } else if (curtok == TOK_IDENT &&
+ !strcicmp(curtokbuf, "BIN")) {
+ fmt = "b";
+ note("Using %b for binary format in scanf [194]");
+ } else
+ warning("Unrecognized format specified in READ [212]");
+ gettok();
+ }
+ type = findbasetype(var->val.type, ODECL_NOPRES);
+ if (exprlongness(var) > 0)
+ ex = makeexpr_string(format_s("%%l%s", fmt));
+ else if (type == tp_integer || type == tp_int ||
+ type == tp_uint || type == tp_sint)
+ ex = makeexpr_string(format_s("%%%s", fmt));
+ else if (type == tp_sshort || type == tp_ushort)
+ ex = makeexpr_string(format_s("%%h%s", fmt));
+ else {
+ tvar = makestmttempvar(tp_int, name_TEMP);
+ spafter = makestmt_seq(spafter,
+ makestmt_assign(var,
+ makeexpr_var(tvar)));
+ var = makeexpr_var(tvar);
+ ex = makeexpr_string(format_s("%%%s", fmt));
+ }
+ break;
+
+ case TK_CHAR:
+ ex = makeexpr_string("%c");
+ if (newlinespace && !isstrread) {
+ spafter = makestmt_seq(spafter,
+ makestmt_if(makeexpr_rel(EK_EQ,
+ copyexpr(var),
+ makeexpr_char('\n')),
+ makestmt_assign(copyexpr(var),
+ makeexpr_char(' ')),
+ NULL));
+ }
+ break;
+
+ case TK_BOOLEAN:
+ tvar = makestmttempvar(tp_str255, name_STRING);
+ spafter = makestmt_seq(spafter,
+ makestmt_assign(var,
+ makeexpr_or(makeexpr_rel(EK_EQ,
+ makeexpr_hat(makeexpr_var(tvar), 0),
+ makeexpr_char('T')),
+ makeexpr_rel(EK_EQ,
+ makeexpr_hat(makeexpr_var(tvar), 0),
+ makeexpr_char('t')))));
+ var = makeexpr_var(tvar);
+ ex = makeexpr_string(" %[a-zA-Z]");
+ break;
+
+ case TK_ENUM:
+ warning("READ on enumerated types not yet supported [213]");
+ if (useenum)
+ ex = makeexpr_string("%d");
+ else
+ ex = makeexpr_string("%hd");
+ break;
+
+ case TK_REAL:
+ if (var->val.type == tp_longreal)
+ ex = makeexpr_string("%lg");
+ else
+ ex = makeexpr_string("%g");
+ break;
+
+ case TK_STRING: /* strread only */
+ ex = makeexpr_string(format_d("%%%lds", strmax(fex)));
+ break;
+
+ case TK_ARRAY: /* strread only */
+ if (!ord_range(ex->val.type->indextype, &rmin, &rmax)) {
+ rmin = 1;
+ rmax = 1;
+ note("Can't determine length of packed array of chars [195]");
+ }
+ ex = makeexpr_string(format_d("%%%ldc", rmax-rmin+1));
+ break;
+
+ default:
+ note("Element has wrong type for WRITE statement [196]");
+ ex = NULL;
+ break;
+
+ }
+ if (ex) {
+ var = makeexpr_addr(var);
+ if (sp) {
+ sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0], ex, 0);
+ insertarg(&sp->exp1, sp->exp1->nargs, var);
+ } else {
+ sp = makestmt_call(makeexpr_bicall_2("scanf", tp_int, ex, var));
+ }
+ }
+ }
+ if (curtok == TOK_COMMA) {
+ gettok();
+ var = p_expr(NULL);
+ } else
+ break;
+ }
+ if (sp) {
+ if (isstrread && !FCheck(checkreadformat) &&
+ ((i=0, checkstring(sp->exp1->args[0], "%d")) ||
+ (i++, checkstring(sp->exp1->args[0], "%ld")) ||
+ (i++, checkstring(sp->exp1->args[0], "%hd")) ||
+ (i++, checkstring(sp->exp1->args[0], "%lg")))) {
+ if (fullstrread != 0 && exj) {
+ tvar = makestmttempvar(tp_strptr, name_STRING);
+ sp->exp1 = makeexpr_assign(makeexpr_hat(sp->exp1->args[1], 0),
+ (i == 3) ? makeexpr_bicall_2("strtod", tp_longreal,
+ copyexpr(fex),
+ makeexpr_addr(makeexpr_var(tvar)))
+ : makeexpr_bicall_3("strtol", tp_integer,
+ copyexpr(fex),
+ makeexpr_addr(makeexpr_var(tvar)),
+ makeexpr_long(10)));
+ spafter = makestmt_seq(spafter,
+ makestmt_assign(copyexpr(exj),
+ makeexpr_minus(makeexpr_var(tvar),
+ makeexpr_addr(copyexpr(fex)))));
+ } else {
+ sp->exp1 = makeexpr_assign(makeexpr_hat(sp->exp1->args[1], 0),
+ makeexpr_bicall_1((i == 1) ? "atol" : (i == 3) ? "atof" : "atoi",
+ (i == 1) ? tp_integer : (i == 3) ? tp_longreal : tp_int,
+ copyexpr(fex)));
+ }
+ } else if (isstrread && fullstrread != 0 && exj) {
+ sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0],
+ makeexpr_string(sizeof_int >= 32 ? "%n" : "%ln"), 0);
+ insertarg(&sp->exp1, sp->exp1->nargs, makeexpr_addr(copyexpr(exj)));
+ } else if (isreadln && scanfmode && !FCheck(checkreadformat)) {
+ isreadln = 0;
+ sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0],
+ makeexpr_string("%*[^\n]"), 0);
+ spafter = makestmt_seq(makestmt_call(makegetchar(fex)), spafter);
+ }
+ spbase = makestmt_seq(spbase, fixscanf(sp, fex));
+ }
+ spbase = makestmt_seq(spbase, spafter);
+ if (isreadln)
+ spbase = makestmt_seq(spbase, skipeoln(fex));
+ return spbase;
+}
+
+
+
+Static Stmt *handleread_bin(fex, var)
+Expr *fex, *var;
+{
+ Type *basetype;
+ Stmt *sp;
+ Expr *ex, *tvardef = NULL;
+
+ sp = NULL;
+ basetype = filebasetype(fex->val.type);
+ for (;;) {
+ ex = makeexpr_bicall_4("fread", tp_integer, makeexpr_addr(var),
+ makeexpr_sizeof(makeexpr_type(basetype), 0),
+ makeexpr_long(1),
+ filebasename(copyexpr(fex)));
+ if (checkeof(fex)) {
+ ex = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
+ makeexpr_name(endoffilename, tp_int));
+ }
+ sp = makestmt_seq(sp, makestmt_call(ex));
+ if (curtok == TOK_COMMA) {
+ gettok();
+ var = p_expr(NULL);
+ } else
+ break;
+ }
+ freeexpr(tvardef);
+ return sp;
+}
+
+
+
+Static Stmt *proc_read()
+{
+ Expr *fex, *ex;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(NULL);
+ if (isfiletype(ex->val.type, -1) && wneedtok(TOK_COMMA)) {
+ fex = ex;
+ ex = p_expr(NULL);
+ } else {
+ fex = makeexpr_var(mp_input);
+ }
+ if (fex->val.type == tp_text || fex->val.type == tp_bigtext)
+ sp = handleread_text(fex, ex, 0);
+ else
+ sp = handleread_bin(fex, ex);
+ skipcloseparen();
+ return wrapopencheck(sp, fex);
+}
+
+
+
+Static Stmt *proc_readdir()
+{
+ Expr *fex, *ex;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ ex = p_expr(tp_integer);
+ sp = doseek(fex, ex);
+ if (!skipopenparen())
+ return sp;
+ sp = makestmt_seq(sp, handleread_bin(fex, p_expr(NULL)));
+ skipcloseparen();
+ return wrapopencheck(sp, fex);
+}
+
+
+
+Static Stmt *proc_readln()
+{
+ Expr *fex, *ex;
+ Stmt *sp;
+
+ if (curtok != TOK_LPAR) {
+ fex = makeexpr_var(mp_input);
+ return wrapopencheck(skipeoln(copyexpr(fex)), fex);
+ } else {
+ gettok();
+ ex = p_expr(NULL);
+ if (isfiletype(ex->val.type, -1)) {
+ fex = ex;
+ if (curtok == TOK_RPAR || !wneedtok(TOK_COMMA)) {
+ skippasttotoken(TOK_RPAR, TOK_SEMI);
+ return wrapopencheck(skipeoln(copyexpr(fex)), fex);
+ } else {
+ ex = p_expr(NULL);
+ }
+ } else {
+ fex = makeexpr_var(mp_input);
+ }
+ sp = handleread_text(fex, ex, 1);
+ skipcloseparen();
+ }
+ return wrapopencheck(sp, fex);
+}
+
+
+
+Static Stmt *proc_readv()
+{
+ Expr *vex;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ sp = handleread_text(vex, NULL, 0);
+ skipcloseparen();
+ return sp;
+}
+
+
+
+Static Stmt *proc_strread()
+{
+ Expr *vex, *exi, *exj, *exjj, *ex;
+ Stmt *sp, *sp2;
+ Meaning *tvar, *jvar;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(tp_str255);
+ if (vex->kind != EK_VAR) {
+ tvar = makestmttempvar(tp_str255, name_STRING);
+ sp = makestmt_assign(makeexpr_var(tvar), vex);
+ vex = makeexpr_var(tvar);
+ } else
+ sp = NULL;
+ if (!skipcomma())
+ return NULL;
+ exi = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ exj = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ if (exprspeed(exi) >= 5 || !nosideeffects(exi, 0)) {
+ sp = makestmt_seq(sp, makestmt_assign(copyexpr(exj), exi));
+ exi = copyexpr(exj);
+ }
+ if (fullstrread != 0 &&
+ ((ex = singlevar(exj)) == NULL || exproccurs(exi, ex))) {
+ jvar = makestmttempvar(exj->val.type, name_TEMP);
+ exjj = makeexpr_var(jvar);
+ } else {
+ exjj = copyexpr(exj);
+ jvar = (exj->kind == EK_VAR) ? (Meaning *)exj->val.i : NULL;
+ }
+ sp2 = handleread_text(bumpstring(copyexpr(vex),
+ copyexpr(exi), 1),
+ exjj, 0);
+ sp = makestmt_seq(sp, sp2);
+ skipcloseparen();
+ if (fullstrread == 0) {
+ sp = makestmt_seq(sp, makestmt_assign(exj,
+ makeexpr_plus(makeexpr_bicall_1("strlen", tp_int,
+ vex),
+ makeexpr_long(1))));
+ freeexpr(exjj);
+ freeexpr(exi);
+ } else {
+ sp = makestmt_seq(sp, makestmt_assign(exj,
+ makeexpr_plus(exjj, exi)));
+ if (fullstrread == 2)
+ note("STRREAD was used [197]");
+ freeexpr(vex);
+ }
+ return mixassignments(sp, jvar);
+}
+
+
+
+
+Static Expr *func_random()
+{
+ Expr *ex;
+
+ if (curtok == TOK_LPAR) {
+ gettok();
+ ex = p_expr(tp_integer);
+ skipcloseparen();
+ return makeexpr_bicall_1(randintname, tp_integer, makeexpr_arglong(ex, 1));
+ } else {
+ return makeexpr_bicall_0(randrealname, tp_longreal);
+ }
+}
+
+
+
+Static Stmt *proc_randomize()
+{
+ if (*randomizename)
+ return makestmt_call(makeexpr_bicall_0(randomizename, tp_void));
+ else
+ return NULL;
+}
+
+
+
+Static Expr *func_round(ex)
+Expr *ex;
+{
+ Meaning *tvar;
+
+ ex = grabarg(ex, 0);
+ if (ex->val.type->kind != TK_REAL)
+ return ex;
+ if (*roundname) {
+ if (*roundname != '*' || (exprspeed(ex) < 5 && nosideeffects(ex, 0))) {
+ return makeexpr_bicall_1(roundname, tp_integer, ex);
+ } else {
+ tvar = makestmttempvar(tp_longreal, name_TEMP);
+ return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), ex),
+ makeexpr_bicall_1(roundname, tp_integer, makeexpr_var(tvar)));
+ }
+ } else {
+ return makeexpr_actcast(makeexpr_bicall_1("floor", tp_longreal,
+ makeexpr_plus(ex, makeexpr_real("0.5"))),
+ tp_integer);
+ }
+}
+
+
+
+Static Stmt *proc_unpack()
+{
+ Expr *exs, *exd, *exi, *mins;
+ Meaning *tvar;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ exs = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ exd = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ exi = p_ord_expr();
+ skipcloseparen();
+ if (exd->val.type->kind != TK_ARRAY ||
+ (exs->val.type->kind != TK_ARRAY &&
+ exs->val.type->kind != TK_SMALLARRAY)) {
+ warning("Bad argument types for PACK/UNPACK [325]");
+ return makestmt_call(makeexpr_bicall_3("unpack", tp_void,
+ exs, exd, exi));
+ }
+ if (exs->val.type->smax || exd->val.type->smax) {
+ tvar = makestmttempvar(exs->val.type->indextype, name_TEMP);
+ sp = makestmt(SK_FOR);
+ if (exs->val.type->smin)
+ mins = exs->val.type->smin;
+ else
+ mins = exs->val.type->indextype->smin;
+ sp->exp1 = makeexpr_assign(makeexpr_var(tvar),
+ copyexpr(mins));
+ sp->exp2 = makeexpr_rel(EK_LE, makeexpr_var(tvar),
+ copyexpr(exs->val.type->indextype->smax));
+ sp->exp3 = makeexpr_assign(makeexpr_var(tvar),
+ makeexpr_plus(makeexpr_var(tvar),
+ makeexpr_long(1)));
+ exi = makeexpr_minus(exi, copyexpr(mins));
+ sp->stm1 = makestmt_assign(p_index(exd,
+ makeexpr_plus(makeexpr_var(tvar),
+ exi)),
+ p_index(exs, makeexpr_var(tvar)));
+ return sp;
+ } else {
+ exi = gentle_cast(exi, exs->val.type->indextype);
+ return makestmt_call(makeexpr_bicall_3("memcpy", exd->val.type,
+ exd,
+ makeexpr_addr(p_index(exs, exi)),
+ makeexpr_sizeof(copyexpr(exd), 0)));
+ }
+}
+
+
+
+Static Expr *func_uround(ex)
+Expr *ex;
+{
+ ex = grabarg(ex, 0);
+ if (ex->val.type->kind != TK_REAL)
+ return ex;
+ return makeexpr_actcast(makeexpr_bicall_1("floor", tp_longreal,
+ makeexpr_plus(ex, makeexpr_real("0.5"))),
+ tp_unsigned);
+}
+
+
+
+Static Expr *func_scan()
+{
+ Expr *ex, *ex2, *ex3;
+ char *name;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ if (curtok == TOK_EQ)
+ name = "P_scaneq";
+ else
+ name = "P_scanne";
+ gettok();
+ ex2 = p_expr(tp_char);
+ if (!skipcomma())
+ return NULL;
+ ex3 = p_expr(tp_str255);
+ skipcloseparen();
+ return makeexpr_bicall_3(name, tp_int,
+ makeexpr_arglong(ex, 0),
+ makeexpr_charcast(ex2), ex3);
+}
+
+
+
+Static Expr *func_scaneq(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_3("P_scaneq", tp_int,
+ makeexpr_arglong(ex->args[0], 0),
+ makeexpr_charcast(ex->args[1]),
+ ex->args[2]);
+}
+
+
+Static Expr *func_scanne(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_3("P_scanne", tp_int,
+ makeexpr_arglong(ex->args[0], 0),
+ makeexpr_charcast(ex->args[1]),
+ ex->args[2]);
+}
+
+
+
+Static Stmt *proc_seek()
+{
+ Expr *fex, *ex;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ ex = p_expr(tp_integer);
+ skipcloseparen();
+ sp = wrapopencheck(doseek(fex, ex), copyexpr(fex));
+ if (*setupbufname && fileisbuffered(fex, 1))
+ sp = makestmt_seq(sp,
+ makestmt_call(
+ makeexpr_bicall_2(setupbufname, tp_void,
+ filebasename(fex),
+ makeexpr_type(filebasetype(fex->val.type)))));
+ else
+ freeexpr(fex);
+ return sp;
+}
+
+
+
+Static Expr *func_seekeof()
+{
+ Expr *ex;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_text);
+ else
+ ex = makeexpr_var(mp_input);
+ if (*skipspacename)
+ ex = makeexpr_bicall_1(skipspacename, tp_text, filebasename(ex));
+ else
+ note("SEEKEOF was used [198]");
+ return iofunc(ex, 0);
+}
+
+
+
+Static Expr *func_seekeoln()
+{
+ Expr *ex;
+
+ if (curtok == TOK_LPAR)
+ ex = p_parexpr(tp_text);
+ else
+ ex = makeexpr_var(mp_input);
+ if (*skipspacename)
+ ex = makeexpr_bicall_1(skipspacename, tp_text, filebasename(ex));
+ else
+ note("SEEKEOLN was used [199]");
+ return iofunc(ex, 1);
+}
+
+
+
+Static Stmt *proc_setstrlen()
+{
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ return makestmt_assign(makeexpr_bicall_1("strlen", tp_int, ex),
+ ex2);
+}
+
+
+
+Static Stmt *proc_settextbuf()
+{
+ Expr *fex, *bex, *sex;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ bex = p_expr(NULL);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ sex = p_expr(tp_integer);
+ } else
+ sex = makeexpr_sizeof(copyexpr(bex), 0);
+ skipcloseparen();
+ note("Make sure setvbuf() call occurs when file is open [200]");
+ return makestmt_call(makeexpr_bicall_4("setvbuf", tp_void,
+ filebasename(fex),
+ makeexpr_addr(bex),
+ makeexpr_name("_IOFBF", tp_integer),
+ sex));
+}
+
+
+
+Static Expr *func_sin(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("sin", tp_longreal, grabarg(ex, 0));
+}
+
+
+Static Expr *func_sinh(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("sinh", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_sizeof()
+{
+ Expr *ex;
+ Type *type;
+ char *name, vbuf[1000];
+ int lpar;
+
+ lpar = (curtok == TOK_LPAR);
+ if (lpar)
+ gettok();
+ if (curtok == TOK_IDENT && curtokmeaning && curtokmeaning->kind == MK_TYPE) {
+ ex = makeexpr_type(curtokmeaning->type);
+ gettok();
+ } else
+ ex = p_expr(NULL);
+ type = ex->val.type;
+ parse_special_variant(type, vbuf);
+ if (lpar)
+ skipcloseparen();
+ name = find_special_variant(vbuf, "SpecialSizeOf", specialsizeofs, 1);
+ if (name) {
+ freeexpr(ex);
+ return pc_expr_str(name);
+ } else
+ return makeexpr_sizeof(ex, 0);
+}
+
+
+
+Static Expr *func_statusv()
+{
+ return makeexpr_name(name_IORESULT, tp_integer);
+}
+
+
+
+Static Expr *func_str_hp(ex)
+Expr *ex;
+{
+ return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1],
+ ex->args[2], ex->args[3]));
+}
+
+
+
+Static Stmt *proc_strappend()
+{
+ Expr *ex, *ex2;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_str255);
+ skipcloseparen();
+ return makestmt_assign(ex, makeexpr_concat(copyexpr(ex), ex2, 0));
+}
+
+
+
+Static Stmt *proc_strdelete()
+{
+ Meaning *tvar = NULL, *tvari;
+ Expr *ex, *ex2, *ex3, *ex4, *exi, *exn;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ exi = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ exn = p_expr(tp_integer);
+ } else
+ exn = makeexpr_long(1);
+ skipcloseparen();
+ if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
+ sp = NULL;
+ else {
+ tvari = makestmttempvar(tp_int, name_TEMP);
+ sp = makestmt_assign(makeexpr_var(tvari), exi);
+ exi = makeexpr_var(tvari);
+ }
+ ex3 = bumpstring(copyexpr(ex), copyexpr(exi), 1);
+ ex4 = bumpstring(copyexpr(ex), makeexpr_plus(exi, exn), 1);
+ if (strcpyleft) {
+ ex2 = ex3;
+ } else {
+ tvar = makestmttempvar(tp_str255, name_STRING);
+ ex2 = makeexpr_var(tvar);
+ }
+ sp = makestmt_seq(sp, makestmt_assign(ex2, ex4));
+ if (!strcpyleft)
+ sp = makestmt_seq(sp, makestmt_assign(ex3, makeexpr_var(tvar)));
+ return sp;
+}
+
+
+
+Static Stmt *proc_strinsert()
+{
+ Meaning *tvari;
+ Expr *exs, *exd, *exi;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ exs = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ exd = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ exi = p_expr(tp_integer);
+ skipcloseparen();
+#if 0
+ if (checkconst(exi, 1)) {
+ freeexpr(exi);
+ return makestmt_assign(exd,
+ makeexpr_concat(exs, copyexpr(exd)));
+ }
+#endif
+ if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
+ sp = NULL;
+ else {
+ tvari = makestmttempvar(tp_int, name_TEMP);
+ sp = makestmt_assign(makeexpr_var(tvari), exi);
+ exi = makeexpr_var(tvari);
+ }
+ exd = bumpstring(exd, exi, 1);
+ sp = makestmt_seq(sp, makestmt_assign(exd,
+ makeexpr_concat(exs, copyexpr(exd), 0)));
+ return sp;
+}
+
+
+
+Static Stmt *proc_strmove()
+{
+ Expr *exlen, *exs, *exsi, *exd, *exdi;
+
+ if (!skipopenparen())
+ return NULL;
+ exlen = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ exs = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ exsi = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ exd = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ exdi = p_expr(tp_integer);
+ skipcloseparen();
+ exsi = makeexpr_arglong(exsi, 0);
+ exdi = makeexpr_arglong(exdi, 0);
+ return makestmt_call(makeexpr_bicall_5(strmovename, tp_str255,
+ exlen, exs, exsi, exd, exdi));
+}
+
+
+
+Static Expr *func_strlen(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("strlen", tp_int, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_strltrim(ex)
+Expr *ex;
+{
+ return makeexpr_assign(makeexpr_hat(ex->args[0], 0),
+ makeexpr_bicall_1(strltrimname, tp_str255, ex->args[1]));
+}
+
+
+
+Static Expr *func_strmax(ex)
+Expr *ex;
+{
+ return strmax_func(grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_strpos(ex)
+Expr *ex;
+{
+ char *cp;
+
+ if (!switch_strpos)
+ swapexprs(ex->args[0], ex->args[1]);
+ cp = strposname;
+ if (!*cp) {
+ note("STRPOS function used [201]");
+ cp = "STRPOS";
+ }
+ return makeexpr_bicall_3(cp, tp_int,
+ ex->args[0],
+ ex->args[1],
+ makeexpr_long(1));
+}
+
+
+
+Static Expr *func_strrpt(ex)
+Expr *ex;
+{
+ if (ex->args[1]->kind == EK_CONST &&
+ ex->args[1]->val.i == 1 && ex->args[1]->val.s[0] == ' ') {
+ return makeexpr_bicall_4("sprintf", tp_strptr, ex->args[0],
+ makeexpr_string("%*s"),
+ makeexpr_longcast(ex->args[2], 0),
+ makeexpr_string(""));
+ } else
+ return makeexpr_bicall_3(strrptname, tp_strptr, ex->args[0], ex->args[1],
+ makeexpr_arglong(ex->args[2], 0));
+}
+
+
+
+Static Expr *func_strrtrim(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1(strrtrimname, tp_strptr,
+ makeexpr_assign(makeexpr_hat(ex->args[0], 0),
+ ex->args[1]));
+}
+
+
+
+Static Expr *func_succ()
+{
+ Expr *ex;
+
+ if (wneedtok(TOK_LPAR)) {
+ ex = p_ord_expr();
+ skipcloseparen();
+ } else
+ ex = p_ord_expr();
+#if 1
+ ex = makeexpr_inc(ex, makeexpr_long(1));
+#else
+ ex = makeexpr_cast(makeexpr_plus(ex, makeexpr_long(1)), ex->val.type);
+#endif
+ return ex;
+}
+
+
+
+Static Expr *func_sqr()
+{
+ return makeexpr_sqr(p_parexpr(tp_integer), 0);
+}
+
+
+
+Static Expr *func_sqrt(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("sqrt", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_swap(ex)
+Expr *ex;
+{
+ char *cp;
+
+ ex = grabarg(ex, 0);
+ cp = swapname;
+ if (!*cp) {
+ note("SWAP function was used [202]");
+ cp = "SWAP";
+ }
+ return makeexpr_bicall_1(swapname, tp_int, ex);
+}
+
+
+
+Static Expr *func_tan(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("tan", tp_longreal, grabarg(ex, 0));
+}
+
+
+Static Expr *func_tanh(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("tanh", tp_longreal, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_trunc(ex)
+Expr *ex;
+{
+ return makeexpr_actcast(grabarg(ex, 0), tp_integer);
+}
+
+
+
+Static Expr *func_utrunc(ex)
+Expr *ex;
+{
+ return makeexpr_actcast(grabarg(ex, 0), tp_unsigned);
+}
+
+
+
+Static Expr *func_uand()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_unsigned);
+ if (skipcomma()) {
+ ex = makeexpr_bin(EK_BAND, ex->val.type, ex, p_expr(tp_unsigned));
+ skipcloseparen();
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_udec()
+{
+ return handle_vax_hex(NULL, "u", 0);
+}
+
+
+
+Static Expr *func_unot()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_unsigned);
+ ex = makeexpr_un(EK_BNOT, ex->val.type, ex);
+ skipcloseparen();
+ return ex;
+}
+
+
+
+Static Expr *func_uor()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_unsigned);
+ if (skipcomma()) {
+ ex = makeexpr_bin(EK_BOR, ex->val.type, ex, p_expr(tp_unsigned));
+ skipcloseparen();
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_upcase(ex)
+Expr *ex;
+{
+ return makeexpr_bicall_1("toupper", tp_char, grabarg(ex, 0));
+}
+
+
+
+Static Expr *func_upper()
+{
+ Expr *ex;
+ Value val;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_integer);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ val = p_constant(tp_integer);
+ if (!val.type || val.i != 1)
+ note("UPPER(v,n) not supported for n>1 [190]");
+ }
+ skipcloseparen();
+ return copyexpr(ex->val.type->indextype->smax);
+}
+
+
+
+Static Expr *func_uxor()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_unsigned);
+ if (skipcomma()) {
+ ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, p_expr(tp_unsigned));
+ skipcloseparen();
+ }
+ return ex;
+}
+
+
+
+Static Expr *func_val_modula()
+{
+ Expr *ex;
+ Type *tp;
+
+ if (!skipopenparen())
+ return NULL;
+ tp = p_type(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex = p_expr(tp);
+ skipcloseparen();
+ return pascaltypecast(tp, ex);
+}
+
+
+
+Static Stmt *proc_val_turbo()
+{
+ Expr *ex, *vex, *code, *fmt;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = gentle_cast(p_expr(tp_str255), tp_str255);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (curtok == TOK_COMMA) {
+ gettok();
+ code = gentle_cast(p_expr(tp_integer), tp_integer);
+ } else
+ code = NULL;
+ skipcloseparen();
+ if (vex->val.type->kind == TK_REAL)
+ fmt = makeexpr_string("%lg");
+ else if (exprlongness(vex) > 0)
+ fmt = makeexpr_string("%ld");
+ else
+ fmt = makeexpr_string("%d");
+ ex = makeexpr_bicall_3("sscanf", tp_int,
+ ex, fmt, makeexpr_addr(vex));
+ if (code) {
+ ex = makeexpr_rel(EK_EQ, ex, makeexpr_long(0));
+ return makestmt_assign(code, makeexpr_ord(ex));
+ } else
+ return makestmt_call(ex);
+}
+
+
+
+
+
+
+
+Static Expr *writestrelement(ex, wid, vex, code, needboth)
+Expr *ex, *wid, *vex;
+int code, needboth;
+{
+ if (formatstrings && needboth) {
+ return makeexpr_bicall_5("sprintf", tp_str255, vex,
+ makeexpr_string(format_d("%%*.*%c", code)),
+ copyexpr(wid),
+ wid,
+ ex);
+ } else {
+ return makeexpr_bicall_4("sprintf", tp_str255, vex,
+ makeexpr_string(format_d("%%*%c", code)),
+ wid,
+ ex);
+ }
+}
+
+
+
+Static char *makeenumnames(tp)
+Type *tp;
+{
+ Strlist *sp;
+ char *name;
+ Meaning *mp;
+ int saveindent;
+
+ for (sp = enumnames; sp && sp->value != (long)tp; sp = sp->next) ;
+ if (!sp) {
+ if (tp->meaning)
+ name = format_s(name_ENUM, tp->meaning->name);
+ else
+ name = format_s(name_ENUM, format_d("_%d", ++enumnamecount));
+ sp = strlist_insert(&enumnames, name);
+ sp->value = (long)tp;
+ outsection(2);
+ output(format_s("static %s *", charname));
+ output(sp->s);
+ output("[] = {\n");
+ saveindent = outindent;
+ moreindent(tabsize);
+ moreindent(structinitindent);
+ for (mp = tp->fbase; mp; mp = mp->xnext) {
+ output(makeCstring(mp->sym->name, strlen(mp->sym->name)));
+ if (mp->xnext)
+ output(",\002 ");
+ }
+ outindent = saveindent;
+ output("\n} ;\n");
+ outsection(2);
+ }
+ return sp->s;
+}
+
+
+
+
+
+/* This function must return a "tempsprintf" */
+
+Expr *writeelement(ex, wid, prec, base)
+Expr *ex, *wid, *prec;
+int base;
+{
+ Expr *vex, *ex1, *ex2;
+ Meaning *tvar;
+ char *fmtcode;
+ Type *type;
+
+ ex = makeexpr_charcast(ex);
+ if (ex->val.type->kind == TK_POINTER) {
+ ex = makeexpr_hat(ex, 0); /* convert char *'s to strings */
+ intwarning("writeelement", "got a char * instead of a string [214]");
+ }
+ if ((ex->val.type->kind == TK_STRING && !wid) ||
+ (ord_type(ex->val.type)->kind == TK_CHAR && (!wid || checkconst(wid, 1)))) {
+ return makeexpr_sprintfify(ex);
+ }
+ tvar = makestmttempvar(tp_str255, name_STRING);
+ vex = makeexpr_var(tvar);
+ if (wid)
+ wid = makeexpr_longcast(wid, 0);
+ if (prec)
+ prec = makeexpr_longcast(prec, 0);
+#if 0
+ if (wid && (wid->kind == EK_CONST && wid->val.i < 0 ||
+ checkconst(wid, -1))) {
+ freeexpr(wid); /* P-system uses write(x:-1) to mean write(x) */
+ wid = NULL;
+ }
+ if (prec && (prec->kind == EK_CONST && prec->val.i < 0 ||
+ checkconst(prec, -1))) {
+ freeexpr(prec);
+ prec = NULL;
+ }
+#endif
+ switch (ord_type(ex->val.type)->kind) {
+
+ case TK_INTEGER:
+ if (!wid) {
+ if (integerwidth < 0)
+ integerwidth = (which_lang == LANG_TURBO) ? 1 : 12;
+ wid = makeexpr_long(integerwidth);
+ }
+ type = findbasetype(ex->val.type, ODECL_NOPRES);
+ if (base == 16)
+ fmtcode = "x";
+ else if (base == 8)
+ fmtcode = "o";
+ else if ((possiblesigns(wid) & (1|4)) == 1) {
+ wid = makeexpr_neg(wid);
+ fmtcode = "x";
+ } else if (type == tp_unsigned ||
+ type == tp_uint ||
+ (type == tp_ushort && sizeof_int < 32))
+ fmtcode = "u";
+ else
+ fmtcode = "d";
+ ex = makeexpr_forcelongness(ex);
+ if (checkconst(wid, 0) || checkconst(wid, 1)) {
+ ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
+ makeexpr_string(format_ss("%%%s%s",
+ (exprlongness(ex) > 0) ? "l" : "",
+ fmtcode)),
+ ex);
+ } else {
+ ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
+ makeexpr_string(format_ss("%%*%s%s",
+ (exprlongness(ex) > 0) ? "l" : "",
+ fmtcode)),
+ wid,
+ ex);
+ }
+ break;
+
+ case TK_CHAR:
+ ex = writestrelement(ex, wid, vex, 'c',
+ (wid->kind != EK_CONST || wid->val.i < 1));
+ break;
+
+ case TK_BOOLEAN:
+ if (!wid) {
+ ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
+ makeexpr_string("%s"),
+ makeexpr_cond(ex,
+ makeexpr_string(" TRUE"),
+ makeexpr_string("FALSE")));
+ } else if (checkconst(wid, 1)) {
+ ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
+ makeexpr_string("%c"),
+ makeexpr_cond(ex,
+ makeexpr_char('T'),
+ makeexpr_char('F')));
+ } else {
+ ex = writestrelement(makeexpr_cond(ex,
+ makeexpr_string("TRUE"),
+ makeexpr_string("FALSE")),
+ wid, vex, 's',
+ (wid->kind != EK_CONST || wid->val.i < 5));
+ }
+ break;
+
+ case TK_ENUM:
+ ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
+ makeexpr_string("%s"),
+ makeexpr_index(makeexpr_name(makeenumnames(ex->val.type),
+ tp_strptr),
+ ex, NULL));
+ break;
+
+ case TK_REAL:
+ if (!wid)
+ wid = makeexpr_long(realwidth);
+ if (prec && (possiblesigns(prec) & (1|4)) != 1) {
+ ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
+ makeexpr_string("%*.*f"),
+ wid,
+ prec,
+ ex);
+ } else {
+ if (prec)
+ prec = makeexpr_neg(prec);
+ else
+ prec = makeexpr_minus(copyexpr(wid),
+ makeexpr_long(7));
+ if (prec->kind == EK_CONST) {
+ if (prec->val.i <= 0)
+ prec = makeexpr_long(1);
+ } else {
+ prec = makeexpr_bicall_2("P_max", tp_integer, prec,
+ makeexpr_long(1));
+ }
+ if (wid->kind == EK_CONST && wid->val.i > 21) {
+ ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
+ makeexpr_string("%*.*E"),
+ wid,
+ prec,
+ ex);
+#if 0
+ } else if (checkconst(wid, 7)) {
+ ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
+ makeexpr_string("%E"),
+ ex);
+#endif
+ } else {
+ ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
+ makeexpr_string("% .*E"),
+ prec,
+ ex);
+ }
+ }
+ break;
+
+ case TK_STRING:
+ ex = writestrelement(ex, wid, vex, 's', 1);
+ break;
+
+ case TK_ARRAY: /* assume packed array of char */
+ ord_range_expr(ex->val.type->indextype, &ex1, &ex2);
+ ex1 = makeexpr_plus(makeexpr_minus(copyexpr(ex2),
+ copyexpr(ex1)),
+ makeexpr_long(1));
+ ex1 = makeexpr_longcast(ex1, 0);
+ fmtcode = "%.*s";
+ if (!wid) {
+ wid = ex1;
+ } else {
+ if (isliteralconst(wid, NULL) == 2 &&
+ isliteralconst(ex1, NULL) == 2) {
+ if (wid->val.i > ex1->val.i) {
+ fmtcode = format_ds("%*s%%.*s",
+ wid->val.i - ex1->val.i, "");
+ wid = ex1;
+ }
+ } else
+ note("Format for packed-array-of-char will work only if width < length [321]");
+ }
+ ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
+ makeexpr_string(fmtcode),
+ wid,
+ makeexpr_addr(ex));
+ break;
+
+ default:
+ note("Element has wrong type for WRITE statement [196]");
+ ex = makeexpr_bicall_2("sprintf", tp_str255, vex, makeexpr_string("<meef>"));
+ break;
+
+ }
+ return ex;
+}
+
+
+
+Static Stmt *handlewrite_text(fex, ex, iswriteln)
+Expr *fex, *ex;
+int iswriteln;
+{
+ Expr *print, *wid, *prec;
+ unsigned char *ucp;
+ int i, done, base;
+
+ print = NULL;
+ for (;;) {
+ wid = NULL;
+ prec = NULL;
+ base = 10;
+ if (curtok == TOK_COLON && iswriteln >= 0) {
+ gettok();
+ wid = p_expr(tp_integer);
+ if (curtok == TOK_COLON) {
+ gettok();
+ prec = p_expr(tp_integer);
+ }
+ }
+ if (curtok == TOK_IDENT &&
+ !strcicmp(curtokbuf, "OCT")) {
+ base = 8;
+ gettok();
+ } else if (curtok == TOK_IDENT &&
+ !strcicmp(curtokbuf, "HEX")) {
+ base = 16;
+ gettok();
+ }
+ ex = writeelement(ex, wid, prec, base);
+ print = makeexpr_concat(print, cleansprintf(ex), 1);
+ if (curtok == TOK_COMMA && iswriteln >= 0) {
+ gettok();
+ ex = p_expr(NULL);
+ } else
+ break;
+ }
+ if (fex->val.type->kind != TK_STRING) { /* not strwrite */
+ switch (iswriteln) {
+ case 1:
+ case -1:
+ print = makeexpr_concat(print, makeexpr_string("\n"), 1);
+ break;
+ case 2:
+ case -2:
+ print = makeexpr_concat(print, makeexpr_string("\r"), 1);
+ break;
+ }
+ if (isvar(fex, mp_output)) {
+ ucp = (unsigned char *)print->args[1]->val.s;
+ for (i = 0; i < print->args[1]->val.i; i++) {
+ if (ucp[i] >= 128 && ucp[i] < 144) {
+ note("WRITE statement contains color/attribute characters [203]");
+ break;
+ }
+ }
+ }
+ if ((i = sprintflength(print, 0)) > 0 && print->nargs == 2 && printfonly != 1) {
+ print = makeexpr_unsprintfify(print);
+ done = 1;
+ if (isvar(fex, mp_output)) {
+ if (i == 1) {
+ print = makeexpr_bicall_1("putchar", tp_int,
+ makeexpr_charcast(print));
+ } else {
+ if (printfonly == 0) {
+ if (print->val.s[print->val.i-1] == '\n') {
+ print->val.s[--(print->val.i)] = 0;
+ print = makeexpr_bicall_1("puts", tp_int, print);
+ } else {
+ print = makeexpr_bicall_2("fputs", tp_int,
+ print,
+ copyexpr(fex));
+ }
+ } else {
+ print = makeexpr_sprintfify(print);
+ done = 0;
+ }
+ }
+ } else {
+ if (i == 1) {
+ print = makeexpr_bicall_2("putc", tp_int,
+ makeexpr_charcast(print),
+ filebasename(copyexpr(fex)));
+ } else if (printfonly == 0) {
+ print = makeexpr_bicall_2("fputs", tp_int,
+ print,
+ filebasename(copyexpr(fex)));
+ } else {
+ print = makeexpr_sprintfify(print);
+ done = 0;
+ }
+ }
+ } else
+ done = 0;
+ if (!done) {
+ canceltempvar(istempvar(print->args[0]));
+ if (checkstring(print->args[1], "%s") && printfonly != 1) {
+ print = makeexpr_bicall_2("fputs", tp_int,
+ grabarg(print, 2),
+ filebasename(copyexpr(fex)));
+ } else if (checkstring(print->args[1], "%c") && printfonly != 1 &&
+ !nosideeffects(print->args[2], 0)) {
+ print = makeexpr_bicall_2("fputc", tp_int,
+ grabarg(print, 2),
+ filebasename(copyexpr(fex)));
+ } else if (isvar(fex, mp_output)) {
+ if (checkstring(print->args[1], "%s\n") && printfonly != 1) {
+ print = makeexpr_bicall_1("puts", tp_int, grabarg(print, 2));
+ } else if (checkstring(print->args[1], "%c") && printfonly != 1) {
+ print = makeexpr_bicall_1("putchar", tp_int, grabarg(print, 2));
+ } else {
+ strchange(&print->val.s, "printf");
+ delfreearg(&print, 0);
+ print->val.type = tp_int;
+ }
+ } else {
+ if (checkstring(print->args[1], "%c") && printfonly != 1) {
+ print = makeexpr_bicall_2("putc", tp_int,
+ grabarg(print, 2),
+ filebasename(copyexpr(fex)));
+ } else {
+ strchange(&print->val.s, "fprintf");
+ freeexpr(print->args[0]);
+ print->args[0] = filebasename(copyexpr(fex));
+ print->val.type = tp_int;
+ }
+ }
+ }
+ if (FCheck(checkfilewrite)) {
+ print = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_GE, print, makeexpr_long(0)),
+ makeexpr_name(filewriteerrorname, tp_int));
+ }
+ }
+ return makestmt_call(print);
+}
+
+
+
+Static Stmt *handlewrite_bin(fex, ex)
+Expr *fex, *ex;
+{
+ Type *basetype;
+ Stmt *sp;
+ Expr *tvardef = NULL;
+ Meaning *tvar = NULL;
+
+ sp = NULL;
+ basetype = filebasetype(fex->val.type);
+ for (;;) {
+ if (!expr_has_address(ex) || ex->val.type != basetype) {
+ if (!tvar)
+ tvar = makestmttempvar(basetype, name_TEMP);
+ if (!tvardef || !exprsame(tvardef, ex, 1)) {
+ freeexpr(tvardef);
+ tvardef = copyexpr(ex);
+ sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(tvar),
+ ex));
+ } else
+ freeexpr(ex);
+ ex = makeexpr_var(tvar);
+ }
+ ex = makeexpr_bicall_4("fwrite", tp_integer, makeexpr_addr(ex),
+ makeexpr_sizeof(makeexpr_type(basetype), 0),
+ makeexpr_long(1),
+ filebasename(copyexpr(fex)));
+ if (FCheck(checkfilewrite)) {
+ ex = makeexpr_bicall_2("~SETIO", tp_void,
+ makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
+ makeexpr_name(filewriteerrorname, tp_int));
+ }
+ sp = makestmt_seq(sp, makestmt_call(ex));
+ if (curtok == TOK_COMMA) {
+ gettok();
+ ex = p_expr(NULL);
+ } else
+ break;
+ }
+ freeexpr(tvardef);
+ return sp;
+}
+
+
+
+Static Stmt *proc_write()
+{
+ Expr *fex, *ex;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(NULL);
+ if (isfiletype(ex->val.type, -1) && wneedtok(TOK_COMMA)) {
+ fex = ex;
+ ex = p_expr(NULL);
+ } else {
+ fex = makeexpr_var(mp_output);
+ }
+ if (fex->val.type == tp_text || fex->val.type == tp_bigtext)
+ sp = handlewrite_text(fex, ex, 0);
+ else
+ sp = handlewrite_bin(fex, ex);
+ skipcloseparen();
+ return wrapopencheck(sp, fex);
+}
+
+
+
+Static Stmt *handle_modula_write(fmt)
+char *fmt;
+{
+ Expr *ex, *wid;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = makeexpr_forcelongness(p_expr(NULL));
+ if (skipcomma())
+ wid = p_expr(tp_integer);
+ else
+ wid = makeexpr_long(1);
+ if (checkconst(wid, 0) || checkconst(wid, 1))
+ ex = makeexpr_bicall_2("printf", tp_str255,
+ makeexpr_string(format_ss("%%%s%s",
+ (exprlongness(ex) > 0) ? "l" : "",
+ fmt)),
+ ex);
+ else
+ ex = makeexpr_bicall_3("printf", tp_str255,
+ makeexpr_string(format_ss("%%*%s%s",
+ (exprlongness(ex) > 0) ? "l" : "",
+ fmt)),
+ makeexpr_arglong(wid, 0),
+ ex);
+ skipcloseparen();
+ return makestmt_call(ex);
+}
+
+
+Static Stmt *proc_writecard()
+{
+ return handle_modula_write("u");
+}
+
+
+Static Stmt *proc_writeint()
+{
+ return handle_modula_write("d");
+}
+
+
+Static Stmt *proc_writehex()
+{
+ return handle_modula_write("x");
+}
+
+
+Static Stmt *proc_writeoct()
+{
+ return handle_modula_write("o");
+}
+
+
+Static Stmt *proc_writereal()
+{
+ return handle_modula_write("f");
+}
+
+
+
+Static Stmt *proc_writedir()
+{
+ Expr *fex, *ex;
+ Stmt *sp;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ ex = p_expr(tp_integer);
+ sp = doseek(fex, ex);
+ if (!skipcomma())
+ return sp;
+ sp = makestmt_seq(sp, handlewrite_bin(fex, p_expr(NULL)));
+ skipcloseparen();
+ return wrapopencheck(sp, fex);
+}
+
+
+
+Static Stmt *handlewriteln(iswriteln)
+int iswriteln;
+{
+ Expr *fex, *ex;
+ Stmt *sp;
+ Meaning *deffile = mp_output;
+
+ sp = NULL;
+ if (iswriteln == 3) {
+ iswriteln = 1;
+ if (messagestderr)
+ deffile = mp_stderr;
+ }
+ if (curtok != TOK_LPAR) {
+ fex = makeexpr_var(deffile);
+ if (iswriteln)
+ sp = handlewrite_text(fex, makeexpr_string(""), -iswriteln);
+ } else {
+ gettok();
+ ex = p_expr(NULL);
+ if (isfiletype(ex->val.type, -1)) {
+ fex = ex;
+ if (curtok == TOK_RPAR || !wneedtok(TOK_COMMA)) {
+ if (iswriteln)
+ ex = makeexpr_string("");
+ else
+ ex = NULL;
+ } else {
+ ex = p_expr(NULL);
+ }
+ } else {
+ fex = makeexpr_var(deffile);
+ }
+ if (ex)
+ sp = handlewrite_text(fex, ex, iswriteln);
+ skipcloseparen();
+ }
+ if (iswriteln == 0) {
+ sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_1("fflush", tp_void,
+ filebasename(copyexpr(fex)))));
+ }
+ return wrapopencheck(sp, fex);
+}
+
+
+
+Static Stmt *proc_overprint()
+{
+ return handlewriteln(2);
+}
+
+
+
+Static Stmt *proc_prompt()
+{
+ return handlewriteln(0);
+}
+
+
+
+Static Stmt *proc_writeln()
+{
+ return handlewriteln(1);
+}
+
+
+Static Stmt *proc_message()
+{
+ return handlewriteln(3);
+}
+
+
+
+Static Stmt *proc_writev()
+{
+ Expr *vex, *ex;
+ Stmt *sp;
+ Meaning *mp;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(tp_str255);
+ if (curtok == TOK_RPAR) {
+ gettok();
+ return makestmt_assign(vex, makeexpr_string(""));
+ }
+ if (!skipcomma())
+ return NULL;
+ sp = handlewrite_text(vex, p_expr(NULL), 0);
+ skipcloseparen();
+ ex = sp->exp1;
+ if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
+ (mp = istempvar(ex->args[0])) != NULL) {
+ canceltempvar(mp);
+ ex->args[0] = vex;
+ } else
+ sp->exp1 = makeexpr_assign(vex, ex);
+ return sp;
+}
+
+
+Static Stmt *proc_strwrite(mp_x, spbase)
+Meaning *mp_x;
+Stmt *spbase;
+{
+ Expr *vex, *exi, *exj, *ex;
+ Stmt *sp;
+ Meaning *mp;
+
+ if (!skipopenparen())
+ return NULL;
+ vex = p_expr(tp_str255);
+ if (!skipcomma())
+ return NULL;
+ exi = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ exj = p_expr(tp_integer);
+ if (!skipcomma())
+ return NULL;
+ sp = handlewrite_text(vex, p_expr(NULL), 0);
+ skipcloseparen();
+ ex = sp->exp1;
+ FREE(sp);
+ if (checkconst(exi, 1)) {
+ sp = spbase;
+ while (sp && sp->next)
+ sp = sp->next;
+ if (sp && sp->kind == SK_ASSIGN && sp->exp1->kind == EK_ASSIGN &&
+ (sp->exp1->args[0]->kind == EK_HAT ||
+ sp->exp1->args[0]->kind == EK_INDEX) &&
+ exprsame(sp->exp1->args[0]->args[0], vex, 1) &&
+ checkconst(sp->exp1->args[1], 0)) {
+ nukestmt(sp); /* remove preceding bogus setstrlen */
+ }
+ }
+ if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
+ (mp = istempvar(ex->args[0])) != NULL) {
+ canceltempvar(mp);
+ ex->args[0] = bumpstring(copyexpr(vex), exi, 1);
+ sp = makestmt_call(ex);
+ } else
+ sp = makestmt_assign(bumpstring(copyexpr(vex), exi, 1), ex);
+ if (fullstrwrite != 0) {
+ sp = makestmt_seq(sp, makestmt_assign(exj,
+ makeexpr_plus(makeexpr_bicall_1("strlen", tp_int, vex),
+ makeexpr_long(1))));
+ if (fullstrwrite == 1)
+ note("FullStrWrite=1 not yet supported [204]");
+ if (fullstrwrite == 2)
+ note("STRWRITE was used [205]");
+ } else {
+ freeexpr(vex);
+ }
+ return mixassignments(sp, NULL);
+}
+
+
+
+Static Stmt *proc_str_turbo()
+{
+ Expr *ex, *wid, *prec;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(NULL);
+ wid = NULL;
+ prec = NULL;
+ if (curtok == TOK_COLON) {
+ gettok();
+ wid = p_expr(tp_integer);
+ if (curtok == TOK_COLON) {
+ gettok();
+ prec = p_expr(tp_integer);
+ }
+ }
+ ex = writeelement(ex, wid, prec, 10);
+ if (!skipcomma())
+ return NULL;
+ wid = p_expr(tp_str255);
+ skipcloseparen();
+ return makestmt_assign(wid, ex);
+}
+
+
+
+Static Stmt *proc_time()
+{
+ Expr *ex;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(tp_str255);
+ skipcloseparen();
+ return makestmt_call(makeexpr_bicall_1("VAXtime", tp_integer, ex));
+}
+
+
+Static Expr *func_xor()
+{
+ Expr *ex, *ex2;
+ Type *type;
+ Meaning *tvar;
+
+ if (!skipopenparen())
+ return NULL;
+ ex = p_expr(NULL);
+ if (!skipcomma())
+ return ex;
+ ex2 = p_expr(ex->val.type);
+ skipcloseparen();
+ if (ex->val.type->kind != TK_SET &&
+ ex->val.type->kind != TK_SMALLSET) {
+ ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, ex2);
+ } else {
+ type = mixsets(&ex, &ex2);
+ tvar = makestmttempvar(type, name_SET);
+ ex = makeexpr_bicall_3(setxorname, type,
+ makeexpr_var(tvar),
+ ex, ex2);
+ }
+ return ex;
+}
+
+
+
+
+
+
+
+void decl_builtins()
+{
+ makespecialfunc( "ABS", func_abs);
+ makespecialfunc( "ADDR", func_addr);
+ if (!modula2)
+ makespecialfunc( "ADDRESS", func_addr);
+ makespecialfunc( "ADDTOPOINTER", func_addtopointer);
+ makespecialfunc( "ADR", func_addr);
+ makespecialfunc( "ASL", func_lsl);
+ makespecialfunc( "ASR", func_asr);
+ makespecialfunc( "BADDRESS", func_iaddress);
+ makespecialfunc( "BAND", func_uand);
+ makespecialfunc( "BIN", func_bin);
+ makespecialfunc( "BITNEXT", func_bitnext);
+ makespecialfunc( "BITSIZE", func_bitsize);
+ makespecialfunc( "BITSIZEOF", func_bitsize);
+mp_blockread_ucsd =
+ makespecialfunc( "BLOCKREAD", func_blockread);
+mp_blockwrite_ucsd =
+ makespecialfunc( "BLOCKWRITE", func_blockwrite);
+ makespecialfunc( "BNOT", func_unot);
+ makespecialfunc( "BOR", func_uor);
+ makespecialfunc( "BSL", func_bsl);
+ makespecialfunc( "BSR", func_bsr);
+ makespecialfunc( "BTST", func_btst);
+ makespecialfunc( "BXOR", func_uxor);
+ makespecialfunc( "BYTEREAD", func_byteread);
+ makespecialfunc( "BYTEWRITE", func_bytewrite);
+ makespecialfunc( "BYTE_OFFSET", func_byte_offset);
+ makespecialfunc( "CHR", func_chr);
+ makespecialfunc( "CONCAT", func_concat);
+ makespecialfunc( "DBLE", func_float);
+mp_dec_dec =
+ makespecialfunc( "DEC", func_dec);
+ makespecialfunc( "EOF", func_eof);
+ makespecialfunc( "EOLN", func_eoln);
+ makespecialfunc( "FCALL", func_fcall);
+ makespecialfunc( "FILEPOS", func_filepos);
+ makespecialfunc( "FILESIZE", func_filesize);
+ makespecialfunc( "FLOAT", func_float);
+ makespecialfunc( "HEX", func_hex);
+ makespecialfunc( "HI", func_hi);
+ makespecialfunc( "HIWORD", func_hiword);
+ makespecialfunc( "HIWRD", func_hiword);
+ makespecialfunc( "HIGH", func_high);
+ makespecialfunc( "IADDRESS", func_iaddress);
+ makespecialfunc( "INT", func_int);
+ makespecialfunc( "LAND", func_uand);
+ makespecialfunc( "LNOT", func_unot);
+ makespecialfunc( "LO", func_lo);
+ makespecialfunc( "LOOPHOLE", func_loophole);
+ makespecialfunc( "LOR", func_uor);
+ makespecialfunc( "LOWER", func_lower);
+ makespecialfunc( "LOWORD", func_loword);
+ makespecialfunc( "LOWRD", func_loword);
+ makespecialfunc( "LSL", func_lsl);
+ makespecialfunc( "LSR", func_lsr);
+ makespecialfunc( "MAX", func_max);
+ makespecialfunc( "MAXPOS", func_maxpos);
+ makespecialfunc( "MIN", func_min);
+ makespecialfunc( "NEXT", func_sizeof);
+ makespecialfunc( "OCT", func_oct);
+ makespecialfunc( "ORD", func_ord);
+ makespecialfunc( "ORD4", func_ord4);
+ makespecialfunc( "PI", func_pi);
+ makespecialfunc( "POSITION", func_position);
+ makespecialfunc( "PRED", func_pred);
+ makespecialfunc( "QUAD", func_float);
+ makespecialfunc( "RANDOM", func_random);
+ makespecialfunc( "REF", func_addr);
+ makespecialfunc( "SCAN", func_scan);
+ makespecialfunc( "SEEKEOF", func_seekeof);
+ makespecialfunc( "SEEKEOLN", func_seekeoln);
+ makespecialfunc( "SIZE", func_sizeof);
+ makespecialfunc( "SIZEOF", func_sizeof);
+ makespecialfunc( "SNGL", func_sngl);
+ makespecialfunc( "SQR", func_sqr);
+ makespecialfunc( "STATUSV", func_statusv);
+ makespecialfunc( "SUCC", func_succ);
+ makespecialfunc( "TSIZE", func_sizeof);
+ makespecialfunc( "UAND", func_uand);
+ makespecialfunc( "UDEC", func_udec);
+ makespecialfunc( "UINT", func_uint);
+ makespecialfunc( "UNOT", func_unot);
+ makespecialfunc( "UOR", func_uor);
+ makespecialfunc( "UPPER", func_upper);
+ makespecialfunc( "UXOR", func_uxor);
+mp_val_modula =
+ makespecialfunc( "VAL", func_val_modula);
+ makespecialfunc( "WADDRESS", func_iaddress);
+ makespecialfunc( "XOR", func_xor);
+
+ makestandardfunc("ARCTAN", func_arctan);
+ makestandardfunc("ARCTANH", func_arctanh);
+ makestandardfunc("BINARY", func_binary);
+ makestandardfunc("CAP", func_upcase);
+ makestandardfunc("COPY", func_copy);
+ makestandardfunc("COS", func_cos);
+ makestandardfunc("COSH", func_cosh);
+ makestandardfunc("EXP", func_exp);
+ makestandardfunc("EXP10", func_pwroften);
+ makestandardfunc("EXPO", func_expo);
+ makestandardfunc("FRAC", func_frac);
+ makestandardfunc("INDEX", func_strpos);
+ makestandardfunc("LASTPOS", NULL);
+ makestandardfunc("LINEPOS", NULL);
+ makestandardfunc("LENGTH", func_strlen);
+ makestandardfunc("LN", func_ln);
+ makestandardfunc("LOG", func_log);
+ makestandardfunc("LOG10", func_log);
+ makestandardfunc("MAXAVAIL", func_maxavail);
+ makestandardfunc("MEMAVAIL", func_memavail);
+ makestandardfunc("OCTAL", func_octal);
+ makestandardfunc("ODD", func_odd);
+ makestandardfunc("PAD", func_pad);
+ makestandardfunc("PARAMCOUNT", func_paramcount);
+ makestandardfunc("PARAMSTR", func_paramstr);
+ makestandardfunc("POS", func_pos);
+ makestandardfunc("PTR", func_ptr);
+ makestandardfunc("PWROFTEN", func_pwroften);
+ makestandardfunc("ROUND", func_round);
+ makestandardfunc("SCANEQ", func_scaneq);
+ makestandardfunc("SCANNE", func_scanne);
+ makestandardfunc("SIN", func_sin);
+ makestandardfunc("SINH", func_sinh);
+ makestandardfunc("SQRT", func_sqrt);
+mp_str_hp =
+ makestandardfunc("STR", func_str_hp);
+ makestandardfunc("STRLEN", func_strlen);
+ makestandardfunc("STRLTRIM", func_strltrim);
+ makestandardfunc("STRMAX", func_strmax);
+ makestandardfunc("STRPOS", func_strpos);
+ makestandardfunc("STRRPT", func_strrpt);
+ makestandardfunc("STRRTRIM", func_strrtrim);
+ makestandardfunc("SUBSTR", func_str_hp);
+ makestandardfunc("SWAP", func_swap);
+ makestandardfunc("TAN", func_tan);
+ makestandardfunc("TANH", func_tanh);
+ makestandardfunc("TRUNC", func_trunc);
+ makestandardfunc("UPCASE", func_upcase);
+ makestandardfunc("UROUND", func_uround);
+ makestandardfunc("UTRUNC", func_utrunc);
+
+ makespecialproc( "APPEND", proc_append);
+ makespecialproc( "ARGV", proc_argv);
+ makespecialproc( "ASSERT", proc_assert);
+ makespecialproc( "ASSIGN", proc_assign);
+ makespecialproc( "BCLR", proc_bclr);
+mp_blockread_turbo =
+ makespecialproc( "BLOCKREAD_TURBO", proc_blockread);
+mp_blockwrite_turbo =
+ makespecialproc( "BLOCKWRITE_TURBO", proc_blockwrite);
+ makespecialproc( "BREAK", proc_flush);
+ makespecialproc( "BSET", proc_bset);
+ makespecialproc( "CALL", proc_call);
+ makespecialproc( "CLOSE", proc_close);
+ makespecialproc( "CONNECT", proc_assign);
+ makespecialproc( "CYCLE", proc_cycle);
+ makespecialproc( "DATE", proc_date);
+mp_dec_turbo =
+ makespecialproc( "DEC_TURBO", proc_dec);
+ makespecialproc( "DISPOSE", proc_dispose);
+ makespecialproc( "ESCAPE", proc_escape);
+ makespecialproc( "EXCL", proc_excl);
+ makespecialproc( "EXIT", proc_exit);
+ makespecialproc( "FILLCHAR", proc_fillchar);
+ makespecialproc( "FLUSH", proc_flush);
+ makespecialproc( "GET", proc_get);
+ makespecialproc( "HALT", proc_escape);
+ makespecialproc( "INC", proc_inc);
+ makespecialproc( "INCL", proc_incl);
+ makespecialproc( "LEAVE", proc_leave);
+ makespecialproc( "LOCATE", proc_seek);
+ makespecialproc( "MESSAGE", proc_message);
+ makespecialproc( "MOVE_FAST", proc_move_fast);
+ makespecialproc( "MOVE_L_TO_R", proc_move_fast);
+ makespecialproc( "MOVE_R_TO_L", proc_move_fast);
+ makespecialproc( "NEW", proc_new);
+ if (which_lang != LANG_VAX)
+ makespecialproc( "OPEN", proc_open);
+ makespecialproc( "OVERPRINT", proc_overprint);
+ makespecialproc( "PACK", proc_pack);
+ makespecialproc( "PAGE", proc_page);
+ makespecialproc( "PUT", proc_put);
+ makespecialproc( "PROMPT", proc_prompt);
+ makespecialproc( "RANDOMIZE", proc_randomize);
+ makespecialproc( "READ", proc_read);
+ makespecialproc( "READDIR", proc_readdir);
+ makespecialproc( "READLN", proc_readln);
+ makespecialproc( "READV", proc_readv);
+ makespecialproc( "RESET", proc_reset);
+ makespecialproc( "REWRITE", proc_rewrite);
+ makespecialproc( "SEEK", proc_seek);
+ makespecialproc( "SETSTRLEN", proc_setstrlen);
+ makespecialproc( "SETTEXTBUF", proc_settextbuf);
+mp_str_turbo =
+ makespecialproc( "STR_TURBO", proc_str_turbo);
+ makespecialproc( "STRAPPEND", proc_strappend);
+ makespecialproc( "STRDELETE", proc_strdelete);
+ makespecialproc( "STRINSERT", proc_strinsert);
+ makespecialproc( "STRMOVE", proc_strmove);
+ makespecialproc( "STRREAD", proc_strread);
+ makespecialproc( "STRWRITE", proc_strwrite);
+ makespecialproc( "TIME", proc_time);
+ makespecialproc( "UNPACK", proc_unpack);
+ makespecialproc( "WRITE", proc_write);
+ makespecialproc( "WRITEDIR", proc_writedir);
+ makespecialproc( "WRITELN", proc_writeln);
+ makespecialproc( "WRITEV", proc_writev);
+mp_val_turbo =
+ makespecialproc( "VAL_TURBO", proc_val_turbo);
+
+ makestandardproc("DELETE", proc_delete);
+ makestandardproc("FREEMEM", proc_freemem);
+ makestandardproc("GETMEM", proc_getmem);
+ makestandardproc("GOTOXY", proc_gotoxy);
+ makestandardproc("INSERT", proc_insert);
+ makestandardproc("MARK", NULL);
+ makestandardproc("MOVE", proc_move);
+ makestandardproc("MOVELEFT", proc_move);
+ makestandardproc("MOVERIGHT", proc_move);
+ makestandardproc("RELEASE", NULL);
+
+ makespecialvar( "MEM", var_mem);
+ makespecialvar( "MEMW", var_memw);
+ makespecialvar( "MEML", var_meml);
+ makespecialvar( "PORT", var_port);
+ makespecialvar( "PORTW", var_portw);
+
+ /* Modula-2 standard I/O procedures (case-sensitive!) */
+ makespecialproc( "Read", proc_read);
+ makespecialproc( "ReadCard", proc_read);
+ makespecialproc( "ReadInt", proc_read);
+ makespecialproc( "ReadReal", proc_read);
+ makespecialproc( "ReadString", proc_read);
+ makespecialproc( "Write", proc_write);
+ makespecialproc( "WriteCard", proc_writecard);
+ makespecialproc( "WriteHex", proc_writehex);
+ makespecialproc( "WriteInt", proc_writeint);
+ makespecialproc( "WriteOct", proc_writeoct);
+ makespecialproc( "WriteLn", proc_writeln);
+ makespecialproc( "WriteReal", proc_writereal);
+ makespecialproc( "WriteString", proc_write);
+}
+
+
+
+
+/* End. */
+
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/hpmods.c b/MultiSource/Benchmarks/MallocBench/p2c/hpmods.c
new file mode 100644
index 00000000..fd30be81
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/hpmods.c
@@ -0,0 +1,140 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_HPMODS_C
+#include "trans.h"
+
+
+
+
+
+/* FS functions */
+
+
+Static Stmt *proc_freadbytes()
+{
+ Expr *ex, *ex2, *vex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ type = vex->val.type;
+ ex = makeexpr_bicall_4("fread", tp_integer,
+ makeexpr_addr(vex),
+ convert_size(type, ex2, "FREADBYTES"),
+ makeexpr_long(1),
+ filebasename(copyexpr(fex)));
+ if (checkeof(fex)) {
+ ex = makeexpr_bicall_2(name_SETIO, tp_void,
+ makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
+ makeexpr_long(30));
+ }
+ return wrapopencheck(makestmt_call(ex), fex);
+}
+
+
+
+
+Static Stmt *proc_fwritebytes()
+{
+ Expr *ex, *ex2, *vex, *fex;
+ Type *type;
+
+ if (!skipopenparen())
+ return NULL;
+ fex = p_expr(tp_text);
+ if (!skipcomma())
+ return NULL;
+ vex = p_expr(NULL);
+ if (!skipcomma())
+ return NULL;
+ ex2 = p_expr(tp_integer);
+ skipcloseparen();
+ type = vex->val.type;
+ ex = makeexpr_bicall_4("fwrite", tp_integer,
+ makeexpr_addr(vex),
+ convert_size(type, ex2, "FWRITEBYTES"),
+ makeexpr_long(1),
+ filebasename(copyexpr(fex)));
+ if (checkfilewrite) {
+ ex = makeexpr_bicall_2(name_SETIO, tp_void,
+ makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
+ makeexpr_long(3));
+ }
+ return wrapopencheck(makestmt_call(ex), fex);
+}
+
+
+
+
+
+
+
+
+
+
+/* SYSGLOBALS */
+
+
+Static void setup_sysglobals()
+{
+ Symbol *sym;
+
+ sym = findsymbol("SYSESCAPECODE");
+ if (sym->mbase)
+ strchange(&sym->mbase->name, name_ESCAPECODE);
+ sym = findsymbol("SYSIORESULT");
+ if (sym->mbase)
+ strchange(&sym->mbase->name, name_IORESULT);
+}
+
+
+
+
+
+
+
+
+void hpmods(name, defn)
+char *name;
+int defn;
+{
+ if (!strcmp(name, "FS")) {
+ makespecialproc("freadbytes", proc_freadbytes);
+ makespecialproc("fwritebytes", proc_fwritebytes);
+ } else if (!strcmp(name, "SYSGLOBALS")) {
+ setup_sysglobals();
+ }
+}
+
+
+
+
+/* End. */
+
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/lex.c b/MultiSource/Benchmarks/MallocBench/p2c/lex.c
new file mode 100644
index 00000000..a31ed1ab
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/lex.c
@@ -0,0 +1,3421 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_LEX_C
+#include "trans.h"
+
+
+/* Define LEXDEBUG for a token trace */
+#define LEXDEBUG
+
+
+
+
+#define EOFMARK 1
+
+
+Static char dollar_flag, lex_initialized;
+Static int if_flag, if_skip;
+Static int commenting_flag;
+Static char *commenting_ptr;
+Static int skipflag;
+Static char modulenotation;
+Static short inputkind;
+Static Strlist *instrlist;
+Static char inbuf[300];
+Static char *oldinfname, *oldctxname;
+Static Strlist *endnotelist;
+
+
+
+#define INP_FILE 0
+#define INP_INCFILE 1
+#define INP_STRLIST 2
+
+Static struct inprec {
+ struct inprec *next;
+ short kind;
+ char *fname, *inbufptr;
+ int lnum;
+ FILE *filep;
+ Strlist *strlistp, *tempopts;
+ Token curtok, saveblockkind;
+ Symbol *curtoksym;
+ Meaning *curtokmeaning;
+ char *curtokbuf, *curtokcase;
+} *topinput;
+
+
+
+
+
+
+char *fixpascalname(name)
+char *name;
+{
+ char *cp, *cp2;
+
+ if (pascalsignif > 0) {
+ name = format_ds("%.*s", pascalsignif, name);
+ if (!pascalcasesens)
+ upc(name);
+ else if (pascalcasesens == 3)
+ lwc(name);
+ } else if (!pascalcasesens)
+ name = strupper(name);
+ else if (pascalcasesens == 3)
+ name = strlower(name);
+ if (ignorenonalpha) {
+ for (cp = cp2 = name; *cp; cp++)
+ if (isalnum(*cp))
+ *cp2++ = *cp;
+ }
+ return name;
+}
+
+
+
+Static void makekeyword(name)
+char *name;
+{
+ Symbol *sym;
+
+ if (*name) {
+ sym = findsymbol(name);
+ sym->flags |= AVOIDNAME;
+ }
+}
+
+
+Static void makeglobword(name)
+char *name;
+{
+ Symbol *sym;
+
+ if (*name) {
+ sym = findsymbol(name);
+ sym->flags |= AVOIDGLOB;
+ }
+}
+
+
+
+Static void makekeywords()
+{
+ makekeyword("auto");
+ makekeyword("break");
+ makekeyword("char");
+ makekeyword("continue");
+ makekeyword("default");
+ makekeyword("defined"); /* is this one really necessary? */
+ makekeyword("double");
+ makekeyword("enum");
+ makekeyword("extern");
+ makekeyword("float");
+ makekeyword("int");
+ makekeyword("long");
+ makekeyword("noalias");
+ makekeyword("register");
+ makekeyword("return");
+ makekeyword("short");
+ makekeyword("signed");
+ makekeyword("sizeof");
+ makekeyword("static");
+ makekeyword("struct");
+ makekeyword("switch");
+ makekeyword("typedef");
+ makekeyword("union");
+ makekeyword("unsigned");
+ makekeyword("void");
+ makekeyword("volatile");
+ makekeyword("asm");
+ makekeyword("fortran");
+ makekeyword("entry");
+ makekeyword("pascal");
+ if (cplus != 0) {
+ makekeyword("class");
+ makekeyword("delete");
+ makekeyword("friend");
+ makekeyword("inline");
+ makekeyword("new");
+ makekeyword("operator");
+ makekeyword("overload");
+ makekeyword("public");
+ makekeyword("this");
+ makekeyword("virtual");
+ }
+ makekeyword(name_UCHAR);
+ makekeyword(name_SCHAR); /* any others? */
+ makekeyword(name_BOOLEAN);
+ makekeyword(name_PROCEDURE);
+ makekeyword(name_ESCAPE);
+ makekeyword(name_ESCIO);
+ makekeyword(name_CHKIO);
+ makekeyword(name_SETIO);
+ makeglobword("main");
+ makeglobword("vextern"); /* used in generated .h files */
+ makeglobword("argc");
+ makeglobword("argv");
+ makekeyword("TRY");
+ makekeyword("RECOVER");
+ makekeyword("RECOVER2");
+ makekeyword("ENDTRY");
+}
+
+
+
+Static Symbol *Pkeyword(name, tok)
+char *name;
+Token tok;
+{
+ Symbol *sp = NULL;
+
+ if (pascalcasesens != 2) {
+ sp = findsymbol(strlower(name));
+ sp->kwtok = tok;
+ }
+ if (pascalcasesens != 3) {
+ sp = findsymbol(strupper(name));
+ sp->kwtok = tok;
+ }
+ return sp;
+}
+
+
+Static Symbol *Pkeywordposs(name, tok)
+char *name;
+Token tok;
+{
+ Symbol *sp = NULL;
+
+ if (pascalcasesens != 2) {
+ sp = findsymbol(strlower(name));
+ sp->kwtok = tok;
+ sp->flags |= KWPOSS;
+ }
+ if (pascalcasesens != 3) {
+ sp = findsymbol(strupper(name));
+ sp->kwtok = tok;
+ sp->flags |= KWPOSS;
+ }
+ return sp;
+}
+
+
+Static void makePascalwords()
+{
+ Pkeyword("AND", TOK_AND);
+ Pkeyword("ARRAY", TOK_ARRAY);
+ Pkeywordposs("ANYVAR", TOK_ANYVAR);
+ Pkeywordposs("ABSOLUTE", TOK_ABSOLUTE);
+ Pkeyword("BEGIN", TOK_BEGIN);
+ Pkeywordposs("BY", TOK_BY);
+ Pkeyword("CASE", TOK_CASE);
+ Pkeyword("CONST", TOK_CONST);
+ Pkeyword("DIV", TOK_DIV);
+ Pkeywordposs("DEFINITION", TOK_DEFINITION);
+ Pkeyword("DO", TOK_DO);
+ Pkeyword("DOWNTO", TOK_DOWNTO);
+ Pkeyword("ELSE", TOK_ELSE);
+ Pkeywordposs("ELSIF", TOK_ELSIF);
+ Pkeyword("END", TOK_END);
+ Pkeywordposs("EXPORT", TOK_EXPORT);
+ Pkeyword("FILE", TOK_FILE);
+ Pkeyword("FOR", TOK_FOR);
+ Pkeywordposs("FROM", TOK_FROM);
+ Pkeyword("FUNCTION", TOK_FUNCTION);
+ Pkeyword("GOTO", TOK_GOTO);
+ Pkeyword("IF", TOK_IF);
+ Pkeywordposs("IMPLEMENT", TOK_IMPLEMENT);
+ Pkeywordposs("IMPLEMENTATION", TOK_IMPLEMENT);
+ Pkeywordposs("IMPORT", TOK_IMPORT);
+ Pkeyword("IN", TOK_IN);
+ Pkeywordposs("INLINE", TOK_INLINE);
+ Pkeywordposs("INTERFACE", TOK_EXPORT);
+ Pkeywordposs("INTERRUPT", TOK_INTERRUPT);
+ Pkeyword("LABEL", TOK_LABEL);
+ Pkeywordposs("LOOP", TOK_LOOP);
+ Pkeyword("MOD", TOK_MOD);
+ Pkeywordposs("MODULE", TOK_MODULE);
+ Pkeyword("NIL", TOK_NIL);
+ Pkeyword("NOT", TOK_NOT);
+ Pkeyword("OF", TOK_OF);
+ Pkeyword("OR", TOK_OR);
+ Pkeywordposs("ORIGIN", TOK_ORIGIN);
+ Pkeywordposs("OTHERWISE", TOK_OTHERWISE);
+ Pkeywordposs("OVERLAY", TOK_SEGMENT);
+ Pkeyword("PACKED", TOK_PACKED);
+ Pkeywordposs("POINTER", TOK_POINTER);
+ Pkeyword("PROCEDURE", TOK_PROCEDURE);
+ Pkeyword("PROGRAM", TOK_PROGRAM);
+ Pkeywordposs("QUALIFIED", TOK_QUALIFIED);
+ Pkeyword("RECORD", TOK_RECORD);
+ Pkeywordposs("RECOVER", TOK_RECOVER);
+ Pkeywordposs("REM", TOK_REM);
+ Pkeyword("REPEAT", TOK_REPEAT);
+ Pkeywordposs("RETURN", TOK_RETURN);
+ if (which_lang == LANG_UCSD)
+ Pkeyword("SEGMENT", TOK_SEGMENT);
+ else
+ Pkeywordposs("SEGMENT", TOK_SEGMENT);
+ Pkeyword("SET", TOK_SET);
+ Pkeywordposs("SHL", TOK_SHL);
+ Pkeywordposs("SHR", TOK_SHR);
+ Pkeyword("THEN", TOK_THEN);
+ Pkeyword("TO", TOK_TO);
+ Pkeywordposs("TRY", TOK_TRY);
+ Pkeyword("TYPE", TOK_TYPE);
+ Pkeyword("UNTIL", TOK_UNTIL);
+ Pkeywordposs("USES", TOK_IMPORT);
+ Pkeywordposs("UNIT", TOK_MODULE);
+ if (which_lang == LANG_VAX)
+ Pkeyword("VALUE", TOK_VALUE);
+ else
+ Pkeywordposs("VALUE", TOK_VALUE);
+ Pkeyword("VAR", TOK_VAR);
+ Pkeywordposs("VARYING", TOK_VARYING);
+ Pkeyword("WHILE", TOK_WHILE);
+ Pkeyword("WITH", TOK_WITH);
+ Pkeywordposs("XOR", TOK_XOR);
+ Pkeyword("__MODULE", TOK_MODULE);
+ Pkeyword("__IMPORT", TOK_IMPORT);
+ Pkeyword("__EXPORT", TOK_EXPORT);
+ Pkeyword("__IMPLEMENT", TOK_IMPLEMENT);
+}
+
+
+
+Static void deterministic(name)
+char *name;
+{
+ Symbol *sym;
+
+ if (*name) {
+ sym = findsymbol(name);
+ sym->flags |= DETERMF;
+ }
+}
+
+
+Static void nosideeff(name)
+char *name;
+{
+ Symbol *sym;
+
+ if (*name) {
+ sym = findsymbol(name);
+ sym->flags |= NOSIDEEFF;
+ }
+}
+
+
+
+Static void recordsideeffects()
+{
+ deterministic("abs");
+ deterministic("acos");
+ deterministic("asin");
+ deterministic("atan");
+ deterministic("atan2");
+ deterministic("atof");
+ deterministic("atoi");
+ deterministic("atol");
+ deterministic("ceil");
+ deterministic("cos");
+ deterministic("cosh");
+ deterministic("exp");
+ deterministic("fabs");
+ deterministic("feof");
+ deterministic("feoln");
+ deterministic("ferror");
+ deterministic("floor");
+ deterministic("fmod");
+ deterministic("ftell");
+ deterministic("isalnum");
+ deterministic("isalpha");
+ deterministic("isdigit");
+ deterministic("islower");
+ deterministic("isspace");
+ deterministic("isupper");
+ deterministic("labs");
+ deterministic("ldexp");
+ deterministic("log");
+ deterministic("log10");
+ deterministic("memcmp");
+ deterministic("memchr");
+ deterministic("pow");
+ deterministic("sin");
+ deterministic("sinh");
+ deterministic("sqrt");
+ deterministic("strchr");
+ deterministic("strcmp");
+ deterministic("strcspn");
+ deterministic("strlen");
+ deterministic("strncmp");
+ deterministic("strpbrk");
+ deterministic("strrchr");
+ deterministic("strspn");
+ deterministic("strstr");
+ deterministic("tan");
+ deterministic("tanh");
+ deterministic("tolower");
+ deterministic("toupper");
+ deterministic(setequalname);
+ deterministic(subsetname);
+ deterministic(signextname);
+}
+
+
+
+
+
+void init_lex()
+{
+ int i;
+
+ inputkind = INP_FILE;
+ inf_lnum = 0;
+ inf_ltotal = 0;
+ *inbuf = 0;
+ inbufptr = inbuf;
+ keepingstrlist = NULL;
+ tempoptionlist = NULL;
+ switch_strpos = 0;
+ dollar_flag = 0;
+ if_flag = 0;
+ if_skip = 0;
+ commenting_flag = 0;
+ skipflag = 0;
+ inbufindent = 0;
+ modulenotation = 1;
+ notephase = 0;
+ endnotelist = NULL;
+ for (i = 0; i < SYMHASHSIZE; i++)
+ symtab[i] = 0;
+ C_lex = 0;
+ lex_initialized = 0;
+}
+
+
+void setup_lex()
+{
+ lex_initialized = 1;
+ if (!strcmp(language, "MODCAL"))
+ sysprog_flag = 2;
+ else
+ sysprog_flag = 0;
+ if (shortcircuit < 0)
+ partial_eval_flag = (which_lang == LANG_TURBO ||
+ which_lang == LANG_VAX ||
+ which_lang == LANG_OREGON ||
+ modula2 ||
+ hpux_lang);
+ else
+ partial_eval_flag = shortcircuit;
+ iocheck_flag = 1;
+ range_flag = 1;
+ ovflcheck_flag = 1;
+ stackcheck_flag = 1;
+ fixedflag = 0;
+ withlevel = 0;
+ makekeywords();
+ makePascalwords();
+ recordsideeffects();
+ topinput = 0;
+ ignore_directives = 0;
+ skipping_module = 0;
+ blockkind = TOK_END;
+ gettok();
+}
+
+
+
+
+int checkeatnote(msg)
+char *msg;
+{
+ Strlist *lp;
+ char *cp;
+ int len;
+
+ for (lp = eatnotes; lp; lp = lp->next) {
+ if (!strcmp(lp->s, "1")) {
+ echoword("[*]", 0);
+ return 1;
+ }
+ if (!strcmp(lp->s, "0"))
+ return 0;
+ len = strlen(lp->s);
+ cp = msg;
+ while (*cp && (*cp != lp->s[0] || strncmp(cp, lp->s, len)))
+ cp++;
+ if (*cp) {
+ cp = lp->s;
+ if (*cp != '[')
+ cp = format_s("[%s", cp);
+ if (cp[strlen(cp)-1] != ']')
+ cp = format_s("%s]", cp);
+ echoword(cp, 0);
+ return 1;
+ }
+ }
+ return 0;
+}
+
+
+
+void beginerror()
+{
+ end_source();
+ if (showprogress) {
+ fprintf(stderr, "\r%60s\r", "");
+ clearprogress();
+ } else
+ echobreak();
+}
+
+
+void counterror()
+{
+ if (maxerrors > 0) {
+ if (--maxerrors == 0) {
+ fprintf(outf, "\n/* Translation aborted: Too many errors. */\n");
+ fprintf(outf, "-------------------------------------------\n");
+ if (outf != stdout)
+ printf("Translation aborted: Too many errors.\n");
+ if (verbose)
+ fprintf(logf, "Translation aborted: Too many errors.\n");
+ closelogfile();
+ exit(EXIT_FAILURE);
+ }
+ }
+}
+
+
+void error(msg) /* does not return */
+char *msg;
+{
+ flushcomments(NULL, -1, -1);
+ beginerror();
+ fprintf(outf, "/* %s, line %d: %s */\n", infname, inf_lnum, msg);
+ fprintf(outf, "/* Translation aborted. */\n");
+ fprintf(outf, "--------------------------\n");
+ if (outf != stdout) {
+ printf("%s, line %d/%d: %s\n", infname, inf_lnum, outf_lnum, msg);
+ printf("Translation aborted.\n");
+ }
+ if (verbose) {
+ fprintf(logf, "%s, line %d/%d: %s\n",
+ infname, inf_lnum, outf_lnum, msg);
+ fprintf(logf, "Translation aborted.\n");
+ }
+ closelogfile();
+ exit(EXIT_FAILURE);
+}
+
+
+void interror(proc, msg) /* does not return */
+char *proc, *msg;
+{
+ error(format_ss("Internal error in %s: %s", proc, msg));
+}
+
+
+void warning(msg)
+char *msg;
+{
+ if (checkeatnote(msg)) {
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: Omitted warning: %s\n",
+ infname, inf_lnum, outf_lnum, msg);
+ return;
+ }
+ beginerror();
+ addnote(format_s("Warning: %s", msg), curserial);
+ counterror();
+}
+
+
+void intwarning(proc, msg)
+char *proc, *msg;
+{
+ if (checkeatnote(msg)) {
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: Omitted internal error in %s: %s\n",
+ infname, inf_lnum, outf_lnum, proc, msg);
+ return;
+ }
+ beginerror();
+ addnote(format_ss("Internal error in %s: %s", proc, msg), curserial);
+ if (error_crash)
+ exit(EXIT_FAILURE);
+ counterror();
+}
+
+
+
+
+void note(msg)
+char *msg;
+{
+ if (blockkind == TOK_IMPORT || checkeatnote(msg)) {
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: Omitted note: %s\n",
+ infname, inf_lnum, outf_lnum, msg);
+ return;
+ }
+ beginerror();
+ addnote(format_s("Note: %s", msg), curserial);
+ counterror();
+}
+
+
+
+void endnote(msg)
+char *msg;
+{
+ if (blockkind == TOK_IMPORT || checkeatnote(msg)) {
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: Omitted end-note: %s\n",
+ infname, inf_lnum, outf_lnum, msg);
+ return;
+ }
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: Recorded end-note: %s\n",
+ infname, inf_lnum, outf_lnum, msg);
+ (void) strlist_add(&endnotelist, msg);
+}
+
+
+void showendnotes()
+{
+ while (initialcalls) {
+ if (initialcalls->value)
+ endnote(format_s("Remember to call %s in main program [215]",
+ initialcalls->s));
+ strlist_eat(&initialcalls);
+ }
+ if (endnotelist) {
+ end_source();
+ while (endnotelist) {
+ if (outf != stdout) {
+ beginerror();
+ printf("Note: %s\n", endnotelist->s);
+ }
+ fprintf(outf, "/* p2c: Note: %s */\n", endnotelist->s);
+ outf_lnum++;
+ strlist_eat(&endnotelist);
+ }
+ }
+}
+
+
+
+
+
+
+
+char *tok_name(tok)
+Token tok;
+{
+ if (tok == TOK_END && inputkind == INP_STRLIST)
+ return "end of macro";
+ if (tok == curtok && tok == TOK_IDENT)
+ return format_s("'%s'", curtokcase);
+ if (!modulenotation) {
+ switch (tok) {
+ case TOK_MODULE: return "UNIT";
+ case TOK_IMPORT: return "USES";
+ case TOK_EXPORT: return "INTERFACE";
+ case TOK_IMPLEMENT: return "IMPLEMENTATION";
+ default: break;
+ }
+ }
+ return toknames[(int) tok];
+}
+
+
+
+void expected(msg)
+char *msg;
+{
+ error(format_ss("Expected %s, found %s", msg, tok_name(curtok)));
+}
+
+
+void expecttok(tok)
+Token tok;
+{
+ if (curtok != tok)
+ expected(tok_name(tok));
+}
+
+
+void needtok(tok)
+Token tok;
+{
+ if (curtok != tok)
+ expected(tok_name(tok));
+ gettok();
+}
+
+
+int wexpected(msg)
+char *msg;
+{
+ warning(format_ss("Expected %s, found %s [227]", msg, tok_name(curtok)));
+ return 0;
+}
+
+
+int wexpecttok(tok)
+Token tok;
+{
+ if (curtok != tok)
+ return wexpected(tok_name(tok));
+ else
+ return 1;
+}
+
+
+int wneedtok(tok)
+Token tok;
+{
+ if (wexpecttok(tok)) {
+ gettok();
+ return 1;
+ } else
+ return 0;
+}
+
+
+void alreadydef(sym)
+Symbol *sym;
+{
+ warning(format_s("Symbol '%s' was already defined [220]", sym->name));
+}
+
+
+void undefsym(sym)
+Symbol *sym;
+{
+ warning(format_s("Symbol '%s' is not defined [221]", sym->name));
+}
+
+
+void symclass(sym)
+Symbol *sym;
+{
+ warning(format_s("Symbol '%s' is not of the appropriate class [222]", sym->name));
+}
+
+
+void badtypes()
+{
+ warning("Type mismatch [223]");
+}
+
+
+void valrange()
+{
+ warning("Value range error [224]");
+}
+
+
+
+void skipparens()
+{
+ Token begintok;
+
+ if (curtok == TOK_LPAR) {
+ gettok();
+ while (curtok != TOK_RPAR)
+ skipparens();
+ } else if (curtok == TOK_LBR) {
+ gettok();
+ while (curtok != TOK_RBR)
+ skipparens();
+ } else if (curtok == TOK_BEGIN || curtok == TOK_RECORD ||
+ curtok == TOK_CASE) {
+ begintok = curtok;
+ gettok();
+ while (curtok != TOK_END)
+ if (curtok == TOK_CASE && begintok == TOK_RECORD)
+ gettok();
+ else
+ skipparens();
+ }
+ gettok();
+}
+
+
+void skiptotoken2(tok1, tok2)
+Token tok1, tok2;
+{
+ while (curtok != tok1 && curtok != tok2 &&
+ curtok != TOK_END && curtok != TOK_RPAR &&
+ curtok != TOK_RBR && curtok != TOK_EOF)
+ skipparens();
+}
+
+
+void skippasttoken2(tok1, tok2)
+Token tok1, tok2;
+{
+ skiptotoken2(tok1, tok2);
+ if (curtok == tok1 || curtok == tok2)
+ gettok();
+}
+
+
+void skippasttotoken(tok1, tok2)
+Token tok1, tok2;
+{
+ skiptotoken2(tok1, tok2);
+ if (curtok == tok1)
+ gettok();
+}
+
+
+void skiptotoken(tok)
+Token tok;
+{
+ skiptotoken2(tok, tok);
+}
+
+
+void skippasttoken(tok)
+Token tok;
+{
+ skippasttoken2(tok, tok);
+}
+
+
+
+int skipopenparen()
+{
+ if (wneedtok(TOK_LPAR))
+ return 1;
+ skiptotoken(TOK_SEMI);
+ return 0;
+}
+
+
+int skipcloseparen()
+{
+ if (curtok == TOK_COMMA)
+ warning("Too many arguments for built-in routine [225]");
+ else
+ if (wneedtok(TOK_RPAR))
+ return 1;
+ skippasttotoken(TOK_RPAR, TOK_SEMI);
+ return 0;
+}
+
+
+int skipcomma()
+{
+ if (curtok == TOK_RPAR)
+ warning("Too few arguments for built-in routine [226]");
+ else
+ if (wneedtok(TOK_COMMA))
+ return 1;
+ skippasttotoken(TOK_RPAR, TOK_SEMI);
+ return 0;
+}
+
+
+
+
+
+char *findaltname(name, num)
+char *name;
+int num;
+{
+ char *cp;
+
+ if (num <= 0)
+ return name;
+ if (num == 1 && *alternatename1)
+ return format_s(alternatename1, name);
+ if (num == 2 && *alternatename2)
+ return format_s(alternatename2, name);
+ if (*alternatename)
+ return format_sd(alternatename, name, num);
+ cp = name;
+ if (*alternatename1) {
+ while (--num >= 0)
+ cp = format_s(alternatename1, cp);
+ } else {
+ while (--num >= 0)
+ cp = format_s("%s_", cp);
+ }
+ return cp;
+}
+
+
+
+
+Symbol *findsymbol_opt(name)
+char *name;
+{
+ register int i;
+ register unsigned int hash;
+ register char *cp;
+ register Symbol *sp;
+
+ hash = 0;
+ for (cp = name; *cp; cp++)
+ hash = hash*3 + *cp;
+ sp = symtab[hash % SYMHASHSIZE];
+ while (sp && (i = strcmp(sp->name, name)) != 0) {
+ if (i < 0)
+ sp = sp->left;
+ else
+ sp = sp->right;
+ }
+ return sp;
+}
+
+
+
+Symbol *findsymbol(name)
+char *name;
+{
+ register int i;
+ register unsigned int hash;
+ register char *cp;
+ register Symbol **prev, *sp;
+
+ hash = 0;
+ for (cp = name; *cp; cp++)
+ hash = hash*3 + *cp;
+ prev = symtab + (hash % SYMHASHSIZE);
+ while ((sp = *prev) != 0 &&
+ (i = strcmp(sp->name, name)) != 0) {
+ if (i < 0)
+ prev = &(sp->left);
+ else
+ prev = &(sp->right);
+ }
+ if (!sp) {
+ sp = ALLOCV(sizeof(Symbol) + strlen(name), Symbol, symbols);
+ sp->mbase = sp->fbase = NULL;
+ sp->left = sp->right = NULL;
+ strcpy(sp->name, name);
+ sp->flags = 0;
+ sp->kwtok = TOK_NONE;
+ sp->symbolnames = NULL;
+ *prev = sp;
+ }
+ return sp;
+}
+
+
+
+
+void clearprogress()
+{
+ oldinfname = NULL;
+}
+
+
+void progress()
+{
+ char *ctxname;
+ int needrefr;
+ static int prevlen;
+
+ if (showprogress) {
+ if (!curctx || curctx == nullctx || curctx->kind == MK_MODULE ||
+ !strncmp(curctx->name, "__PROCPTR", 9) || blockkind == TOK_IMPORT)
+ ctxname = "";
+ else
+ ctxname = curctx->name;
+ needrefr = (inf_lnum & 15) == 0;
+ if (oldinfname != infname || oldctxname != ctxname) {
+ if (oldinfname != infname)
+ prevlen = 60;
+ fprintf(stderr, "\r%*s", prevlen + 2, "");
+ oldinfname = infname;
+ oldctxname = ctxname;
+ needrefr = 1;
+ }
+ if (needrefr) {
+ fprintf(stderr, "\r%5d %s %s", inf_lnum, infname, ctxname);
+ prevlen = 8 + strlen(infname) + strlen(ctxname);
+ } else {
+ fprintf(stderr, "\r%5d", inf_lnum);
+ prevlen = 5;
+ }
+ }
+}
+
+
+
+void p2c_getline()
+{
+ char *cp, *cp2;
+
+ switch (inputkind) {
+
+ case INP_FILE:
+ case INP_INCFILE:
+ inf_lnum++;
+ inf_ltotal++;
+ if (fgets(inbuf, 300, inf)) {
+ cp = inbuf + strlen(inbuf);
+ if (*inbuf && cp[-1] == '\n')
+ cp[-1] = 0;
+ if (inbuf[0] == '#' && inbuf[1] == ' ' && isdigit(inbuf[2])) {
+ cp = inbuf + 2; /* in case input text came */
+ inf_lnum = 0; /* from the C preprocessor */
+ while (isdigit(*cp))
+ inf_lnum = inf_lnum*10 + (*cp++) - '0';
+ inf_lnum--;
+ while (isspace(*cp)) cp++;
+ if (*cp == '"' && (cp2 = my_strchr(cp+1, '"')) != NULL) {
+ cp++;
+ infname = stralloc(cp);
+ infname[cp2 - cp] = 0;
+ }
+ p2c_getline();
+ return;
+ }
+ if (copysource && *inbuf) {
+ start_source();
+ fprintf(outf, "%s\n", inbuf);
+ }
+ if (keepingstrlist) {
+ strlist_append(keepingstrlist, inbuf)->value = inf_lnum;
+ }
+ if (showprogress && inf_lnum % showprogress == 0)
+ progress();
+ } else {
+ if (showprogress)
+ fprintf(stderr, "\n");
+ if (inputkind == INP_INCFILE) {
+ pop_input();
+ p2c_getline();
+ } else
+ strcpy(inbuf, "\001");
+ }
+ break;
+
+ case INP_STRLIST:
+ if (instrlist) {
+ strcpy(inbuf, instrlist->s);
+ if (instrlist->value)
+ inf_lnum = instrlist->value;
+ else
+ inf_lnum++;
+ instrlist = instrlist->next;
+ } else
+ strcpy(inbuf, "\001");
+ break;
+ }
+ inbufptr = inbuf;
+ inbufindent = 0;
+}
+
+
+
+
+Static void push_input()
+{
+ struct inprec *inp;
+
+ inp = ALLOC(1, struct inprec, inprecs);
+ inp->kind = inputkind;
+ inp->fname = infname;
+ inp->lnum = inf_lnum;
+ inp->filep = inf;
+ inp->strlistp = instrlist;
+ inp->inbufptr = stralloc(inbufptr);
+ inp->curtok = curtok;
+ inp->curtoksym = curtoksym;
+ inp->curtokmeaning = curtokmeaning;
+ inp->curtokbuf = stralloc(curtokbuf);
+ inp->curtokcase = stralloc(curtokcase);
+ inp->saveblockkind = TOK_NIL;
+ inp->next = topinput;
+ topinput = inp;
+ inbufptr = inbuf + strlen(inbuf);
+}
+
+
+
+void push_input_file(fp, fname, isinclude)
+FILE *fp;
+char *fname;
+int isinclude;
+{
+ push_input();
+ inputkind = (isinclude == 1) ? INP_INCFILE : INP_FILE;
+ inf = fp;
+ inf_lnum = 0;
+ infname = fname;
+ *inbuf = 0;
+ inbufptr = inbuf;
+ topinput->tempopts = tempoptionlist;
+ tempoptionlist = NULL;
+ if (isinclude != 2)
+ gettok();
+}
+
+
+void include_as_import()
+{
+ if (inputkind == INP_INCFILE) {
+ if (topinput->saveblockkind == TOK_NIL)
+ topinput->saveblockkind = blockkind;
+ blockkind = TOK_IMPORT;
+ } else
+ warning(format_s("%s ignored except in include files [228]",
+ interfacecomment));
+}
+
+
+void push_input_strlist(sp, fname)
+Strlist *sp;
+char *fname;
+{
+ push_input();
+ inputkind = INP_STRLIST;
+ instrlist = sp;
+ if (fname) {
+ infname = fname;
+ inf_lnum = 0;
+ } else
+ inf_lnum--; /* adjust for extra p2c_getline() */
+ *inbuf = 0;
+ inbufptr = inbuf;
+ gettok();
+}
+
+
+
+void pop_input()
+{
+ struct inprec *inp;
+
+ if (inputkind == INP_FILE || inputkind == INP_INCFILE) {
+ while (tempoptionlist) {
+ undooption(tempoptionlist->value, tempoptionlist->s);
+ strlist_eat(&tempoptionlist);
+ }
+ tempoptionlist = topinput->tempopts;
+ if (inf)
+ fclose(inf);
+ }
+ inp = topinput;
+ topinput = inp->next;
+ if (inp->saveblockkind != TOK_NIL)
+ blockkind = inp->saveblockkind;
+ inputkind = inp->kind;
+ infname = inp->fname;
+ inf_lnum = inp->lnum;
+ inf = inp->filep;
+ curtok = inp->curtok;
+ curtoksym = inp->curtoksym;
+ curtokmeaning = inp->curtokmeaning;
+ strcpy(curtokbuf, inp->curtokbuf);
+ FREE(inp->curtokbuf);
+ strcpy(curtokcase, inp->curtokcase);
+ FREE(inp->curtokcase);
+ strcpy(inbuf, inp->inbufptr);
+ FREE(inp->inbufptr);
+ inbufptr = inbuf;
+ instrlist = inp->strlistp;
+ FREE(inp);
+}
+
+
+
+
+int undooption(i, name)
+int i;
+char *name;
+{
+ char kind = rctable[i].kind;
+
+ switch (kind) {
+
+ case 'S':
+ case 'B':
+ if (rcprevvalues[i]) {
+ *((short *)rctable[i].ptr) = rcprevvalues[i]->value;
+ strlist_eat(&rcprevvalues[i]);
+ return 1;
+ }
+ break;
+
+ case 'I':
+ case 'D':
+ if (rcprevvalues[i]) {
+ *((int *)rctable[i].ptr) = rcprevvalues[i]->value;
+ strlist_eat(&rcprevvalues[i]);
+ return 1;
+ }
+ break;
+
+ case 'L':
+ if (rcprevvalues[i]) {
+ *((long *)rctable[i].ptr) = rcprevvalues[i]->value;
+ strlist_eat(&rcprevvalues[i]);
+ return 1;
+ }
+ break;
+
+ case 'R':
+ if (rcprevvalues[i]) {
+ *((double *)rctable[i].ptr) = atof(rcprevvalues[i]->s);
+ strlist_eat(&rcprevvalues[i]);
+ return 1;
+ }
+ break;
+
+ case 'C':
+ case 'U':
+ if (rcprevvalues[i]) {
+ strcpy((char *)rctable[i].ptr, rcprevvalues[i]->s);
+ strlist_eat(&rcprevvalues[i]);
+ return 1;
+ }
+ break;
+
+ case 'A':
+ strlist_remove((Strlist **)rctable[i].ptr, name);
+ return 1;
+
+ case 'X':
+ if (rctable[i].def == 1) {
+ strlist_remove((Strlist **)rctable[i].ptr, name);
+ return 1;
+ }
+ break;
+
+ }
+ return 0;
+}
+
+
+
+
+void badinclude()
+{
+ warning("Can't handle an \"include\" directive here [229]");
+ inputkind = INP_INCFILE; /* expand it in-line */
+ gettok();
+}
+
+
+
+int handle_include(fn)
+char *fn;
+{
+ FILE *fp = NULL;
+ Strlist *sl;
+
+ for (sl = includedirs; sl; sl = sl->next) {
+ fp = fopen(format_s(sl->s, fn), "r");
+ if (fp) {
+ fn = stralloc(format_s(sl->s, fn));
+ break;
+ }
+ }
+ if (!fp) {
+ perror(fn);
+ warning(format_s("Could not open include file %s [230]", fn));
+ return 0;
+ } else {
+ if (!quietmode && !showprogress)
+ if (outf == stdout)
+ fprintf(stderr, "Reading include file \"%s\"\n", fn);
+ else
+ printf("Reading include file \"%s\"\n", fn);
+ if (verbose)
+ fprintf(logf, "Reading include file \"%s\"\n", fn);
+ if (expandincludes == 0) {
+ push_input_file(fp, fn, 2);
+ curtok = TOK_INCLUDE;
+ strcpy(curtokbuf, fn);
+ } else {
+ push_input_file(fp, fn, 1);
+ }
+ return 1;
+ }
+}
+
+
+
+int turbo_directive(closing, after)
+char *closing, *after;
+{
+ char *cp, *cp2;
+ int i, result;
+
+ if (!strcincmp(inbufptr, "$double", 7)) {
+ cp = inbufptr + 7;
+ while (isspace(*cp)) cp++;
+ if (cp == closing) {
+ inbufptr = after;
+ doublereals = 1;
+ return 1;
+ }
+ } else if (!strcincmp(inbufptr, "$nodouble", 9)) {
+ cp = inbufptr + 9;
+ while (isspace(*cp)) cp++;
+ if (cp == closing) {
+ inbufptr = after;
+ doublereals = 0;
+ return 1;
+ }
+ }
+ switch (inbufptr[2]) {
+
+ case '+':
+ case '-':
+ result = 1;
+ cp = inbufptr + 1;
+ for (;;) {
+ if (!isalpha(*cp++))
+ return 0;
+ if (*cp != '+' && *cp != '-')
+ return 0;
+ if (++cp == closing)
+ break;
+ if (*cp++ != ',')
+ return 0;
+ }
+ cp = inbufptr + 1;
+ do {
+ switch (*cp++) {
+
+ case 'b':
+ case 'B':
+ if (shortcircuit < 0 && which_lang != LANG_MPW)
+ partial_eval_flag = (*cp == '-');
+ break;
+
+ case 'i':
+ case 'I':
+ iocheck_flag = (*cp == '+');
+ break;
+
+ case 'r':
+ case 'R':
+ if (*cp == '+') {
+ if (!range_flag)
+ note("Range checking is ON [216]");
+ range_flag = 1;
+ } else {
+ if (range_flag)
+ note("Range checking is OFF [216]");
+ range_flag = 0;
+ }
+ break;
+
+ case 's':
+ case 'S':
+ if (*cp == '+') {
+ if (!stackcheck_flag)
+ note("Stack checking is ON [217]");
+ stackcheck_flag = 1;
+ } else {
+ if (stackcheck_flag)
+ note("Stack checking is OFF [217]");
+ stackcheck_flag = 0;
+ }
+ break;
+
+ default:
+ result = 0;
+ break;
+ }
+ cp++;
+ } while (*cp++ == ',');
+ if (result)
+ inbufptr = after;
+ return result;
+
+ case 'c':
+ case 'C':
+ if (toupper(inbufptr[1]) == 'S' &&
+ (inbufptr[3] == '+' || inbufptr[3] == '-') &&
+ inbufptr + 4 == closing) {
+ if (shortcircuit < 0)
+ partial_eval_flag = (inbufptr[3] == '+');
+ inbufptr = after;
+ return 1;
+ }
+ return 0;
+
+ case ' ':
+ switch (inbufptr[1]) {
+
+ case 'i':
+ case 'I':
+ if (skipping_module)
+ break;
+ cp = inbufptr + 3;
+ while (isspace(*cp)) cp++;
+ cp2 = cp;
+ i = 0;
+ while (*cp2 && cp2 != closing)
+ i++, cp2++;
+ if (cp2 != closing)
+ return 0;
+ while (isspace(cp[i-1]))
+ if (--i <= 0)
+ return 0;
+ inbufptr = after;
+ cp2 = ALLOC(i + 1, char, strings);
+ strncpy(cp2, cp, i);
+ cp2[i] = 0;
+ if (handle_include(cp2))
+ return 2;
+ break;
+
+ case 's':
+ case 'S':
+ cp = inbufptr + 3;
+ outsection(minorspace);
+ if (cp == closing) {
+ output("#undef __SEG__\n");
+ } else {
+ output("#define __SEG__ ");
+ while (*cp && cp != closing)
+ cp++;
+ if (*cp) {
+ i = *cp;
+ *cp = 0;
+ output(inbufptr + 3);
+ *cp = i;
+ }
+ output("\n");
+ }
+ outsection(minorspace);
+ inbufptr = after;
+ return 1;
+
+ }
+ return 0;
+
+ case '}':
+ case '*':
+ if (inbufptr + 2 == closing) {
+ switch (inbufptr[1]) {
+
+ case 's':
+ case 'S':
+ outsection(minorspace);
+ output("#undef __SEG__\n");
+ outsection(minorspace);
+ inbufptr = after;
+ return 1;
+
+ }
+ }
+ return 0;
+
+ case 'f': /* $ifdef etc. */
+ case 'F':
+ if (toupper(inbufptr[1]) == 'I' &&
+ ((toupper(inbufptr[3]) == 'O' &&
+ toupper(inbufptr[4]) == 'P' &&
+ toupper(inbufptr[5]) == 'T') ||
+ (toupper(inbufptr[3]) == 'D' &&
+ toupper(inbufptr[4]) == 'E' &&
+ toupper(inbufptr[5]) == 'F') ||
+ (toupper(inbufptr[3]) == 'N' &&
+ toupper(inbufptr[4]) == 'D' &&
+ toupper(inbufptr[5]) == 'E' &&
+ toupper(inbufptr[6]) == 'F'))) {
+ note("Turbo Pascal conditional compilation directive was ignored [218]");
+ }
+ return 0;
+
+ }
+ return 0;
+}
+
+
+
+
+extern Strlist *addmacros;
+
+void defmacro(name, kind, fname, lnum)
+char *name, *fname;
+long kind;
+int lnum;
+{
+ Strlist *defsl, *sl, *sl2;
+ Symbol *sym, *sym2;
+ Meaning *mp;
+ Expr *ex;
+
+ defsl = NULL;
+ sl = strlist_append(&defsl, name);
+ C_lex++;
+ if (fname && !strcmp(fname, "<macro>") && curtok == TOK_IDENT)
+ fname = curtoksym->name;
+ push_input_strlist(defsl, fname);
+ if (fname)
+ inf_lnum = lnum;
+ switch (kind) {
+
+ case MAC_VAR:
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ for (mp = curtoksym->mbase; mp; mp = mp->snext) {
+ if (mp->kind == MK_VAR)
+ warning(format_s("VarMacro must be defined before declaration of variable %s [231]", curtokcase));
+ }
+ sl = strlist_append(&varmacros, curtoksym->name);
+ gettok();
+ if (!wneedtok(TOK_EQ))
+ break;
+ sl->value = (long)pc_expr();
+ break;
+
+ case MAC_CONST:
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ for (mp = curtoksym->mbase; mp; mp = mp->snext) {
+ if (mp->kind == MK_CONST)
+ warning(format_s("ConstMacro must be defined before declaration of variable %s [232]", curtokcase));
+ }
+ sl = strlist_append(&constmacros, curtoksym->name);
+ gettok();
+ if (!wneedtok(TOK_EQ))
+ break;
+ sl->value = (long)pc_expr();
+ break;
+
+ case MAC_FIELD:
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ sym = curtoksym;
+ gettok();
+ if (!wneedtok(TOK_DOT))
+ break;
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ sym2 = curtoksym;
+ gettok();
+ if (!wneedtok(TOK_EQ))
+ break;
+ funcmacroargs = NULL;
+ sym->flags |= FMACREC;
+ ex = pc_expr();
+ sym->flags &= ~FMACREC;
+ for (mp = sym2->fbase; mp; mp = mp->snext) {
+ if (mp->rectype && mp->rectype->meaning &&
+ mp->rectype->meaning->sym == sym)
+ break;
+ }
+ if (mp) {
+ mp->constdefn = ex;
+ } else {
+ sl = strlist_append(&fieldmacros,
+ format_ss("%s.%s", sym->name, sym2->name));
+ sl->value = (long)ex;
+ }
+ break;
+
+ case MAC_FUNC:
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ sym = curtoksym;
+ if (sym->mbase &&
+ (sym->mbase->kind == MK_FUNCTION ||
+ sym->mbase->kind == MK_SPECIAL))
+ sl = NULL;
+ else
+ sl = strlist_append(&funcmacros, sym->name);
+ gettok();
+ funcmacroargs = NULL;
+ if (curtok == TOK_LPAR) {
+ do {
+ gettok();
+ if (curtok == TOK_RPAR && !funcmacroargs)
+ break;
+ if (!wexpecttok(TOK_IDENT)) {
+ skiptotoken2(TOK_COMMA, TOK_RPAR);
+ continue;
+ }
+ sl2 = strlist_append(&funcmacroargs, curtoksym->name);
+ sl2->value = (long)curtoksym;
+ curtoksym->flags |= FMACREC;
+ gettok();
+ } while (curtok == TOK_COMMA);
+ if (!wneedtok(TOK_RPAR))
+ skippasttotoken(TOK_RPAR, TOK_EQ);
+ }
+ if (!wneedtok(TOK_EQ))
+ break;
+ if (sl)
+ sl->value = (long)pc_expr();
+ else
+ sym->mbase->constdefn = pc_expr();
+ for (sl2 = funcmacroargs; sl2; sl2 = sl2->next) {
+ sym2 = (Symbol *)sl2->value;
+ sym2->flags &= ~FMACREC;
+ }
+ strlist_empty(&funcmacroargs);
+ break;
+
+ }
+ if (curtok != TOK_EOF)
+ warning(format_s("Junk (%s) at end of macro definition [233]", tok_name(curtok)));
+ pop_input();
+ C_lex--;
+ strlist_empty(&defsl);
+}
+
+
+
+void check_unused_macros()
+{
+ Strlist *sl;
+
+ if (warnmacros) {
+ for (sl = varmacros; sl; sl = sl->next)
+ warning(format_s("VarMacro %s was never used [234]", sl->s));
+ for (sl = constmacros; sl; sl = sl->next)
+ warning(format_s("ConstMacro %s was never used [234]", sl->s));
+ for (sl = fieldmacros; sl; sl = sl->next)
+ warning(format_s("FieldMacro %s was never used [234]", sl->s));
+ for (sl = funcmacros; sl; sl = sl->next)
+ warning(format_s("FuncMacro %s was never used [234]", sl->s));
+ }
+}
+
+
+
+
+
+#define skipspc(cp) while (isspace(*cp)) cp++
+
+Static int parsecomment(p2c_only, starparen)
+int p2c_only, starparen;
+{
+ char namebuf[302];
+ char *cp, *cp2 = namebuf, *closing, *after;
+ char kind, chgmode, upcflag;
+ long val, oldval, sign;
+ double dval;
+ int i, tempopt, hassign;
+ Strlist *sp;
+ Symbol *sym;
+
+ if (if_flag)
+ return 0;
+ if (!p2c_only) {
+ if (!strncmp(inbufptr, noskipcomment, strlen(noskipcomment)) &&
+ *noskipcomment) {
+ inbufptr += strlen(noskipcomment);
+ if (skipflag < 0) {
+ if (skipflag < -1) {
+ skipflag++;
+ } else {
+ curtok = TOK_ENDIF;
+ skipflag = 1;
+ return 2;
+ }
+ } else {
+ skipflag = 1;
+ return 1;
+ }
+ }
+ }
+ closing = inbufptr;
+ while (*closing && (starparen
+ ? (closing[0] != '*' || closing[1] != ')')
+ : (closing[0] != '}')))
+ closing++;
+ if (!*closing)
+ return 0;
+ after = closing + (starparen ? 2 : 1);
+ cp = inbufptr;
+ while (cp < closing && (*cp != '#' || cp[1] != '#'))
+ cp++; /* Ignore comments */
+ if (cp < closing) {
+ while (isspace(cp[-1]))
+ cp--;
+ *cp = '#'; /* avoid skipping spaces past closing! */
+ closing = cp;
+ }
+ if (!p2c_only) {
+ if (!strncmp(inbufptr, "DUMP-SYMBOLS", 12) &&
+ closing == inbufptr + 12) {
+ wrapup();
+ inbufptr = after;
+ return 1;
+ }
+ if (!strncmp(inbufptr, fixedcomment, strlen(fixedcomment)) &&
+ *fixedcomment &&
+ inbufptr + strlen(fixedcomment) == closing) {
+ fixedflag++;
+ inbufptr = after;
+ return 1;
+ }
+ if (!strncmp(inbufptr, permanentcomment, strlen(permanentcomment)) &&
+ *permanentcomment &&
+ inbufptr + strlen(permanentcomment) == closing) {
+ permflag = 1;
+ inbufptr = after;
+ return 1;
+ }
+ if (!strncmp(inbufptr, interfacecomment, strlen(interfacecomment)) &&
+ *interfacecomment &&
+ inbufptr + strlen(interfacecomment) == closing) {
+ inbufptr = after;
+ curtok = TOK_INTFONLY;
+ return 2;
+ }
+ if (!strncmp(inbufptr, skipcomment, strlen(skipcomment)) &&
+ *skipcomment &&
+ inbufptr + strlen(skipcomment) == closing) {
+ inbufptr = after;
+ skipflag--;
+ if (skipflag == -1) {
+ skipping_module++; /* eat comments in skipped portion */
+ do {
+ gettok();
+ } while (curtok != TOK_ENDIF);
+ skipping_module--;
+ }
+ return 1;
+ }
+ if (!strncmp(inbufptr, signedcomment, strlen(signedcomment)) &&
+ *signedcomment && !p2c_only &&
+ inbufptr + strlen(signedcomment) == closing) {
+ inbufptr = after;
+ gettok();
+ if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE &&
+ curtokmeaning->type == tp_char) {
+ curtokmeaning = mp_schar;
+ } else
+ warning("{SIGNED} applied to type other than CHAR [314]");
+ return 2;
+ }
+ if (!strncmp(inbufptr, unsignedcomment, strlen(unsignedcomment)) &&
+ *unsignedcomment && !p2c_only &&
+ inbufptr + strlen(unsignedcomment) == closing) {
+ inbufptr = after;
+ gettok();
+ if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE &&
+ curtokmeaning->type == tp_char) {
+ curtokmeaning = mp_uchar;
+ } else if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE &&
+ curtokmeaning->type == tp_integer) {
+ curtokmeaning = mp_unsigned;
+ } else if (curtok == TOK_IDENT && curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE &&
+ curtokmeaning->type == tp_int) {
+ curtokmeaning = mp_uint;
+ } else
+ warning("{UNSIGNED} applied to type other than CHAR or INTEGER [313]");
+ return 2;
+ }
+ if (*inbufptr == '$') {
+ i = turbo_directive(closing, after);
+ if (i)
+ return i;
+ }
+ }
+ tempopt = 0;
+ cp = inbufptr;
+ if (*cp == '*') {
+ cp++;
+ tempopt = 1;
+ }
+ if (!isalpha(*cp))
+ return 0;
+ while ((isalnum(*cp) || *cp == '_') && cp2 < namebuf+300)
+ *cp2++ = toupper(*cp++);
+ *cp2 = 0;
+ i = numparams;
+ while (--i >= 0 && strcmp(rctable[i].name, namebuf)) ;
+ if (i < 0)
+ return 0;
+ kind = rctable[i].kind;
+ chgmode = rctable[i].chgmode;
+ if (chgmode == ' ') /* allowed in p2crc only */
+ return 0;
+ if (chgmode == 'T' && lex_initialized) {
+ if (cp == closing || *cp == '=' || *cp == '+' || *cp == '-')
+ warning(format_s("%s works only at top of program [235]",
+ rctable[i].name));
+ }
+ if (cp == closing) {
+ if (kind == 'S' || kind == 'I' || kind == 'D' || kind == 'L' ||
+ kind == 'R' || kind == 'B' || kind == 'C' || kind == 'U') {
+ undooption(i, "");
+ inbufptr = after;
+ return 1;
+ }
+ }
+ switch (kind) {
+
+ case 'S':
+ case 'I':
+ case 'L':
+ val = oldval = (kind == 'L') ? *(( long *)rctable[i].ptr) :
+ (kind == 'S') ? *((short *)rctable[i].ptr) :
+ *(( int *)rctable[i].ptr);
+ switch (*cp) {
+
+ case '=':
+ skipspc(cp);
+ hassign = (*++cp == '-' || *cp == '+');
+ sign = (*cp == '-') ? -1 : 1;
+ cp += hassign;
+ if (isdigit(*cp)) {
+ val = 0;
+ while (isdigit(*cp))
+ val = val * 10 + (*cp++) - '0';
+ val *= sign;
+ if (kind == 'D' && !hassign)
+ val += 10000;
+ } else if (toupper(cp[0]) == 'D' &&
+ toupper(cp[1]) == 'E' &&
+ toupper(cp[2]) == 'F') {
+ val = rctable[i].def;
+ cp += 3;
+ }
+ break;
+
+ case '+':
+ case '-':
+ if (chgmode != 'R')
+ return 0;
+ for (;;) {
+ if (*cp == '+')
+ val++;
+ else if (*cp == '-')
+ val--;
+ else
+ break;
+ cp++;
+ }
+ break;
+
+ }
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ strlist_insert(&rcprevvalues[i], "")->value = oldval;
+ if (tempopt)
+ strlist_insert(&tempoptionlist, "")->value = i;
+ if (kind == 'L')
+ *((long *)rctable[i].ptr) = val;
+ else if (kind == 'S')
+ *((short *)rctable[i].ptr) = val;
+ else
+ *((int *)rctable[i].ptr) = val;
+ inbufptr = after;
+ return 1;
+
+ case 'D':
+ val = oldval = *((int *)rctable[i].ptr);
+ if (*cp++ != '=')
+ return 0;
+ skipspc(cp);
+ if (toupper(cp[0]) == 'D' &&
+ toupper(cp[1]) == 'E' &&
+ toupper(cp[2]) == 'F') {
+ val = rctable[i].def;
+ cp += 3;
+ } else {
+ cp2 = namebuf;
+ while (*cp && cp != closing && !isspace(*cp))
+ *cp2++ = *cp++;
+ *cp2 = 0;
+ val = parsedelta(namebuf, -1);
+ if (!val)
+ return 0;
+ }
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ strlist_insert(&rcprevvalues[i], "")->value = oldval;
+ if (tempopt)
+ strlist_insert(&tempoptionlist, "")->value = i;
+ *((int *)rctable[i].ptr) = val;
+ inbufptr = after;
+ return 1;
+
+ case 'R':
+ if (*cp++ != '=')
+ return 0;
+ skipspc(cp);
+ if (toupper(cp[0]) == 'D' &&
+ toupper(cp[1]) == 'E' &&
+ toupper(cp[2]) == 'F') {
+ dval = rctable[i].def / 100.0;
+ cp += 3;
+ } else {
+ cp2 = cp;
+ while (isdigit(*cp) || *cp == '-' || *cp == '+' ||
+ *cp == '.' || toupper(*cp) == 'E')
+ cp++;
+ if (cp == cp2)
+ return 0;
+ dval = atof(cp2);
+ }
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ sprintf(namebuf, "%g", *((double *)rctable[i].ptr));
+ strlist_insert(&rcprevvalues[i], namebuf);
+ if (tempopt)
+ strlist_insert(&tempoptionlist, namebuf)->value = i;
+ *((double *)rctable[i].ptr) = dval;
+ inbufptr = after;
+ return 1;
+
+ case 'B':
+ if (*cp++ != '=')
+ return 0;
+ skipspc(cp);
+ if (toupper(cp[0]) == 'D' &&
+ toupper(cp[1]) == 'E' &&
+ toupper(cp[2]) == 'F') {
+ val = rctable[i].def;
+ cp += 3;
+ } else {
+ val = parse_breakstr(cp);
+ while (*cp && cp != closing && !isspace(*cp))
+ cp++;
+ }
+ skipspc(cp);
+ if (cp != closing || val == -1)
+ return 0;
+ strlist_insert(&rcprevvalues[i], "")->value =
+ *((short *)rctable[i].ptr);
+ if (tempopt)
+ strlist_insert(&tempoptionlist, "")->value = i;
+ *((short *)rctable[i].ptr) = val;
+ inbufptr = after;
+ return 1;
+
+ case 'C':
+ case 'U':
+ if (*cp == '=') {
+ cp++;
+ skipspc(cp);
+ for (cp2 = cp; cp2 != closing && !isspace(*cp2); cp2++)
+ if (!*cp2 || cp2-cp >= rctable[i].def)
+ return 0;
+ cp2 = (char *)rctable[i].ptr;
+ sp = strlist_insert(&rcprevvalues[i], cp2);
+ if (tempopt)
+ strlist_insert(&tempoptionlist, "")->value = i;
+ while (cp != closing && !isspace(*cp2))
+ *cp2++ = *cp++;
+ *cp2 = 0;
+ if (kind == 'U')
+ upc((char *)rctable[i].ptr);
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ inbufptr = after;
+ if (!strcmp(rctable[i].name, "LANGUAGE") &&
+ !strcmp((char *)rctable[i].ptr, "MODCAL"))
+ sysprog_flag |= 2;
+ return 1;
+ }
+ return 0;
+
+ case 'F':
+ case 'G':
+ if (*cp == '=' || *cp == '+' || *cp == '-') {
+ upcflag = (kind == 'F' && !pascalcasesens);
+ chgmode = *cp++;
+ skipspc(cp);
+ cp2 = namebuf;
+ while (isalnum(*cp) || *cp == '_' || *cp == '$' || *cp == '%')
+ *cp2++ = *cp++;
+ *cp2++ = 0;
+ if (!*namebuf)
+ return 0;
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ if (upcflag)
+ upc(namebuf);
+ sym = findsymbol(namebuf);
+ if (rctable[i].def & FUNCBREAK)
+ sym->flags &= ~FUNCBREAK;
+ if (chgmode == '-')
+ sym->flags &= ~rctable[i].def;
+ else
+ sym->flags |= rctable[i].def;
+ inbufptr = after;
+ return 1;
+ }
+ return 0;
+
+ case 'A':
+ if (*cp == '=' || *cp == '+' || *cp == '-') {
+ chgmode = *cp++;
+ skipspc(cp);
+ cp2 = namebuf;
+ while (cp != closing && !isspace(*cp) && *cp)
+ *cp2++ = *cp++;
+ *cp2++ = 0;
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ if (chgmode != '+')
+ strlist_remove((Strlist **)rctable[i].ptr, namebuf);
+ if (chgmode != '-')
+ sp = strlist_insert((Strlist **)rctable[i].ptr, namebuf);
+ if (tempopt)
+ strlist_insert(&tempoptionlist, namebuf)->value = i;
+ inbufptr = after;
+ return 1;
+ }
+ return 0;
+
+ case 'M':
+ if (!isspace(*cp))
+ return 0;
+ skipspc(cp);
+ if (!isalpha(*cp))
+ return 0;
+ for (cp2 = cp; *cp2 && cp2 != closing; cp2++) ;
+ if (cp2 > cp && cp2 == closing) {
+ inbufptr = after;
+ cp2 = format_ds("%.*s", (int)(cp2-cp), cp);
+ if (tp_integer != NULL) {
+ defmacro(cp2, rctable[i].def, NULL, 0);
+ } else {
+ sp = strlist_append(&addmacros, cp2);
+ sp->value = rctable[i].def;
+ }
+ return 1;
+ }
+ return 0;
+
+ case 'X':
+ switch (rctable[i].def) {
+
+ case 1: /* strlist with string values */
+ if (!isspace(*cp) && *cp != '=' &&
+ *cp != '+' && *cp != '-')
+ return 0;
+ chgmode = *cp++;
+ skipspc(cp);
+ cp2 = namebuf;
+ while (isalnum(*cp) || *cp == '_' ||
+ *cp == '$' || *cp == '%' ||
+ *cp == '.' || *cp == '-' ||
+ (*cp == '\'' && cp[1] && cp[2] == '\'' &&
+ cp+1 != closing && cp[1] != '=')) {
+ if (*cp == '\'') {
+ *cp2++ = *cp++;
+ *cp2++ = *cp++;
+ }
+ *cp2++ = *cp++;
+ }
+ *cp2++ = 0;
+ if (chgmode == '-') {
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ strlist_remove((Strlist **)rctable[i].ptr, namebuf);
+ } else {
+ if (!isspace(*cp) && *cp != '=')
+ return 0;
+ skipspc(cp);
+ if (*cp == '=') {
+ cp++;
+ skipspc(cp);
+ }
+ if (chgmode == '=' || isspace(chgmode))
+ strlist_remove((Strlist **)rctable[i].ptr, namebuf);
+ sp = strlist_append((Strlist **)rctable[i].ptr, namebuf);
+ if (tempopt)
+ strlist_insert(&tempoptionlist, namebuf)->value = i;
+ cp2 = namebuf;
+ while (*cp && cp != closing && !isspace(*cp))
+ *cp2++ = *cp++;
+ *cp2++ = 0;
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ sp->value = (long)stralloc(namebuf);
+ }
+ inbufptr = after;
+ if (lex_initialized)
+ handle_nameof(); /* as good a place to do this as any! */
+ return 1;
+
+ case 3: /* Synonym parameter */
+ if (isspace(*cp) || *cp == '=' ||
+ *cp == '+' || *cp == '-') {
+ chgmode = *cp++;
+ skipspc(cp);
+ cp2 = namebuf;
+ while (isalnum(*cp) || *cp == '_' ||
+ *cp == '$' || *cp == '%')
+ *cp2++ = *cp++;
+ *cp2++ = 0;
+ if (!*namebuf)
+ return 0;
+ skipspc(cp);
+ if (!pascalcasesens)
+ upc(namebuf);
+ sym = findsymbol(namebuf);
+ if (chgmode == '-') {
+ if (cp != closing)
+ return 0;
+ sym->flags &= ~SSYNONYM;
+ inbufptr = after;
+ return 1;
+ }
+ if (*cp == '=') {
+ cp++;
+ skipspc(cp);
+ }
+ cp2 = namebuf;
+ while (isalnum(*cp) || *cp == '_' ||
+ *cp == '$' || *cp == '%')
+ *cp2++ = *cp++;
+ *cp2++ = 0;
+ skipspc(cp);
+ if (cp != closing)
+ return 0;
+ sym->flags |= SSYNONYM;
+ if (!pascalcasesens)
+ upc(namebuf);
+ if (*namebuf)
+ strlist_append(&sym->symbolnames, "===")->value =
+ (long)findsymbol(namebuf);
+ else
+ strlist_append(&sym->symbolnames, "===")->value=0;
+ inbufptr = after;
+ return 1;
+ }
+ return 0;
+
+ }
+ return 0;
+
+ }
+ return 0;
+}
+
+
+
+Static void comment(starparen)
+int starparen; /* 0={ }, 1=(* *), 2=C comments*/
+{
+ register char ch;
+ int nestcount = 1, startlnum = inf_lnum, wasrel = 0, trailing;
+ int i, cmtindent, cmtindent2, saveeat = eatcomments;
+ char *cp;
+
+ if (!strncmp(inbufptr, embedcomment, strlen(embedcomment)) &&
+ *embedcomment)
+ eatcomments = 0;
+ cp = inbuf;
+ while (isspace(*cp))
+ cp++;
+ trailing = (*cp != '{' && ((*cp != '(' && *cp != '/') || cp[1] != '*'));
+ cmtindent = inbufindent;
+ cmtindent2 = cmtindent + 1 + (starparen != 0);
+ cp = inbufptr;
+ while (isspace(*cp))
+ cmtindent2++, cp++;
+ cp = curtokbuf;
+ for (;;) {
+ ch = *inbufptr++;
+ switch (ch) {
+
+ case '}':
+ if ((!starparen || nestedcomments == 0) &&
+ starparen != 2 &&
+ --nestcount <= 0) {
+ *cp = 0;
+ if (wasrel && !strcmp(curtokbuf, "\003"))
+ *curtokbuf = '\002';
+ if (!commenting_flag)
+ commentline(trailing ? CMT_TRAIL : CMT_POST);
+ eatcomments = saveeat;
+ return;
+ }
+ break;
+
+ case '{':
+ if (nestedcomments == 1 && starparen != 2)
+ nestcount++;
+ break;
+
+ case '*':
+ if ((*inbufptr == ((starparen == 2) ? '/' : ')') &&
+ (starparen || nestedcomments == 0)) &&
+ --nestcount <= 0) {
+ inbufptr++;
+ *cp = 0;
+ if (wasrel && !strcmp(curtokbuf, "\003"))
+ *curtokbuf = '\002';
+ if (!commenting_flag)
+ commentline(trailing ? CMT_TRAIL : CMT_POST);
+ eatcomments = saveeat;
+ return;
+ }
+ break;
+
+ case '(':
+ if (*inbufptr == '*' && nestedcomments == 1 &&
+ starparen != 2) {
+ *cp++ = ch;
+ ch = *inbufptr++;
+ nestcount++;
+ }
+ break;
+
+ case 0:
+ *cp = 0;
+ if (commenting_flag)
+ saveinputcomment(inbufptr-1);
+ else
+ commentline(CMT_POST);
+ trailing = 0;
+ p2c_getline();
+ i = 0;
+ for (;;) {
+ if (*inbufptr == ' ') {
+ inbufptr++;
+ i++;
+ } else if (*inbufptr == '\t') {
+ inbufptr++;
+ i++;
+ if (intabsize)
+ i = (i / intabsize + 1) * intabsize;
+ } else
+ break;
+ }
+ cp = curtokbuf;
+ if (*inbufptr) {
+ if (i == cmtindent2 && !starparen)
+ cmtindent--;
+ cmtindent2 = -1;
+ if (i >= cmtindent && i > 0) {
+ *cp++ = '\002';
+ i -= cmtindent;
+ wasrel = 1;
+ } else {
+ *cp++ = '\003';
+ }
+ while (--i >= 0)
+ *cp++ = ' ';
+ } else
+ *cp++ = '\003';
+ continue;
+
+ case EOFMARK:
+ error(format_d("Runaway comment from line %d", startlnum));
+ eatcomments = saveeat;
+ return; /* unnecessary */
+
+ }
+ *cp++ = ch;
+ }
+}
+
+
+
+char *getinlinepart()
+{
+ char *cp, *buf;
+
+ for (;;) {
+ if (isspace(*inbufptr)) {
+ inbufptr++;
+ } else if (!*inbufptr) {
+ p2c_getline();
+ } else if (*inbufptr == '{') {
+ inbufptr++;
+ comment(0);
+ } else if (*inbufptr == '(' && inbufptr[1] == '*') {
+ inbufptr += 2;
+ comment(1);
+ } else
+ break;
+ }
+ cp = inbufptr;
+ while (isspace(*cp) || isalnum(*cp) ||
+ *cp == '_' || *cp == '$' ||
+ *cp == '+' || *cp == '-' ||
+ *cp == '<' || *cp == '>')
+ cp++;
+ if (cp == inbufptr)
+ return "";
+ while (isspace(cp[-1]))
+ cp--;
+ buf = format_s("%s", inbufptr);
+ buf[cp-inbufptr] = 0; /* truncate the string */
+ inbufptr = cp;
+ return buf;
+}
+
+
+
+
+Static int getflag()
+{
+ int res = 1;
+
+ gettok();
+ if (curtok == TOK_IDENT) {
+ res = (strcmp(curtokbuf, "OFF") != 0);
+ gettok();
+ }
+ return res;
+}
+
+
+
+
+char getchartok()
+{
+ if (!*inbufptr) {
+ warning("Unexpected end of line [236]");
+ return ' ';
+ }
+ if (isspace(*inbufptr)) {
+ warning("Whitespace not allowed here [237]");
+ return ' ';
+ }
+ return *inbufptr++;
+}
+
+
+
+char *getparenstr(buf)
+char *buf;
+{
+ int count = 0;
+ char *cp;
+
+ if (inbufptr < buf) /* this will get most bad cases */
+ error("Can't handle a line break here");
+ while (isspace(*buf))
+ buf++;
+ cp = buf;
+ for (;;) {
+ if (!*cp)
+ error("Can't handle a line break here");
+ if (*cp == '(')
+ count++;
+ if (*cp == ')')
+ if (--count < 0)
+ break;
+ cp++;
+ }
+ inbufptr = cp + 1;
+ while (cp > buf && isspace(cp[-1]))
+ cp--;
+ return format_ds("%.*s", (int)(cp - buf), buf);
+}
+
+
+
+void leadingcomments()
+{
+ for (;;) {
+ switch (*inbufptr++) {
+
+ case 0:
+ p2c_getline();
+ break;
+
+ case ' ':
+ case '\t':
+ case 26:
+ /* ignore whitespace */
+ break;
+
+ case '{':
+ if (!parsecomment(1, 0)) {
+ inbufptr--;
+ return;
+ }
+ break;
+
+ case '(':
+ if (*inbufptr == '*') {
+ inbufptr++;
+ if (!parsecomment(1, 1)) {
+ inbufptr -= 2;
+ return;
+ }
+ break;
+ }
+ /* fall through */
+
+ default:
+ inbufptr--;
+ return;
+
+ }
+ }
+}
+
+
+
+
+void get_C_string(term)
+int term;
+{
+ char *cp = curtokbuf;
+ char ch;
+ int i;
+
+ while ((ch = *inbufptr++)) {
+ if (ch == term) {
+ *cp = 0;
+ curtokint = cp - curtokbuf;
+ return;
+ } else if (ch == '\\') {
+ if (isdigit(*inbufptr)) {
+ i = (*inbufptr++) - '0';
+ if (isdigit(*inbufptr))
+ i = i*8 + (*inbufptr++) - '0';
+ if (isdigit(*inbufptr))
+ i = i*8 + (*inbufptr++) - '0';
+ *cp++ = i;
+ } else {
+ ch = *inbufptr++;
+ switch (tolower(ch)) {
+ case 'n':
+ *cp++ = '\n';
+ break;
+ case 't':
+ *cp++ = '\t';
+ break;
+ case 'v':
+ *cp++ = '\v';
+ break;
+ case 'b':
+ *cp++ = '\b';
+ break;
+ case 'r':
+ *cp++ = '\r';
+ break;
+ case 'f':
+ *cp++ = '\f';
+ break;
+ case '\\':
+ *cp++ = '\\';
+ break;
+ case '\'':
+ *cp++ = '\'';
+ break;
+ case '"':
+ *cp++ = '"';
+ break;
+ case 'x':
+ if (isxdigit(*inbufptr)) {
+ if (isdigit(*inbufptr))
+ i = (*inbufptr++) - '0';
+ else
+ i = (toupper(*inbufptr++)) - 'A' + 10;
+ if (isdigit(*inbufptr))
+ i = i*16 + (*inbufptr++) - '0';
+ else if (isxdigit(*inbufptr))
+ i = i*16 + (toupper(*inbufptr++)) - 'A' + 10;
+ *cp++ = i;
+ break;
+ }
+ /* fall through */
+ default:
+ warning("Strange character in C string [238]");
+ }
+ }
+ } else
+ *cp++ = ch;
+ }
+ *cp = 0;
+ curtokint = cp - curtokbuf;
+ warning("Unterminated C string [239]");
+}
+
+
+
+
+
+void begincommenting(cp)
+char *cp;
+{
+ if (!commenting_flag) {
+ commenting_ptr = cp;
+ }
+ commenting_flag++;
+}
+
+
+void saveinputcomment(cp)
+char *cp;
+{
+ if (commenting_ptr)
+ sprintf(curtokbuf, "%.*s", (int)(cp - commenting_ptr), commenting_ptr);
+ else
+ sprintf(curtokbuf, "\003%.*s", (int)(cp - inbuf), inbuf);
+ commentline(CMT_POST);
+ commenting_ptr = NULL;
+}
+
+
+void endcommenting(cp)
+char *cp;
+{
+ commenting_flag--;
+ if (!commenting_flag) {
+ saveinputcomment(cp);
+ }
+}
+
+
+
+
+int peeknextchar()
+{
+ char *cp;
+
+ cp = inbufptr;
+ while (isspace(*cp))
+ cp++;
+ return *cp;
+}
+
+
+
+
+#ifdef LEXDEBUG
+Static void zgettok();
+void gettok()
+{
+ zgettok();
+ if (tokentrace) {
+ printf("gettok() found %s", tok_name(curtok));
+ switch (curtok) {
+ case TOK_HEXLIT:
+ case TOK_OCTLIT:
+ case TOK_INTLIT:
+ case TOK_MININT:
+ printf(", curtokint = %d", curtokint);
+ break;
+ case TOK_REALLIT:
+ case TOK_STRLIT:
+ printf(", curtokbuf = %s", makeCstring(curtokbuf, curtokint));
+ break;
+ default:
+ break;
+ }
+ putchar('\n');
+ }
+}
+Static void zgettok()
+#else
+void gettok()
+#endif
+{
+ register char ch;
+ register char *cp;
+ char ch2;
+ char *startcp;
+ int i;
+
+ debughook();
+ for (;;) {
+ switch ((ch = *inbufptr++)) {
+
+ case 0:
+ if (commenting_flag)
+ saveinputcomment(inbufptr-1);
+ p2c_getline();
+ cp = curtokbuf;
+ for (;;) {
+ inbufindent = 0;
+ for (;;) {
+ if (*inbufptr == '\t') {
+ inbufindent++;
+ if (intabsize)
+ inbufindent = (inbufindent / intabsize + 1) * intabsize;
+ } else if (*inbufptr == ' ')
+ inbufindent++;
+ else if (*inbufptr != 26)
+ break;
+ inbufptr++;
+ }
+ if (!*inbufptr && !commenting_flag) { /* blank line */
+ *cp++ = '\001';
+ p2c_getline();
+ } else
+ break;
+ }
+ if (cp > curtokbuf) {
+ *cp = 0;
+ commentline(CMT_POST);
+ }
+ break;
+
+ case '\t':
+ case ' ':
+ case 26: /* ignore ^Z's in Turbo files */
+ while (*inbufptr++ == ch) ;
+ inbufptr--;
+ break;
+
+ case '$':
+ if (dollar_idents)
+ goto ident;
+ if (dollar_flag) {
+ dollar_flag = 0;
+ curtok = TOK_DOLLAR;
+ return;
+ }
+ startcp = inbufptr-1;
+ while (isspace(*inbufptr))
+ inbufptr++;
+ cp = inbufptr;
+ while (isxdigit(*cp))
+ cp++;
+ if (cp > inbufptr && cp <= inbufptr+8 && !isalnum(*cp)) {
+ while (isspace(*cp))
+ cp++;
+ if (!isdigit(*cp) && *cp != '\'') {
+ cp = curtokbuf; /* Turbo hex constant */
+ while (isxdigit(*inbufptr))
+ *cp++ = *inbufptr++;
+ *cp = 0;
+ curtok = TOK_HEXLIT;
+ curtokint = my_strtol(curtokbuf, NULL, 16);
+ return;
+ }
+ }
+ dollar_flag++; /* HP Pascal compiler directive */
+ do {
+ gettok();
+ if (curtok == TOK_IF) { /* $IF expr$ */
+ Expr *ex;
+ Value val;
+ if (!skipping_module) {
+ if (!setup_complete)
+ error("$IF$ not allowed at top of program");
+
+ /* Even though HP Pascal doesn't let these nest,
+ there's no harm in supporting it. */
+ if (if_flag) {
+ skiptotoken(TOK_DOLLAR);
+ if_flag++;
+ break;
+ }
+ gettok();
+ ex = p_expr(tp_boolean);
+ val = eval_expr_consts(ex);
+ freeexpr(ex);
+ i = (val.type == tp_boolean && val.i);
+ free_value(&val);
+ if (!i) {
+ if (curtok != TOK_DOLLAR) {
+ warning("Syntax error in $IF$ expression [240]");
+ skiptotoken(TOK_DOLLAR);
+ }
+ begincommenting(startcp);
+ if_flag++;
+ while (if_flag > 0)
+ gettok();
+ endcommenting(inbufptr);
+ }
+ } else {
+ skiptotoken(TOK_DOLLAR);
+ }
+ } else if (curtok == TOK_END) { /* $END$ */
+ if (if_flag) {
+ gettok();
+ if (!wexpecttok(TOK_DOLLAR))
+ skiptotoken(TOK_DOLLAR);
+ curtok = TOK_ENDIF;
+ if_flag--;
+ return;
+ } else {
+ gettok();
+ if (!wexpecttok(TOK_DOLLAR))
+ skiptotoken(TOK_DOLLAR);
+ }
+ } else if (curtok == TOK_IDENT) {
+ if (!strcmp(curtokbuf, "INCLUDE") &&
+ !if_flag && !skipping_module) {
+ char *fn;
+ gettok();
+ if (curtok == TOK_IDENT) {
+ fn = stralloc(curtokcase);
+ gettok();
+ } else if (wexpecttok(TOK_STRLIT)) {
+ fn = stralloc(curtokbuf);
+ gettok();
+ } else
+ fn = "";
+ if (!wexpecttok(TOK_DOLLAR)) {
+ skiptotoken(TOK_DOLLAR);
+ } else {
+ if (handle_include(fn))
+ return;
+ }
+ } else if (ignore_directives ||
+ if_flag ||
+ !strcmp(curtokbuf, "SEARCH") ||
+ !strcmp(curtokbuf, "REF") ||
+ !strcmp(curtokbuf, "DEF")) {
+ skiptotoken(TOK_DOLLAR);
+ } else if (!strcmp(curtokbuf, "SWITCH_STRPOS")) {
+ switch_strpos = getflag();
+ } else if (!strcmp(curtokbuf, "SYSPROG")) {
+ if (getflag())
+ sysprog_flag |= 1;
+ else
+ sysprog_flag &= ~1;
+ } else if (!strcmp(curtokbuf, "MODCAL")) {
+ if (getflag())
+ sysprog_flag |= 2;
+ else
+ sysprog_flag &= ~2;
+ } else if (!strcmp(curtokbuf, "PARTIAL_EVAL")) {
+ if (shortcircuit < 0)
+ partial_eval_flag = getflag();
+ } else if (!strcmp(curtokbuf, "IOCHECK")) {
+ iocheck_flag = getflag();
+ } else if (!strcmp(curtokbuf, "RANGE")) {
+ if (getflag()) {
+ if (!range_flag)
+ note("Range checking is ON [216]");
+ range_flag = 1;
+ } else {
+ if (range_flag)
+ note("Range checking is OFF [216]");
+ range_flag = 0;
+ }
+ } else if (!strcmp(curtokbuf, "OVFLCHECK")) {
+ if (getflag()) {
+ if (!ovflcheck_flag)
+ note("Overflow checking is ON [219]");
+ ovflcheck_flag = 1;
+ } else {
+ if (ovflcheck_flag)
+ note("Overflow checking is OFF [219]");
+ ovflcheck_flag = 0;
+ }
+ } else if (!strcmp(curtokbuf, "STACKCHECK")) {
+ if (getflag()) {
+ if (!stackcheck_flag)
+ note("Stack checking is ON [217]");
+ stackcheck_flag = 1;
+ } else {
+ if (stackcheck_flag)
+ note("Stack checking is OFF [217]");
+ stackcheck_flag = 0;
+ }
+ }
+ skiptotoken2(TOK_DOLLAR, TOK_COMMA);
+ } else {
+ warning("Mismatched '$' signs [241]");
+ dollar_flag = 0; /* got out of sync */
+ return;
+ }
+ } while (curtok == TOK_COMMA);
+ break;
+
+ case '"':
+ if (C_lex) {
+ get_C_string(ch);
+ curtok = TOK_STRLIT;
+ return;
+ }
+ goto stringLiteral;
+
+ case '#':
+ if (modula2) {
+ curtok = TOK_NE;
+ return;
+ }
+ cp = inbufptr;
+ while (isspace(*cp)) cp++;
+ if (!strcincmp(cp, "INCLUDE", 7)) {
+ char *cp2, *cp3;
+ cp += 7;
+ while (isspace(*cp)) cp++;
+ cp2 = cp + strlen(cp) - 1;
+ while (isspace(*cp2)) cp2--;
+ if ((*cp == '"' && *cp2 == '"' && cp2 > cp) ||
+ (*cp == '<' && *cp2 == '>')) {
+ inbufptr = cp2 + 1;
+ cp3 = stralloc(cp + 1);
+ cp3[cp2 - cp - 1] = 0;
+ if (handle_include(cp3))
+ return;
+ else
+ break;
+ }
+ }
+ /* fall through */
+
+ case '\'':
+ if (C_lex && ch == '\'') {
+ get_C_string(ch);
+ if (curtokint != 1)
+ warning("Character constant has length != 1 [242]");
+ curtokint = *curtokbuf;
+ curtok = TOK_CHARLIT;
+ return;
+ }
+ stringLiteral:
+ cp = curtokbuf;
+ ch2 = (ch == '"') ? '"' : '\'';
+ do {
+ if (ch == ch2) {
+ while ((ch = *inbufptr++) != '\n' &&
+ ch != EOF) {
+ if (ch == ch2) {
+ if (*inbufptr != ch2 || modula2)
+ break;
+ else
+ inbufptr++;
+ }
+ *cp++ = ch;
+ }
+ if (ch != ch2)
+ warning("Error in string literal [243]");
+ } else {
+ ch = *inbufptr++;
+ if (isdigit(ch)) {
+ i = 0;
+ while (isdigit(ch)) {
+ i = i*10 + ch - '0';
+ ch = *inbufptr++;
+ }
+ inbufptr--;
+ *cp++ = i;
+ } else {
+ *cp++ = ch & 0x1f;
+ }
+ }
+ while (*inbufptr == ' ' || *inbufptr == '\t')
+ inbufptr++;
+ } while ((ch = *inbufptr++) == ch2 || ch == '#');
+ inbufptr--;
+ *cp = 0;
+ curtokint = cp - curtokbuf;
+ curtok = TOK_STRLIT;
+ return;
+
+ case '(':
+ if (*inbufptr == '*' && !C_lex) {
+ inbufptr++;
+ switch (commenting_flag ? 0 : parsecomment(0, 1)) {
+ case 0:
+ comment(1);
+ break;
+ case 2:
+ return;
+ }
+ break;
+ } else if (*inbufptr == '.') {
+ curtok = TOK_LBR;
+ inbufptr++;
+ } else {
+ curtok = TOK_LPAR;
+ }
+ return;
+
+ case '{':
+ if (C_lex || modula2) {
+ curtok = TOK_LBRACE;
+ return;
+ }
+ switch (commenting_flag ? 0 : parsecomment(0, 0)) {
+ case 0:
+ comment(0);
+ break;
+ case 2:
+ return;
+ }
+ break;
+
+ case '}':
+ if (C_lex || modula2) {
+ curtok = TOK_RBRACE;
+ return;
+ }
+ if (skipflag > 0) {
+ skipflag = 0;
+ } else
+ warning("Unmatched '}' in input file [244]");
+ break;
+
+ case ')':
+ curtok = TOK_RPAR;
+ return;
+
+ case '*':
+ if (*inbufptr == (C_lex ? '/' : ')')) {
+ inbufptr++;
+ if (skipflag > 0) {
+ skipflag = 0;
+ } else
+ warning("Unmatched '*)' in input file [245]");
+ break;
+ } else if (*inbufptr == '*' && !C_lex) {
+ curtok = TOK_STARSTAR;
+ inbufptr++;
+ } else
+ curtok = TOK_STAR;
+ return;
+
+ case '+':
+ if (C_lex && *inbufptr == '+') {
+ curtok = TOK_PLPL;
+ inbufptr++;
+ } else
+ curtok = TOK_PLUS;
+ return;
+
+ case ',':
+ curtok = TOK_COMMA;
+ return;
+
+ case '-':
+ if (C_lex && *inbufptr == '-') {
+ curtok = TOK_MIMI;
+ inbufptr++;
+ } else if (*inbufptr == '>') {
+ curtok = TOK_ARROW;
+ inbufptr++;
+ } else
+ curtok = TOK_MINUS;
+ return;
+
+ case '.':
+ if (*inbufptr == '.') {
+ curtok = TOK_DOTS;
+ inbufptr++;
+ } else if (*inbufptr == ')') {
+ curtok = TOK_RBR;
+ inbufptr++;
+ } else
+ curtok = TOK_DOT;
+ return;
+
+ case '/':
+ if (C_lex && *inbufptr == '*') {
+ inbufptr++;
+ comment(2);
+ break;
+ }
+ curtok = TOK_SLASH;
+ return;
+
+ case ':':
+ if (*inbufptr == '=') {
+ curtok = TOK_ASSIGN;
+ inbufptr++;
+ } else if (*inbufptr == ':') {
+ curtok = TOK_COLONCOLON;
+ inbufptr++;
+ } else
+ curtok = TOK_COLON;
+ return;
+
+ case ';':
+ curtok = TOK_SEMI;
+ return;
+
+ case '<':
+ if (*inbufptr == '=') {
+ curtok = TOK_LE;
+ inbufptr++;
+ } else if (*inbufptr == '>') {
+ curtok = TOK_NE;
+ inbufptr++;
+ } else if (*inbufptr == '<') {
+ curtok = TOK_LTLT;
+ inbufptr++;
+ } else
+ curtok = TOK_LT;
+ return;
+
+ case '>':
+ if (*inbufptr == '=') {
+ curtok = TOK_GE;
+ inbufptr++;
+ } else if (*inbufptr == '>') {
+ curtok = TOK_GTGT;
+ inbufptr++;
+ } else
+ curtok = TOK_GT;
+ return;
+
+ case '=':
+ if (*inbufptr == '=') {
+ curtok = TOK_EQEQ;
+ inbufptr++;
+ } else
+ curtok = TOK_EQ;
+ return;
+
+ case '[':
+ curtok = TOK_LBR;
+ return;
+
+ case ']':
+ curtok = TOK_RBR;
+ return;
+
+ case '^':
+ curtok = TOK_HAT;
+ return;
+
+ case '&':
+ if (*inbufptr == '&') {
+ curtok = TOK_ANDAND;
+ inbufptr++;
+ } else
+ curtok = TOK_AMP;
+ return;
+
+ case '|':
+ if (*inbufptr == '|') {
+ curtok = TOK_OROR;
+ inbufptr++;
+ } else
+ curtok = TOK_VBAR;
+ return;
+
+ case '~':
+ curtok = TOK_TWIDDLE;
+ return;
+
+ case '!':
+ if (*inbufptr == '=') {
+ curtok = TOK_BANGEQ;
+ inbufptr++;
+ } else
+ curtok = TOK_BANG;
+ return;
+
+ case '%':
+ if (C_lex) {
+ curtok = TOK_PERC;
+ return;
+ }
+ goto ident;
+
+ case '?':
+ curtok = TOK_QM;
+ return;
+
+ case '@':
+ curtok = TOK_ADDR;
+ return;
+
+ case EOFMARK:
+ if (curtok == TOK_EOF) {
+ if (inputkind == INP_STRLIST)
+ error("Unexpected end of macro");
+ else
+ error("Unexpected end of file");
+ }
+ curtok = TOK_EOF;
+ return;
+
+ default:
+ if (isdigit(ch)) {
+ cp = inbufptr;
+ while (isxdigit(*cp))
+ cp++;
+ if (*cp == '#' && isxdigit(cp[1])) {
+ i = atoi(inbufptr-1);
+ inbufptr = cp+1;
+ } else if (toupper(cp[-1]) == 'B' ||
+ toupper(cp[-1]) == 'C') {
+ inbufptr--;
+ i = 8;
+ } else if (toupper(*cp) == 'H') {
+ inbufptr--;
+ i = 16;
+ } else if ((ch == '0' && toupper(*inbufptr) == 'X' &&
+ isxdigit(inbufptr[1]))) {
+ inbufptr++;
+ i = 16;
+ } else {
+ i = 10;
+ }
+ if (i != 10) {
+ curtokint = 0;
+ while (isdigit(*inbufptr) ||
+ (i > 10 && isxdigit(*inbufptr))) {
+ ch = toupper(*inbufptr++);
+ curtokint *= i;
+ if (ch <= '9')
+ curtokint += ch - '0';
+ else
+ curtokint += ch - 'A' + 10;
+ }
+ sprintf(curtokbuf, "%ld", curtokint);
+ if ((toupper(*inbufptr) == 'B' && i == 8) ||
+ (toupper(*inbufptr) == 'H' && i == 16))
+ inbufptr++;
+ if (toupper(*inbufptr) == 'C' && i == 8) {
+ inbufptr++;
+ curtok = TOK_STRLIT;
+ curtokbuf[0] = curtokint;
+ curtokbuf[1] = 0;
+ curtokint = 1;
+ return;
+ }
+ if (toupper(*inbufptr) == 'L') {
+ strcat(curtokbuf, "L");
+ inbufptr++;
+ }
+ curtok = (i == 8) ? TOK_OCTLIT : TOK_HEXLIT;
+ return;
+ }
+ cp = curtokbuf;
+ i = 0;
+ while (ch == '0')
+ ch = *inbufptr++;
+ if (isdigit(ch)) {
+ while (isdigit(ch)) {
+ *cp++ = ch;
+ ch = *inbufptr++;
+ }
+ } else
+ *cp++ = '0';
+ if (ch == '.') {
+ if (isdigit(*inbufptr)) {
+ *cp++ = ch;
+ ch = *inbufptr++;
+ i = 1;
+ while (isdigit(ch)) {
+ *cp++ = ch;
+ ch = *inbufptr++;
+ }
+ }
+ }
+ if (ch == 'e' || ch == 'E' ||
+ ch == 'd' || ch == 'D' ||
+ ch == 'q' || ch == 'Q') {
+ ch = *inbufptr;
+ if (isdigit(ch) || ch == '+' || ch == '-') {
+ *cp++ = 'e';
+ inbufptr++;
+ i = 1;
+ do {
+ *cp++ = ch;
+ ch = *inbufptr++;
+ } while (isdigit(ch));
+ }
+ }
+ inbufptr--;
+ *cp = 0;
+ if (i) {
+ curtok = TOK_REALLIT;
+ curtokint = cp - curtokbuf;
+ } else {
+ if (cp >= curtokbuf+10) {
+ i = strcmp(curtokbuf, "2147483648");
+ if (cp > curtokbuf+10 || i > 0) {
+ curtok = TOK_REALLIT;
+ curtokint = cp - curtokbuf + 2;
+ strcat(curtokbuf, ".0");
+ return;
+ }
+ if (i == 0) {
+ curtok = TOK_MININT;
+ curtokint = -2147483648;
+ return;
+ }
+ }
+ curtok = TOK_INTLIT;
+ curtokint = atol(curtokbuf);
+ if (toupper(*inbufptr) == 'L') {
+ strcat(curtokbuf, "L");
+ inbufptr++;
+ }
+ }
+ return;
+ } else if (isalpha(ch) || ch == '_') {
+ident:
+ {
+ register char *cp2;
+ curtoksym = NULL;
+ cp = curtokbuf;
+ cp2 = curtokcase;
+ *cp2++ = symcase ? ch : tolower(ch);
+ *cp++ = pascalcasesens ? ch : toupper(ch);
+ while (isalnum((ch = *inbufptr++)) ||
+ ch == '_' ||
+ (ch == '%' && !C_lex) ||
+ (ch == '$' && dollar_idents)) {
+ *cp2++ = symcase ? ch : tolower(ch);
+ if (!ignorenonalpha || isalnum(ch))
+ *cp++ = pascalcasesens ? ch : toupper(ch);
+ }
+ inbufptr--;
+ *cp2 = 0;
+ *cp = 0;
+ if (pascalsignif > 0)
+ curtokbuf[pascalsignif] = 0;
+ }
+ if (*curtokbuf == '%') {
+ if (!strcicmp(curtokbuf, "%INCLUDE")) {
+ char *cp2 = inbufptr;
+ while (isspace(*cp2)) cp2++;
+ if (*cp2 == '\'')
+ cp2++;
+ cp = curtokbuf;
+ while (*cp2 && *cp2 != '\'' &&
+ *cp2 != ';' && !isspace(*cp2)) {
+ *cp++ = *cp2++;
+ }
+ *cp = 0;
+ cp = my_strrchr(curtokbuf, '/');
+ if (cp && (!strcicmp(cp, "/LIST") ||
+ !strcicmp(cp, "/NOLIST")))
+ *cp = 0;
+ if (*cp2 == '\'')
+ cp2++;
+ while (isspace(*cp2)) cp2++;
+ if (*cp2 == ';')
+ cp2++;
+ while (isspace(*cp2)) cp2++;
+ if (!*cp2) {
+ inbufptr = cp2;
+ (void) handle_include(stralloc(curtokbuf));
+ return;
+ }
+ } else if (!strcicmp(curtokbuf, "%TITLE") ||
+ !strcicmp(curtokbuf, "%SUBTITLE")) {
+ gettok(); /* string literal */
+ break;
+ } else if (!strcicmp(curtokbuf, "%PAGE")) {
+ /* should store a special page-break comment? */
+ break; /* ignore token */
+ } else if ((i = 2, !strcicmp(curtokbuf, "%B")) ||
+ (i = 8, !strcicmp(curtokbuf, "%O")) ||
+ (i = 16, !strcicmp(curtokbuf, "%X"))) {
+ while (isspace(*inbufptr)) inbufptr++;
+ if (*inbufptr == '\'') {
+ inbufptr++;
+ curtokint = 0;
+ while (*inbufptr && *inbufptr != '\'') {
+ ch = toupper(*inbufptr++);
+ if (isxdigit(ch)) {
+ curtokint *= i;
+ if (ch <= '9')
+ curtokint += ch - '0';
+ else
+ curtokint += ch - 'A' + 10;
+ } else if (!isspace(ch))
+ warning("Bad digit in literal [246]");
+ }
+ if (*inbufptr)
+ inbufptr++;
+ sprintf(curtokbuf, "%ld", curtokint);
+ curtok = (i == 8) ? TOK_OCTLIT : TOK_HEXLIT;
+ return;
+ }
+ }
+ }
+ {
+ register unsigned int hash;
+ register Symbol *sp;
+
+ hash = 0;
+ for (cp = curtokbuf; *cp; cp++)
+ hash = hash*3 + *cp;
+ sp = symtab[hash % SYMHASHSIZE];
+ while (sp && (i = strcmp(sp->name, curtokbuf)) != 0) {
+ if (i < 0)
+ sp = sp->left;
+ else
+ sp = sp->right;
+ }
+ if (!sp)
+ sp = findsymbol(curtokbuf);
+ if (sp->flags & SSYNONYM) {
+ i = 100;
+ while (--i > 0 && sp && (sp->flags & SSYNONYM)) {
+ Strlist *sl;
+ sl = strlist_find(sp->symbolnames, "===");
+ if (sl)
+ sp = (Symbol *)sl->value;
+ else
+ sp = NULL;
+ }
+ if (!sp)
+ break; /* ignore token */
+ }
+ if (sp->kwtok && !(sp->flags & KWPOSS) &&
+ (pascalcasesens != 2 || !islower(*curtokbuf)) &&
+ (pascalcasesens != 3 || !isupper(*curtokbuf))) {
+ curtok = sp->kwtok;
+ return;
+ }
+ curtok = TOK_IDENT;
+ curtoksym = sp;
+ if ((i = withlevel) != 0 && sp->fbase) {
+ while (--i >= 0) {
+ curtokmeaning = sp->fbase;
+ while (curtokmeaning) {
+ if (curtokmeaning->rectype == withlist[i]) {
+ curtokint = i;
+ return;
+ }
+ curtokmeaning = curtokmeaning->snext;
+ }
+ }
+ }
+ curtokmeaning = sp->mbase;
+ while (curtokmeaning && !curtokmeaning->isactive)
+ curtokmeaning = curtokmeaning->snext;
+ if (!curtokmeaning)
+ return;
+ while (curtokmeaning->kind == MK_SYNONYM)
+ curtokmeaning = curtokmeaning->xnext;
+ /* look for unit.ident notation */
+ if (curtokmeaning->kind == MK_MODULE ||
+ curtokmeaning->kind == MK_FUNCTION) {
+ for (cp = inbufptr; isspace(*cp); cp++) ;
+ if (*cp == '.') {
+ for (cp++; isspace(*cp); cp++) ;
+ if (isalpha(*cp)) {
+ Meaning *mp = curtokmeaning;
+ Symbol *sym = curtoksym;
+ char *saveinbufptr = inbufptr;
+ gettok();
+ if (curtok == TOK_DOT)
+ gettok();
+ else
+ curtok = TOK_END;
+ if (curtok == TOK_IDENT) {
+ curtokmeaning = curtoksym->mbase;
+ while (curtokmeaning &&
+ curtokmeaning->ctx != mp)
+ curtokmeaning = curtokmeaning->snext;
+ if (!curtokmeaning &&
+ !strcmp(sym->name, "SYSTEM")) {
+ curtokmeaning = curtoksym->mbase;
+ while (curtokmeaning &&
+ curtokmeaning->ctx != nullctx)
+ curtokmeaning = curtokmeaning->snext;
+ }
+ } else
+ curtokmeaning = NULL;
+ if (!curtokmeaning) {
+ /* oops, was probably funcname.field */
+ inbufptr = saveinbufptr;
+ curtokmeaning = mp;
+ curtoksym = sym;
+ }
+ }
+ }
+ }
+ return;
+ }
+ } else {
+ warning(format_d("Unrecognized character 0%o in file [247]",
+ ch));
+ }
+ }
+ }
+}
+
+
+
+void checkkeyword(tok)
+Token tok;
+{
+ if (curtok == TOK_IDENT &&
+ curtoksym->kwtok == tok) {
+ curtoksym->flags &= ~KWPOSS;
+ curtok = tok;
+ }
+}
+
+
+void checkmodulewords()
+{
+ if (modula2) {
+ checkkeyword(TOK_FROM);
+ checkkeyword(TOK_DEFINITION);
+ checkkeyword(TOK_IMPLEMENT);
+ checkkeyword(TOK_MODULE);
+ checkkeyword(TOK_IMPORT);
+ checkkeyword(TOK_EXPORT);
+ } else if (curtok == TOK_IDENT &&
+ (curtoksym->kwtok == TOK_MODULE ||
+ curtoksym->kwtok == TOK_IMPORT ||
+ curtoksym->kwtok == TOK_EXPORT ||
+ curtoksym->kwtok == TOK_IMPLEMENT)) {
+ if (!strcmp(curtokbuf, "UNIT") ||
+ !strcmp(curtokbuf, "USES") ||
+ !strcmp(curtokbuf, "INTERFACE") ||
+ !strcmp(curtokbuf, "IMPLEMENTATION")) {
+ modulenotation = 0;
+ findsymbol("UNIT")->flags &= ~KWPOSS;
+ findsymbol("USES")->flags &= ~KWPOSS;
+ findsymbol("INTERFACE")->flags &= ~KWPOSS;
+ findsymbol("IMPLEMENTATION")->flags &= ~KWPOSS;
+ } else {
+ modulenotation = 1;
+ findsymbol("MODULE")->flags &= ~KWPOSS;
+ findsymbol("EXPORT")->flags &= ~KWPOSS;
+ findsymbol("IMPORT")->flags &= ~KWPOSS;
+ findsymbol("IMPLEMENT")->flags &= ~KWPOSS;
+ }
+ curtok = curtoksym->kwtok;
+ }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+/* End. */
+
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/libp2c.a b/MultiSource/Benchmarks/MallocBench/p2c/libp2c.a
new file mode 100644
index 00000000..a2b76f3c
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/libp2c.a
Binary files differ
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/loc.p2clib.c b/MultiSource/Benchmarks/MallocBench/p2c/loc.p2clib.c
new file mode 100644
index 00000000..5ad3b636
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/loc.p2clib.c
@@ -0,0 +1,6 @@
+
+/* Put p2c runtime features local to your system here.
+ * In particular, additional initialization may be provided by defining
+ * the symbol LOCAL_INIT when you compile p2clib.c.
+ */
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/makeproto b/MultiSource/Benchmarks/MallocBench/p2c/makeproto
new file mode 100644
index 00000000..adaaa6f9
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/makeproto
Binary files differ
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/out.c b/MultiSource/Benchmarks/MallocBench/p2c/out.c
new file mode 100644
index 00000000..e0591ae8
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/out.c
@@ -0,0 +1,1580 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+
+/* This needs to go before trans.h (and thus p2c.proto) is read */
+
+typedef struct S_paren {
+ struct S_paren *next;
+ int pos, indent, qmindent, flags;
+} Paren;
+
+
+
+#define PROTO_OUT_C
+#include "trans.h"
+
+
+#ifndef USETIME
+# if defined(BSD) || defined(hpux)
+# define USETIME 1
+# else
+# define USETIME 0
+# endif
+#endif
+
+#if USETIME
+# include <sys/time.h>
+#else
+# include <time.h>
+#endif
+
+
+
+
+/* Output control characters:
+
+ \001 \B Possible break point
+ \002 \X Break point in parentheses
+ \003 \( Invisible open paren
+ \004 \) Invisible close paren
+ \005 \T Set left margin
+ \006 \F Forced break point
+ \007 \A Preceding paren requires all-or-none breaking
+ \010 \[ Invisible open paren, becomes visible if not all on one line
+ \011 \S Break point after last "special argument" of a function
+ \012 \n (newline)
+ \013 \E Preceding break has extra penalty
+ \014 \f (form-feed)
+ \015 \H Hang-indent the preceding operator
+ \016 \. (unused)
+ \017 \C Break point for last : of a ?: construct
+
+*/
+
+char spchars[] = ".BX()TFA[SnEfH.C................";
+
+
+
+Static int testinglinebreaker = 0;
+
+Static int deltaindent, thisindent, thisfutureindent;
+Static int sectionsize, blanklines, codesectsize, hdrsectsize;
+Static int codelnum, hdrlnum;
+
+#define MAXBREAKS 200
+Static int numbreaks, bestnumbreaks;
+Static double bestbadness;
+Static int breakpos[MAXBREAKS], breakindent[MAXBREAKS];
+Static int breakcount[MAXBREAKS], breakparen[MAXBREAKS];
+Static int bestbreakpos[MAXBREAKS], bestbreakindent[MAXBREAKS];
+Static int breakerrorflag;
+
+#define MAXEDITS 200
+Static int numedits, bestnumedits;
+Static int editpos[MAXEDITS], besteditpos[MAXEDITS];
+Static char editold[MAXEDITS], editnew[MAXEDITS];
+Static char besteditold[MAXEDITS], besteditnew[MAXEDITS];
+
+Static Paren *parenlist;
+
+Static long numalts, bestnumalts;
+Static int randombreaks;
+
+Static char *outbuf;
+Static int outbufpos, outbufcount, outbufsize;
+Static int suppressnewline, lastlinelength;
+Static int eatblanks;
+Static int embeddedcode;
+Static int showingsourcecode = 0;
+
+#define BIGBADNESS (1e20)
+
+
+
+void setup_out()
+{
+ end_source();
+ if (!nobanner)
+ fprintf(outf, "/* From input file \"%s\" */\n", infname);
+ outf_lnum++;
+ hdrlnum = 1;
+ outindent = 0;
+ deltaindent = 0;
+ thisindent = 0;
+ thisfutureindent = -1;
+ sectionsize = 2;
+ blanklines = 0;
+ dontbreaklines = 0;
+ embeddedcode = 0;
+ outputmode = 0;
+ suppressnewline = 0;
+ eatblanks = 0;
+ outbufsize = 1000;
+ outbuf = ALLOC(outbufsize, char, misc);
+ outbufpos = 0;
+ outbufcount = 0;
+ srand(17);
+}
+
+
+
+void select_outfile(fp)
+FILE *fp;
+{
+ if (outf == codef) {
+ codesectsize = sectionsize;
+ codelnum = outf_lnum;
+ } else {
+ hdrsectsize = sectionsize;
+ hdrlnum = outf_lnum;
+ }
+ outf = fp;
+ if (outf == codef) {
+ sectionsize = codesectsize;
+ outf_lnum = codelnum;
+ } else {
+ sectionsize = hdrsectsize;
+ outf_lnum = hdrlnum;
+ }
+}
+
+
+
+void start_source()
+{
+ if (!showingsourcecode) {
+ fprintf(outf, "\n#ifdef Pascal\n");
+ showingsourcecode = 1;
+ }
+}
+
+void end_source()
+{
+ if (showingsourcecode) {
+ fprintf(outf, "#endif /*Pascal*/\n\n");
+ showingsourcecode = 0;
+ }
+}
+
+
+
+int line_start()
+{
+ return (outbufcount == 0);
+}
+
+
+int cur_column()
+{
+ if (outbufpos == 0)
+ return outindent;
+ else
+ return thisindent + outbufcount;
+}
+
+
+
+int lookback(n)
+int n;
+{
+ if (n <= 0 || n > outbufpos)
+ return 0;
+ else
+ return outbuf[outbufpos - n];
+}
+
+
+int lookback_prn(n)
+int n;
+{
+ for (;;) {
+ if (n <= 0 || n > outbufpos)
+ return 0;
+ else if (outbuf[outbufpos - n] >= ' ')
+ return outbuf[outbufpos - n];
+ else
+ n++;
+ }
+}
+
+
+
+/* Combine two indentation adjustments */
+int adddeltas(d1, d2)
+int d1, d2;
+{
+ if (d2 >= 1000)
+ return d2;
+ else
+ return d1 + d2;
+}
+
+
+/* Apply an indentation delta */
+int applydelta(i, d)
+int i, d;
+{
+ if (d >= 1000)
+ return d - 1000;
+ else
+ return i + d;
+}
+
+
+/* Adjust the current indentation by delta */
+void moreindent(delta)
+int delta;
+{
+ outindent = applydelta(outindent, delta);
+}
+
+
+/* Adjust indentation for just this line */
+void singleindent(delta)
+int delta;
+{
+ deltaindent = adddeltas(deltaindent, delta);
+}
+
+
+/* Predict indentation for next line */
+void futureindent(num)
+int num;
+{
+ thisfutureindent = applydelta(applydelta(outindent, deltaindent), num);
+}
+
+
+int parsedelta(cp, def)
+char *cp;
+int def;
+{
+ if (!cp || !*cp)
+ return def;
+ if ((*cp == '+' || *cp == '-') && isdigit(cp[1]))
+ return atoi(cp);
+ if (*cp == '*' && isdigit(cp[1]))
+ return 2000 + atoi(cp+1);
+ else
+ return 1000 + atoi(cp);
+}
+
+
+
+
+Static void leading_tab(col)
+int col;
+{
+ if (col > maxlinewidth)
+ return; /* something wrong happened! */
+ if (phystabsize > 0) {
+ while (col >= phystabsize) {
+ putc('\t', outf);
+ col -= phystabsize;
+ }
+ }
+ while (col > 0) {
+ putc(' ', outf);
+ col--;
+ }
+}
+
+
+
+void eatblanklines()
+{
+ eatblanks = 1;
+}
+
+
+
+Static void flush_outbuf(numbreaks, breakpos, breakindent,
+ numedits, editpos, editold, editnew)
+int numbreaks, *breakpos, *breakindent, numedits, *editpos;
+char *editold, *editnew;
+{
+ unsigned char ch, ch2;
+ char *cp;
+ int i, j, linelen = 0, spaces, hashline;
+ int editsaves[MAXEDITS];
+
+ end_source();
+ if (outbufcount > 0) {
+ for (i = 0; i < numedits; i++) {
+ editsaves[i] = outbuf[editpos[i]];
+ outbuf[editpos[i]] = editnew[i];
+ }
+ leading_tab(thisindent);
+ cp = outbuf;
+ hashline = (*cp == '#'); /* a preprocessor directive */
+ spaces = 0;
+ j = 1;
+ for (i = 0; i < outbufpos; ) {
+ if (j < numbreaks && i == breakpos[j]) {
+ if (hashline)
+ fprintf(outf, " \\"); /* trailing backslash required */
+ putc('\n', outf);
+ outf_lnum++;
+ leading_tab(breakindent[j]);
+ linelen = breakindent[j];
+ j++;
+ while (i < outbufpos && *cp == ' ')
+ i++, cp++; /* eat leading spaces */
+ spaces = 0; /* eat trailing spaces */
+ } else {
+ ch = *cp++;
+ if (ch == ' ') {
+ spaces++;
+ } else if (ch > ' ') {
+ linelen += spaces;
+ while (spaces > 0)
+ putc(' ', outf), spaces--;
+ linelen++;
+ if (ch == '\\' && embeddedcode) {
+ if (*cp == '[') {
+ putc('{', outf);
+ cp++, i++;
+ } else if (*cp == ']') {
+ putc('}', outf);
+ cp++, i++;
+ } else
+ putc(ch, outf);
+ } else
+ putc(ch, outf);
+ } else if (testinglinebreaker >= 3) {
+ linelen += spaces;
+ while (spaces > 0)
+ putc(' ', outf), spaces--;
+ linelen++;
+ putc('\\', outf);
+ ch2 = spchars[ch];
+ if (ch2 != '.')
+ putc(ch2, outf);
+ else {
+ putc('0' + ((ch >> 6) & 7), outf);
+ putc('0' + ((ch >> 3) & 7), outf);
+ putc('0' + (ch & 7), outf);
+ }
+ }
+ i++;
+ }
+ }
+ for (i = 0; i < numedits; i++)
+ outbuf[editpos[i]] = editsaves[i];
+ eatblanks = 0;
+ } else if (eatblanks) {
+ return;
+ }
+ if (suppressnewline) {
+ lastlinelength = linelen;
+ } else
+ putc('\n', outf);
+ outf_lnum++;
+}
+
+
+
+#define ISQUOTE(ch) ((ch)=='"' || (ch)=='\'')
+#define ISOPENP(ch) ((ch)=='(' || (ch)=='[' || (ch)=='\003' || (ch)=='\010')
+#define ISCLOSEP(ch) ((ch)==')' || (ch)==']' || (ch)=='\004')
+#define ISBREAK(ch) ((ch)=='\001' || (ch)=='\002' || (ch)=='\006' || (ch)=='\011' || (ch)=='\017')
+
+Static int readquotes(posp, err)
+int *posp, err;
+{
+ int pos;
+ char quote;
+
+ pos = *posp;
+ quote = outbuf[pos++];
+ while (pos < outbufpos && outbuf[pos] != quote) {
+ if (outbuf[pos] == '\\')
+ pos++;
+ pos++;
+ }
+ if (pos >= outbufpos) {
+ if (err && breakerrorflag) {
+ intwarning("output", "Mismatched quotes [248]");
+ breakerrorflag = 0;
+ }
+ return 0;
+ } else {
+ *posp = pos;
+ return 1;
+ }
+}
+
+
+Static int maxdepth;
+
+Static int readparens(posp, err)
+int *posp, err;
+{
+ char ch, closing;
+ int pos, level;
+
+ pos = *posp;
+ switch (outbuf[pos]) {
+ case '(':
+ closing = ')';
+ break;
+ case '[':
+ closing = ']';
+ break;
+ case '\003':
+ case '\010':
+ closing = '\004';
+ break;
+ default:
+ closing = 0;
+ break;
+ }
+ level = 0;
+ for (;;) {
+ pos++;
+ if (pos >= outbufpos)
+ break;
+ ch = outbuf[pos];
+ if (ISOPENP(ch)) {
+ level++;
+ if (level > maxdepth)
+ maxdepth = level;
+ } else if (ISCLOSEP(ch)) {
+ level--;
+ if (level < 0) {
+ if (closing && outbuf[pos] != closing)
+ break;
+ *posp = pos;
+ return 1;
+ }
+ } else if (ISQUOTE(ch)) {
+ if (!readquotes(&pos, err))
+ return 0;
+ }
+ }
+ if (err && breakerrorflag) {
+ switch (closing) {
+ case ')':
+ intwarning("output", "Mismatched parentheses [249]");
+ break;
+ case ']':
+ intwarning("output", "Mismatched brackets [249]");
+ break;
+ default:
+ intwarning("output", "Mismatched clauses [250]");
+ break;
+ }
+ breakerrorflag = 0;
+ }
+ return 0;
+}
+
+
+
+Static int measurechars(first, last)
+int first, last;
+{
+ int count = 0;
+
+ while (first <= last) {
+ if (outbuf[first] >= ' ')
+ count++;
+ first++;
+ }
+ return count;
+}
+
+
+
+Static void makeedit(pos, ch)
+int pos, ch;
+{
+ editpos[numedits] = pos;
+ editold[numedits] = outbuf[pos];
+ editnew[numedits] = ch;
+ outbuf[pos] = ch;
+ numedits++;
+}
+
+Static void unedit()
+{
+ numedits--;
+ outbuf[editpos[numedits]] = editold[numedits];
+}
+
+
+Static int parencount(par)
+Paren *par;
+{
+ int count = 0;
+
+ while (par) {
+ count++;
+ par = par->next;
+ }
+ return count;
+}
+
+
+
+
+
+/* The following routine explores the tree of all possible line breaks,
+ pruning according to the fact that "badness" and "extra" are
+ increasing functions. The object is to find the set of breaks and
+ indentation with the least total badness.
+ (The basic idea was borrowed from Donald Knuth's "TeX".)
+*/
+
+/* As an additional optimization, the concept of a "simple" line is used,
+ i.e., a line with a structure such that the best break is sure to be
+ the straightforward left-to-right fill used by a simple word processor.
+ (For example, a long line with nothing but comma-breakpoints is simple.)
+
+ Also, if the line is very long a few initial random passes are made just
+ to scope out an estimate of the eventual badness of the line. This
+ combined with the badness cull helps keep the breaker from using up its
+ quota of tries before even considering a key break point! Note that
+ when randombreaks==1, each call to trybreakline is fast since only one
+ branch is taken at each decision point.
+*/
+
+
+#define randtest(lim) (!randombreaks ? -1 \
+ : randombreaks > 0 \
+ ? parencount(parens) < randombreaks-1 \
+ : randombreaks == -2 \
+ ? 0 \
+ : (rand() & 0xfff) < (lim))
+
+#define TB_BRKCOUNT 0x0ff
+#define TB_FORCEBRK 0x100
+#define TB_NOBREAK 0x200
+#define TB_ALREADYBRK 0x400
+#define TB_ALLORNONE 0x800
+#define TB_EXTRAIND 0x1000
+#define TB_EXTRAIND2 0x2000
+
+#define TBR_ABORT 0x1
+#define TBR_SIMPLE 0x2
+#define TBR_REACHED 0x4
+
+Static int trybreakline(pos, count, indent, badness, flags, parens)
+int pos, count, indent, flags;
+double badness;
+Paren *parens;
+{
+ int edited;
+ int i, j, jmask, f, pos2, r;
+ char ch, ch2, closing;
+ double extra, penalty;
+ Paren *pp;
+
+#if 0
+ { static double save = -1;
+ if (showbadlimit != save) printf("Showbadlimit = %g\n", showbadlimit);
+ save = showbadlimit;
+ }
+#endif
+
+ if (numalts >= maxalts)
+ return TBR_ABORT;
+ jmask = -1;
+ for (;;) {
+ if (numbreaks >= MAXBREAKS) { /* must leave rest of line alone */
+ count += measurechars(pos, outbufpos-1);
+ pos = outbufpos;
+ }
+ i = count - breakcount[numbreaks-1] +
+ breakindent[numbreaks-1] - linewidth;
+ if (i <= 0)
+ extra = 0;
+ else {
+ if (i + linewidth >= maxlinewidth || randombreaks == -2)
+ return 0; /* absolutely too long! */
+ extra = overwidepenalty + ((long)i*i)*overwideextrapenalty;
+ jmask &= ~TBR_SIMPLE;
+ if (extra < 0)
+ extra = 0;
+ }
+ if ((testinglinebreaker > 1 && showbadlimit > 0) ?
+ (badness + extra >= showbadlimit) :
+ (badness + extra >= bestbadness)) {
+ numalts++;
+ return 0; /* no point in going on, badness will only increase */
+ }
+ if (pos >= outbufpos)
+ break;
+ if (parens && pos >= parens->pos) {
+ indent = parens->indent;
+ flags = parens->flags;
+ parens = parens->next;
+ }
+ ch = outbuf[pos++];
+ if (ch >= ' ')
+ count++;
+ switch (ch) {
+
+ case '(':
+ case '[':
+ case '\003': /* "invisible open paren" */
+ case '\010': /* "semi-invisible open paren" */
+ pos2 = pos - 1;
+ if (!readparens(&pos2, 1))
+ break;
+ i = measurechars(pos, pos2);
+ if (count + i - breakcount[numbreaks-1] +
+ breakindent[numbreaks-1] <= linewidth) {
+ /* it fits, so leave it on one line */
+#if 0 /* I don't think this is necessary */
+ while (pos <= pos2) {
+ if (outbuf[pos] == '\002') {
+ jmask &= ~TBR_SIMPLE;
+ pos = pos2 + 1;
+ break;
+ }
+ pos++;
+ }
+#else
+ pos = pos2 + 1;
+#endif
+ count += i;
+ break;
+ }
+ pp = ALLOC(1, Paren, parens); /* doesn't fit, try poss breaks */
+ pp->next = parens;
+ pp->pos = pos2;
+ pp->indent = indent;
+ pp->qmindent = indent;
+ pp->flags = flags;
+ parens = pp;
+ flags = 0;
+ if (ch == '\010' && /* change to real parens when broken */
+ numedits+1 < MAXEDITS) { /* (assume it will be broken!) */
+ makeedit(pos-1, '(');
+ makeedit(pos2, ')');
+ count++; /* count the new open paren */
+ edited = 1;
+ } else
+ edited = 0;
+ i = breakindent[numbreaks-1] + count - breakcount[numbreaks-1];
+ if (i <= thisindent)
+ r = 0; /* e.g., don't break top-level assignments */
+ else if (i == indent + extraindent)
+ r = 1; /* don't waste time on identical operations */
+ else
+ r = randtest(0xc00);
+ if (r != 0) {
+ j = trybreakline(pos, count, i,
+ badness + MAX(- extraindentpenalty,0),
+ flags, parens);
+ } else
+ j = 0;
+ if (r != 1) {
+ j &= trybreakline(pos, count, indent + extraindent,
+ badness + MAX(extraindentpenalty,0),
+ flags | TB_EXTRAIND, parens);
+ }
+ if (!randombreaks && bumpindent != 0) {
+ if (i == thisfutureindent) {
+ j &= trybreakline(pos, count, i + bumpindent,
+ badness + MAX(- extraindentpenalty,0)
+ + bumpindentpenalty,
+ flags, parens);
+ } else if (indent + extraindent == thisfutureindent) {
+ j &= trybreakline(pos, count,
+ indent + extraindent + bumpindent,
+ badness + MAX(extraindentpenalty,0)
+ + bumpindentpenalty,
+ flags | TB_EXTRAIND, parens);
+ }
+ }
+ if (edited) {
+ unedit();
+ unedit();
+ }
+ FREE(pp);
+ return j & jmask;
+
+ case '\005': /* "set left margin" */
+ indent = breakindent[numbreaks-1] +
+ count - breakcount[numbreaks-1];
+ break;
+
+ case '\007': /* "all-or-none breaking" */
+ flags |= TB_ALLORNONE;
+ break;
+
+ case '\001': /* "possible break point" */
+ case '\002': /* "break point in parens" */
+ case '\006': /* "forced break point" */
+ case '\011': /* "break point after special args" */
+ case '\017': /* "break point for final : operator" */
+ /* first try the non-breaking case */
+ if (ch != '\001' && ch != '\006')
+ jmask &= ~TBR_SIMPLE;
+ if ((flags & TB_BRKCOUNT) != TB_BRKCOUNT)
+ flags++; /* increment TB_BRKCOUNT field */
+ if (outbuf[pos] == '?' && parens)
+ parens->qmindent = breakindent[numbreaks-1] +
+ count - breakcount[numbreaks-1];
+ j = TBR_REACHED;
+ if (ch == '\006' || (flags & TB_FORCEBRK)) {
+ /* don't try the non-breaking case */
+ } else {
+ if (ch == '\011') {
+ i = breakindent[numbreaks-1] +
+ count - breakcount[numbreaks-1] + 2;
+ } else {
+ i = indent;
+ }
+ f = flags;
+ if (f & TB_ALLORNONE)
+ f |= TB_NOBREAK;
+ r = randtest(0x800);
+ if (r != 1 || (flags & TB_NOBREAK)) {
+ j = trybreakline(pos, count, i, badness, f, parens) &
+ jmask;
+ if (randombreaks == -2 && !(j & TBR_REACHED)) {
+ r = -1;
+ j |= TBR_REACHED;
+ }
+ if (r == 0 || (j & TBR_SIMPLE))
+ flags |= TB_NOBREAK;
+ }
+ }
+ if (flags & TB_NOBREAK)
+ return j;
+ if (flags & TB_ALLORNONE)
+ flags |= TB_FORCEBRK;
+ if (flags & TB_EXTRAIND) {
+ flags &= ~TB_EXTRAIND;
+ flags |= TB_EXTRAIND2;
+ }
+ /* now try breaking here */
+ if (ch == '\017')
+ indent = parens->qmindent;
+ if (indent < 0)
+ indent = 0;
+ breakpos[numbreaks] = pos;
+ breakcount[numbreaks] = count;
+ breakindent[numbreaks] = indent;
+ breakparen[numbreaks] = parens ? parens->pos : 0;
+ numbreaks++;
+ penalty = extra;
+ if (indent == thisfutureindent) {
+ i = pos;
+ while (i < outbufpos-1 && outbuf[i] <= ' ')
+ i++;
+ ch2 = outbuf[i]; /* first character on next line */
+ if (ch2 != '(' && ch2 != '!' && ch2 != '~' && ch2 != '-')
+ penalty += nobumpindentpenalty;
+ }
+ switch (ch) {
+ case '\001':
+ penalty += commabreakpenalty;
+ if (flags & TB_ALREADYBRK)
+ penalty += morebreakpenalty;
+ break;
+ case '\011':
+ i = parencount(parens);
+ penalty += specialargbreakpenalty + commabreakextrapenalty*i;
+ break;
+ case '\002':
+ case '\017':
+ i = parencount(parens);
+ if (outbuf[pos-2] == '(')
+ penalty += parenbreakpenalty + parenbreakextrapenalty*i;
+ else if (outbuf[pos-2] == ',')
+ penalty += commabreakpenalty + commabreakextrapenalty*i;
+ else if (((outbuf[pos] == '&' || outbuf[pos] == '|') &&
+ outbuf[pos+1] == outbuf[pos]) ||
+ ((outbuf[pos-3] == '&' || outbuf[pos-3] == '|') &&
+ outbuf[pos-3] == outbuf[pos-2]))
+ penalty += logbreakpenalty + logbreakextrapenalty*i;
+ else if (((outbuf[pos] == '<' || outbuf[pos] == '>') &&
+ outbuf[pos+1] != outbuf[pos]) ||
+ ((outbuf[pos] == '=' || outbuf[pos] == '!') &&
+ outbuf[pos+1] == '=') ||
+ ((outbuf[pos-2] == '<' || outbuf[pos-2] == '>') &&
+ outbuf[pos-3] != outbuf[pos-2]) ||
+ ((outbuf[pos-3] == '<' || outbuf[pos-3] == '>' ||
+ outbuf[pos-3] == '=' || outbuf[pos-3] == '!') &&
+ outbuf[pos-2] == '='))
+ penalty += relbreakpenalty + relbreakextrapenalty*i;
+ else if (outbuf[pos-2] == '=')
+ penalty += assignbreakpenalty + assignbreakextrapenalty*i;
+ else if (outbuf[pos] == '?') {
+ penalty += qmarkbreakpenalty + qmarkbreakextrapenalty*i;
+ if (parens)
+ parens->qmindent = breakindent[numbreaks-1] +
+ count - breakcount[numbreaks-1];
+ } else
+ penalty += opbreakpenalty + opbreakextrapenalty*i;
+ if (outbuf[pos-2] == '-')
+ penalty += exhyphenpenalty;
+ if (flags & TB_ALREADYBRK)
+ penalty += morebreakpenalty + morebreakextrapenalty*i;
+ break;
+ default:
+ break;
+ }
+ while (pos < outbufpos && outbuf[pos] == '\013') {
+ penalty += wrongsidepenalty;
+ pos++;
+ }
+ penalty -= earlybreakpenalty*(flags & TB_BRKCOUNT);
+ /* the following test is not quite right, but it's not too bad. */
+ if (breakindent[numbreaks-2] == breakindent[numbreaks-1] &&
+ breakparen[numbreaks-2] != breakparen[numbreaks-1])
+ penalty += sameindentpenalty;
+#if 0
+ else if (ch == '\002' && parens && /*don't think this is needed*/
+ parens->indent == breakindent[numbreaks-1] &&
+ parens->pos != breakparen[numbreaks-1])
+ penalty += sameindentpenalty + 0.001; /***/
+#endif
+ penalty += (breakindent[numbreaks-1] - thisindent) *
+ indentamountpenalty;
+ if (penalty < 1) penalty = 1;
+ pos2 = pos;
+ while (pos2 < outbufpos && outbuf[pos2] == ' ')
+ pos2++;
+ flags |= TB_ALREADYBRK;
+ j = trybreakline(pos2, count, indent, badness + penalty,
+ flags, parens) & jmask;
+ numbreaks--;
+ return j;
+
+ case '\015': /* "hang-indent operator" */
+ if (count <= breakcount[numbreaks-1] + 2 &&
+ !(flags & TB_EXTRAIND2)) {
+ breakindent[numbreaks-1] -= count - breakcount[numbreaks-1];
+ pos2 = pos;
+ while (pos2 < outbufpos && outbuf[pos2] <= ' ') {
+ if (outbuf[pos2] == ' ')
+ breakindent[numbreaks-1]--;
+ pos2++;
+ }
+ }
+ break;
+
+ case '"':
+ case '\'':
+ closing = ch;
+ while (pos < outbufpos && outbuf[pos] != closing) {
+ if (outbuf[pos] == '\\')
+ pos++, count++;
+ pos++;
+ count++;
+ }
+ if (pos >= outbufpos) {
+ intwarning("output", "Mismatched quotes [248]");
+ continue;
+ }
+ pos++;
+ count++;
+ break;
+
+ case '/':
+ if (pos < outbufpos && (outbuf[pos] == '*' ||
+ (outbuf[pos] == '/' && cplus > 0))) {
+ count += measurechars(pos, outbufpos-1);
+ pos = outbufpos; /* assume comment is at end of line */
+ }
+ break;
+
+ }
+ }
+ numalts++;
+ badness += extra;
+ if (testinglinebreaker > 1) {
+ if (badness >= bestbadness &&
+ (badness < showbadlimit || showbadlimit == 0)) {
+ fprintf(outf, "\n#if 0 /* rejected #%ld, badness = %g >= %g */\n", numalts, badness, bestbadness);
+ flush_outbuf(numbreaks, breakpos, breakindent,
+ numedits, editpos, editold, editnew);
+ fprintf(outf, "#endif\n");
+ return TBR_SIMPLE & jmask;
+ } else if ((bestbadness < showbadlimit || showbadlimit == 0) &&
+ bestnumalts > 0) {
+ fprintf(outf, "\n#if 0 /* rejected #%ld, badness = %g > %g */\n", bestnumalts, bestbadness, badness);
+ flush_outbuf(bestnumbreaks, bestbreakpos, bestbreakindent,
+ bestnumedits, besteditpos,
+ besteditold, besteditnew);
+ fprintf(outf, "#endif\n");
+ }
+ }
+ bestbadness = badness;
+ bestnumbreaks = numbreaks;
+ bestnumalts = numalts;
+ for (i = 0; i < numbreaks; i++) {
+ bestbreakpos[i] = breakpos[i];
+ bestbreakindent[i] = breakindent[i];
+ }
+ bestnumedits = numedits;
+ for (i = 0; i < numedits; i++) {
+ besteditpos[i] = editpos[i];
+ besteditold[i] = editold[i];
+ besteditnew[i] = editnew[i];
+ }
+ return TBR_SIMPLE & jmask;
+}
+
+
+
+
+int parse_breakstr(cp)
+char *cp;
+{
+ short val = 0;
+
+ if (isdigit(*cp))
+ return atoi(cp);
+ while (*cp && !isspace(*cp) && *cp != '}') {
+ switch (toupper(*cp++)) {
+
+ case 'N':
+ case '=':
+ break;
+
+ case 'L':
+ val |= BRK_LEFT;
+ break;
+
+ case 'R':
+ val |= BRK_RIGHT;
+ break;
+
+ case 'H':
+ val |= BRK_HANG | BRK_LEFT;
+ break;
+
+ case '>':
+ if (val & BRK_LEFT)
+ val |= BRK_LPREF;
+ else if (val & BRK_RIGHT)
+ val |= BRK_RPREF;
+ else
+ return -1;
+ break;
+
+ case '<':
+ if (val & BRK_LEFT)
+ val |= BRK_RPREF;
+ else if (val & BRK_RIGHT)
+ val |= BRK_LPREF;
+ else
+ return -1;
+ break;
+
+ case 'A':
+ val |= BRK_ALLNONE;
+ break;
+
+ default:
+ return -1;
+
+ }
+ }
+ return val;
+}
+
+
+
+
+long getcurtime()
+{
+#if USETIME
+ static unsigned long starttime = 0;
+ struct timeval t;
+ struct timezone tz;
+
+ gettimeofday(&t, &tz);
+ if (starttime == 0)
+ starttime = t.tv_sec;
+ t.tv_sec -= starttime;
+ return (t.tv_sec*1000 + t.tv_usec/1000);
+#else
+ static unsigned long starttime = 0;
+ if (!starttime) starttime = time(NULL);
+ return (time(NULL) - starttime) * 1000;
+#endif
+}
+
+
+
+void output(msg)
+register char *msg;
+{
+ unsigned char ch;
+ double savelimit;
+ int i, savemaxlw, maxdp;
+ long alts;
+ long time0, time0a, time1;
+
+ debughook();
+ if (outputmode) {
+ end_source();
+ while ((ch = *msg++) != 0) {
+ if (ch >= ' ') {
+ putc(ch, outf);
+ } else if (ch == '\n') {
+ putc('\n', outf);
+ outf_lnum++;
+ }
+ }
+ return;
+ }
+ while ((ch = *msg++) != 0) {
+ if (ch == '\n') {
+ if (outbufpos == 0) { /* blank line */
+ thisfutureindent = -1;
+ blanklines++;
+ continue;
+ }
+ if (sectionsize > blanklines)
+ blanklines = sectionsize;
+ sectionsize = 0;
+ if (eatblanks)
+ blanklines = 0;
+ while (blanklines > 0) {
+ blanklines--;
+ end_source();
+ putc('\n', outf);
+ outf_lnum++;
+ }
+ if (thisindent + outbufcount >= linewidth && !dontbreaklines) {
+ numbreaks = 1;
+ bestnumbreaks = 0;
+ bestbadness = BIGBADNESS;
+ breakpos[0] = 0;
+ breakindent[0] = thisindent;
+ breakcount[0] = 0;
+ breakerrorflag = 1;
+ numedits = 0;
+ bestnumedits = 0;
+ savelimit = showbadlimit;
+ numalts = 0;
+ bestnumalts = 0;
+ savemaxlw = maxlinewidth;
+ time0 = time0a = getcurtime();
+ if (regression)
+ srand(17);
+ if (thisindent + outbufcount > linewidth*3/2) {
+ i = 0;
+ maxdepth = 0;
+ readparens(&i, 0);
+ maxdp = maxdepth;
+ for (;;) { /* try some simple fixed methods first... */
+ for (i = 1; i <= 20; i++) {
+ randombreaks = -1;
+ trybreakline(0, 0, thisindent, 0.0, 0, NULL);
+ }
+ randombreaks = -2;
+ trybreakline(0, 0, thisindent, 0.0, 0, NULL);
+ for (i = 0; i <= maxdp+1; i++) {
+ randombreaks = i+1;
+ trybreakline(0, 0, thisindent, 0.0, 0, NULL);
+ }
+ if (bestbadness == BIGBADNESS && maxlinewidth < 9999) {
+ maxlinewidth = 9999; /* no choice but to relax */
+ numalts = 0;
+ } else
+ break;
+ }
+ time0a = getcurtime();
+ }
+ randombreaks = 0;
+ trybreakline(0, 0, thisindent, 0.0, 0, NULL);
+ if (bestbadness == BIGBADNESS && maxlinewidth < 9999) {
+ numalts = 0;
+ maxlinewidth = 9999; /* no choice but to relax this */
+ trybreakline(0, 0, thisindent, 0.0, 0, NULL);
+ }
+ time1 = getcurtime() - time0;
+ alts = numalts;
+ if (testinglinebreaker) {
+ if (savelimit < 0 && testinglinebreaker > 1) {
+ showbadlimit = bestbadness * (-savelimit);
+ numalts = 0;
+ bestnumalts = 0;
+ trybreakline(0, 0, thisindent, 0.0, 0, NULL);
+ }
+ fprintf(outf, "\n#if 1 /* accepted #%ld, badness = %g, tried %ld in %.3f sec */\n", bestnumalts, bestbadness, alts, time1/1000.0);
+ }
+ showbadlimit = savelimit;
+ maxlinewidth = savemaxlw;
+ flush_outbuf(bestnumbreaks, bestbreakpos, bestbreakindent,
+ bestnumedits, besteditpos,
+ besteditold, besteditnew);
+ if (((USETIME && time1 > 1000) || alts >= maxalts) &&
+ !regression) {
+ sprintf(outbuf, "Line breaker spent %.1f",
+ (time1 + time0 - time0a) / 1000.0);
+ if (time0 != time0a)
+ sprintf(outbuf + strlen(outbuf),
+ "+%.2f", (time0a - time0) / 1000.0);
+ sprintf(outbuf + strlen(outbuf),
+ " seconds, %ld tries on line %d [251]", alts, outf_lnum);
+ note(outbuf);
+ } else if (verbose) {
+ fprintf(logf, "%s, %d/%d: Line breaker spent %ld tries\n",
+ infname, inf_lnum, outf_lnum, alts);
+ }
+ if (testinglinebreaker)
+ fprintf(outf, "#endif\n\n");
+ } else {
+ if (testinglinebreaker < 2)
+ flush_outbuf(0, NULL, NULL, 0, NULL, NULL, NULL);
+ }
+ thisfutureindent = -1;
+ outbufpos = 0;
+ outbufcount = 0;
+ } else {
+ if (outbufpos == 0) {
+ if (ch == ' ' && !dontbreaklines) /* eat leading spaces */
+ continue;
+ thisindent = applydelta(outindent, deltaindent);
+ deltaindent = 0;
+ }
+ if (outbufpos == outbufsize) {
+ outbufsize *= 2;
+ outbuf = REALLOC(outbuf, outbufsize, char);
+ }
+ outbuf[outbufpos++] = ch;
+ if (ch >= ' ')
+ outbufcount++;
+ }
+ }
+}
+
+
+
+void out_n_spaces(n)
+int n;
+{
+ while (--n >= 0)
+ output(" ");
+}
+
+
+
+void out_spaces(spc, over, len, delta)
+int spc, over, len, delta;
+{
+ int n;
+
+ if (spc == -999)
+ spc = commentindent;
+ if (spc < 0) { /* right-justify */
+ n = (-spc) - cur_column() - len;
+ if (n < minspcthresh)
+ n = minspacing;
+ else
+ over = 1000;
+ } else if (spc >= 2000) { /* tab to multiple */
+ spc -= 2000;
+ n = (spc-1) - ((cur_column()+spc-1) % spc);
+ if (n < minspcthresh)
+ n += spc;
+ } else if (spc >= 1000) { /* absolute column */
+ spc -= 1000;
+ n = spc - cur_column();
+ if (n < minspcthresh)
+ n = minspacing;
+ } else /* relative spacing */
+ n = spc;
+ if (line_start()) {
+ singleindent(n);
+ } else if (len > 0 && over != 1000 && cur_column() + n + len > linewidth) {
+ output("\n");
+ out_spaces(over, 1000, len, 0);
+ singleindent(delta);
+ } else {
+ out_n_spaces(n);
+ }
+}
+
+
+
+
+void testlinebreaker(lev, fn)
+int lev;
+char *fn;
+{
+ char buf[256], *bp, *cp;
+ int first, indent;
+
+ testinglinebreaker = lev;
+ if (!fn)
+ return;
+ inf = fopen(fn, "r");
+ if (!inf) {
+ perror(fn);
+ exit(1);
+ }
+ sprintf(buf, "%s.br", fn);
+ outf = fopen(buf, "w");
+ if (!outf) {
+ perror(buf);
+ exit(1);
+ }
+ setup_out();
+ outindent = 4;
+ first = 1;
+ while (fgets(buf, 256, inf)) {
+ cp = buf + strlen(buf) - 2;
+ if (cp >= buf) {
+ bp = buf;
+ indent = 0;
+ while (isspace(*bp))
+ if (*bp++ == '\t')
+ indent += 8;
+ else
+ indent++;
+ if (first) {
+ first = 0;
+ outindent = indent;
+ }
+ if (!(*cp == '{' ||
+ *cp == ')' ||
+ *cp == ';') ||
+ (*cp == '/' && cp[-1] == '*')) {
+ cp[1] = '\001'; /* eat the \n */
+ } else {
+ first = 1;
+ }
+ output(bp);
+ }
+ }
+ fclose(outf);
+ fclose(inf);
+}
+
+
+
+
+
+void outsection(size)
+int size;
+{
+ if (size > sectionsize)
+ sectionsize = size;
+}
+
+
+
+int isembedcomment(cmt)
+Strlist *cmt;
+{
+ int len = strlen(embedcomment);
+ return (cmt && len > 0 && !strncmp(cmt->s, embedcomment, len) &&
+ (isspace(cmt->s[len]) ||
+ (!cmt->s[len] && cmt->next &&
+ (*cmt->next->s == '\002' || *cmt->next->s == '\003'))));
+}
+
+
+Strlist *outcomments(cmt)
+Strlist *cmt;
+{
+ char *cp;
+ int saveindent = outindent, savesingle = deltaindent, theindent;
+ int saveeat = eatcomments;
+ int i = 0;
+
+ if (!cmt)
+ return NULL;
+ if (!commentvisible(cmt)) {
+ setcommentkind(cmt, CMT_DONE);
+ return cmt->next;
+ }
+ if (*cmt->s == '\001') {
+ if (cmtdebug)
+ output(format_sd("[] [%s:%d]",
+ CMT_NAMES[getcommentkind(cmt)],
+ cmt->value & CMT_MASK));
+ for (cp = cmt->s; *cp; cp++) {
+ output("\n");
+ if (cmtdebug && cp[1])
+ output("[]");
+ }
+ setcommentkind(cmt, CMT_DONE);
+ return cmt->next;
+ }
+ dontbreaklines++;
+ if (isembedcomment(cmt)) {
+ embeddedcode = 1;
+ eatcomments = 0;
+ if (!strcmp(cmt->s, embedcomment)) {
+ cmt = cmt->next;
+ theindent = 0;
+ cp = cmt/*->next*/->s + 1;
+ while (*cp++ == ' ')
+ theindent++;
+ } else {
+ strcpy(cmt->s, cmt->s + strlen(embedcomment) + 1);
+ moreindent(deltaindent);
+ theindent = outindent;
+ deltaindent = 0;
+ }
+ } else {
+ moreindent(deltaindent);
+ if (cmt->s[0] == '\004')
+ outindent = 0;
+ theindent = outindent;
+ deltaindent = 0;
+ output("/*");
+ }
+ cp = cmt->s;
+ for (;;) {
+ if (*cp == '\002')
+ cp++;
+ else if (*cp == '\003' || *cp == '\004') {
+ outindent = 0;
+ cp++;
+ }
+ if (embeddedcode) {
+ for (i = 0; *cp == ' ' && i < theindent; i++)
+ cp++;
+ i = *cp;
+ if (*cp == '#')
+ outindent = 0;
+ }
+ output(cp);
+ if (cmtdebug)
+ output(format_sd(" [%s:%d] ",
+ CMT_NAMES[getcommentkind(cmt)],
+ cmt->value & CMT_MASK));
+ setcommentkind(cmt, CMT_DONE);
+ cmt = cmt->next;
+ if (!cmt || !commentvisible(cmt))
+ break;
+ cp = cmt->s;
+ if (*cp != '\002' && *cp != '\003')
+ break;
+ output("\n");
+ if (!embeddedcode) {
+ outindent = (*cp == '\002') ? theindent : 0;
+ deltaindent = 0;
+ }
+ }
+ if (embeddedcode) {
+ embeddedcode = 0;
+ if (i) { /* eat final blank line */
+ output("\n");
+ }
+ } else {
+ output("*/\n");
+ }
+ outindent = saveindent;
+ deltaindent = savesingle;
+ dontbreaklines--;
+ eatcomments = saveeat;
+ return cmt;
+}
+
+
+
+void outcomment(cmt)
+Strlist *cmt;
+{
+ Strlist *savenext;
+
+ if (cmt) {
+ savenext = cmt->next;
+ cmt->next = NULL;
+ outcomments(cmt);
+ cmt->next = savenext;
+ }
+}
+
+
+
+void outtrailcomment(cmt, serial, indent)
+Strlist *cmt;
+int serial, indent;
+{
+ int savedelta = deltaindent;
+
+#if 0
+ suppressnewline = 1;
+ output("\n");
+ suppressnewline = 0;
+#endif
+ cmt = findcomment(cmt, CMT_TRAIL, serial);
+ if (commentvisible(cmt)) {
+ out_spaces(indent, commentoverindent, commentlen(cmt), 0);
+ outcomment(cmt);
+ deltaindent = savedelta;
+ } else
+ output("\n");
+}
+
+
+
+void flushcomments(cmt, kind, serial)
+Strlist **cmt;
+int kind, serial;
+{
+ Strlist *cmt2, *cmt3;
+ int saveindent, savesingle, saveeat;
+
+ if (!cmt)
+ cmt = &curcomments;
+ cmt2 = extractcomment(cmt, kind, serial);
+ saveindent = outindent;
+ savesingle = deltaindent;
+ moreindent(deltaindent);
+ deltaindent = 0;
+ saveeat = eatcomments;
+ if (eatcomments == 2)
+ eatcomments = 0;
+ cmt3 = cmt2;
+ while (cmt3)
+ cmt3 = outcomments(cmt3);
+ eatcomments = saveeat;
+ outindent = saveindent;
+ deltaindent = savesingle;
+ strlist_empty(&cmt2);
+}
+
+
+
+
+
+char *rawCstring(fmt, s, len, special)
+char *fmt;
+register char *s;
+int len, special;
+{
+ char buf[500];
+ register char *cp;
+ register unsigned char ch;
+
+ cp = buf;
+ while (--len >= 0) {
+ ch = *((unsigned char *) s);
+ s++;
+ if (ch == 0 && (len == 0 || !isdigit(*s))) {
+ *cp++ = '\\';
+ *cp++ = '0';
+ } else if (ch == '\n') {
+ *cp++ = '\\';
+ *cp++ = 'n';
+ } else if (ch == '\b') {
+ *cp++ = '\\';
+ *cp++ = 'b';
+ } else if (ch == '\t') {
+ *cp++ = '\\';
+ *cp++ = 't';
+ } else if (ch == '\f') {
+ *cp++ = '\\';
+ *cp++ = 'f';
+#if 0
+ } else if (ch == '\r') {
+ *cp++ = '\\';
+ *cp++ = 'r';
+#endif
+ } else if (ch < ' ' || ch >= 127) {
+ *cp++ = '\\';
+ *cp++ = '0' + (ch>>6);
+ *cp++ = '0' + ((ch>>3) & 7);
+ *cp++ = '0' + (ch & 7);
+ } else if (ch == special) {
+ switch (ch) {
+ case '%':
+ *cp++ = ch;
+ *cp++ = ch;
+ break;
+ }
+ } else {
+ if (ch == '"' || ch == '\\')
+ *cp++ = '\\';
+ *cp++ = ch;
+ }
+ }
+ *cp = 0;
+ return format_s(fmt, buf);
+}
+
+
+char *makeCstring(s, len)
+register char *s;
+int len;
+{
+ return rawCstring("\"%s\"", s, len, 0);
+}
+
+
+
+char *makeCchar(ich)
+int ich;
+{
+ char buf[500];
+ register char *cp;
+ register unsigned char ch = (ich & 0xff);
+
+ if (ich < 0 || ich > 255 || (ich == 0 && !nullcharconst))
+ return format_d("%d", ich);
+ cp = buf;
+ if (ch == 0) {
+ *cp++ = '\\';
+ *cp++ = '0';
+ } else if (ch == '\n') {
+ *cp++ = '\\';
+ *cp++ = 'n';
+ } else if (ch == '\b') {
+ *cp++ = '\\';
+ *cp++ = 'b';
+ } else if (ch == '\t') {
+ *cp++ = '\\';
+ *cp++ = 't';
+ } else if (ch == '\f') {
+ *cp++ = '\\';
+ *cp++ = 'f';
+#if 0
+ } else if (ch == '\r') {
+ *cp++ = '\\';
+ *cp++ = 'r';
+#endif
+ } else if (ch < ' ' || ch >= 127) {
+ *cp++ = '\\';
+ *cp++ = '0' + (ch>>6);
+ *cp++ = '0' + ((ch>>3) & 7);
+ *cp++ = '0' + (ch & 7);
+ } else {
+ if (ch == '\'' || ch == '\\')
+ *cp++ = '\\';
+ *cp++ = ch;
+ }
+ *cp = 0;
+ return format_s("'%s'", buf);
+}
+
+
+
+
+
+
+/* End. */
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/p2c.h b/MultiSource/Benchmarks/MallocBench/p2c/p2c.h
new file mode 100644
index 00000000..d39e619c
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/p2c.h
@@ -0,0 +1,511 @@
+#ifndef P2C_H
+#define P2C_H
+
+
+/* Header file for code generated by "p2c", the Pascal-to-C translator */
+
+/* "p2c" Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ * By Dave Gillespie, daveg@csvax.cs.caltech.edu. Version 1.20.
+ * This file may be copied, modified, etc. in any way. It is not restricted
+ * by the licence agreement accompanying p2c itself.
+ */
+
+
+#include <stdio.h>
+
+
+
+/* If the following heuristic fails, compile -DBSD=0 for non-BSD systems,
+ or -DBSD=1 for BSD systems. */
+
+#ifdef M_XENIX
+# define BSD 0
+#endif
+
+#ifdef vms
+# define BSD 0
+# ifndef __STDC__
+# define __STDC__ 1
+# endif
+#endif
+
+#ifdef __TURBOC__
+# define MSDOS 1
+#endif
+
+#ifdef MSDOS
+# define BSD 0
+#endif
+
+#ifdef FILE /* a #define in BSD, a typedef in SYSV (hp-ux, at least) */
+# ifndef BSD /* (a convenient, but horrible kludge!) */
+# define BSD 1
+# endif
+#endif
+
+#ifdef BSD
+# if !BSD
+# undef BSD
+# endif
+#endif
+
+
+#if (defined(__STDC__) && !defined(M_XENIX)) || defined(__TURBOC__)
+/*# include <stddef.h>*/
+# include <stdlib.h>
+# define HAS_STDLIB
+# if defined(vms) || defined(__TURBOC__)
+# define __ID__(a)a
+# endif
+#else
+# ifndef BSD
+# ifndef __TURBOC__
+# include <memory.h>
+# endif
+# endif
+# ifdef hpux
+# ifdef _INCLUDE__STDC__
+# include <stddef.h>
+# include <stdlib.h>
+# endif
+# endif
+# include <sys/types.h>
+# if !defined(MSDOS) || defined(__TURBOC__)
+# define __ID__(a)a
+# endif
+#endif
+
+#ifdef __ID__
+# define __CAT__(a,b)__ID__(a)b
+#else
+# define __CAT__(a,b)a##b
+#endif
+
+
+#ifdef BSD
+# include <strings.h>
+# define memcpy(a,b,n) (bcopy(b,a,n),a)
+# define memcmp(a,b,n) bcmp(a,b,n)
+# define strchr(s,c) index(s,c)
+# define strrchr(s,c) rindex(s,c)
+#else
+# include <string.h>
+#endif
+
+#include <ctype.h>
+#include <math.h>
+#include <setjmp.h>
+#include <assert.h>
+
+
+#ifndef NO_LACK
+#ifdef vms
+
+#define LACK_LABS
+#define LACK_MEMMOVE
+#define LACK_MEMCPY
+
+#else
+
+#define LACK_LABS /* Undefine these if your library has these */
+#define LACK_MEMMOVE
+
+#endif
+#endif
+
+
+typedef struct __p2c_jmp_buf {
+ struct __p2c_jmp_buf *next;
+ jmp_buf jbuf;
+} __p2c_jmp_buf;
+
+
+/* Warning: The following will not work if setjmp is used simultaneously.
+ This also violates the ANSI restriction about using vars after longjmp,
+ but a typical implementation of longjmp will get it right anyway. */
+
+#ifndef FAKE_TRY
+# define TRY(x) do { __p2c_jmp_buf __try_jb; \
+ __try_jb.next = __top_jb; \
+ if (!setjmp((__top_jb = &__try_jb)->jbuf)) {
+# define RECOVER(x) __top_jb = __try_jb.next; } else {
+# define RECOVER2(x,L) __top_jb = __try_jb.next; } else { \
+ if (0) { L: __top_jb = __try_jb.next; }
+# define ENDTRY(x) } } while (0)
+#else
+# define TRY(x) if (1) {
+# define RECOVER(x) } else do {
+# define RECOVER2(x,L) } else do { L: ;
+# define ENDTRY(x) } while (0)
+#endif
+
+
+
+#ifdef M_XENIX /* avoid compiler bug */
+# define SHORT_MAX (32767)
+# define SHORT_MIN (-32768)
+#endif
+
+
+/* The following definitions work only on twos-complement machines */
+#ifndef SHORT_MAX
+# define SHORT_MAX ((short)(((unsigned short) -1) >> 1))
+# define SHORT_MIN (~SHORT_MAX)
+#endif
+
+#ifndef INT_MAX
+# define INT_MAX ((int)(((unsigned int) -1) >> 1))
+# define INT_MIN (~INT_MAX)
+#endif
+
+#ifndef LONG_MAX
+# define LONG_MAX ((long)(((unsigned long) -1) >> 1))
+# define LONG_MIN (~LONG_MAX)
+#endif
+
+#ifndef SEEK_SET
+# define SEEK_SET 0
+# define SEEK_CUR 1
+# define SEEK_END 2
+#endif
+
+#ifndef EXIT_SUCCESS
+# ifdef vms
+# define EXIT_SUCCESS 1
+# define EXIT_FAILURE (02000000000L)
+# else
+# define EXIT_SUCCESS 0
+# define EXIT_FAILURE 1
+# endif
+#endif
+
+
+#define SETBITS 32
+
+
+#if defined(__STDC__) || defined(__TURBOC__)
+# if !defined(vms) && !defined(M_LINT)
+# define Signed signed
+# else
+# define Signed
+# endif
+# define Void void /* Void f() = procedure */
+# ifndef Const
+# define Const const
+# endif
+# ifndef Volatile
+# define Volatile volatile
+# endif
+# ifdef M_LINT
+# define PP(x) ()
+# define PV() ()
+typedef char *Anyptr;
+# else
+# define PP(x) x /* function prototype */
+# define PV() (void) /* null function prototype */
+typedef void *Anyptr;
+# endif
+#else
+# define Signed
+# define Void void
+# ifndef Const
+# define Const
+# endif
+# ifndef Volatile
+# define Volatile
+# endif
+# define PP(x) ()
+# define PV() ()
+typedef char *Anyptr;
+#endif
+
+#ifdef __GNUC__
+# define Inline inline
+#else
+# define Inline
+#endif
+
+#define Register register /* Register variables */
+#define Char char /* Characters (not bytes) */
+
+#ifndef Static
+# define Static static /* Private global funcs and vars */
+#endif
+
+#ifndef Local
+# define Local static /* Nested functions */
+#endif
+
+typedef Signed char schar;
+typedef unsigned char uchar;
+typedef unsigned char boolean;
+
+#ifndef true
+# define true 1
+# define false 0
+#endif
+
+#ifndef TRUE
+# define TRUE 1
+# define FALSE 0
+#endif
+
+
+typedef struct {
+ Anyptr proc, link;
+} _PROCEDURE;
+
+#ifndef _FNSIZE
+# define _FNSIZE 120
+#endif
+
+
+extern Void PASCAL_MAIN PP( (int, Char **) );
+extern Char **P_argv;
+extern int P_argc;
+extern short P_escapecode;
+extern int P_ioresult;
+extern __p2c_jmp_buf *__top_jb;
+
+
+#ifdef P2C_H_PROTO /* if you have Ansi C but non-prototyped header files */
+extern Char *strcat PP( (Char *, Const Char *) );
+extern Char *strchr PP( (Const Char *, int) );
+extern int strcmp PP( (Const Char *, Const Char *) );
+extern Char *strcpy PP( (Char *, Const Char *) );
+extern size_t strlen PP( (Const Char *) );
+extern Char *strncat PP( (Char *, Const Char *, size_t) );
+extern int strncmp PP( (Const Char *, Const Char *, size_t) );
+extern Char *strncpy PP( (Char *, Const Char *, size_t) );
+extern Char *strrchr PP( (Const Char *, int) );
+
+extern Anyptr memchr PP( (Const Anyptr, int, size_t) );
+extern Anyptr memmove PP( (Anyptr, Const Anyptr, size_t) );
+extern Anyptr memset PP( (Anyptr, int, size_t) );
+#ifndef memcpy
+extern Anyptr memcpy PP( (Anyptr, Const Anyptr, size_t) );
+extern int memcmp PP( (Const Anyptr, Const Anyptr, size_t) );
+#endif
+
+extern int atoi PP( (Const Char *) );
+extern double atof PP( (Const Char *) );
+extern long atol PP( (Const Char *) );
+extern double strtod PP( (Const Char *, Char **) );
+extern long strtol PP( (Const Char *, Char **, int) );
+#endif /*P2C_H_PROTO*/
+
+#ifndef HAS_STDLIB
+extern Anyptr malloc PP( (size_t) );
+extern Void free PP( (Anyptr) );
+#endif
+
+extern int _OutMem PV();
+extern int _CaseCheck PV();
+extern int _NilCheck PV();
+extern int _Escape PP( (int) );
+extern int _EscIO PP( (int) );
+
+extern long ipow PP( (long, long) );
+extern Char *strsub PP( (Char *, Char *, int, int) );
+extern Char *strltrim PP( (Char *) );
+extern Char *strrtrim PP( (Char *) );
+extern Char *strrpt PP( (Char *, Char *, int) );
+extern Char *strpad PP( (Char *, Char *, int, int) );
+extern int strpos2 PP( (Char *, Char *, int) );
+extern long memavail PV();
+extern int P_peek PP( (FILE *) );
+extern int P_eof PP( (FILE *) );
+extern int P_eoln PP( (FILE *) );
+extern Void P_readpaoc PP( (FILE *, Char *, int) );
+extern Void P_readlnpaoc PP( (FILE *, Char *, int) );
+extern long P_maxpos PP( (FILE *) );
+extern Char *P_trimname PP( (Char *, int) );
+extern long *P_setunion PP( (long *, long *, long *) );
+extern long *P_setint PP( (long *, long *, long *) );
+extern long *P_setdiff PP( (long *, long *, long *) );
+extern long *P_setxor PP( (long *, long *, long *) );
+extern int P_inset PP( (unsigned, long *) );
+extern int P_setequal PP( (long *, long *) );
+extern int P_subset PP( (long *, long *) );
+extern long *P_addset PP( (long *, unsigned) );
+extern long *P_addsetr PP( (long *, unsigned, unsigned) );
+extern long *P_remset PP( (long *, unsigned) );
+extern long *P_setcpy PP( (long *, long *) );
+extern long *P_expset PP( (long *, long) );
+extern long P_packset PP( (long *) );
+extern int P_getcmdline PP( (int, int, Char *) );
+extern Void TimeStamp PP( (int *, int *, int *,
+ int *, int *, int *) );
+extern Void P_sun_argv PP( (char *, int, int) );
+
+
+/* I/O error handling */
+#define _CHKIO(cond,ior,val,def) ((cond) ? P_ioresult=0,(val) \
+ : P_ioresult=(ior),(def))
+#define _SETIO(cond,ior) (P_ioresult = (cond) ? 0 : (ior))
+
+/* Following defines are suitable for the HP Pascal operating system */
+#define FileNotFound 10
+#define FileNotOpen 13
+#define FileWriteError 38
+#define BadInputFormat 14
+#define EndOfFile 30
+
+#define FILENOTFOUND 10
+#define FILENOTOPEN 13
+#define FILEWRITEERROR 38
+#define BADINPUTFORMAT 14
+#define ENDOFFILE 30
+
+/* Creating temporary files */
+#if (defined(BSD) || defined(NO_TMPFILE)) && !defined(HAVE_TMPFILE)
+# define tmpfile() (fopen(tmpnam(NULL), "w+"))
+#endif
+
+/* File buffers */
+#define FILEBUF(f,sc,type) sc int __CAT__(f,_BFLAGS); \
+ sc type __CAT__(f,_BUFFER)
+#define FILEBUFNC(f,type) int __CAT__(f,_BFLAGS); \
+ type __CAT__(f,_BUFFER)
+
+#define RESETBUF(f,type) (__CAT__(f,_BFLAGS) = 1)
+#define SETUPBUF(f,type) (__CAT__(f,_BFLAGS) = 0)
+
+#define GETFBUF(f,type) (*((__CAT__(f,_BFLAGS) == 1 && \
+ ((__CAT__(f,_BFLAGS) = 2), \
+ fread(&__CAT__(f,_BUFFER), \
+ sizeof(type),1,(f)))),\
+ &__CAT__(f,_BUFFER)))
+#define AGETFBUF(f,type) ((__CAT__(f,_BFLAGS) == 1 && \
+ ((__CAT__(f,_BFLAGS) = 2), \
+ fread(__CAT__(f,_BUFFER), \
+ sizeof(type),1,(f)))),\
+ __CAT__(f,_BUFFER))
+
+#define PUTFBUF(f,type,v) (GETFBUF(f,type) = (v))
+#define CPUTFBUF(f,v) (PUTFBUF(f,char,v))
+#define APUTFBUF(f,type,v) (memcpy(AGETFBUF(f,type), (v), \
+ sizeof(__CAT__(f,_BUFFER))))
+
+#define GET(f,type) (__CAT__(f,_BFLAGS) == 1 ? \
+ fread(&__CAT__(f,_BUFFER),sizeof(type),1,(f)) : \
+ (__CAT__(f,_BFLAGS) = 1))
+
+#define PUT(f,type) (fwrite(&__CAT__(f,_BUFFER),sizeof(type),1,(f)), \
+ (__CAT__(f,_BFLAGS) = 0))
+#define CPUT(f) (PUT(f,char))
+
+#define BUFEOF(f) (__CAT__(f,_BFLAGS) != 2 && P_eof(f))
+#define BUFFPOS(f) (ftell(f) - (__CAT__(f,_BFLAGS) == 2))
+
+typedef struct {
+ FILE *f;
+ FILEBUFNC(f,Char);
+ Char name[_FNSIZE];
+} _TEXT;
+
+/* Memory allocation */
+#ifdef __GCC__
+# define Malloc(n) (malloc(n) ?: (Anyptr)_OutMem())
+#else
+extern Anyptr __MallocTemp__;
+# define Malloc(n) ((__MallocTemp__ = malloc(n)) ? __MallocTemp__ : (Anyptr)_OutMem())
+#endif
+#define FreeR(p) (free((Anyptr)(p))) /* used if arg is an rvalue */
+#define Free(p) (free((Anyptr)(p)), (p)=NULL)
+
+/* sign extension */
+#define SEXT(x,n) ((x) | -(((x) & (1L<<((n)-1))) << 1))
+
+/* packed arrays */ /* BEWARE: these are untested! */
+#define P_getbits_UB(a,i,n,L) ((int)((a)[(i)>>(L)-(n)] >> \
+ (((~(i))&((1<<(L)-(n))-1)) << (n)) & \
+ (1<<(1<<(n)))-1))
+
+#define P_getbits_SB(a,i,n,L) ((int)((a)[(i)>>(L)-(n)] << \
+ (16 - ((((~(i))&((1<<(L)-(n))-1))+1) <<\
+ (n)) >> (16-(1<<(n))))))
+
+#define P_putbits_UB(a,i,x,n,L) ((a)[(i)>>(L)-(n)] |= \
+ (x) << (((~(i))&((1<<(L)-(n))-1)) << (n)))
+
+#define P_putbits_SB(a,i,x,n,L) ((a)[(i)>>(L)-(n)] |= \
+ ((x) & (1<<(1<<(n)))-1) << \
+ (((~(i))&((1<<(L)-(n))-1)) << (n)))
+
+#define P_clrbits_B(a,i,n,L) ((a)[(i)>>(L)-(n)] &= \
+ ~( ((1<<(1<<(n)))-1) << \
+ (((~(i))&((1<<(L)-(n))-1)) << (n))) )
+
+/* small packed arrays */
+#define P_getbits_US(v,i,n) ((int)((v) >> ((i)<<(n)) & (1<<(1<<(n)))-1))
+#define P_getbits_SS(v,i,n) ((int)((long)(v) << (SETBITS - (((i)+1) << (n))) >> (SETBITS-(1<<(n)))))
+#define P_putbits_US(v,i,x,n) ((v) |= (x) << ((i) << (n)))
+#define P_putbits_SS(v,i,x,n) ((v) |= ((x) & (1<<(1<<(n)))-1) << ((i)<<(n)))
+#define P_clrbits_S(v,i,n) ((v) &= ~( ((1<<(1<<(n)))-1) << ((i)<<(n)) ))
+
+#define P_max(a,b) ((a) > (b) ? (a) : (b))
+#define P_min(a,b) ((a) < (b) ? (a) : (b))
+
+
+/* Fix ANSI-isms */
+
+#ifdef LACK_LABS
+# ifndef labs
+# define labs my_labs
+ extern long my_labs PP( (long) );
+# endif
+#endif
+
+#ifdef LACK_MEMMOVE
+# ifndef memmove
+# define memmove my_memmove
+ extern Anyptr my_memmove PP( (Anyptr, Const Anyptr, size_t) );
+# endif
+#endif
+
+#ifdef LACK_MEMCPY
+# ifndef memcpy
+# define memcpy my_memcpy
+ extern Anyptr my_memcpy PP( (Anyptr, Const Anyptr, size_t) );
+# endif
+# ifndef memcmp
+# define memcmp my_memcmp
+ extern int my_memcmp PP( (Const Anyptr, Const Anyptr, size_t) );
+# endif
+# ifndef memset
+# define memset my_memset
+ extern Anyptr my_memset PP( (Anyptr, int, size_t) );
+# endif
+#endif
+
+/* Fix toupper/tolower on Suns and other stupid BSD systems */
+#ifdef toupper
+# undef toupper
+# undef tolower
+# define toupper(c) my_toupper(c)
+# define tolower(c) my_tolower(c)
+#endif
+
+#ifndef _toupper
+# if 'A' == 65 && 'a' == 97
+# define _toupper(c) ((c)-'a'+'A')
+# define _tolower(c) ((c)-'A'+'a')
+# else
+# ifdef toupper
+# undef toupper /* hope these are shadowing real functions, */
+# undef tolower /* because my_toupper calls _toupper! */
+# endif
+# define _toupper(c) toupper(c)
+# define _tolower(c) tolower(c)
+# endif
+#endif
+
+
+#endif /* P2C_H */
+
+
+
+/* End. */
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/parse.c b/MultiSource/Benchmarks/MallocBench/p2c/parse.c
new file mode 100644
index 00000000..1d0be409
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/parse.c
@@ -0,0 +1,4380 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_PARSE_C
+#include "trans.h"
+
+
+
+Static short candeclare;
+Static int trycount;
+Static Strlist *includedfiles;
+Static char echo_first;
+Static int echo_pos;
+
+
+
+void setup_parse()
+{
+ candeclare = 0;
+ trycount = 0;
+ includedfiles = NULL;
+ echo_first = 1;
+ echo_pos = 0;
+ fixexpr_tryblock = 0;
+}
+
+
+
+void echobreak()
+{
+ if (echo_pos > 0) {
+ printf("\n");
+ echo_pos = 0;
+ echo_first = 0;
+ }
+}
+
+
+void echoword(name, comma)
+char *name;
+int comma;
+{
+ FILE *f = (outf == stdout) ? stderr : stdout;
+
+ if (quietmode || showprogress)
+ return;
+ if (!echo_first) {
+ if (comma) {
+ fprintf(f, ",");
+ echo_pos++;
+ }
+ if (echo_pos + strlen(name) > 77) {
+ fprintf(f, "\n");
+ echo_pos = 0;
+ } else {
+ fprintf(f, " ");
+ echo_pos++;
+ }
+ }
+ echo_first = 0;
+ fprintf(f, "%s", name);
+ echo_pos += strlen(name);
+ fflush(f);
+}
+
+
+
+void echoprocname(mp)
+Meaning *mp;
+{
+ echoword(mp->name, 1);
+}
+
+
+
+
+
+Static void forward_decl(func, isextern)
+Meaning *func;
+int isextern;
+{
+ if (func->wasdeclared)
+ return;
+ if (isextern && func->constdefn && !checkvarmac(func))
+ return;
+ if (isextern) {
+ output("extern ");
+ } else if (func->ctx->kind == MK_FUNCTION) {
+ if (useAnyptrMacros)
+ output("Local ");
+ else
+ output("static ");
+ } else if ((use_static != 0 && !useAnyptrMacros) ||
+ (findsymbol(func->name)->flags & NEEDSTATIC)) {
+ output("static ");
+ } else if (useAnyptrMacros) {
+ output("Static ");
+ }
+ if (func->type->basetype != tp_void || ansiC != 0) {
+ outbasetype(func->type, ODECL_FORWARD);
+ output(" ");
+ }
+ outdeclarator(func->type, func->name, ODECL_FORWARD);
+ output(";\n");
+ func->wasdeclared = 1;
+}
+
+
+
+
+/* Check if calling a parent procedure, whose body must */
+/* be declared forward */
+
+void need_forward_decl(func)
+Meaning *func;
+{
+ Meaning *mp;
+
+ if (func->wasdeclared)
+ return;
+ for (mp = curctx->ctx; mp; mp = mp->ctx) {
+ if (mp == func) {
+ if (func->ctx->kind == MK_FUNCTION)
+ func->isforward = 1;
+ else
+ forward_decl(func, 0);
+ return;
+ }
+ }
+}
+
+
+
+
+void free_stmt(sp)
+register Stmt *sp;
+{
+ if (sp) {
+ free_stmt(sp->stm1);
+ free_stmt(sp->stm2);
+ free_stmt(sp->next);
+ freeexpr(sp->exp1);
+ freeexpr(sp->exp2);
+ freeexpr(sp->exp3);
+ FREE(sp);
+ }
+}
+
+
+
+
+Stmt *makestmt(kind)
+enum stmtkind kind;
+{
+ Stmt *sp;
+
+ sp = ALLOC(1, Stmt, stmts);
+ sp->kind = kind;
+ sp->next = NULL;
+ sp->stm1 = NULL;
+ sp->stm2 = NULL;
+ sp->exp1 = NULL;
+ sp->exp2 = NULL;
+ sp->exp3 = NULL;
+ sp->serial = curserial = ++serialcount;
+ return sp;
+}
+
+
+
+Stmt *makestmt_call(call)
+Expr *call;
+{
+ Stmt *sp = makestmt(SK_ASSIGN);
+ sp->exp1 = call;
+ return sp;
+}
+
+
+
+Stmt *makestmt_assign(lhs, rhs)
+Expr *lhs, *rhs;
+{
+ Stmt *sp = makestmt(SK_ASSIGN);
+ sp->exp1 = makeexpr_assign(lhs, rhs);
+ return sp;
+}
+
+
+
+Stmt *makestmt_if(cond, thn, els)
+Expr *cond;
+Stmt *thn, *els;
+{
+ Stmt *sp = makestmt(SK_IF);
+ sp->exp1 = cond;
+ sp->stm1 = thn;
+ sp->stm2 = els;
+ return sp;
+}
+
+
+
+Stmt *makestmt_seq(s1, s2)
+Stmt *s1, *s2;
+{
+ Stmt *s1a;
+
+ if (!s1)
+ return s2;
+ if (!s2)
+ return s1;
+ for (s1a = s1; s1a->next; s1a = s1a->next) ;
+ s1a->next = s2;
+ return s1;
+}
+
+
+
+Stmt *copystmt(sp)
+Stmt *sp;
+{
+ Stmt *sp2;
+
+ if (sp) {
+ sp2 = makestmt(sp->kind);
+ sp2->stm1 = copystmt(sp->stm1);
+ sp2->stm2 = copystmt(sp->stm2);
+ sp2->exp1 = copyexpr(sp->exp1);
+ sp2->exp2 = copyexpr(sp->exp2);
+ sp2->exp3 = copyexpr(sp->exp3);
+ return sp2;
+ } else
+ return NULL;
+}
+
+
+
+void nukestmt(sp)
+Stmt *sp;
+{
+ if (sp) {
+ sp->kind = SK_ASSIGN;
+ sp->exp1 = makeexpr_long(0);
+ }
+}
+
+
+
+void splicestmt(sp, spnew)
+Stmt *sp, *spnew;
+{
+ Stmt *snext;
+
+ if (spnew) {
+ snext = sp->next;
+ *sp = *spnew;
+ while (sp->next)
+ sp = sp->next;
+ sp->next = snext;
+ } else
+ nukestmt(sp);
+}
+
+
+
+int stmtcount(sp)
+Stmt *sp;
+{
+ int i = 0;
+
+ while (sp) {
+ i += 1 + stmtcount(sp->stm1) + stmtcount(sp->stm2);
+ sp = sp->next;
+ }
+ return i;
+}
+
+
+
+
+
+Stmt *close_files_to_ctx(ctx)
+Meaning *ctx;
+{
+ Meaning *ctx2, *mp;
+ Stmt *splist = NULL, *sp;
+
+ ctx2 = curctx;
+ while (ctx2 && ctx2 != ctx && ctx2->kind == MK_FUNCTION) {
+ for (mp = ctx2->cbase; mp; mp = mp->cnext) {
+ if (mp->kind == MK_VAR &&
+ isfiletype(mp->type, -1) && !mp->istemporary) {
+ var_reference(mp);
+ sp = makestmt_if(makeexpr_rel(EK_NE,
+ filebasename(makeexpr_var(mp)),
+ makeexpr_nil()),
+ makestmt_call(
+ makeexpr_bicall_1("fclose", tp_void,
+ filebasename(makeexpr_var(mp)))),
+ NULL);
+ splist = makestmt_seq(splist, sp);
+ }
+ }
+ ctx2 = ctx2->ctx;
+ }
+ return splist;
+}
+
+
+
+
+int simplewith(ex)
+Expr *ex;
+{
+ switch (ex->kind) {
+ case EK_VAR:
+ case EK_CONST:
+ return 1;
+ case EK_DOT:
+ return simplewith(ex->args[0]);
+ default:
+ return 0;
+ }
+}
+
+
+int simplefor(sp, ex)
+Stmt *sp;
+Expr *ex;
+{
+ return (exprspeed(sp->exp2) <= 3 &&
+ !checkexprchanged(sp->stm1, sp->exp2) &&
+ !exproccurs(sp->exp2, ex));
+}
+
+
+
+int tryfuncmacro(exp, mp)
+Expr **exp;
+Meaning *mp;
+{
+ char *name;
+ Strlist *lp;
+ Expr *ex = *exp, *ex2;
+
+ ex2 = (mp) ? mp->constdefn : NULL;
+ if (!ex2) {
+ if (ex->kind == EK_BICALL || ex->kind == EK_NAME)
+ name = ex->val.s;
+ else if (ex->kind == EK_FUNCTION)
+ name = ((Meaning *)ex->val.i)->name;
+ else
+ return 0;
+ lp = strlist_cifind(funcmacros, name);
+ ex2 = (lp) ? (Expr *)lp->value : NULL;
+ }
+ if (ex2) {
+ *exp = replacemacargs(copyexpr(ex2), ex);
+ freeexpr(ex);
+ return 1;
+ }
+ return 0;
+}
+
+
+
+
+
+#define addstmt(kind) \
+ *spp = sp = makestmt(kind), \
+ spp = &(sp->next)
+
+#define newstmt(kind) \
+ addstmt(kind), \
+ steal_comments(firstserial, sp->serial, sflags & SF_FIRST), \
+ sflags &= ~SF_FIRST
+
+
+
+#define SF_FUNC 0x1
+#define SF_SAVESER 0x2
+#define SF_FIRST 0x4
+#define SF_IF 0x8
+
+Static Stmt *p_stmt(slist, sflags)
+Stmt *slist;
+int sflags;
+{
+ Stmt *sbase = NULL, **spp = &sbase, **spp2, **spp3, **savespp;
+ Stmt *defsp, **defsphook;
+ register Stmt *sp;
+ Stmt *sp2;
+ long li1, li2, firstserial = 0, saveserial = 0, saveserial2;
+ int i, forfixed, offset, line1, line2, toobig, isunsafe;
+ Token savetok;
+ char *name;
+ Expr *ep, *ep2, *ep3, *forstep, *range, *swexpr, *trueswexpr;
+ Type *tp;
+ Meaning *mp, *tvar, *tempmark;
+ Symbol *sym;
+ enum exprkind ekind;
+ Stmt *(*prochandler)();
+ Strlist *cmt;
+
+ tempmark = markstmttemps();
+again:
+ while (findlabelsym()) {
+ newstmt(SK_LABEL);
+ sp->exp1 = makeexpr_name(format_s(name_LABEL, curtokmeaning->name), tp_integer);
+ gettok();
+ wneedtok(TOK_COLON);
+ }
+ firstserial = curserial;
+ checkkeyword(TOK_TRY);
+ checkkeyword(TOK_INLINE);
+ checkkeyword(TOK_LOOP);
+ checkkeyword(TOK_RETURN);
+ if (modula2) {
+ if (sflags & SF_SAVESER)
+ goto stmtSeq;
+ }
+ switch (curtok) {
+
+ case TOK_BEGIN:
+ stmtSeq:
+ if (sflags & (SF_FUNC|SF_SAVESER)) {
+ saveserial = curserial;
+ cmt = grabcomment(CMT_ONBEGIN);
+ if (sflags & SF_FUNC)
+ cmt = fixbeginendcomment(cmt);
+ strlist_mix(&curcomments, cmt);
+ }
+ i = sflags & SF_FIRST;
+ do {
+ if (modula2) {
+ if (curtok == TOK_BEGIN || curtok == TOK_SEMI)
+ gettok();
+ checkkeyword(TOK_ELSIF);
+ if (curtok == TOK_ELSE || curtok == TOK_ELSIF)
+ break;
+ } else
+ gettok();
+ *spp = p_stmt(sbase, i);
+ i = 0;
+ while (*spp)
+ spp = &((*spp)->next);
+ } while (curtok == TOK_SEMI);
+ if (sflags & (SF_FUNC|SF_SAVESER)) {
+ cmt = grabcomment(CMT_ONEND);
+ changecomments(cmt, -1, -1, -1, saveserial);
+ if (sflags & SF_FUNC)
+ cmt = fixbeginendcomment(cmt);
+ strlist_mix(&curcomments, cmt);
+ if (sflags & SF_FUNC)
+ changecomments(curcomments, -1, saveserial, -1, 10000);
+ curserial = saveserial;
+ }
+ checkkeyword(TOK_ELSIF);
+ if (modula2 && (sflags & SF_IF)) {
+ break;
+ }
+ if (curtok == TOK_VBAR)
+ break;
+ if (!wneedtok(TOK_END))
+ skippasttoken(TOK_END);
+ break;
+
+ case TOK_CASE:
+ gettok();
+ swexpr = trueswexpr = p_ord_expr();
+ if (nosideeffects(swexpr, 1)) {
+ tvar = NULL;
+ } else {
+ tvar = makestmttempvar(swexpr->val.type, name_TEMP);
+ swexpr = makeexpr_var(tvar);
+ }
+ savespp = spp;
+ newstmt(SK_CASE);
+ saveserial2 = curserial;
+ sp->exp1 = trueswexpr;
+ spp2 = &sp->stm1;
+ tp = swexpr->val.type;
+ defsp = NULL;
+ defsphook = &defsp;
+ if (!wneedtok(TOK_OF)) {
+ skippasttoken(TOK_END);
+ break;
+ }
+ i = 1;
+ while (curtok == TOK_VBAR)
+ gettok();
+ checkkeyword(TOK_OTHERWISE);
+ while (curtok != TOK_END && curtok != TOK_OTHERWISE && curtok != TOK_ELSE) {
+ spp3 = spp2;
+ saveserial = curserial;
+ *spp2 = sp = makestmt(SK_CASELABEL);
+ steal_comments(saveserial, sp->serial, i);
+ spp2 = &sp->next;
+ range = NULL;
+ toobig = 0;
+ for (;;) {
+ ep = gentle_cast(p_expr(tp), tp);
+ if (curtok == TOK_DOTS) {
+ li1 = ord_value(eval_expr(ep));
+ gettok();
+ ep2 = gentle_cast(p_expr(tp), tp);
+ li2 = ord_value(eval_expr(ep2));
+ range = makeexpr_or(range,
+ makeexpr_range(copyexpr(swexpr),
+ ep, ep2, 1));
+ if (li2 - li1 >= caselimit)
+ toobig = 1;
+ if (!toobig) {
+ for (;;) {
+ sp->exp1 = makeexpr_val(make_ord(tp, li1));
+ if (li1 >= li2) break;
+ li1++;
+ serialcount--; /* make it reuse the count */
+ sp->stm1 = makestmt(SK_CASELABEL);
+ sp = sp->stm1;
+ }
+ }
+ } else {
+ sp->exp1 = copyexpr(ep);
+ range = makeexpr_or(range,
+ makeexpr_rel(EK_EQ,
+ copyexpr(swexpr),
+ ep));
+ }
+ if (curtok == TOK_COMMA) {
+ gettok();
+ serialcount--; /* make it reuse the count */
+ sp->stm1 = makestmt(SK_CASELABEL);
+ sp = sp->stm1;
+ } else
+ break;
+ }
+ wneedtok(TOK_COLON);
+ if (toobig) {
+ free_stmt(*spp3);
+ spp2 = spp3;
+ *defsphook = makestmt_if(range, p_stmt(NULL, SF_SAVESER),
+ NULL);
+ if (defsphook != &defsp && elseif != 0)
+ (*defsphook)->exp2 = makeexpr_long(1);
+ defsphook = &((*defsphook)->stm2);
+ } else {
+ freeexpr(range);
+ sp->stm1 = p_stmt(NULL, SF_SAVESER);
+ }
+ i = 0;
+ checkkeyword(TOK_OTHERWISE);
+ if (curtok != TOK_END && curtok != TOK_OTHERWISE && curtok != TOK_ELSE) {
+ if (curtok == TOK_VBAR) {
+ while (curtok == TOK_VBAR)
+ gettok();
+ } else
+ wneedtok(TOK_SEMI);
+ checkkeyword(TOK_OTHERWISE);
+ }
+ }
+ if (defsp) {
+ *spp2 = defsp;
+ spp2 = defsphook;
+ if (tvar) {
+ sp = makestmt_assign(makeexpr_var(tvar), trueswexpr);
+ sp->next = *savespp;
+ *savespp = sp;
+ sp->next->exp1 = swexpr;
+ }
+ } else {
+ if (tvar) {
+ canceltempvar(tvar);
+ freeexpr(swexpr);
+ }
+ }
+ if (curtok == TOK_OTHERWISE || curtok == TOK_ELSE) {
+ gettok();
+ while (curtok == TOK_SEMI)
+ gettok();
+/* changecomments(curcomments, CMT_TRAIL, curserial,
+ CMT_POST, -1); */
+ i = SF_FIRST;
+ while (curtok != TOK_END) {
+ *spp2 = p_stmt(NULL, i);
+ while (*spp2)
+ spp2 = &((*spp2)->next);
+ i = 0;
+ if (curtok != TOK_SEMI)
+ break;
+ gettok();
+ }
+ if (!wexpecttok(TOK_END))
+ skiptotoken(TOK_END);
+ } else if (casecheck == 1 || (casecheck == 2 && range_flag)) {
+ *spp2 = makestmt(SK_CASECHECK);
+ }
+ curserial = saveserial2;
+ strlist_mix(&curcomments, grabcomment(CMT_ONEND));
+ gettok();
+ break;
+
+ case TOK_FOR:
+ forfixed = fixedflag;
+ gettok();
+ newstmt(SK_FOR);
+ ep = p_expr(tp_integer);
+ if (!wneedtok(TOK_ASSIGN)) {
+ skippasttoken(TOK_DO);
+ break;
+ }
+ ep2 = makeexpr_charcast(p_expr(ep->val.type));
+ if (curtok != TOK_DOWNTO) {
+ if (!wexpecttok(TOK_TO)) {
+ skippasttoken(TOK_DO);
+ break;
+ }
+ }
+ savetok = curtok;
+ gettok();
+ sp->exp2 = makeexpr_charcast(p_expr(ep->val.type));
+ checkkeyword(TOK_BY);
+ if (curtok == TOK_BY) {
+ gettok();
+ forstep = p_expr(tp_integer);
+ i = possiblesigns(forstep);
+ if ((i & 5) == 5) {
+ if (expr_is_neg(forstep)) {
+ ekind = EK_GE;
+ note("Assuming FOR loop step is negative [252]");
+ } else {
+ ekind = EK_LE;
+ note("Assuming FOR loop step is positive [252]");
+ }
+ } else {
+ if (!(i & 1))
+ ekind = EK_LE;
+ else
+ ekind = EK_GE;
+ }
+ } else {
+ if (savetok == TOK_DOWNTO) {
+ ekind = EK_GE;
+ forstep = makeexpr_long(-1);
+ } else {
+ ekind = EK_LE;
+ forstep = makeexpr_long(1);
+ }
+ }
+ tvar = NULL;
+ swexpr = NULL;
+ if (ep->kind == EK_VAR) {
+ tp = findbasetype(ep->val.type, ODECL_NOPRES);
+ if ((tp == tp_char || tp == tp_schar || tp == tp_uchar ||
+ tp == tp_abyte || tp == tp_sbyte || tp == tp_ubyte ||
+ tp == tp_boolean) &&
+ ((checkconst(sp->exp2, 0) &&
+ tp != tp_sbyte && tp != tp_schar) ||
+ checkconst(sp->exp2, -128) ||
+ (checkconst(sp->exp2, 127) &&
+ tp != tp_ubyte && tp != tp_uchar) ||
+ checkconst(sp->exp2, 255) ||
+ (tp == tp_char &&
+ (useAnyptrMacros == 1 || unsignedchar != 1) &&
+ isliteralconst(sp->exp2, NULL) == 2 &&
+ sp->exp2->val.i >= 128))) {
+ swexpr = ep;
+ tvar = makestmttempvar(tp_sshort, name_TEMP);
+ ep = makeexpr_var(tvar);
+ } else if (((tp == tp_sshort &&
+ (checkconst(sp->exp2, -32768) ||
+ checkconst(sp->exp2, 32767))) ||
+ (tp == tp_ushort &&
+ (checkconst(sp->exp2, 0) ||
+ checkconst(sp->exp2, 65535))))) {
+ swexpr = ep;
+ tvar = makestmttempvar(tp_integer, name_TEMP);
+ ep = makeexpr_var(tvar);
+ } else if (tp == tp_integer &&
+ (checkconst(sp->exp2, LONG_MAX) ||
+ (sp->exp2->kind == EK_VAR &&
+ sp->exp2->val.i == (long)mp_maxint))) {
+ swexpr = ep;
+ tvar = makestmttempvar(tp_unsigned, name_TEMP);
+ ep = makeexpr_var(tvar);
+ }
+ }
+ sp->exp3 = makeexpr_assign(copyexpr(ep),
+ makeexpr_inc(copyexpr(ep),
+ copyexpr(forstep)));
+ wneedtok(TOK_DO);
+ forfixed = (fixedflag != forfixed);
+ mp = makestmttempvar(ep->val.type, name_FOR);
+ sp->stm1 = p_stmt(NULL, SF_SAVESER);
+ if (tvar) {
+ if (checkexprchanged(sp->stm1, swexpr))
+ note(format_s("Rewritten FOR loop won't work if it meddles with %s [253]",
+ ((Meaning *)swexpr->val.i)->name));
+ sp->stm1 = makestmt_seq(makestmt_assign(swexpr, makeexpr_var(tvar)),
+ sp->stm1);
+ } else if (offsetforloops && ep->kind == EK_VAR) {
+ offset = checkvaroffset(sp->stm1, (Meaning *)ep->val.i);
+ if (offset != 0) {
+ ep3 = makeexpr_inc(copyexpr(ep), makeexpr_long(-offset));
+ replaceexpr(sp->stm1, ep, ep3);
+ freeexpr(ep3);
+ ep2 = makeexpr_plus(ep2, makeexpr_long(offset));
+ sp->exp2 = makeexpr_inc(sp->exp2, makeexpr_long(offset));
+ }
+ }
+ if (!exprsame(ep, ep2, 1))
+ sp->exp1 = makeexpr_assign(copyexpr(ep), copyexpr(ep2));
+ isunsafe = ((!nodependencies(ep2, 2) &&
+ !nosideeffects(sp->exp2, 1)) ||
+ (!nodependencies(sp->exp2, 2) &&
+ !nosideeffects(ep2, 1)));
+ if (forfixed || (simplefor(sp, ep) && !isunsafe)) {
+ canceltempvar(mp);
+ sp->exp2 = makeexpr_rel(ekind, ep, sp->exp2);
+ } else {
+ ep3 = makeexpr_neg(copyexpr(forstep));
+ if ((checkconst(forstep, 1) || checkconst(forstep, -1)) &&
+ sp->exp2->kind == EK_PLUS &&
+ exprsame(sp->exp2->args[sp->exp2->nargs-1], ep3, 2)) {
+ sp->exp2 = makeexpr_inc(sp->exp2, forstep);
+ } else {
+ freeexpr(forstep);
+ freeexpr(ep3);
+ ep3 = makeexpr_long(0);
+ }
+ if (forevalorder && isunsafe) {
+ if (exprdepends(sp->exp2, ep)) {
+ tvar = makestmttempvar(mp->type, name_TEMP);
+ sp->exp1 = makeexpr_comma(
+ makeexpr_comma(
+ makeexpr_assign(makeexpr_var(tvar),
+ copyexpr(ep2)),
+ makeexpr_assign(makeexpr_var(mp),
+ sp->exp2)),
+ makeexpr_assign(copyexpr(ep),
+ makeexpr_var(tvar)));
+ } else
+ sp->exp1 = makeexpr_comma(
+ sp->exp1,
+ makeexpr_assign(makeexpr_var(mp),
+ sp->exp2));
+ } else {
+ if (isunsafe)
+ note("Evaluating FOR loop limit before initial value [315]");
+ sp->exp1 = makeexpr_comma(
+ makeexpr_assign(makeexpr_var(mp),
+ sp->exp2),
+ sp->exp1);
+ }
+ sp->exp2 = makeexpr_inc(makeexpr_var(mp), ep3);
+ sp->exp2 = makeexpr_rel(ekind, ep, sp->exp2);
+ }
+ freeexpr(ep2);
+ break;
+
+ case TOK_GOTO:
+ gettok();
+ if (findlabelsym()) {
+ if (curtokmeaning->ctx != curctx) {
+ curtokmeaning->val.i = 1;
+ *spp = close_files_to_ctx(curtokmeaning->ctx);
+ while (*spp)
+ spp = &((*spp)->next);
+ newstmt(SK_ASSIGN);
+ var_reference(curtokmeaning->xnext);
+ if (curtokmeaning->ctx->kind == MK_MODULE &&
+ !curtokmeaning->xnext->wasdeclared) {
+ outsection(minorspace);
+ declarevar(curtokmeaning->xnext, 0x7);
+ curtokmeaning->xnext->wasdeclared = 1;
+ outsection(minorspace);
+ }
+ sp->exp1 = makeexpr_bicall_2("longjmp", tp_void,
+ makeexpr_var(curtokmeaning->xnext),
+ makeexpr_long(1));
+ } else {
+ newstmt(SK_GOTO);
+ sp->exp1 = makeexpr_name(format_s(name_LABEL,
+ curtokmeaning->name),
+ tp_integer);
+ }
+ } else {
+ warning("Expected a label [263]");
+ }
+ gettok();
+ break;
+
+ case TOK_IF:
+ gettok();
+ newstmt(SK_IF);
+ saveserial = curserial;
+ curserial = ++serialcount;
+ sp->exp1 = p_expr(tp_boolean);
+ wneedtok(TOK_THEN);
+ sp->stm1 = p_stmt(NULL, SF_SAVESER|SF_IF);
+ changecomments(curcomments, -1, saveserial+1, -1, saveserial);
+ checkkeyword(TOK_ELSIF);
+ while (curtok == TOK_ELSIF) {
+ gettok();
+ sp->stm2 = makestmt(SK_IF);
+ sp = sp->stm2;
+ sp->exp1 = p_expr(tp_boolean);
+ wneedtok(TOK_THEN);
+ sp->stm1 = p_stmt(NULL, SF_SAVESER|SF_IF);
+ sp->exp2 = makeexpr_long(1);
+ }
+ if (curtok == TOK_ELSE) {
+ line1 = inf_lnum;
+ strlist_mix(&curcomments, grabcomment(CMT_ONELSE));
+ gettok();
+ line2 = (curtok == TOK_IF) ? inf_lnum : -1;
+ saveserial2 = curserial;
+ sp->stm2 = p_stmt(NULL, SF_SAVESER|SF_IF);
+ changecomments(curcomments, -1, saveserial2, -1, saveserial+1);
+ if (sp->stm2 && sp->stm2->kind == SK_IF &&
+ !sp->stm2->next && !modula2) {
+ sp->stm2->exp2 = makeexpr_long(elseif > 0 ||
+ (elseif < 0 && line1 == line2));
+ }
+ }
+ if (modula2)
+ wneedtok(TOK_END);
+ curserial = saveserial;
+ break;
+
+ case TOK_INLINE:
+ gettok();
+ note("Inline assembly language encountered [254]");
+ if (curtok != TOK_LPAR) { /* Macintosh style */
+ newstmt(SK_ASSIGN);
+ sp->exp1 = makeexpr_bicall_1("inline", tp_void,
+ p_expr(tp_integer));
+ break;
+ }
+ do {
+ name = getinlinepart();
+ if (!*name)
+ break;
+ newstmt(SK_ASSIGN);
+ sp->exp1 = makeexpr_bicall_1("asm", tp_void,
+ makeexpr_string(format_s(" inline %s", name)));
+ gettok();
+ } while (curtok == TOK_SLASH);
+ skipcloseparen();
+ break;
+
+ case TOK_LOOP:
+ gettok();
+ newstmt(SK_WHILE);
+ sp->exp1 = makeexpr_long(1);
+ sp->stm1 = p_stmt(NULL, SF_SAVESER);
+ break;
+
+ case TOK_REPEAT:
+ newstmt(SK_REPEAT);
+ saveserial = curserial;
+ spp2 = &(sp->stm1);
+ i = SF_FIRST;
+ do {
+ gettok();
+ *spp2 = p_stmt(sp->stm1, i);
+ i = 0;
+ while (*spp2)
+ spp2 = &((*spp2)->next);
+ } while (curtok == TOK_SEMI);
+ if (!wneedtok(TOK_UNTIL))
+ skippasttoken(TOK_UNTIL);
+ sp->exp1 = makeexpr_not(p_expr(tp_boolean));
+ curserial = saveserial;
+ strlist_mix(&curcomments, grabcomment(CMT_ONEND));
+ break;
+
+ case TOK_RETURN:
+ gettok();
+ newstmt(SK_RETURN);
+ if (curctx->isfunction) {
+ sp->exp1 = gentle_cast(p_expr(curctx->cbase->type),
+ curctx->cbase->type);
+ }
+ break;
+
+ case TOK_TRY:
+ findsymbol("RECOVER")->flags &= ~KWPOSS;
+ newstmt(SK_TRY);
+ sp->exp1 = makeexpr_long(++trycount);
+ spp2 = &(sp->stm1);
+ i = SF_FIRST;
+ do {
+ gettok();
+ *spp2 = p_stmt(sp->stm1, i);
+ i = 0;
+ while (*spp2)
+ spp2 = &((*spp2)->next);
+ } while (curtok == TOK_SEMI);
+ if (!wneedtok(TOK_RECOVER))
+ skippasttoken(TOK_RECOVER);
+ sp->stm2 = p_stmt(NULL, SF_SAVESER);
+ break;
+
+ case TOK_WHILE:
+ gettok();
+ newstmt(SK_WHILE);
+ sp->exp1 = p_expr(tp_boolean);
+ wneedtok(TOK_DO);
+ sp->stm1 = p_stmt(NULL, SF_SAVESER);
+ break;
+
+ case TOK_WITH:
+ gettok();
+ if (withlevel >= MAXWITHS-1)
+ error("Too many nested WITHs");
+ ep = p_expr(NULL);
+ if (ep->val.type->kind != TK_RECORD)
+ warning("Argument of WITH is not a RECORD [264]");
+ withlist[withlevel] = ep->val.type;
+ if (simplewith(ep)) {
+ withexprs[withlevel] = ep;
+ mp = NULL;
+ } else { /* need to save a temporary pointer */
+ tp = makepointertype(ep->val.type);
+ mp = makestmttempvar(tp, name_WITH);
+ withexprs[withlevel] = makeexpr_hat(makeexpr_var(mp), 0);
+ }
+ withlevel++;
+ if (curtok == TOK_COMMA) {
+ curtok = TOK_WITH;
+ sp2 = p_stmt(NULL, sflags & SF_FIRST);
+ } else {
+ wneedtok(TOK_DO);
+ sp2 = p_stmt(NULL, sflags & SF_FIRST);
+ }
+ withlevel--;
+ if (mp) { /* if "with p^" for constant p, don't need temp ptr */
+ if (ep->kind == EK_HAT && ep->args[0]->kind == EK_VAR &&
+ !checkvarchanged(sp2, (Meaning *)ep->args[0]->val.i)) {
+ replaceexpr(sp2, withexprs[withlevel]->args[0],
+ ep->args[0]);
+ freeexpr(ep);
+ canceltempvar(mp);
+ } else {
+ newstmt(SK_ASSIGN);
+ sp->exp1 = makeexpr_assign(makeexpr_var(mp),
+ makeexpr_addr(ep));
+ }
+ }
+ freeexpr(withexprs[withlevel]);
+ *spp = sp2;
+ while (*spp)
+ spp = &((*spp)->next);
+ break;
+
+ case TOK_INCLUDE:
+ badinclude();
+ goto again;
+
+ case TOK_ADDR: /* flakey Turbo "@procptr := anyptr" assignment */
+ newstmt(SK_ASSIGN);
+ ep = p_expr(tp_void);
+ if (wneedtok(TOK_ASSIGN))
+ sp->exp1 = makeexpr_assign(ep, p_expr(ep->val.type));
+ else
+ sp->exp1 = ep;
+ break;
+
+ case TOK_IDENT:
+ mp = curtokmeaning;
+ if (mp == mp_str_hp)
+ mp = curtokmeaning = mp_str_turbo;
+ if (mp == mp_val_modula)
+ mp = curtokmeaning = mp_val_turbo;
+ if (mp == mp_blockread_ucsd)
+ mp = curtokmeaning = mp_blockread_turbo;
+ if (mp == mp_blockwrite_ucsd)
+ mp = curtokmeaning = mp_blockwrite_turbo;
+ if (mp == mp_dec_dec)
+ mp = curtokmeaning = mp_dec_turbo;
+ if (!mp) {
+ sym = curtoksym; /* make a guess at what the undefined name is... */
+ name = stralloc(curtokcase);
+ gettok();
+ newstmt(SK_ASSIGN);
+ if (curtok == TOK_ASSIGN) {
+ gettok();
+ ep = p_expr(NULL);
+ mp = addmeaning(sym, MK_VAR);
+ mp->name = name;
+ mp->type = ep->val.type;
+ sp->exp1 = makeexpr_assign(makeexpr_var(mp), ep);
+ } else if (curtok == TOK_HAT || curtok == TOK_ADDR ||
+ curtok == TOK_LBR || curtok == TOK_DOT) {
+ ep = makeexpr_name(name, tp_integer);
+ ep = fake_dots_n_hats(ep);
+ if (wneedtok(TOK_ASSIGN))
+ sp->exp1 = makeexpr_assign(ep, p_expr(NULL));
+ else
+ sp->exp1 = ep;
+ } else if (curtok == TOK_LPAR) {
+ ep = makeexpr_bicall_0(name, tp_void);
+ do {
+ gettok();
+ insertarg(&ep, ep->nargs, p_expr(NULL));
+ } while (curtok == TOK_COMMA);
+ skipcloseparen();
+ sp->exp1 = ep;
+ } else {
+ sp->exp1 = makeexpr_bicall_0(name, tp_void);
+ }
+ if (!tryfuncmacro(&sp->exp1, NULL))
+ undefsym(sym);
+ } else if (mp->kind == MK_FUNCTION && !mp->isfunction) {
+ mp->refcount++;
+ gettok();
+ ep = p_funccall(mp);
+ if (!mp->constdefn)
+ need_forward_decl(mp);
+ if (mp->handler && !(mp->sym->flags & LEAVEALONE) &&
+ !mp->constdefn) {
+ prochandler = (Stmt *(*)())mp->handler;
+ *spp = (*prochandler)(ep, slist);
+ while (*spp)
+ spp = &((*spp)->next);
+ } else {
+ newstmt(SK_ASSIGN);
+ sp->exp1 = ep;
+ }
+ } else if (mp->kind == MK_SPECIAL) {
+ gettok();
+ if (mp->handler && !mp->isfunction) {
+ if ((mp->sym->flags & LEAVEALONE) || mp->constdefn) {
+ ep = makeexpr_bicall_0(mp->name, tp_void);
+ if (curtok == TOK_LPAR) {
+ do {
+ gettok();
+ insertarg(&ep, ep->nargs, p_expr(NULL));
+ } while (curtok == TOK_COMMA);
+ skipcloseparen();
+ }
+ newstmt(SK_ASSIGN);
+ tryfuncmacro(&ep, mp);
+ sp->exp1 = ep;
+ } else {
+ prochandler = (Stmt *(*)())mp->handler;
+ *spp = (*prochandler)(mp, slist);
+ while (*spp)
+ spp = &((*spp)->next);
+ }
+ } else
+ symclass(curtoksym);
+ } else {
+ newstmt(SK_ASSIGN);
+ if (curtokmeaning->kind == MK_FUNCTION &&
+ peeknextchar() != '(') {
+ mp = curctx;
+ while (mp && mp != curtokmeaning)
+ mp = mp->ctx;
+ if (mp)
+ curtokmeaning = curtokmeaning->cbase;
+ }
+ ep = p_expr(tp_void);
+#if 0
+ if (!(ep->kind == EK_SPCALL ||
+ (ep->kind == EK_COND &&
+ ep->args[1]->kind == EK_SPCALL)))
+ wexpecttok(TOK_ASSIGN);
+#endif
+ if (curtok == TOK_ASSIGN) {
+ gettok();
+ if (curtok == TOK_IDENT && !strcicmp(curtokbuf, "ZERO") &&
+ !curtokmeaning) { /* VAX Pascal foolishness */
+ gettok();
+ ep2 = makeexpr_sizeof(copyexpr(ep), 0);
+ sp->exp1 = makeexpr_bicall_3("memset", tp_void,
+ makeexpr_addr(ep),
+ makeexpr_long(0), ep2);
+ } else
+ sp->exp1 = makeexpr_assign(ep, p_expr(ep->val.type));
+ } else
+ sp->exp1 = ep;
+ }
+ break;
+
+ default:
+ break; /* null statement */
+ }
+ freestmttemps(tempmark);
+ if (sflags & SF_SAVESER)
+ curserial = firstserial;
+ return sbase;
+}
+
+
+
+
+
+
+
+#define BR_NEVER 0x1 /* never use braces */
+#define BR_FUNCTION 0x2 /* function body */
+#define BR_THENPART 0x4 /* before an "else" */
+#define BR_ALWAYS 0x8 /* always use braces */
+#define BR_REPEAT 0x10 /* "do-while" loop */
+#define BR_TRY 0x20 /* in a recover block */
+#define BR_ELSEPART 0x40 /* after an "else" */
+#define BR_CASE 0x80 /* case of a switch stmt */
+
+Static int usebraces(sp, opts)
+Stmt *sp;
+int opts;
+{
+ if (opts & (BR_FUNCTION|BR_ALWAYS))
+ return 1;
+ if (opts & BR_NEVER)
+ return 0;
+ switch (bracesalways) {
+ case 0:
+ if (sp) {
+ if (sp->next ||
+ sp->kind == SK_TRY ||
+ (sp->kind == SK_IF && !sp->stm2) ||
+ (opts & BR_REPEAT))
+ return 1;
+ }
+ break;
+
+ case 1:
+ return 1;
+
+ default:
+ if (sp) {
+ if (sp->next ||
+ sp->kind == SK_IF ||
+ sp->kind == SK_WHILE ||
+ sp->kind == SK_REPEAT ||
+ sp->kind == SK_TRY ||
+ sp->kind == SK_CASE ||
+ sp->kind == SK_FOR)
+ return 1;
+ }
+ break;
+ }
+ if (sp != NULL &&
+ findcomment(curcomments, CMT_NOT | CMT_TRAIL, sp->serial) != NULL)
+ return 1;
+ return 0;
+}
+
+
+
+#define outspnl(spflag) output((spflag) ? " " : "\n")
+
+#define openbrace() \
+ wbraces = (!candeclare); \
+ if (wbraces) { \
+ output("{"); \
+ outspnl(braceline <= 0); \
+ candeclare = 1; \
+ }
+
+#define closebrace() \
+ if (wbraces) { \
+ if (sp->next || braces) \
+ output("}\n"); \
+ else \
+ braces = 1; \
+ }
+
+
+
+Meaning *outcontext;
+
+Static void outnl(serial)
+int serial;
+{
+ outtrailcomment(curcomments, serial, commentindent);
+}
+
+
+Static void out_block(spbase, opts, serial)
+Stmt *spbase;
+int opts, serial;
+{
+ int i, j, braces, always, trynum, istrail, hascmt;
+ int gotcomments = 0;
+ int saveindent, saveindent2, delta;
+ Stmt *sp = spbase;
+ Stmt *sp2, *sp3;
+ Meaning *ctx, *mp;
+ Strlist *curcmt, *cmt, *savecurcmt = curcomments;
+ Strlist *trailcmt, *begincmt, *endcmt;
+
+ if (debug>1) { fprintf(outf, "out_block of:\n"); dumpstmt(spbase,5); }
+ if (opts & BR_FUNCTION) {
+ if (outcontext && outcontext->comments) {
+ gotcomments = 1;
+ curcomments = outcontext->comments;
+ }
+ attach_comments(spbase);
+ }
+ braces = usebraces(sp, opts);
+ trailcmt = findcomment(curcomments, CMT_TRAIL, serial);
+ begincmt = findcomment(curcomments, CMT_ONBEGIN, serial);
+ istrail = 1;
+ if (!trailcmt) {
+ trailcmt = begincmt;
+ begincmt = NULL;
+ istrail = 0;
+ }
+ endcmt = findcomment(curcomments, CMT_ONEND, serial);
+ if ((begincmt || endcmt) && !(opts & BR_NEVER))
+ braces = 1;
+ if (opts & BR_ELSEPART) {
+ cmt = findcomment(curcomments, CMT_ONELSE, serial);
+ if (cmt) {
+ if (trailcmt) {
+ out_spaces(bracecommentindent, commentoverindent,
+ commentlen(cmt), 0);
+ output("\001");
+ outcomment(cmt);
+ } else
+ trailcmt = cmt;
+ }
+ }
+ if (braces) {
+ j = (opts & BR_FUNCTION) ? funcopenindent : openbraceindent;
+ if (!line_start()) {
+ if (trailcmt &&
+ cur_column() + commentlen(trailcmt) + 2 > linewidth &&
+ outindent + commentlen(trailcmt) + 2 < linewidth) /*close enough*/
+ i = 0;
+ else if (opts & BR_ELSEPART)
+ i = ((braceelseline & 2) == 0);
+ else if (braceline >= 0)
+ i = (braceline == 0);
+ else
+ i = ((opts & BR_FUNCTION) == 0);
+ if (trailcmt && begincmt) {
+ out_spaces(commentindent, commentoverindent,
+ commentlen(trailcmt), j);
+ outcomment(trailcmt);
+ trailcmt = begincmt;
+ begincmt = NULL;
+ istrail = 0;
+ } else
+ outspnl(i);
+ }
+ if (line_start())
+ singleindent(j);
+ output("{");
+ candeclare = 1;
+ } else if (!sp) {
+ if (!line_start())
+ outspnl(!nullstmtline && !(opts & BR_TRY));
+ if (line_start())
+ singleindent(tabsize);
+ output(";");
+ }
+ if (opts & BR_CASE)
+ delta = 0;
+ else {
+ delta = tabsize;
+ if (opts & BR_FUNCTION)
+ delta = adddeltas(delta, bodyindent);
+ else if (braces)
+ delta = adddeltas(delta, blockindent);
+ }
+ futureindent(delta);
+ if (bracecombine && braces)
+ i = applydelta(outindent, delta) - cur_column();
+ else
+ i = -1;
+ if (commentvisible(trailcmt)) {
+ if (line_start()) {
+ singleindent(delta);
+ out_spaces(commentoverindent, 1000, commentlen(trailcmt), 0);
+ outcomment(trailcmt);
+ } else /*if (commentlen(trailcmt) + cur_column() + 1 <= linewidth)*/ {
+ out_spaces(istrail ? commentindent : bracecommentindent,
+ commentoverindent, commentlen(trailcmt), delta);
+ outcomment(trailcmt);
+ } /*else {
+ output("\n");
+ singleindent(delta);
+ out_spaces(commentoverindent, 1000, commentlen(trailcmt), 0);
+ outcomment(trailcmt);
+ }*/
+ i = -9999;
+ }
+ if (i > 0)
+ out_spaces(i, 0, 0, 0);
+ else if (i != -9999)
+ output("\n");
+ saveindent = outindent;
+ moreindent(delta);
+ outcomment(begincmt);
+ while (sp) {
+ flushcomments(NULL, CMT_PRE, sp->serial);
+ if (cmtdebug)
+ output(format_d("[%d] ", sp->serial));
+ switch (sp->kind) {
+
+ case SK_HEADER:
+ ctx = (Meaning *)sp->exp1->val.i;
+ eatblanklines();
+ if (declarevars(ctx, 0))
+ outsection(minorspace);
+ flushcomments(NULL, CMT_NOT | CMT_ONEND, serial);
+ if (ctx->kind == MK_MODULE) {
+ if (ctx->anyvarflag) {
+ output(format_s(name_MAIN, ""));
+ if (spacefuncs)
+ output(" ");
+ output("(argc,");
+ if (spacecommas)
+ output(" ");
+ output("argv);\n");
+ } else {
+ output("static int _was_initialized = 0;\n");
+ output("if (_was_initialized++)\n");
+ singleindent(tabsize);
+ output("return;\n");
+ }
+ while (initialcalls) {
+ output(initialcalls->s);
+ output(";\n");
+ strlist_remove(&initialcalls, initialcalls->s);
+ }
+ } else {
+ if (ctx->varstructflag && ctx->ctx->kind == MK_FUNCTION &&
+ ctx->ctx->varstructflag) {
+ output(format_s(name_VARS, ctx->name));
+ output(".");
+ output(format_s(name_LINK, ctx->ctx->name));
+ output(" = ");
+ output(format_s(name_LINK, ctx->ctx->name));
+ output(";\n");
+ }
+ for (mp = ctx->cbase; mp; mp = mp->cnext) {
+ if ((mp->kind == MK_VAR || /* these are variables with */
+ mp->kind == MK_VARREF) &&
+ ((mp->varstructflag && /* initializers which were moved */
+ mp->cnext && /* into a varstruct, so they */
+ mp->cnext->snext == mp && /* must be initialized now */
+ mp->cnext->constdefn &&
+ ctx->kind == MK_FUNCTION) ||
+ (mp->constdefn &&
+ mp->type->kind == TK_ARRAY &&
+ mp->constdefn->val.type->kind == TK_STRING &&
+ !initpacstrings))) {
+ if (mp->type->kind == TK_ARRAY) {
+ output("memcpy(");
+ out_var(mp, 2);
+ output(",\002");
+ if (spacecommas)
+ output(" ");
+ if (mp->constdefn) {
+ output(makeCstring(mp->constdefn->val.s,
+ mp->constdefn->val.i));
+ mp->constdefn = NULL;
+ } else
+ out_var(mp->cnext, 2);
+ output(",\002");
+ if (spacecommas)
+ output(" ");
+ output("sizeof(");
+ out_type(mp->type, 1);
+ output("))");
+ } else {
+ out_var(mp, 2);
+ output(" = ");
+ out_var(mp->cnext, 2);
+ }
+ output(";\n");
+ }
+ }
+ }
+ break;
+
+ case SK_RETURN:
+ output("return");
+ if (sp->exp1) {
+ switch (returnparens) {
+
+ case 0:
+ output(" ");
+ out_expr(sp->exp1);
+ break;
+
+ case 1:
+ if (spaceexprs != 0)
+ output(" ");
+ out_expr_parens(sp->exp1);
+ break;
+
+ default:
+ if (sp->exp1->kind == EK_VAR ||
+ sp->exp1->kind == EK_CONST ||
+ sp->exp1->kind == EK_LONGCONST ||
+ sp->exp1->kind == EK_BICALL) {
+ output(" ");
+ out_expr(sp->exp1);
+ } else {
+ if (spaceexprs != 0)
+ output(" ");
+ out_expr_parens(sp->exp1);
+ }
+ break;
+ }
+ }
+ output(";");
+ outnl(sp->serial);
+ break;
+
+ case SK_ASSIGN:
+ out_expr_stmt(sp->exp1);
+ output(";");
+ outnl(sp->serial);
+ break;
+
+ case SK_CASE:
+ output("switch (");
+ out_expr(sp->exp1);
+ output(")");
+ outspnl(braceline <= 0);
+ output("{");
+ outnl(sp->serial);
+ saveindent2 = outindent;
+ moreindent(tabsize);
+ moreindent(switchindent);
+ sp2 = sp->stm1;
+ while (sp2 && sp2->kind == SK_CASELABEL) {
+ outsection(casespacing);
+ sp3 = sp2;
+ i = 0;
+ hascmt = (findcomment(curcomments, -1, sp2->serial) != NULL);
+ singleindent(caseindent);
+ flushcomments(NULL, CMT_PRE, sp2->serial);
+ for (;;) {
+ if (i)
+ singleindent(caseindent);
+ i = 0;
+ output("case ");
+ out_expr(sp3->exp1);
+ output(":\001");
+ sp3 = sp3->stm1;
+ if (!sp3 || sp3->kind != SK_CASELABEL)
+ break;
+ if (casetabs != 1000)
+ out_spaces(casetabs, 0, 0, 0);
+ else {
+ output("\n");
+ i = 1;
+ }
+ }
+ if (sp3)
+ out_block(sp3, BR_NEVER|BR_CASE, sp2->serial);
+ else {
+ outnl(sp2->serial);
+ if (!hascmt)
+ output("/* blank case */\n");
+ }
+ output("break;\n");
+ flushcomments(NULL, -1, sp2->serial);
+ sp2 = sp2->next;
+ }
+ if (sp2) {
+ outsection(casespacing);
+ singleindent(caseindent);
+ flushcomments(NULL, CMT_PRE, sp2->serial);
+ output("default:");
+ out_block(sp2, BR_NEVER|BR_CASE, sp2->serial);
+ output("break;\n");
+ flushcomments(NULL, -1, sp2->serial);
+ }
+ outindent = saveindent2;
+ output("}");
+ curcmt = findcomment(curcomments, CMT_ONEND, sp->serial);
+ if (curcmt)
+ outcomment(curcmt);
+ else
+ output("\n");
+ break;
+
+ case SK_CASECHECK:
+ output(name_CASECHECK);
+ output("(); /* CASE value range error */\n");
+ break;
+
+ case SK_FOR:
+ output("for (");
+ if (for_allornone)
+ output("\007");
+ if (sp->exp1 || sp->exp2 || sp->exp3 || spaceexprs > 0) {
+ if (sp->exp1)
+ out_expr_top(sp->exp1);
+ else if (spaceexprs > 0)
+ output(" ");
+ output(";\002 ");
+ if (sp->exp2)
+ out_expr(sp->exp2);
+ output(";\002 ");
+ if (sp->exp3)
+ out_expr_top(sp->exp3);
+ } else {
+ output(";;");
+ }
+ output(")");
+ out_block(sp->stm1, 0, sp->serial);
+ break;
+
+ case SK_LABEL:
+ if (!line_start())
+ output("\n");
+ singleindent(labelindent);
+ out_expr(sp->exp1);
+ output(":");
+ if (!sp->next)
+ output(" ;");
+ outnl(sp->serial);
+ break;
+
+ case SK_GOTO:
+ /* what about non-local goto's? */
+ output("goto ");
+ out_expr(sp->exp1);
+ output(";");
+ outnl(sp->serial);
+ break;
+
+ case SK_IF:
+ sp2 = sp;
+ for (;;) {
+ output("if (");
+ out_expr_bool(sp2->exp1);
+ output(")");
+ if (sp2->stm2) {
+ cmt = findcomment(curcomments, CMT_ONELSE, sp->serial+1);
+ i = (!cmt && sp2->stm2->kind == SK_IF &&
+ !sp2->stm2->next &&
+ ((sp2->stm2->exp2)
+ ? checkconst(sp2->stm2->exp2, 1)
+ : (elseif > 0)));
+ if (braceelse &&
+ (usebraces(sp2->stm1, 0) ||
+ usebraces(sp2->stm2, 0) || i))
+ always = BR_ALWAYS;
+ else
+ always = 0;
+ out_block(sp2->stm1, BR_THENPART|always, sp->serial);
+ output("else");
+ sp2 = sp2->stm2;
+ if (i) {
+ output(" ");
+ } else {
+ out_block(sp2, BR_ELSEPART|always, sp->serial+1);
+ break;
+ }
+ } else {
+ out_block(sp2->stm1, 0, sp->serial);
+ break;
+ }
+ }
+ break;
+
+ case SK_REPEAT:
+ output("do");
+ out_block(sp->stm1, BR_ALWAYS|BR_REPEAT, sp->serial);
+ output("while (");
+ out_expr_bool(sp->exp1);
+ output(");");
+ cmt = findcomment(curcomments, CMT_ONEND, sp->serial);
+ if (commentvisible(cmt)) {
+ out_spaces(commentindent, commentoverindent,
+ commentlen(cmt), 0);
+ output("\001");
+ outcomment(cmt);
+ } else
+ output("\n");
+ break;
+
+ case SK_TRY:
+ trynum = sp->exp1->val.i;
+ output(format_d("TRY(try%d);", trynum));
+ out_block(sp->stm1, BR_NEVER|BR_TRY, sp->serial);
+ if (sp->exp2)
+ output(format_ds("RECOVER2(try%d,%s);", trynum,
+ format_s(name_LABEL, format_d("try%d", trynum))));
+ else
+ output(format_d("RECOVER(try%d);", trynum));
+ out_block(sp->stm2, BR_NEVER|BR_TRY, sp->serial);
+ output(format_d("ENDTRY(try%d);\n", trynum));
+ break;
+
+ case SK_WHILE:
+ output("while (");
+ out_expr_bool(sp->exp1);
+ output(")");
+ out_block(sp->stm1, 0, sp->serial);
+ break;
+
+ case SK_BREAK:
+ output("break;");
+ outnl(sp->serial);
+ break;
+
+ case SK_CONTINUE:
+ output("continue;");
+ outnl(sp->serial);
+ break;
+
+ default:
+ intwarning("out_block",
+ format_s("Misplaced statement kind %s [265]",
+ stmtkindname(sp->kind)));
+ break;
+ }
+ flushcomments(NULL, -1, sp->serial);
+ candeclare = 0;
+ if (debug>1) { fprintf(outf, "in out_block:\n"); dumpstmt(spbase,5); }
+ sp = sp->next;
+ }
+ if (opts & BR_FUNCTION) {
+ cmt = extractcomment(&curcomments, CMT_ONEND, serial);
+ if (findcomment(curcomments, -1, -1) != NULL) /* check for non-DONE */
+ output("\n");
+ flushcomments(NULL, -1, -1);
+ curcomments = cmt;
+ }
+ outindent = saveindent;
+ if (braces) {
+ if (line_start()) {
+ if (opts & BR_FUNCTION)
+ singleindent(funccloseindent);
+ else
+ singleindent(closebraceindent);
+ }
+ output("}");
+ i = 1;
+ cmt = findcomment(curcomments, CMT_ONEND, serial);
+ if (!(opts & BR_REPEAT) && commentvisible(cmt)) {
+ out_spaces(bracecommentindent, commentoverindent,
+ commentlen(cmt), 0);
+ output("\001");
+ outcomment(cmt);
+ i = 0;
+ }
+ if (i) {
+ outspnl((opts & BR_REPEAT) ||
+ ((opts & BR_THENPART) && (braceelseline & 1) == 0));
+ }
+ candeclare = 0;
+ }
+ if (gotcomments) {
+ outcontext->comments = curcomments;
+ curcomments = savecurcmt;
+ }
+}
+
+
+
+
+
+/* Should have a way to convert GOTO's to the end of the function to RETURN's */
+
+
+/* Convert "_RETV = foo;" at end of function to "return foo" */
+
+Static int checkreturns(spp, nearret)
+Stmt **spp;
+int nearret;
+{
+ Stmt *sp;
+ Expr *rvar, *ex;
+ Meaning *mp;
+ int spnearret, spnextreturn;
+ int result = 0;
+
+ if (debug>2) { fprintf(outf, "checkreturns on:\n"); dumpstmt(*spp, 5); }
+ while ((sp = *spp)) {
+ spnextreturn = (sp->next &&
+ sp->next->kind == SK_RETURN && sp->next->exp1 &&
+ isretvar(sp->next->exp1) == curctx->cbase);
+ spnearret = (nearret && !sp->next) || spnextreturn;
+ result = 0;
+ switch (sp->kind) {
+
+ case SK_ASSIGN:
+ ex = sp->exp1;
+ if (ex->kind == EK_ASSIGN || structuredfunc(ex)) {
+ rvar = ex->args[0];
+ mp = isretvar(rvar);
+ if (mp == curctx->cbase && spnearret) {
+ if (ex->kind == EK_ASSIGN) {
+ if (mp->kind == MK_VARPARAM) {
+ ex = makeexpr_comma(ex, makeexpr_var(mp));
+ } else {
+ ex = grabarg(ex, 1);
+ mp->refcount--;
+ }
+ }
+ sp->exp1 = ex;
+ sp->kind = SK_RETURN;
+ if (spnextreturn) {
+ mp->refcount--;
+ sp->next = sp->next->next;
+ }
+ result = 1;
+ }
+ }
+ break;
+
+ case SK_RETURN:
+ case SK_GOTO:
+ result = 1;
+ break;
+
+ case SK_IF:
+ result = checkreturns(&sp->stm1, spnearret) & /* NOT && */
+ checkreturns(&sp->stm2, spnearret);
+ break;
+
+ case SK_TRY:
+ (void) checkreturns(&sp->stm1, 0);
+ (void) checkreturns(&sp->stm2, spnearret);
+ break;
+
+ /* should handle CASE statements as well */
+
+ default:
+ (void) checkreturns(&sp->stm1, 0);
+ (void) checkreturns(&sp->stm2, 0);
+ break;
+ }
+ spp = &sp->next;
+ }
+ return result;
+}
+
+
+
+
+
+
+
+/* Replace all occurrences of one expression with another expression */
+
+Expr *replaceexprexpr(ex, oldex, newex, keeptype)
+Expr *ex, *oldex, *newex;
+int keeptype;
+{
+ int i;
+ Type *type;
+
+ for (i = 0; i < ex->nargs; i++)
+ ex->args[i] = replaceexprexpr(ex->args[i], oldex, newex, keeptype);
+ if (exprsame(ex, oldex, 2)) {
+ if (ex->val.type->kind == TK_POINTER &&
+ ex->val.type->basetype == oldex->val.type) {
+ freeexpr(ex);
+ return makeexpr_addr(copyexpr(newex));
+ } else if (oldex->val.type->kind == TK_POINTER &&
+ oldex->val.type->basetype == ex->val.type) {
+ freeexpr(ex);
+ return makeexpr_hat(copyexpr(newex), 0);
+ } else {
+ type = ex->val.type;
+ freeexpr(ex);
+ ex = copyexpr(newex);
+ if (keeptype)
+ ex->val.type = type;
+ return ex;
+ }
+ }
+ return resimplify(ex);
+}
+
+
+void replaceexpr(sp, oldex, newex)
+Stmt *sp;
+Expr *oldex, *newex;
+{
+ while (sp) {
+ replaceexpr(sp->stm1, oldex, newex);
+ replaceexpr(sp->stm2, oldex, newex);
+ if (sp->exp1)
+ sp->exp1 = replaceexprexpr(sp->exp1, oldex, newex, 1);
+ if (sp->exp2)
+ sp->exp2 = replaceexprexpr(sp->exp2, oldex, newex, 1);
+ if (sp->exp3)
+ sp->exp3 = replaceexprexpr(sp->exp3, oldex, newex, 1);
+ sp = sp->next;
+ }
+}
+
+
+
+
+
+
+Stmt *mixassignments(sp, mp)
+Stmt *sp;
+Meaning *mp;
+{
+ if (!sp)
+ return NULL;
+ sp->next = mixassignments(sp->next, mp);
+ if (sp->next &&
+ sp->kind == SK_ASSIGN &&
+ sp->exp1->kind == EK_ASSIGN &&
+ sp->exp1->args[0]->kind == EK_VAR &&
+ (!mp || mp == (Meaning *)sp->exp1->args[0]->val.i) &&
+ ord_type(sp->exp1->args[0]->val.type)->kind == TK_INTEGER &&
+ nodependencies(sp->exp1->args[1], 0) &&
+ sp->next->kind == SK_ASSIGN &&
+ sp->next->exp1->kind == EK_ASSIGN &&
+ (exprsame(sp->exp1->args[0], sp->next->exp1->args[0], 1) ||
+ (mp && mp->istemporary)) &&
+ exproccurs(sp->next->exp1->args[1], sp->exp1->args[0]) == 1) {
+ sp->next->exp1->args[1] = replaceexprexpr(sp->next->exp1->args[1],
+ sp->exp1->args[0],
+ sp->exp1->args[1], 1);
+ if (mp && mp->istemporary)
+ canceltempvar(mp);
+ return sp->next;
+ }
+ return sp;
+}
+
+
+
+
+
+
+
+
+/* Do various simple (sometimes necessary) massages on the statements */
+
+
+Static Stmt bogusreturn = { SK_RETURN, NULL, NULL, NULL, NULL, NULL, NULL };
+
+
+
+Static int isescape(ex)
+Expr *ex;
+{
+ if (ex->kind == EK_BICALL && (!strcmp(ex->val.s, name_ESCAPE) ||
+ !strcmp(ex->val.s, name_ESCIO) ||
+ !strcmp(ex->val.s, name_OUTMEM) ||
+ !strcmp(ex->val.s, name_CASECHECK) ||
+ !strcmp(ex->val.s, name_NILCHECK) ||
+ !strcmp(ex->val.s, "_exit") ||
+ !strcmp(ex->val.s, "exit")))
+ return 1;
+ if (ex->kind == EK_CAST)
+ return isescape(ex->args[0]);
+ return 0;
+}
+
+
+/* check if a block can never exit by falling off the end */
+Static int deadendblock(sp)
+Stmt *sp;
+{
+ if (!sp)
+ return 0;
+ while (sp->next)
+ sp = sp->next;
+ return (sp->kind == SK_GOTO ||
+ sp->kind == SK_BREAK ||
+ sp->kind == SK_CONTINUE ||
+ sp->kind == SK_RETURN ||
+ sp->kind == SK_CASECHECK ||
+ (sp->kind == SK_IF && deadendblock(sp->stm1) &&
+ deadendblock(sp->stm2)) ||
+ (sp->kind == SK_ASSIGN && isescape(sp->exp1)));
+}
+
+
+
+
+int expr_is_bool(ex, want)
+Expr *ex;
+int want;
+{
+ long val;
+
+ if (ex->val.type == tp_boolean && isconstexpr(ex, &val))
+ return (val == want);
+ return 0;
+}
+
+
+
+
+/* Returns 1 if c1 implies c2, 0 otherwise */
+/* If not1 is true, then checks if (!c1) implies c2; similarly for not2 */
+
+/* Identities used:
+ c1 -> (c2a && c2b) <=> (c1 -> c2a) && (c1 -> c2b)
+ c1 -> (c2a || c2b) <=> (c1 -> c2a) || (c1 -> c2b)
+ (c1a && c1b) -> c2 <=> (c1a -> c2) || (c1b -> c2)
+ (c1a || c1b) -> c2 <=> (c1a -> c2) && (c1b -> c2)
+ (!c1) -> (!c2) <=> c2 -> c1
+ (a == b) -> c2(b) <=> c2(a)
+ !(c1 && c2) <=> (!c1) || (!c2)
+ !(c1 || c2) <=> (!c1) && (!c2)
+*/
+/* This could be smarter about, e.g., (a>5) -> (a>0) */
+
+int implies(c1, c2, not1, not2)
+Expr *c1, *c2;
+int not1, not2;
+{
+ Expr *ex;
+ int i;
+
+ if (c1->kind == EK_EQ && c1->args[0]->val.type == tp_boolean) {
+ if (checkconst(c1->args[0], 1)) { /* things like "flag = true" */
+ return implies(c1->args[1], c2, not1, not2);
+ } else if (checkconst(c1->args[1], 1)) {
+ return implies(c1->args[0], c2, not1, not2);
+ } else if (checkconst(c1->args[0], 0)) {
+ return implies(c1->args[1], c2, !not1, not2);
+ } else if (checkconst(c1->args[1], 0)) {
+ return implies(c1->args[0], c2, !not1, not2);
+ }
+ }
+ if (c2->kind == EK_EQ && c2->args[0]->val.type == tp_boolean) {
+ if (checkconst(c2->args[0], 1)) {
+ return implies(c1, c2->args[1], not1, not2);
+ } else if (checkconst(c2->args[1], 1)) {
+ return implies(c1, c2->args[0], not1, not2);
+ } else if (checkconst(c2->args[0], 0)) {
+ return implies(c1, c2->args[1], not1, !not2);
+ } else if (checkconst(c2->args[1], 0)) {
+ return implies(c1, c2->args[0], not1, !not2);
+ }
+ }
+ switch (c2->kind) {
+
+ case EK_AND:
+ if (not2) /* c1 -> (!c2a || !c2b) */
+ return (implies(c1, c2->args[0], not1, 1) ||
+ implies(c1, c2->args[1], not1, 1));
+ else /* c1 -> (c2a && c2b) */
+ return (implies(c1, c2->args[0], not1, 0) &&
+ implies(c1, c2->args[1], not1, 0));
+
+ case EK_OR:
+ if (not2) /* c1 -> (!c2a && !c2b) */
+ return (implies(c1, c2->args[0], not1, 1) &&
+ implies(c1, c2->args[1], not1, 1));
+ else /* c1 -> (c2a || c2b) */
+ return (implies(c1, c2->args[0], not1, 0) ||
+ implies(c1, c2->args[1], not1, 0));
+
+ case EK_NOT: /* c1 -> (!c2) */
+ return (implies(c1, c2->args[0], not1, !not2));
+
+ case EK_CONST:
+ if ((c2->val.i != 0) != not2) /* c1 -> true */
+ return 1;
+ break;
+
+ default:
+ break;
+ }
+ switch (c1->kind) {
+
+ case EK_AND:
+ if (not1) /* (!c1a || !c1b) -> c2 */
+ return (implies(c1->args[0], c2, 1, not2) &&
+ implies(c1->args[1], c2, 1, not2));
+ else /* (c1a && c1b) -> c2 */
+ return (implies(c1->args[0], c2, 0, not2) ||
+ implies(c1->args[1], c2, 0, not2));
+
+ case EK_OR:
+ if (not1) /* (!c1a && !c1b) -> c2 */
+ return (implies(c1->args[0], c2, 1, not2) ||
+ implies(c1->args[1], c2, 1, not2));
+ else /* (c1a || c1b) -> c2 */
+ return (implies(c1->args[0], c2, 0, not2) &&
+ implies(c1->args[1], c2, 0, not2));
+
+ case EK_NOT: /* (!c1) -> c2 */
+ return (implies(c1->args[0], c2, !not1, not2));
+
+ case EK_CONST:
+ if ((c1->val.i != 0) == not1) /* false -> c2 */
+ return 1;
+ break;
+
+ case EK_EQ: /* (a=b) -> c2 */
+ case EK_ASSIGN: /* (a:=b) -> c2 */
+ case EK_NE: /* (a<>b) -> c2 */
+ if ((c1->kind == EK_NE) == not1) {
+ if (c1->args[0]->kind == EK_VAR) {
+ ex = replaceexprexpr(copyexpr(c2), c1->args[0], c1->args[1], 1);
+ i = expr_is_bool(ex, !not2);
+ freeexpr(ex);
+ if (i)
+ return 1;
+ }
+ if (c1->args[1]->kind == EK_VAR) {
+ ex = replaceexprexpr(copyexpr(c2), c1->args[1], c1->args[0], 1);
+ i = expr_is_bool(ex, !not2);
+ freeexpr(ex);
+ if (i)
+ return 1;
+ }
+ }
+ break;
+
+ default:
+ break;
+ }
+ if (not1 == not2 && exprequiv(c1, c2)) { /* c1 -> c1 */
+ return 1;
+ }
+ return 0;
+}
+
+
+
+
+
+void infiniteloop(sp)
+Stmt *sp;
+{
+ switch (infloopstyle) {
+
+ case 1: /* write "for (;;) ..." */
+ sp->kind = SK_FOR;
+ freeexpr(sp->exp1);
+ sp->exp1 = NULL;
+ break;
+
+ case 2: /* write "while (1) ..." */
+ sp->kind = SK_WHILE;
+ freeexpr(sp->exp1);
+ sp->exp1 = makeexpr_val(make_ord(tp_boolean, 1));
+ break;
+
+ case 3: /* write "do ... while (1)" */
+ sp->kind = SK_REPEAT;
+ freeexpr(sp->exp1);
+ sp->exp1 = makeexpr_val(make_ord(tp_boolean, 1));
+ break;
+
+ default: /* leave it alone */
+ break;
+
+ }
+}
+
+
+
+
+
+Expr *print_func(ex)
+Expr *ex;
+{
+ if (!ex || ex->kind != EK_BICALL)
+ return NULL;
+ if ((!strcmp(ex->val.s, "printf") &&
+ ex->args[0]->kind == EK_CONST) ||
+ !strcmp(ex->val.s, "putchar") ||
+ !strcmp(ex->val.s, "puts"))
+ return ex_output;
+ if ((!strcmp(ex->val.s, "fprintf") ||
+ !strcmp(ex->val.s, "sprintf")) &&
+ ex->args[1]->kind == EK_CONST)
+ return ex->args[0];
+ if (!strcmp(ex->val.s, "putc") ||
+ !strcmp(ex->val.s, "fputc") ||
+ !strcmp(ex->val.s, "fputs"))
+ return ex->args[1];
+ return NULL;
+}
+
+
+
+int printnl_func(ex)
+Expr *ex;
+{
+ char *cp, ch;
+ int i, len;
+
+ if (debug>2) { fprintf(outf,"printnl_func("); dumpexpr(ex); fprintf(outf, ")\n"); }
+ if (!strcmp(ex->val.s, "printf") ||
+ !strcmp(ex->val.s, "puts") ||
+ !strcmp(ex->val.s, "fputs")) {
+ if (ex->args[0]->kind != EK_CONST)
+ return 0;
+ cp = ex->args[0]->val.s;
+ len = ex->args[0]->val.i;
+ } else if (!strcmp(ex->val.s, "fprintf")) {
+ if (ex->args[1]->kind != EK_CONST)
+ return 0;
+ cp = ex->args[1]->val.s;
+ len = ex->args[1]->val.i;
+ } else if (!strcmp(ex->val.s, "putchar") ||
+ !strcmp(ex->val.s, "putc") ||
+ !strcmp(ex->val.s, "fputc")) {
+ if (ex->args[0]->kind != EK_CONST)
+ return 0;
+ ch = ex->args[0]->val.i;
+ cp = &ch;
+ len = 1;
+ } else
+ return 0;
+ for (i = 1; i <= len; i++)
+ if (*cp++ != '\n')
+ return 0;
+ return len + (!strcmp(ex->val.s, "puts"));
+}
+
+
+
+Expr *chg_printf(ex)
+Expr *ex;
+{
+ Expr *fex;
+
+ if (debug>2) { fprintf(outf,"chg_printf("); dumpexpr(ex); fprintf(outf, ")\n"); }
+ if (!strcmp(ex->val.s, "putchar")) {
+ ex = makeexpr_sprintfify(grabarg(ex, 0));
+ canceltempvar(istempvar(ex->args[0]));
+ strchange(&ex->val.s, "printf");
+ delfreearg(&ex, 0);
+ ex->val.type = tp_void;
+ } else if (!strcmp(ex->val.s, "putc") ||
+ !strcmp(ex->val.s, "fputc") ||
+ !strcmp(ex->val.s, "fputs")) {
+ fex = copyexpr(ex->args[1]);
+ ex = makeexpr_sprintfify(grabarg(ex, 0));
+ canceltempvar(istempvar(ex->args[0]));
+ strchange(&ex->val.s, "fprintf");
+ ex->args[0] = fex;
+ ex->val.type = tp_void;
+ } else if (!strcmp(ex->val.s, "puts")) {
+ ex = makeexpr_concat(makeexpr_sprintfify(grabarg(ex, 0)),
+ makeexpr_string("\n"), 1);
+ strchange(&ex->val.s, "printf");
+ delfreearg(&ex, 0);
+ ex->val.type = tp_void;
+ }
+ if (!strcmp(ex->val.s, "fprintf") && exprsame(ex->args[0], ex_output, 1)) {
+ delfreearg(&ex, 0);
+ strchange(&ex->val.s, "printf");
+ }
+ return ex;
+}
+
+
+Expr *mix_printf(ex, ex2)
+Expr *ex, *ex2;
+{
+ int i;
+
+ ex = chg_printf(ex);
+ if (debug>2) { fprintf(outf,"chg_printf returns "); dumpexpr(ex); fprintf(outf, "\n"); }
+ ex2 = chg_printf(copyexpr(ex2));
+ if (debug>2) { fprintf(outf,"chg_printf returns "); dumpexpr(ex2);fprintf(outf, "\n"); }
+ i = (!strcmp(ex->val.s, "printf")) ? 0 : 1;
+ ex->args[i] = makeexpr_concat(ex->args[i], ex2->args[i], 0);
+ for (i++; i < ex2->nargs; i++) {
+ insertarg(&ex, ex->nargs, ex2->args[i]);
+ }
+ return ex;
+}
+
+
+
+
+
+
+void eatstmt(spp)
+Stmt **spp;
+{
+ Stmt *sp = *spp;
+
+ if (debug>2) { fprintf(outf, "eatstmt on:\n"); dumpstmt(sp, 5); }
+ *spp = sp->next;
+ sp->next = NULL;
+ free_stmt(sp);
+}
+
+
+
+int haslabels(sp)
+Stmt *sp;
+{
+ if (!sp)
+ return 0;
+ if (haslabels(sp->stm1) || haslabels(sp->stm2))
+ return 1;
+ return (sp->kind == SK_LABEL);
+}
+
+
+
+void fixblock(spp, thereturn)
+Stmt **spp, *thereturn;
+{
+ Stmt *sp, *sp1, *sp2, *sp3, **spp2, *thisreturn;
+ Expr *ex;
+ Meaning *tvar;
+ int save_tryblock;
+ short save_tryflag;
+ int i, j, de1, de2;
+ long saveserial = curserial;
+
+ while ((sp = *spp)) {
+ sp2 = sp->next;
+ sp->next = NULL;
+ sp = fix_statement(*spp);
+ if (!sp) {
+ *spp = sp2;
+ continue;
+ }
+ *spp = sp;
+ for (sp3 = sp; sp3->next; sp3 = sp3->next) ;
+ sp3->next = sp2;
+ if (!sp->next)
+ thisreturn = thereturn;
+ else if (sp->next->kind == SK_RETURN ||
+ (sp->next->kind == SK_ASSIGN &&
+ isescape(sp->next->exp1)))
+ thisreturn = sp->next;
+ else
+ thisreturn = NULL;
+ if (sp->serial >= 0)
+ curserial = sp->serial;
+ switch (sp->kind) {
+
+ case SK_ASSIGN:
+ if (sp->exp1)
+ sp->exp1 = fixexpr(sp->exp1, ENV_STMT);
+ if (!sp->exp1)
+ intwarning("fixblock", "sp->exp1 == NULL in SK_ASSIGN");
+ if (!sp->exp1 || nosideeffects(sp->exp1, 1)) {
+ eatstmt(spp);
+ continue;
+ } else {
+ switch (sp->exp1->kind) {
+
+ case EK_COND:
+ *spp = makestmt_if(sp->exp1->args[0],
+ makestmt_call(sp->exp1->args[1]),
+ makestmt_call(sp->exp1->args[2]));
+ (*spp)->next = sp->next;
+ continue; /* ... to fix this new if statement */
+
+ case EK_ASSIGN:
+ if (sp->exp1->args[1]->kind == EK_COND && usecommas != 1) {
+ *spp = makestmt_if(sp->exp1->args[1]->args[0],
+ makestmt_assign(copyexpr(sp->exp1->args[0]),
+ sp->exp1->args[1]->args[1]),
+ makestmt_assign(sp->exp1->args[0],
+ sp->exp1->args[1]->args[2]));
+ (*spp)->next = sp->next;
+ continue;
+ }
+ if (isescape(sp->exp1->args[1])) {
+ sp->exp1 = grabarg(sp->exp1, 1);
+ continue;
+ }
+ if (exprsame(sp->exp1->args[0], sp->exp1->args[1], 1)) {
+ /* *spp = sp->next; */
+ sp->exp1 = grabarg(sp->exp1, 0);
+ continue;
+ }
+ if (sp->exp1->args[1]->kind == EK_BICALL) {
+ if (!strcmp(sp->exp1->args[1]->val.s,
+ getfbufname) &&
+ buildreads == 1 &&
+ sp->next &&
+ sp->next->kind == SK_ASSIGN &&
+ sp->next->exp1->kind == EK_BICALL &&
+ !strcmp(sp->next->exp1->val.s,
+ getname) &&
+ expr_has_address(sp->exp1->args[0]) &&
+ similartypes(sp->exp1->args[0]->val.type,
+ filebasetype(sp->exp1->args[1]->args[0]->val.type)) &&
+ exprsame(sp->exp1->args[1]->args[0],
+ sp->next->exp1->args[0], 1)) {
+ eatstmt(&sp->next);
+ ex = makeexpr_bicall_4("fread", tp_integer,
+ makeexpr_addr(sp->exp1->args[0]),
+ makeexpr_sizeof(sp->exp1->args[1]->args[1], 0),
+ makeexpr_long(1),
+ sp->exp1->args[1]->args[0]);
+ FREE(sp->exp1);
+ sp->exp1 = ex;
+ continue;
+ }
+ if (!strcmp(sp->exp1->args[1]->val.s,
+ chargetfbufname) &&
+ buildreads != 0 &&
+ sp->next &&
+ sp->next->kind == SK_ASSIGN &&
+ sp->next->exp1->kind == EK_BICALL &&
+ !strcmp(sp->next->exp1->val.s,
+ chargetname) &&
+ expr_has_address(sp->exp1->args[0]) &&
+ exprsame(sp->exp1->args[1]->args[0],
+ sp->next->exp1->args[0], 1)) {
+ eatstmt(&sp->next);
+ strchange(&sp->exp1->args[1]->val.s,
+ "getc");
+ continue;
+ }
+ }
+ break;
+
+ case EK_BICALL:
+ if (!strcmp(sp->exp1->val.s, name_ESCAPE)) {
+ if (fixexpr_tryblock) {
+ *spp = makestmt_assign(makeexpr_var(mp_escapecode),
+ grabarg(sp->exp1, 0));
+ (*spp)->next = makestmt(SK_GOTO);
+ (*spp)->next->exp1 = makeexpr_name(format_s(name_LABEL,
+ format_d("try%d",
+ fixexpr_tryblock)),
+ tp_integer);
+ (*spp)->next->next = sp->next;
+ fixexpr_tryflag = 1;
+ continue;
+ }
+ } else if (!strcmp(sp->exp1->val.s, name_ESCIO)) {
+ if (fixexpr_tryblock) {
+ *spp = makestmt_assign(makeexpr_var(mp_escapecode),
+ makeexpr_long(-10));
+ (*spp)->next = makestmt_assign(makeexpr_var(mp_ioresult),
+ grabarg(sp->exp1, 0));
+ (*spp)->next->next = makestmt(SK_GOTO);
+ (*spp)->next->next->exp1 = makeexpr_name(format_s(name_LABEL,
+ format_d("try%d",
+ fixexpr_tryblock)),
+ tp_integer);
+ (*spp)->next->next->next = sp->next;
+ fixexpr_tryflag = 1;
+ continue;
+ }
+ }
+ if (!strcmp(sp->exp1->val.s, putfbufname) &&
+ buildwrites == 1 &&
+ sp->next &&
+ sp->next->kind == SK_ASSIGN &&
+ sp->next->exp1->kind == EK_BICALL &&
+ !strcmp(sp->next->exp1->val.s,
+ putname) &&
+ exprsame(sp->exp1->args[0],
+ sp->next->exp1->args[0], 1)) {
+ eatstmt(&sp->next);
+ if (!expr_has_address(sp->exp1->args[2]) ||
+ sp->exp1->args[2]->val.type !=
+ sp->exp1->args[1]->val.type) {
+ tvar = maketempvar(sp->exp1->args[1]->val.type,
+ name_TEMP);
+ sp2 = makestmt_assign(makeexpr_var(tvar),
+ sp->exp1->args[2]);
+ sp2->next = sp;
+ *spp = sp2;
+ sp->exp1->args[2] = makeexpr_var(tvar);
+ freetempvar(tvar);
+ }
+ ex = makeexpr_bicall_4("fwrite", tp_integer,
+ makeexpr_addr(sp->exp1->args[2]),
+ makeexpr_sizeof(sp->exp1->args[1], 0),
+ makeexpr_long(1),
+ sp->exp1->args[0]);
+ FREE(sp->exp1);
+ sp->exp1 = ex;
+ continue;
+ }
+ if (!strcmp(sp->exp1->val.s, charputfbufname) &&
+ buildwrites != 0 &&
+ sp->next &&
+ sp->next->kind == SK_ASSIGN &&
+ sp->next->exp1->kind == EK_BICALL &&
+ !strcmp(sp->next->exp1->val.s,
+ charputname) &&
+ exprsame(sp->exp1->args[0],
+ sp->next->exp1->args[0], 1)) {
+ eatstmt(&sp->next);
+ swapexprs(sp->exp1->args[0],
+ sp->exp1->args[1]);
+ strchange(&sp->exp1->val.s, "putc");
+ continue;
+ }
+ if ((!strcmp(sp->exp1->val.s, resetbufname) ||
+ !strcmp(sp->exp1->val.s, setupbufname)) &&
+ !fileisbuffered(sp->exp1->args[0], 0)) {
+ eatstmt(spp);
+ continue;
+ }
+ ex = print_func(sp->exp1);
+ if (ex && sp->next && mixwritelns &&
+ sp->next->kind == SK_ASSIGN &&
+ exprsame(ex, print_func(sp->next->exp1), 1) &&
+ (printnl_func(sp->exp1) ||
+ printnl_func(sp->next->exp1))) {
+ sp->exp1 = mix_printf(sp->exp1,
+ sp->next->exp1);
+ eatstmt(&sp->next);
+ continue;
+ }
+ break;
+
+ case EK_FUNCTION:
+ case EK_SPCALL:
+ case EK_POSTINC:
+ case EK_POSTDEC:
+ case EK_AND:
+ case EK_OR:
+ break;
+
+ default:
+ spp2 = spp;
+ for (i = 0; i < sp->exp1->nargs; i++) {
+ *spp2 = makestmt_call(sp->exp1->args[i]);
+ spp2 = &(*spp2)->next;
+ }
+ *spp2 = sp->next;
+ continue; /* ... to fix these new statements */
+
+ }
+ }
+ break;
+
+ case SK_IF:
+ fixblock(&sp->stm1, thisreturn);
+ fixblock(&sp->stm2, thisreturn);
+ if (!sp->stm1) {
+ if (!sp->stm2) {
+ sp->kind = SK_ASSIGN;
+ continue;
+ } else {
+ if (sp->stm2->kind == SK_IF && sp->stm2->exp2) {
+ freeexpr(sp->stm2->exp2);
+ sp->stm2->exp2 = NULL;
+ }
+ sp->exp1 = makeexpr_not(sp->exp1); /* if (x) else foo => if (!x) foo */
+ swapstmts(sp->stm1, sp->stm2);
+ /* Ought to exchange comments for then/else parts */
+ }
+ }
+ /* At this point we know sp1 != NULL */
+ if (thisreturn) {
+ if (thisreturn->kind == SK_WHILE) {
+ if (usebreaks) {
+ sp1 = sp->stm1;
+ while (sp1->next)
+ sp1 = sp1->next;
+ if (sp->stm2) {
+ sp2 = sp->stm2;
+ while (sp2->next)
+ sp2 = sp2->next;
+ i = stmtcount(sp->stm1);
+ j = stmtcount(sp->stm2);
+ if (j >= breaklimit && i <= 2 && j > i*2 &&
+ ((implies(sp->exp1, thisreturn->exp1, 0, 1) &&
+ !checkexprchanged(sp->stm1, sp->exp1)) ||
+ (sp1->kind == SK_ASSIGN &&
+ implies(sp1->exp1, thisreturn->exp1, 0, 1)))) {
+ sp1->next = makestmt(SK_BREAK);
+ } else if (i >= breaklimit && j <= 2 && i > j*2 &&
+ ((implies(sp->exp1, thisreturn->exp1, 1, 1) &&
+ !checkexprchanged(sp->stm2, sp->exp1)) ||
+ (sp2->kind == SK_ASSIGN &&
+ implies(sp2->exp1, thisreturn->exp1, 0, 1)))) {
+ sp2->next = makestmt(SK_BREAK);
+ } else if (!checkconst(sp->exp2, 1)) {
+ /* not part of an else-if */
+ if (j >= continuelimit) {
+ sp1->next = makestmt(SK_CONTINUE);
+ } else if (i >= continuelimit) {
+ sp2->next = makestmt(SK_CONTINUE);
+ }
+ }
+ } else {
+ i = stmtcount(sp->stm1);
+ if (i >= breaklimit &&
+ implies(sp->exp1, thisreturn->exp1, 1, 1)) {
+ sp->exp1 = makeexpr_not(sp->exp1);
+ sp1->next = sp->next;
+ sp->next = sp->stm1;
+ sp->stm1 = makestmt(SK_BREAK);
+ } else if (i >= continuelimit) {
+ sp->exp1 = makeexpr_not(sp->exp1);
+ sp1->next = sp->next;
+ sp->next = sp->stm1;
+ sp->stm1 = makestmt(SK_CONTINUE);
+ }
+ }
+ }
+ } else {
+ if (usereturns) {
+ sp2 = sp->stm1;
+ while (sp2->next)
+ sp2 = sp2->next;
+ if (sp->stm2) {
+ /* if (x) foo; else bar; (return;) => if (x) {foo; return;} bar; */
+ if (stmtcount(sp->stm2) >= returnlimit) {
+ if (!deadendblock(sp->stm1))
+ sp2->next = copystmt(thisreturn);
+ } else if (stmtcount(sp->stm1) >= returnlimit) {
+ sp2 = sp->stm2;
+ while (sp2->next)
+ sp2 = sp2->next;
+ if (!deadendblock(sp->stm2))
+ sp2->next = copystmt(thisreturn);
+ }
+ } else { /* if (x) foo; (return;) => if (!x) return; foo; */
+ if (stmtcount(sp->stm1) >= returnlimit) {
+ sp->exp1 = makeexpr_not(sp->exp1);
+ sp2->next = sp->next;
+ sp->next = sp->stm1;
+ sp->stm1 = copystmt(thisreturn);
+ }
+ }
+ }
+ }
+ }
+ if (!checkconst(sp->exp2, 1)) { /* not part of an else-if */
+ de1 = deadendblock(sp->stm1);
+ de2 = deadendblock(sp->stm2);
+ if (de2 && !de1) {
+ sp->exp1 = makeexpr_not(sp->exp1);
+ swapstmts(sp->stm1, sp->stm2);
+ de1 = 1, de2 = 0;
+ }
+ if (de1 && !de2 && sp->stm2) {
+ if (sp->stm2->kind == SK_IF && sp->stm2->exp2) {
+ freeexpr(sp->stm2->exp2);
+ sp->stm2->exp2 = NULL;
+ }
+ for (sp2 = sp->stm2; sp2->next; sp2 = sp2->next) ;
+ sp2->next = sp->next;
+ sp->next = sp->stm2; /* if (x) ESCAPE else foo => if (x) ESCAPE; foo */
+ sp->stm2 = NULL;
+ }
+ }
+ sp->exp1 = fixexpr(sp->exp1, ENV_BOOL);
+ if (elimdeadcode > 1 && checkconst(sp->exp1, 0)) {
+ note("Eliminated \"if false\" statement [326]");
+ splicestmt(sp, sp->stm2);
+ continue;
+ } else if (elimdeadcode > 1 && checkconst(sp->exp1, 1)) {
+ note("Eliminated \"if true\" statement [327]");
+ splicestmt(sp, sp->stm1);
+ continue;
+ }
+ break;
+
+ case SK_WHILE:
+ if (whilefgets && /* handle "while eof(f) do readln(f,...)" */
+ sp->stm1 &&
+ sp->stm1->kind == SK_ASSIGN &&
+ sp->stm1->exp1->kind == EK_BICALL &&
+ !strcmp(sp->stm1->exp1->val.s, "fgets") &&
+ nosideeffects(sp->stm1->exp1->args[0], 1) &&
+ nosideeffects(sp->stm1->exp1->args[1], 1) &&
+ nosideeffects(sp->stm1->exp1->args[2], 1)) {
+ if ((sp->exp1->kind == EK_NOT &&
+ sp->exp1->args[0]->kind == EK_BICALL && *eofname &&
+ !strcmp(sp->exp1->args[0]->val.s, eofname) &&
+ exprsame(sp->exp1->args[0]->args[0],
+ sp->stm1->exp1->args[2], 1)) ||
+ (sp->exp1->kind == EK_EQ &&
+ sp->exp1->args[0]->kind == EK_BICALL &&
+ !strcmp(sp->exp1->args[0]->val.s, "feof") &&
+ checkconst(sp->exp1->args[1], 0) &&
+ exprsame(sp->exp1->args[0]->args[0],
+ sp->stm1->exp1->args[2], 1))) {
+ sp->stm1->exp1->val.type = tp_strptr;
+ sp->exp1 = makeexpr_rel(EK_NE,
+ sp->stm1->exp1,
+ makeexpr_nil());
+ sp->stm1 = sp->stm1->next;
+ }
+ }
+ fixblock(&sp->stm1, sp);
+ sp->exp1 = fixexpr(sp->exp1, ENV_BOOL);
+ if (checkconst(sp->exp1, 1))
+ infiniteloop(sp);
+ break;
+
+ case SK_REPEAT:
+ fixblock(&sp->stm1, NULL);
+ sp->exp1 = fixexpr(sp->exp1, ENV_BOOL);
+ if (checkconst(sp->exp1, 1))
+ infiniteloop(sp);
+ break;
+
+ case SK_TRY:
+ save_tryblock = fixexpr_tryblock;
+ save_tryflag = fixexpr_tryflag;
+ fixexpr_tryblock = sp->exp1->val.i;
+ fixexpr_tryflag = 0;
+ fixblock(&sp->stm1, NULL);
+ if (fixexpr_tryflag)
+ sp->exp2 = makeexpr_long(1);
+ fixexpr_tryblock = save_tryblock;
+ fixexpr_tryflag = save_tryflag;
+ fixblock(&sp->stm2, NULL);
+ break;
+
+ case SK_BODY:
+ fixblock(&sp->stm1, thisreturn);
+ break;
+
+ case SK_CASE:
+ fixblock(&sp->stm1, NULL);
+ sp->exp1 = fixexpr(sp->exp1, ENV_EXPR);
+ if (!sp->stm1) { /* empty case */
+ sp->kind = SK_ASSIGN;
+ continue;
+ } else if (sp->stm1->kind != SK_CASELABEL) { /* default only */
+ for (sp2 = sp->stm1; sp2->next; sp2 = sp2->next) ;
+ sp2->next = sp->next;
+ sp->next = sp->stm1;
+ sp->kind = SK_ASSIGN;
+ sp->stm1 = NULL;
+ continue;
+ }
+ break;
+
+ default:
+ fixblock(&sp->stm1, NULL);
+ fixblock(&sp->stm2, NULL);
+ sp->exp1 = fixexpr(sp->exp1, ENV_EXPR);
+ sp->exp2 = fixexpr(sp->exp2, ENV_EXPR);
+ sp->exp3 = fixexpr(sp->exp3, ENV_EXPR);
+ if (sp->next &&
+ (sp->kind == SK_GOTO ||
+ sp->kind == SK_BREAK ||
+ sp->kind == SK_CONTINUE ||
+ sp->kind == SK_RETURN) &&
+ !haslabels(sp->next)) {
+ if (elimdeadcode) {
+ note("Deleting unreachable code [255]");
+ while (sp->next && !haslabels(sp->next))
+ eatstmt(&sp->next);
+ } else {
+ note("Code is unreachable [256]");
+ }
+ } else if (sp->kind == SK_RETURN &&
+ thisreturn &&
+ thisreturn->kind == SK_RETURN &&
+ exprsame(sp->exp1, thisreturn->exp1, 1)) {
+ eatstmt(spp);
+ continue;
+ }
+ break;
+ }
+ spp = &sp->next;
+ }
+ saveserial = curserial;
+}
+
+
+
+
+/* Convert comma expressions into multiple statements */
+
+Static int checkcomma_expr(spp, exp)
+Stmt **spp;
+Expr **exp;
+{
+ Stmt *sp;
+ Expr *ex = *exp;
+ int i, res;
+
+ switch (ex->kind) {
+
+ case EK_COMMA:
+ if (spp) {
+ res = checkcomma_expr(spp, &ex->args[ex->nargs-1]);
+ for (i = ex->nargs-1; --i >= 0; ) {
+ sp = makestmt(SK_ASSIGN);
+ sp->exp1 = ex->args[i];
+ sp->next = *spp;
+ *spp = sp;
+ res = checkcomma_expr(spp, &ex->args[i]);
+ }
+ *exp = ex->args[ex->nargs-1];
+ }
+ return 1;
+
+ case EK_COND:
+ if (isescape(ex->args[1]) && spp &&
+ !isescape(ex->args[2])) {
+ swapexprs(ex->args[1], ex->args[2]);
+ ex->args[0] = makeexpr_not(ex->args[0]);
+ }
+ if (isescape(ex->args[2])) {
+ if (spp) {
+ res = checkcomma_expr(spp, &ex->args[1]);
+ if (ex->args[0]->kind == EK_ASSIGN) {
+ sp = makestmt(SK_ASSIGN);
+ sp->exp1 = copyexpr(ex->args[0]);
+ sp->next = makestmt(SK_IF);
+ sp->next->next = *spp;
+ *spp = sp;
+ res = checkcomma_expr(spp, &sp->exp1);
+ ex->args[0] = grabarg(ex->args[0], 0);
+ sp = sp->next;
+ } else {
+ sp = makestmt(SK_IF);
+ sp->next = *spp;
+ *spp = sp;
+ }
+ sp->exp1 = makeexpr_not(ex->args[0]);
+ sp->stm1 = makestmt(SK_ASSIGN);
+ sp->stm1->exp1 = eatcasts(ex->args[2]);
+ res = checkcomma_expr(&sp->stm1, &ex->args[2]);
+ res = checkcomma_expr(spp, &sp->exp1);
+ *exp = ex->args[1];
+ }
+ return 1;
+ }
+ return checkcomma_expr(spp, &ex->args[0]);
+
+ case EK_AND:
+ case EK_OR:
+ return checkcomma_expr(spp, &ex->args[0]);
+
+ default:
+ res = 0;
+ for (i = ex->nargs; --i >= 0; ) {
+ res += checkcomma_expr(spp, &ex->args[i]);
+ }
+ return res;
+
+ }
+}
+
+
+
+Static void checkcommas(spp)
+Stmt **spp;
+{
+ Stmt *sp;
+ int res;
+
+ while ((sp = *spp)) {
+ checkcommas(&sp->stm1);
+ checkcommas(&sp->stm2);
+ switch (sp->kind) {
+
+ case SK_ASSIGN:
+ case SK_IF:
+ case SK_CASE:
+ case SK_RETURN:
+ if (sp->exp1)
+ res = checkcomma_expr(spp, &sp->exp1);
+ break;
+
+ case SK_WHILE:
+ /* handle the argument */
+ break;
+
+ case SK_REPEAT:
+ /* handle the argument */
+ break;
+
+ case SK_FOR:
+ if (sp->exp1)
+ res = checkcomma_expr(spp, &sp->exp1);
+ /* handle the other arguments */
+ break;
+
+ default:
+ break;
+ }
+ spp = &sp->next;
+ }
+}
+
+
+
+
+Static int checkvarchangeable(ex, mp)
+Expr *ex;
+Meaning *mp;
+{
+ switch (ex->kind) {
+
+ case EK_VAR:
+ return (mp == (Meaning *)ex->val.i);
+
+ case EK_DOT:
+ case EK_INDEX:
+ return checkvarchangeable(ex->args[0], mp);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+int checkvarchangedexpr(ex, mp, addrokay)
+Expr *ex;
+Meaning *mp;
+int addrokay;
+{
+ int i;
+ Meaning *mp3;
+ unsigned int safemask = 0;
+
+ switch (ex->kind) {
+
+ case EK_FUNCTION:
+ case EK_SPCALL:
+ if (ex->kind == EK_FUNCTION) {
+ i = 0;
+ mp3 = ((Meaning *)ex->val.i)->type->fbase;
+ } else {
+ i = 1;
+ if (ex->args[0]->val.type->kind != TK_PROCPTR)
+ return 1;
+ mp3 = ex->args[0]->val.type->basetype->fbase;
+ }
+ for ( ; i < ex->nargs && i < 16; i++) {
+ if (!mp3) {
+ intwarning("checkvarchangedexpr", "Too many arguments for EK_FUNCTION [266]");
+ break;
+ }
+ if (mp3->kind == MK_PARAM &&
+ (mp3->type->kind == TK_ARRAY ||
+ mp3->type->kind == TK_STRING ||
+ mp3->type->kind == TK_SET))
+ safemask |= 1<<i;
+ if (mp3->kind == MK_VARPARAM &&
+ mp3->type == tp_strptr && mp3->anyvarflag)
+ i++;
+ mp3 = mp3->xnext;
+ }
+ if (mp3)
+ intwarning("checkvarchangedexpr", "Too few arguments for EK_FUNCTION [267]");
+ break;
+
+ case EK_VAR:
+ if (mp == (Meaning *)ex->val.i) {
+ if ((mp->type->kind == TK_ARRAY ||
+ mp->type->kind == TK_STRING ||
+ mp->type->kind == TK_SET) &&
+ ex->val.type->kind == TK_POINTER && !addrokay)
+ return 1; /* must be an implicit & */
+ }
+ break;
+
+ case EK_ADDR:
+ case EK_ASSIGN:
+ case EK_POSTINC:
+ case EK_POSTDEC:
+ if (checkvarchangeable(ex->args[0], mp))
+ return 1;
+ break;
+
+ case EK_BICALL:
+ if (structuredfunc(ex) && checkvarchangeable(ex->args[0], mp))
+ return 1;
+ safemask = safemask_bicall(ex->val.s);
+ break;
+ /* In case calls to these functions were lazy and passed
+ the array rather than its (implicit) address. Other
+ BICALLs had better be careful about their arguments. */
+
+ case EK_PLUS:
+ if (addrokay) /* to keep from being scared by pointer */
+ safemask = ~0; /* arithmetic on string being passed */
+ break; /* to functions. */
+
+ default:
+ break;
+ }
+ for (i = 0; i < ex->nargs; i++) {
+ if (checkvarchangedexpr(ex->args[i], mp, safemask&1))
+ return 1;
+ safemask >>= 1;
+ }
+ return 0;
+}
+
+
+
+int checkvarchanged(sp, mp)
+Stmt *sp;
+Meaning *mp;
+{
+ if (mp->constqual)
+ return 0;
+ if (mp->varstructflag || !mp->ctx || mp->ctx->kind != MK_FUNCTION ||
+ mp->volatilequal || alwayscopyvalues)
+ return 1;
+ while (sp) {
+ if (/* sp->kind == SK_GOTO || */
+ sp->kind == SK_LABEL ||
+ checkvarchanged(sp->stm1, mp) ||
+ checkvarchanged(sp->stm2, mp) ||
+ (sp->exp1 && checkvarchangedexpr(sp->exp1, mp, 1)) ||
+ (sp->exp2 && checkvarchangedexpr(sp->exp2, mp, 1)) ||
+ (sp->exp3 && checkvarchangedexpr(sp->exp3, mp, 1)))
+ return 1;
+ sp = sp->next;
+ }
+ return 0;
+}
+
+
+
+int checkexprchanged(sp, ex)
+Stmt *sp;
+Expr *ex;
+{
+ Meaning *mp;
+ int i;
+
+ for (i = 0; i < ex->nargs; i++) {
+ if (checkexprchanged(sp, ex->args[i]))
+ return 1;
+ }
+ switch (ex->kind) {
+
+ case EK_VAR:
+ mp = (Meaning *)ex->val.i;
+ if (mp->kind == MK_CONST)
+ return 0;
+ else
+ return checkvarchanged(sp, mp);
+
+ case EK_HAT:
+ case EK_INDEX:
+ case EK_SPCALL:
+ return 1;
+
+ case EK_FUNCTION:
+ case EK_BICALL:
+ return !nosideeffects_func(ex);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+
+
+/* Check if a variable always occurs with a certain offset added, e.g. "i+1" */
+
+Static int theoffset, numoffsets, numzerooffsets;
+#define BadOffset (-999)
+
+void checkvaroffsetexpr(ex, mp, myoffset)
+Expr *ex;
+Meaning *mp;
+int myoffset;
+{
+ int i, nextoffset = 0;
+ Expr *ex2;
+
+ if (!ex)
+ return;
+ switch (ex->kind) {
+
+ case EK_VAR:
+ if (ex->val.i == (long)mp) {
+ if (myoffset == 0)
+ numzerooffsets++;
+ else if (numoffsets == 0 || myoffset == theoffset) {
+ theoffset = myoffset;
+ numoffsets++;
+ } else
+ theoffset = BadOffset;
+ }
+ break;
+
+ case EK_PLUS:
+ ex2 = ex->args[ex->nargs-1];
+ if (ex2->kind == EK_CONST &&
+ ex2->val.type->kind == TK_INTEGER) {
+ nextoffset = ex2->val.i;
+ }
+ break;
+
+ case EK_HAT:
+ case EK_POSTINC:
+ case EK_POSTDEC:
+ nextoffset = BadOffset;
+ break;
+
+ case EK_ASSIGN:
+ checkvaroffsetexpr(ex->args[0], mp, BadOffset);
+ checkvaroffsetexpr(ex->args[1], mp, 0);
+ return;
+
+ default:
+ break;
+ }
+ i = ex->nargs;
+ while (--i >= 0)
+ checkvaroffsetexpr(ex->args[i], mp, nextoffset);
+}
+
+
+void checkvaroffsetstmt(sp, mp)
+Stmt *sp;
+Meaning *mp;
+{
+ while (sp) {
+ checkvaroffsetstmt(sp->stm1, mp);
+ checkvaroffsetstmt(sp->stm1, mp);
+ checkvaroffsetexpr(sp->exp1, mp, 0);
+ checkvaroffsetexpr(sp->exp2, mp, 0);
+ checkvaroffsetexpr(sp->exp3, mp, 0);
+ sp = sp->next;
+ }
+}
+
+
+int checkvaroffset(sp, mp)
+Stmt *sp;
+Meaning *mp;
+{
+ if (mp->varstructflag || !mp->ctx || mp->ctx->kind != MK_FUNCTION)
+ return 0;
+ numoffsets = 0;
+ numzerooffsets = 0;
+ checkvaroffsetstmt(sp, mp);
+ if (numoffsets == 0 || theoffset == BadOffset ||
+ numoffsets <= numzerooffsets * 3)
+ return 0;
+ else
+ return theoffset;
+}
+
+
+
+
+Expr *initfilevar(ex)
+Expr *ex;
+{
+ Expr *ex2;
+ Meaning *mp;
+ char *name;
+
+ if (ex->val.type->kind == TK_BIGFILE) {
+ ex2 = copyexpr(ex);
+ if (ex->kind == EK_VAR &&
+ (mp = (Meaning *)ex->val.i)->kind == MK_VAR &&
+ mp->ctx->kind != MK_FUNCTION &&
+ !is_std_file(ex) &&
+ literalfilesflag > 0 &&
+ (literalfilesflag == 1 ||
+ strlist_cifind(literalfiles, mp->name)))
+ name = mp->name;
+ else
+ name = "";
+ return makeexpr_comma(makeexpr_assign(filebasename(ex),
+ makeexpr_nil()),
+ makeexpr_assign(makeexpr_dotq(ex2, "name",
+ tp_str255),
+ makeexpr_string(name)));
+ } else {
+ return makeexpr_assign(ex, makeexpr_nil());
+ }
+}
+
+
+void initfilevars(mp, sppp, exbase)
+Meaning *mp;
+Stmt ***sppp;
+Expr *exbase;
+{
+ Stmt *sp;
+ Type *tp;
+ Expr *ex;
+
+ while (mp) {
+ if ((mp->kind == MK_VAR && mp->refcount > 0 && !mp->istemporary) ||
+ mp->kind == MK_FIELD) {
+ tp = mp->type;
+ if (isfiletype(tp, -1)) {
+ mp->refcount++;
+ sp = makestmt(SK_ASSIGN);
+ sp->next = **sppp;
+ **sppp = sp;
+ if (exbase)
+ ex = makeexpr_dot(copyexpr(exbase), mp);
+ else
+ ex = makeexpr_var(mp);
+ sp->exp1 = initfilevar(copyexpr(ex));
+ } else if (tp->kind == TK_RECORD) {
+ if (exbase)
+ ex = makeexpr_dot(copyexpr(exbase), mp);
+ else
+ ex = makeexpr_var(mp);
+ initfilevars(tp->fbase, sppp, ex);
+ freeexpr(ex);
+ } else if (tp->kind == TK_ARRAY) {
+ while (tp->kind == TK_ARRAY)
+ tp = tp->basetype;
+ if (isfiletype(tp, -1))
+ note(format_s("Array of files %s should be initialized [257]",
+ mp->name));
+ }
+ }
+ mp = mp->cnext;
+ }
+}
+
+
+
+
+
+Static Stmt *p_body()
+{
+ Stmt *sp, **spp, *spbody, **sppbody, *spbase, *thereturn;
+ Meaning *mp;
+ Expr *ex;
+ int haspostamble;
+ long saveserial;
+
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: Translating %s (in %s)\n",
+ infname, inf_lnum, outf_lnum,
+ curctx->name, curctx->ctx->name);
+ notephase = 1;
+ spp = &spbase;
+ addstmt(SK_HEADER);
+ sp->exp1 = makeexpr_var(curctx);
+ checkkeyword(TOK_INLINE);
+ if (curtok != TOK_END && curtok != TOK_BEGIN && curtok != TOK_INLINE) {
+ if (curctx->kind == MK_FUNCTION || curctx->anyvarflag)
+ wexpecttok(TOK_BEGIN);
+ else
+ wexpecttok(TOK_END);
+ skiptotoken2(TOK_BEGIN, TOK_END);
+ }
+ if (curtok == TOK_END) {
+ gettok();
+ spbody = NULL;
+ } else {
+ spbody = p_stmt(NULL, SF_FUNC); /* parse the procedure/program body */
+ }
+ if (curtok == TOK_IDENT && curtokmeaning == curctx) {
+ gettok(); /* Modula-2 */
+ }
+ notephase = 2;
+ saveserial = curserial;
+ curserial = 10000;
+ if (curctx->kind == MK_FUNCTION) { /* handle copy parameters */
+ for (mp = curctx->type->fbase; mp; mp = mp->xnext) {
+ if (!mp->othername && mp->varstructflag) {
+ mp->othername = stralloc(format_s(name_COPYPAR, mp->name));
+ mp->rectype = mp->type;
+ addstmt(SK_ASSIGN);
+ sp->exp1 = makeexpr_assign(makeexpr_var(mp),
+ makeexpr_name(mp->othername, mp->rectype));
+ mp->refcount++;
+ } else if (mp->othername) {
+ if (checkvarchanged(spbody, mp)) {
+ addstmt(SK_ASSIGN);
+ sp->exp1 = makeexpr_assign(makeexpr_var(mp),
+ makeexpr_hat(makeexpr_name(mp->othername,
+ mp->rectype), 0));
+ mp->refcount++;
+ } else { /* don't need to copy it after all */
+ strchange(&mp->othername, mp->name);
+ ex = makeexpr_var(mp);
+ ex->val.type = mp->rectype;
+ replaceexpr(spbody, makeexpr_var(mp), makeexpr_hat(ex, 0));
+ }
+ }
+ }
+ }
+ for (mp = curctx->cbase; mp; mp = mp->cnext) {
+ if (mp->kind == MK_LABEL && mp->val.i) {
+ addstmt(SK_IF);
+ sp->exp1 = makeexpr_bicall_1("setjmp", tp_int,
+ makeexpr_var(mp->xnext));
+ sp->stm1 = makestmt(SK_GOTO);
+ sp->stm1->exp1 = makeexpr_name(format_s(name_LABEL, mp->name),
+ tp_integer);
+ }
+ }
+ *spp = spbody;
+ sppbody = spp;
+ while (*spp)
+ spp = &((*spp)->next);
+ haspostamble = 0;
+ initfilevars(curctx->cbase, &sppbody, NULL);
+ for (mp = curctx->cbase; mp; mp = mp->cnext) {
+ if (mp->kind == MK_VAR && mp->refcount > 0 &&
+ isfiletype(mp->type, -1) &&
+ !mp->istemporary) {
+ if (curctx->kind != MK_MODULE || curctx->anyvarflag) {
+ addstmt(SK_IF); /* close file variables */
+ sp->exp1 = makeexpr_rel(EK_NE, filebasename(makeexpr_var(mp)),
+ makeexpr_nil());
+ sp->stm1 = makestmt(SK_ASSIGN);
+ sp->stm1->exp1 = makeexpr_bicall_1("fclose", tp_void,
+ filebasename(makeexpr_var(mp)));
+ }
+ haspostamble = 1;
+ }
+ }
+ thereturn = &bogusreturn;
+ if (curctx->kind == MK_FUNCTION && curctx->type->basetype != tp_void) {
+ if ((haspostamble || !checkreturns(&spbase, 1)) &&
+ curctx->cbase->refcount > 0) { /* add function return code */
+ addstmt(SK_RETURN);
+ sp->exp1 = makeexpr_var(curctx->cbase);
+ }
+ thereturn = NULL;
+ } else if (curctx->kind == MK_MODULE && curctx->anyvarflag) {
+ addstmt(SK_ASSIGN);
+ sp->exp1 = makeexpr_bicall_1("exit", tp_void,
+ makeexpr_name("EXIT_SUCCESS",
+ tp_integer));
+ thereturn = NULL;
+ }
+ if (debug>2) { fprintf(outf, "calling fixblock/usecommas on:\n"); dumpstmt(spbase, 5); }
+ curserial = saveserial;
+ sp = makestmt(SK_BODY);
+ sp->stm1 = spbase;
+ fixblock(&sp, thereturn); /* finishing touches to statements and expressions */
+ spbase = sp->stm1;
+ FREE(sp);
+ if (usecommas != 1)
+ checkcommas(&spbase); /* unroll ugly EK_COMMA and EK_COND expressions */
+ if (debug>1) { fprintf(outf, "p_body returns:\n"); dumpstmt(spbase, 5); }
+ notephase = 0;
+ return spbase;
+}
+
+
+
+
+#define checkWord() if (anywords) output(" "); anywords = 1
+
+Static void out_function(func)
+Meaning *func;
+{
+ Meaning *mp;
+ Symbol *sym;
+ int opts, anywords, spacing, saveindent;
+
+ if (func->varstructflag) {
+ makevarstruct(func);
+ }
+ if (collectnest) {
+ for (mp = func->cbase; mp; mp = mp->cnext) {
+ if (mp->kind == MK_FUNCTION && mp->isforward) {
+ forward_decl(mp, 0);
+ }
+ }
+ for (mp = func->cbase; mp; mp = mp->cnext) {
+ if (mp->kind == MK_FUNCTION && mp->type && !mp->exported) {
+ pushctx(mp);
+ out_function(mp); /* generate the sub-procedures first */
+ popctx();
+ }
+ }
+ }
+ spacing = functionspace;
+ for (mp = func; mp->ctx->kind == MK_FUNCTION; mp = mp->ctx) {
+ if (spacing > minfuncspace)
+ spacing--;
+ }
+ outsection(spacing);
+ flushcomments(&func->comments, -1, 0);
+ if (usePPMacros == 1) {
+ forward_decl(func, 0);
+ outsection(minorspace);
+ }
+ opts = ODECL_HEADER;
+ anywords = 0;
+ if (func->namedfile) {
+ checkWord();
+ if (useAnyptrMacros || ansiC < 2)
+ output("Inline");
+ else
+ output("inline");
+ }
+ if (!func->exported) {
+ if (func->ctx->kind == MK_FUNCTION) {
+ if (useAnyptrMacros) {
+ checkWord();
+ output("Local");
+ } else if (use_static) {
+ checkWord();
+ output("static");
+ }
+ } else if ((findsymbol(func->name)->flags & NEEDSTATIC) ||
+ (use_static != 0 && !useAnyptrMacros)) {
+ checkWord();
+ output("static");
+ } else if (useAnyptrMacros) {
+ checkWord();
+ output("Static");
+ }
+ }
+ if (func->type->basetype != tp_void || ansiC != 0) {
+ checkWord();
+ outbasetype(func->type, 0);
+ }
+ if (anywords) {
+ if (newlinefunctions)
+ opts |= ODECL_FUNCTION;
+ else
+ output(" ");
+ }
+ outdeclarator(func->type, func->name, opts);
+ if (fullprototyping == 0) {
+ saveindent = outindent;
+ moreindent(argindent);
+ out_argdecls(func->type);
+ outindent = saveindent;
+ }
+ for (mp = func->type->fbase; mp; mp = mp->xnext) {
+ if (mp->othername && strcmp(mp->name, mp->othername))
+ mp->wasdeclared = 0; /* make sure we also declare the copy */
+ }
+ func->wasdeclared = 1;
+ outcontext = func;
+ out_block((Stmt *)func->val.i, BR_FUNCTION, 10000);
+ if (useundef) {
+ anywords = 0;
+ for (mp = func->cbase; mp; mp = mp->cnext) {
+ if (mp->kind == MK_CONST &&
+ mp->isreturn) { /* the was-#defined flag */
+ if (!anywords)
+ outsection(minorspace);
+ anywords++;
+ output(format_s("#undef %s\n", mp->name));
+ sym = findsymbol(mp->name);
+ sym->flags &= ~AVOIDNAME;
+ }
+ }
+ }
+ if (conserve_mem) {
+ free_stmt((Stmt *)func->val.i); /* is this safe? */
+ func->val.i = 0;
+ forget_ctx(func, 0);
+ }
+ outsection(spacing);
+}
+
+
+
+
+void movetoend(mp)
+Meaning *mp;
+{
+ Meaning **mpp;
+
+ if (mp->ctx != curctx) {
+ intwarning("movetoend", "curctx is wrong [268]");
+ } else {
+ mpp = &mp->ctx->cbase; /* move a meaning to end of its parent context */
+ while (*mpp != mp) {
+ if (!*mpp) {
+ intwarning("movetoend", "meaning not on its context list [269]");
+ return;
+ }
+ mpp = &(*mpp)->cnext;
+ }
+ *mpp = mp->cnext; /* Remove from present position in list */
+ while (*mpp)
+ mpp = &(*mpp)->cnext;
+ *mpp = mp; /* Insert at end of list */
+ mp->cnext = NULL;
+ curctxlast = mp;
+ }
+}
+
+
+
+Static void scanfwdparams(mp)
+Meaning *mp;
+{
+ Symbol *sym;
+
+ mp = mp->type->fbase;
+ while (mp) {
+ sym = findsymbol(mp->name);
+ sym->flags |= FWDPARAM;
+ mp = mp->xnext;
+ }
+}
+
+
+
+Static void p_function(isfunc)
+int isfunc;
+{
+ Meaning *func;
+ Type *type;
+ Stmt *sp;
+ Strlist *sl, *comments, *savecmt;
+ int initializeattr = 0, isinline = 0;
+
+ if ((sl = strlist_find(attrlist, "INITIALIZE")) != NULL) {
+ initializeattr = 1;
+ strlist_delete(&attrlist, sl);
+ }
+ if ((sl = strlist_find(attrlist, "OPTIMIZE")) != NULL &&
+ sl->value != -1 &&
+ !strcmp((char *)(sl->value), "INLINE")) {
+ isinline = 1;
+ strlist_delete(&attrlist, sl);
+ }
+ ignore_attributes();
+ comments = extractcomment(&curcomments, -1, curserial);
+ changecomments(comments, -1, -1, -1, 0);
+ if (curctx->kind == MK_FUNCTION) { /* sub-procedure */
+ savecmt = curcomments;
+ } else {
+ savecmt = NULL;
+ flushcomments(&curcomments, -1, -1);
+ }
+ curcomments = comments;
+ curserial = serialcount = 1;
+ gettok();
+ if (!wexpecttok(TOK_IDENT))
+ skiptotoken(TOK_IDENT);
+ if (curtokmeaning && curtokmeaning->ctx == curctx &&
+ curtokmeaning->kind == MK_FUNCTION) {
+ func = curtokmeaning;
+ if (!func->isforward || func->val.i)
+ warning(format_s("Redeclaration of function %s [270]", func->name));
+ skiptotoken(TOK_SEMI);
+ movetoend(func);
+ pushctx(func);
+ type = func->type;
+ } else {
+ func = addmeaning(curtoksym, MK_FUNCTION);
+ gettok();
+ func->val.i = 0;
+ pushctx(func);
+ func->type = type = p_funcdecl(&isfunc, 0);
+ func->isfunction = isfunc;
+ func->namedfile = isinline;
+ type->meaning = func;
+ }
+ if (blockkind == TOK_EXPORT)
+ flushcomments(NULL, -1, -1);
+ wneedtok(TOK_SEMI);
+ if (initializeattr) {
+ sl = strlist_append(&initialcalls, format_s("%s()", func->name));
+ sl->value = 1;
+ }
+ if (curtok == TOK_IDENT && !strcmp(curtokbuf, "C")) {
+ gettok();
+ wneedtok(TOK_SEMI);
+ }
+ if (blockkind == TOK_IMPORT) {
+ strlist_empty(&curcomments);
+ if (curtok == TOK_IDENT &&
+ (!strcicmp(curtokbuf, "FORWARD") ||
+ strlist_cifind(externwords, curtokbuf) ||
+ strlist_cifind(cexternwords, curtokbuf))) {
+ gettok();
+ while (curtok == TOK_IDENT)
+ gettok();
+ wneedtok(TOK_SEMI);
+ }
+ /* do nothing more */
+ } else if (blockkind == TOK_EXPORT) {
+ func->isforward = 1;
+ scanfwdparams(func);
+ forward_decl(func, 1);
+ } else {
+ checkkeyword(TOK_INTERRUPT);
+ checkkeyword(TOK_INLINE);
+ if (curtok == TOK_INTERRUPT) {
+ note("Ignoring INTERRUPT keyword [258]");
+ gettok();
+ wneedtok(TOK_SEMI);
+ }
+ if (curtok == TOK_IDENT && !strcicmp(curtokbuf, "FORWARD")) {
+ func->isforward = 1;
+ scanfwdparams(func);
+ gettok();
+ if (func->ctx->kind != MK_FUNCTION) {
+ outsection(minorspace);
+ flushcomments(NULL, -1, -1);
+ forward_decl(func, 0);
+ outsection(minorspace);
+ }
+ } else if (curtok == TOK_IDENT &&
+ (strlist_cifind(externwords, curtokbuf) ||
+ strlist_cifind(cexternwords, curtokbuf))) {
+ if (*externalias && my_strchr(externalias, '%')) {
+ strchange(&func->name, format_s(externalias, func->name));
+ } else if (strlist_cifind(cexternwords, curtokbuf)) {
+ if (func->name[0] == '_')
+ strchange(&func->name, func->name + 1);
+ if (func->name[strlen(func->name)-1] == '_')
+ func->name[strlen(func->name)-1] = 0;
+ }
+ func->isforward = 1; /* for Oregon Software Pascal-2 */
+ func->exported = 1;
+ gettok();
+ while (curtok == TOK_IDENT)
+ gettok();
+ outsection(minorspace);
+ flushcomments(NULL, -1, -1);
+ scanfwdparams(func);
+ forward_decl(func, 1);
+ outsection(minorspace);
+ } else if (curtok == TOK_IDENT) {
+ wexpecttok(TOK_BEGIN); /* print warning */
+ gettok();
+ outsection(minorspace);
+ flushcomments(NULL, -1, -1);
+ scanfwdparams(func);
+ forward_decl(func, 1);
+ outsection(minorspace);
+ } else {
+ if (func->ctx->kind == MK_FUNCTION)
+ func->ctx->needvarstruct = 1;
+ func->comments = curcomments;
+ curcomments = NULL;
+ p_block(TOK_FUNCTION);
+ echoprocname(func);
+ changecomments(curcomments, -1, curserial, -1, 10000);
+ sp = p_body();
+ func->ctx->needvarstruct = 0;
+ func->val.i = (long)sp;
+ strlist_mix(&func->comments, curcomments);
+ curcomments = NULL;
+ if (func->ctx->kind != MK_FUNCTION || !collectnest) {
+ out_function(func); /* output top-level procedures immediately */
+ } /* (sub-procedures are output later) */
+ }
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+ }
+ strlist_mix(&curcomments, savecmt);
+ popctx();
+}
+
+
+
+Static void out_include(name, quoted)
+char *name;
+int quoted;
+{
+ if (*name == '"' || *name == '<')
+ output(format_s("#include %s\n", name));
+ else if (quoted)
+ output(format_s("#include \"%s\"\n", name));
+ else
+ output(format_s("#include <%s>\n", name));
+}
+
+
+Static void cleanheadername(dest, name)
+char *dest, *name;
+{
+ char *cp;
+ int len;
+
+ if (*name == '<' || *name == '"')
+ name++;
+ cp = my_strrchr(name, '/');
+ if (cp)
+ cp++;
+ else
+ cp = name;
+ strcpy(dest, cp);
+ len = strlen(dest);
+ if (dest[len-1] == '>' || dest[len-1] == '"')
+ dest[len-1] = 0;
+}
+
+
+
+
+Static int tryimport(sym, fname, ext, need)
+Symbol *sym;
+char *fname, *ext;
+int need;
+{
+ int found = 0;
+ Meaning *savectx, *savectxlast;
+
+ savectx = curctx;
+ savectxlast = curctxlast;
+ curctx = nullctx;
+ curctxlast = curctx->cbase;
+ while (curctxlast && curctxlast->cnext)
+ curctxlast = curctxlast->cnext;
+ if (p_search(fname, ext, need)) {
+ curtokmeaning = sym->mbase;
+ while (curtokmeaning && !curtokmeaning->isactive)
+ curtokmeaning = curtokmeaning->snext;
+ if (curtokmeaning)
+ found = 1;
+ }
+ curctx = savectx;
+ curctxlast = savectxlast;
+ return found;
+}
+
+
+
+Static void p_import(inheader)
+int inheader;
+{
+ Strlist *sl;
+ Symbol *sym;
+ char *name;
+ int found, isfrom = (curtok == TOK_FROM);
+
+ outsection(minorspace);
+ do {
+ gettok();
+ if (!wexpecttok(TOK_IDENT)) {
+ skiptotoken(TOK_SEMI);
+ break;
+ }
+ sym = curtoksym;
+ if (curtokmeaning && curtokmeaning->kind == MK_MODULE) {
+ found = 1;
+ } else if (strlist_cifind(permimports, sym->name)) {
+ found = 2; /* built-in module, there already! */
+ } else {
+ found = 0;
+ sl = strlist_cifind(importfrom, sym->name);
+ name = (sl) ? format_none((char *)sl->value) : NULL;
+ if (name) {
+ if (tryimport(sym, name, "pas", 1))
+ found = 1;
+ } else {
+ for (sl = importdirs; sl && !found; sl = sl->next) {
+ if (tryimport(sym, format_s(sl->s, curtokcase), NULL, 0))
+ found = 1;
+ }
+ }
+ }
+ if (found == 1) {
+ if (!inheader) {
+ sl = strlist_cifind(includefrom, curtokmeaning->name);
+ name = (sl) ? (char *)sl->value :
+ format_ss(*headerfnfmt2 ? headerfnfmt2 : headerfnfmt,
+ infname, curtokmeaning->name);
+ if (name && !strlist_find(includedfiles, name)) {
+ strlist_insert(&includedfiles, name);
+ if (*name_HSYMBOL)
+ output(format_s("#ifndef %s\n", format_s(name_HSYMBOL, sym->name)));
+ out_include(name, quoteincludes);
+ if (*name_HSYMBOL)
+ output("#endif\n");
+ outsection(minorspace);
+ }
+ }
+ import_ctx(curtokmeaning);
+ } else if (curtokmeaning) {
+ /* Modula-2, importing a single ident */
+ /* Ignored for now, since we always import whole modules */
+ } else if (found == 0) {
+ warning(format_s("Could not find module %s [271]", sym->name));
+ if (!inheader) {
+ out_include(format_ss(*headerfnfmt2?headerfnfmt2:headerfnfmt,
+ sym->name, sym->name),
+ quoteincludes);
+ }
+ }
+ gettok();
+ } while (curtok == TOK_COMMA);
+ if (isfrom) {
+ checkkeyword(TOK_IMPORT);
+ if (wneedtok(TOK_IMPORT)) {
+ do {
+ gettok();
+ if (curtok == TOK_IDENT)
+ gettok();
+ } while (curtok == TOK_COMMA);
+ }
+ }
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+ outsection(minorspace);
+}
+
+
+
+
+void do_include(blkind)
+Token blkind;
+{
+ FILE *oldfile = outf;
+ int savelnum = outf_lnum;
+ char fname[256];
+
+ outsection(majorspace);
+ strcpy(fname, curtokbuf);
+ removesuffix(fname);
+ strcat(fname, ".c");
+ if (!strcmp(fname, codefname)) {
+ warning("Include file name conflict! [272]");
+ badinclude();
+ return;
+ }
+ saveoldfile(fname);
+ outf = fopen(fname, "w");
+ if (!outf) {
+ outf = oldfile;
+ perror(fname);
+ badinclude();
+ return;
+ }
+ outf_lnum = 1;
+ if (nobanner)
+ output("\n");
+ else
+ output(format_ss("\n/* Include file %s from %s */\n\n",
+ fname, codefname));
+ if (blkind == TOK_END)
+ gettok();
+ else
+ curtok = blkind;
+ p_block(blockkind);
+ if (nobanner)
+ output("\n");
+ else
+ output("\n\n/* End. */\n\n");
+ fclose(outf);
+ outf = oldfile;
+ outf_lnum = savelnum;
+ if (curtok != TOK_EOF) {
+ warning("Junk at end of include file ignored [273]");
+ }
+ outsection(majorspace);
+ if (*includefnfmt)
+ out_include(format_s(includefnfmt, fname), 1);
+ else
+ out_include(fname, 1);
+ outsection(majorspace);
+ pop_input();
+ p2c_getline();
+ gettok();
+}
+
+
+
+
+/* blockkind is one of:
+ TOK_PROGRAM: Global declarations of a program
+ TOK_FUNCTION: Declarations local to a procedure or function
+ TOK_IMPORT: Import text read from a module
+ TOK_EXPORT: Export section of a module
+ TOK_IMPLEMENT: Implementation section of a module
+ TOK_END: None of the above
+*/
+
+void p_block(blkind)
+Token blkind;
+{
+ Token saveblockkind = blockkind;
+ Token lastblockkind = TOK_END;
+
+ blockkind = blkind;
+ for (;;) {
+ while (curtok == TOK_INTFONLY) {
+ include_as_import();
+ gettok();
+ }
+ if (curtok == TOK_CONST || curtok == TOK_TYPE ||
+ curtok == TOK_VAR || curtok == TOK_VALUE) {
+ while (curtok == TOK_CONST || curtok == TOK_TYPE ||
+ curtok == TOK_VAR || curtok == TOK_VALUE) {
+ lastblockkind = curtok;
+ switch (curtok) {
+
+ case TOK_CONST:
+ p_constdecl();
+ break;
+
+ case TOK_TYPE:
+ p_typedecl();
+ break;
+
+ case TOK_VAR:
+ p_vardecl();
+ break;
+
+ case TOK_VALUE:
+ p_valuedecl();
+ break;
+
+ default:
+ break;
+ }
+ }
+ if ((blkind == TOK_PROGRAM ||
+ blkind == TOK_EXPORT ||
+ blkind == TOK_IMPLEMENT) &&
+ (curtok != TOK_BEGIN || !mainlocals)) {
+ outsection(majorspace);
+ if (declarevars(curctx, 0))
+ outsection(majorspace);
+ }
+ } else {
+ checkmodulewords();
+ checkkeyword(TOK_SEGMENT);
+ if (curtok == TOK_SEGMENT) {
+ note("SEGMENT or OVERLAY keyword ignored [259]");
+ gettok();
+ }
+ p_attributes();
+ switch (curtok) {
+
+ case TOK_LABEL:
+ p_labeldecl();
+ break;
+
+ case TOK_IMPORT:
+ case TOK_FROM:
+ p_import(0);
+ break;
+
+ case TOK_EXPORT:
+ do {
+ gettok();
+ checkkeyword(TOK_QUALIFIED);
+ if (curtok == TOK_QUALIFIED)
+ gettok();
+ wneedtok(TOK_IDENT);
+ } while (curtok == TOK_COMMA);
+ if (!wneedtok(TOK_SEMI))
+ skippasttoken(TOK_SEMI);
+ break;
+
+ case TOK_MODULE:
+ p_nested_module();
+ break;
+
+ case TOK_PROCEDURE:
+ p_function(0);
+ break;
+
+ case TOK_FUNCTION:
+ p_function(1);
+ break;
+
+ case TOK_INCLUDE:
+ if (blockkind == TOK_PROGRAM ||
+ blockkind == TOK_IMPLEMENT ||
+ (blockkind == TOK_FUNCTION && !collectnest)) {
+ do_include(lastblockkind);
+ } else {
+ badinclude();
+ }
+ break;
+
+ default:
+ if (curtok == TOK_BEGIN && blockkind == TOK_IMPORT) {
+ warning("BEGIN encountered in interface text [274]");
+ skipparens();
+ if (curtok == TOK_SEMI)
+ gettok();
+ break;
+ }
+ blockkind = saveblockkind;
+ return;
+ }
+ lastblockkind = TOK_END;
+ }
+ }
+}
+
+
+
+
+Static void skipunitheader()
+{
+ if (curtok == TOK_LPAR || curtok == TOK_LBR) {
+ skipparens();
+ }
+}
+
+
+Static void skiptomodule()
+{
+ skipping_module++;
+ while (curtok != TOK_MODULE) {
+ if (curtok == TOK_END) {
+ gettok();
+ if (curtok == TOK_DOT)
+ break;
+ } else
+ gettok();
+ }
+ skipping_module--;
+}
+
+
+
+Static void p_moduleinit(mod)
+Meaning *mod;
+{
+ Stmt *sp;
+ Strlist *sl;
+
+ if (curtok != TOK_BEGIN && curtok != TOK_END) {
+ wexpecttok(TOK_END);
+ skiptotoken2(TOK_BEGIN, TOK_END);
+ }
+ if (curtok == TOK_BEGIN || initialcalls) {
+ echoprocname(mod);
+ sp = p_body();
+ strlist_mix(&mod->comments, curcomments);
+ curcomments = NULL;
+ if (ansiC != 0)
+ output("void ");
+ output(format_s(name_UNITINIT, mod->name));
+ if (void_args)
+ output("(void)\n");
+ else
+ output("()\n");
+ outcontext = mod;
+ out_block(sp, BR_FUNCTION, 10000);
+ free_stmt(sp);
+ /* The following must come after out_block! */
+ sl = strlist_append(&initialcalls,
+ format_s("%s()",
+ format_s(name_UNITINIT, mod->name)));
+ sl->value = 1;
+ } else
+ wneedtok(TOK_END);
+}
+
+
+
+Static void p_nested_module()
+{
+ Meaning *mp;
+
+ if (!modula2) {
+ note("Ignoring nested module [260]");
+ p_module(1, 0);
+ return;
+ }
+ note("Nested modules not fully supported [261]");
+ checkmodulewords();
+ wneedtok(TOK_MODULE);
+ wexpecttok(TOK_IDENT);
+ mp = addmeaning(curtoksym, MK_MODULE);
+ mp->anyvarflag = 0;
+ gettok();
+ skipunitheader();
+ wneedtok(TOK_SEMI);
+ p_block(TOK_IMPLEMENT);
+ p_moduleinit(mp);
+ if (curtok == TOK_IDENT)
+ gettok();
+ wneedtok(TOK_SEMI);
+}
+
+
+
+Static int p_module(ignoreit, isdefn)
+int ignoreit;
+int isdefn; /* Modula-2: 0=local module, 1=DEFINITION, 2=IMPLEMENTATION */
+{
+ Meaning *mod, *mp;
+ Strlist *sl;
+ int kind;
+ char *cp;
+
+ checkmodulewords();
+ wneedtok(TOK_MODULE);
+ wexpecttok(TOK_IDENT);
+ if (curtokmeaning && curtokmeaning->kind == MK_MODULE && isdefn == 2) {
+ mod = curtokmeaning;
+ import_ctx(mod);
+ for (mp = mod->cbase; mp; mp = mp->cnext)
+ if (mp->kind == MK_FUNCTION)
+ mp->isforward = 1;
+ } else {
+ mod = addmeaning(curtoksym, MK_MODULE);
+ }
+ mod->anyvarflag = 0;
+ pushctx(mod);
+ gettok();
+ skipunitheader();
+ wneedtok(TOK_SEMI);
+ if (ignoreit ||
+ (requested_module && strcicmp(requested_module, mod->name))) {
+ if (!quietmode)
+ if (outf == stdout)
+ fprintf(stderr, "Skipping over module \"%s\"\n", mod->name);
+ else
+ printf("Skipping over module \"%s\"\n", mod->name);
+ checkmodulewords();
+ while (curtok == TOK_IMPORT || curtok == TOK_FROM)
+ p_import(1);
+ checkmodulewords();
+ if (curtok == TOK_EXPORT)
+ gettok();
+ strlist_empty(&curcomments);
+ p_block(TOK_IMPORT);
+ setup_module(mod->sym->name, 0);
+ checkmodulewords();
+ if (curtok == TOK_IMPLEMENT) {
+ skiptomodule();
+ } else {
+ if (!wneedtok(TOK_END))
+ skippasttoken(TOK_END);
+ if (curtok == TOK_SEMI)
+ gettok();
+ }
+ popctx();
+ strlist_empty(&curcomments);
+ return 0;
+ }
+ found_module = 1;
+ if (isdefn != 2) {
+ if (!*hdrfname) {
+ sl = strlist_cifind(includefrom, mod->name);
+ if (sl)
+ cleanheadername(hdrfname, (char *)sl->value);
+ else
+ strcpy(hdrfname, format_ss(headerfnfmt, infname, mod->name));
+ }
+ saveoldfile(hdrfname);
+ hdrf = fopen(hdrfname, "w");
+ if (!hdrf) {
+ perror(hdrfname);
+ error("Could not open output file for header");
+ }
+ outsection(majorspace);
+ if (usevextern && my_strchr(name_GSYMBOL, '%'))
+ output(format_s("#define %s\n", format_s(name_GSYMBOL, mod->sym->name)));
+ if (*selfincludefmt)
+ cp = format_s(selfincludefmt, hdrfname);
+ else
+ cp = hdrfname;
+ out_include(cp, quoteincludes);
+ outsection(majorspace);
+ select_outfile(hdrf);
+ if (nobanner)
+ output("\n");
+ else
+ output(format_s("/* Header for module %s, generated by p2c */\n",
+ mod->name));
+ if (*name_HSYMBOL) {
+ cp = format_s(name_HSYMBOL, mod->sym->name);
+ output(format_ss("#ifndef %s\n#define %s\n", cp, cp));
+ }
+ outsection(majorspace);
+ checkmodulewords();
+ while (curtok == TOK_IMPORT || curtok == TOK_FROM)
+ p_import(0);
+ checkmodulewords();
+ if (curtok == TOK_EXPORT)
+ gettok();
+ checkmodulewords();
+ while (curtok == TOK_IMPORT || curtok == TOK_FROM)
+ p_import(0);
+ outsection(majorspace);
+ if (usevextern) {
+ output(format_s("#ifdef %s\n# define vextern\n#else\n",
+ format_s(name_GSYMBOL, mod->sym->name)));
+ output("# define vextern extern\n#endif\n");
+ }
+ checkmodulewords();
+ p_block(TOK_EXPORT);
+ flushcomments(NULL, -1, -1);
+ setup_module(mod->sym->name, 1);
+ outsection(majorspace);
+ if (usevextern)
+ output("#undef vextern\n");
+ outsection(minorspace);
+ if (*name_HSYMBOL)
+ output(format_s("#endif /*%s*/\n", format_s(name_HSYMBOL, mod->sym->name)));
+ if (nobanner)
+ output("\n");
+ else
+ output("\n/* End. */\n\n");
+ select_outfile(codef);
+ fclose(hdrf);
+ *hdrfname = 0;
+ redeclarevars(mod);
+ declarevars(mod, 0);
+ }
+ checkmodulewords();
+ if (curtok != TOK_END) {
+ if (!modula2 && !implementationmodules)
+ wneedtok(TOK_IMPLEMENT);
+ import_ctx(mod);
+ p_block(TOK_IMPLEMENT);
+ flushcomments(NULL, -1, -1);
+ p_moduleinit(mod);
+ kind = 1;
+ } else {
+ kind = 0;
+ if (!wneedtok(TOK_END))
+ skippasttoken(TOK_END);
+ }
+ if (curtok == TOK_IDENT)
+ gettok();
+ if (curtok == TOK_SEMI)
+ gettok();
+ popctx();
+ return kind;
+}
+
+
+
+
+int p_search(fname, ext, need)
+char *fname, *ext;
+int need;
+{
+ char infnbuf[300];
+ FILE *fp;
+ Meaning *mod;
+ int savesysprog, savecopysource;
+ int outerimportmark, importmark, mypermflag;
+
+ strcpy(infnbuf, fname);
+ fixfname(infnbuf, ext);
+ fp = fopen(infnbuf, "r");
+ if (!fp) {
+ if (need)
+ perror(infnbuf);
+ if (logf)
+ fprintf(logf, "(Unable to open search file \"%s\")\n", infnbuf);
+ return 0;
+ }
+ flushcomments(NULL, -1, -1);
+ ignore_directives++;
+ savesysprog = sysprog_flag;
+ sysprog_flag |= 3;
+ savecopysource = copysource;
+ copysource = 0;
+ outerimportmark = numimports; /*obsolete*/
+ importmark = push_imports();
+ clearprogress();
+ push_input_file(fp, infnbuf, 0);
+ do {
+ strlist_empty(&curcomments);
+ checkmodulewords();
+ permflag = 0;
+ if (curtok == TOK_DEFINITION) {
+ gettok();
+ checkmodulewords();
+ } else if (curtok == TOK_IMPLEMENT && modula2) {
+ gettok();
+ checkmodulewords();
+ warning("IMPLEMENTATION module in search text! [275]");
+ }
+ if (!wneedtok(TOK_MODULE))
+ break;
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ mod = addmeaning(curtoksym, MK_MODULE);
+ mod->anyvarflag = 0;
+ if (!quietmode && !showprogress)
+ if (outf == stdout)
+ fprintf(stderr, "Reading import text for \"%s\"\n", mod->name);
+ else
+ printf("Reading import text for \"%s\"\n", mod->name);
+ if (verbose)
+ fprintf(logf, "%s, %d/%d: Reading import text for \"%s\"\n",
+ infname, inf_lnum, outf_lnum, mod->name);
+ pushctx(mod);
+ gettok();
+ skipunitheader();
+ wneedtok(TOK_SEMI);
+ mypermflag = permflag;
+ if (debug>0) printf("Found module %s\n", mod->name);
+ checkmodulewords();
+ while (curtok == TOK_IMPORT || curtok == TOK_FROM)
+ p_import(1);
+ checkmodulewords();
+ if (curtok == TOK_EXPORT)
+ gettok();
+ strlist_empty(&curcomments);
+ p_block(TOK_IMPORT);
+ setup_module(mod->sym->name, 0);
+ if (mypermflag) {
+ strlist_add(&permimports, mod->sym->name)->value = (long)mod;
+ perm_import(mod);
+ }
+ checkmodulewords();
+ if (curtok == TOK_END) {
+ gettok();
+ if (curtok == TOK_SEMI)
+ gettok();
+ } else {
+ wexpecttok(TOK_IMPLEMENT);
+ if (importall) {
+ skiptomodule();
+ }
+ }
+ popctx();
+ } while (curtok == TOK_MODULE);
+ pop_imports(importmark);
+ unimport(outerimportmark);
+ sysprog_flag = savesysprog;
+ copysource = savecopysource;
+ ignore_directives--;
+ pop_input();
+ strlist_empty(&curcomments);
+ clearprogress();
+ return 1;
+}
+
+
+
+
+void p_program()
+{
+ Meaning *prog;
+ Stmt *sp;
+ int nummods, isdefn = 0;
+
+ flushcomments(NULL, -1, -1);
+ output(format_s("\n#include %s\n", p2c_h_name));
+ outsection(majorspace);
+ p_attributes();
+ ignore_attributes();
+ checkmodulewords();
+ if (modula2) {
+ if (curtok == TOK_MODULE) {
+ curtok = TOK_PROGRAM;
+ } else {
+ if (curtok == TOK_DEFINITION) {
+ isdefn = 1;
+ gettok();
+ checkmodulewords();
+ } else if (curtok == TOK_IMPLEMENT) {
+ isdefn = 2;
+ gettok();
+ checkmodulewords();
+ }
+ }
+ }
+ switch (curtok) {
+
+ case TOK_MODULE:
+ if (implementationmodules)
+ isdefn = 2;
+ nummods = 0;
+ while (curtok == TOK_MODULE) {
+ if (p_module(0, isdefn)) {
+ nummods++;
+ if (nummods == 2 && !requested_module)
+ warning("Multiple modules in one source file may not work correctly [276]");
+ }
+ }
+ wneedtok(TOK_DOT);
+ break;
+
+ default:
+ if (curtok == TOK_PROGRAM) {
+ gettok();
+ if (!wexpecttok(TOK_IDENT))
+ skiptotoken(TOK_IDENT);
+ prog = addmeaning(curtoksym, MK_MODULE);
+ gettok();
+ if (curtok == TOK_LPAR) {
+ while (curtok != TOK_RPAR) {
+ if (curtok == TOK_IDENT &&
+ strcicmp(curtokbuf, "INPUT") &&
+ strcicmp(curtokbuf, "OUTPUT") &&
+ strcicmp(curtokbuf, "KEYBOARD") &&
+ strcicmp(curtokbuf, "LISTING")) {
+ if (literalfilesflag == 2) {
+ strlist_add(&literalfiles, curtokbuf);
+ } else
+ note(format_s("Unexpected name \"%s\" in program header [262]",
+ curtokcase));
+ }
+ gettok();
+ }
+ gettok();
+ }
+ if (curtok == TOK_LBR)
+ skipparens();
+ wneedtok(TOK_SEMI);
+ } else {
+ prog = addmeaning(findsymbol("program"), MK_MODULE);
+ }
+ prog->anyvarflag = 1;
+ if (requested_module && strcicmp(requested_module, prog->name) &&
+ strcicmp(requested_module, "program")) {
+ for (;;) {
+ skiptomodule();
+ if (curtok == TOK_DOT)
+ break;
+ (void)p_module(0, 2);
+ }
+ gettok();
+ break;
+ }
+ pushctx(prog);
+ p_block(TOK_PROGRAM);
+ echoprocname(prog);
+ flushcomments(NULL, -1, -1);
+ if (curtok != TOK_EOF) {
+ sp = p_body();
+ strlist_mix(&prog->comments, curcomments);
+ curcomments = NULL;
+ if (fullprototyping > 0) {
+ output(format_sss("main%s(int argc,%s%s *argv[])",
+ spacefuncs ? " " : "",
+ spacecommas ? " " : "",
+ charname));
+ } else {
+ output("main");
+ if (spacefuncs)
+ output(" ");
+ output("(argc,");
+ if (spacecommas)
+ output(" ");
+ output("argv)\n");
+ singleindent(argindent);
+ output("int argc;\n");
+ singleindent(argindent);
+ output(format_s("%s *argv[];\n", charname));
+ }
+ outcontext = prog;
+ out_block(sp, BR_FUNCTION, 10000);
+ free_stmt(sp);
+ popctx();
+ if (curtok == TOK_SEMI)
+ gettok();
+ else
+ wneedtok(TOK_DOT);
+ }
+ break;
+
+ }
+ if (curtok != TOK_EOF) {
+ warning("Junk at end of input file ignored [277]");
+ }
+}
+
+
+
+
+
+/* End. */
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/pexpr.c b/MultiSource/Benchmarks/MallocBench/p2c/pexpr.c
new file mode 100644
index 00000000..ed8c7c50
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/pexpr.c
@@ -0,0 +1,3626 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_PEXPR_C
+#include "trans.h"
+
+
+
+
+Expr *dots_n_hats(ex, target)
+Expr *ex;
+Type *target;
+{
+ Expr *ex2, *ex3;
+ Type *tp, *tp2;
+ Meaning *mp, *tvar;
+ int hassl;
+
+ for (;;) {
+ if ((ex->val.type->kind == TK_PROCPTR ||
+ ex->val.type->kind == TK_CPROCPTR) &&
+ curtok != TOK_ASSIGN &&
+ ((mp = (tp2 = ex->val.type)->basetype->fbase) == NULL ||
+ (mp->isreturn && mp->xnext == NULL) ||
+ curtok == TOK_LPAR) &&
+ (tp2->basetype->basetype != tp_void || target == tp_void) &&
+ (!target || (target->kind != TK_PROCPTR &&
+ target->kind != TK_CPROCPTR))) {
+ hassl = tp2->escale;
+ ex2 = ex;
+ ex3 = copyexpr(ex2);
+ if (hassl != 0)
+ ex3 = makeexpr_cast(makeexpr_dotq(ex3, "proc", tp_anyptr),
+ makepointertype(tp2->basetype));
+ ex = makeexpr_un(EK_SPCALL, tp2->basetype->basetype, ex3);
+ if (mp && mp->isreturn) { /* pointer to buffer for return value */
+ tvar = makestmttempvar(ex->val.type->basetype,
+ (ex->val.type->basetype->kind == TK_STRING) ? name_STRING : name_TEMP);
+ insertarg(&ex, 1, makeexpr_addr(makeexpr_var(tvar)));
+ mp = mp->xnext;
+ }
+ if (mp) {
+ if (wneedtok(TOK_LPAR)) {
+ ex = p_funcarglist(ex, mp, 0, 0);
+ skipcloseparen();
+ }
+ } else if (curtok == TOK_LPAR) {
+ gettok();
+ if (!wneedtok(TOK_RPAR))
+ skippasttoken(TOK_RPAR);
+ }
+ if (hassl != 1 || hasstaticlinks == 2) {
+ freeexpr(ex2);
+ } else {
+ ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
+ ex3 = copyexpr(ex);
+ insertarg(&ex3, ex3->nargs, copyexpr(ex2));
+ tp = maketype(TK_FUNCTION);
+ tp->basetype = tp2->basetype->basetype;
+ tp->fbase = tp2->basetype->fbase;
+ tp->issigned = 1;
+ ex3->args[0]->val.type = makepointertype(tp);
+ ex = makeexpr_cond(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
+ ex3, ex);
+ }
+ if (tp2->basetype->fbase &&
+ tp2->basetype->fbase->isreturn &&
+ tp2->basetype->fbase->kind == MK_VARPARAM)
+ ex = makeexpr_hat(ex, 0); /* returns pointer to structured result */
+ continue;
+ }
+ switch (curtok) {
+
+ case TOK_HAT:
+ case TOK_ADDR:
+ gettok();
+ ex = makeexpr_hat(ex, 1);
+ break;
+
+ case TOK_LBR:
+ do {
+ gettok();
+ ex2 = p_ord_expr();
+ ex = p_index(ex, ex2);
+ } while (curtok == TOK_COMMA);
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ break;
+
+ case TOK_DOT:
+ gettok();
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ if (ex->val.type->kind == TK_STRING) {
+ if (!strcicmp(curtokbuf, "LENGTH")) {
+ ex = makeexpr_bicall_1("strlen", tp_int, ex);
+ } else if (!strcicmp(curtokbuf, "BODY")) {
+ /* nothing to do */
+ }
+ gettok();
+ break;
+ }
+ mp = curtoksym->fbase;
+ while (mp && mp->rectype != ex->val.type)
+ mp = mp->snext;
+ if (mp)
+ ex = makeexpr_dot(ex, mp);
+ else {
+ warning(format_s("No field called %s in that record [288]", curtokbuf));
+ ex = makeexpr_dotq(ex, curtokcase, tp_integer);
+ }
+ gettok();
+ break;
+
+ case TOK_COLONCOLON:
+ gettok();
+ if (wexpecttok(TOK_IDENT)) {
+ ex = pascaltypecast(curtokmeaning->type, ex);
+ gettok();
+ }
+ break;
+
+ default:
+ return ex;
+ }
+ }
+}
+
+
+Expr *p_index(ex, ex2)
+Expr *ex, *ex2;
+{
+ Expr *ex3;
+ Type *tp, *ot;
+ Meaning *mp;
+ int bits;
+
+ tp = ex->val.type;
+ if (tp->kind == TK_STRING) {
+ if (checkconst(ex2, 0)) /* is it "s[0]"? */
+ return makeexpr_bicall_1("strlen", tp_char, ex);
+ else
+ return makeexpr_index(ex, ex2, makeexpr_long(1));
+ } else if (tp->kind == TK_ARRAY ||
+ tp->kind == TK_SMALLARRAY) {
+ if (tp->smax) {
+ ord_range_expr(tp->indextype, &ex3, NULL);
+ ex2 = makeexpr_minus(ex2, copyexpr(ex3));
+ if (!nodependencies(ex2, 0) &&
+ *getbitsname == '*') {
+ mp = makestmttempvar(tp_integer, name_TEMP);
+ ex3 = makeexpr_assign(makeexpr_var(mp), ex2);
+ ex2 = makeexpr_var(mp);
+ } else
+ ex3 = NULL;
+ ex = makeexpr_bicall_3(getbitsname, tp_int,
+ ex, ex2,
+ makeexpr_long(tp->escale));
+ if (tp->kind == TK_ARRAY) {
+ if (tp->basetype == tp_sshort)
+ bits = 4;
+ else
+ bits = 3;
+ insertarg(&ex, 3, makeexpr_long(bits));
+ }
+ ex = makeexpr_comma(ex3, ex);
+ ot = ord_type(tp->smax->val.type);
+ if (ot->kind == TK_ENUM && ot->meaning && useenum)
+ ex = makeexpr_cast(ex, tp->smax->val.type);
+ ex->val.type = tp->smax->val.type;
+ return ex;
+ } else {
+ ord_range_expr(ex->val.type->indextype, &ex3, NULL);
+ if (debug>2) { fprintf(outf, "ord_range_expr returns "); dumpexpr(ex3); fprintf(outf, "\n"); }
+ return makeexpr_index(ex, ex2, copyexpr(ex3));
+ }
+ } else {
+ warning("Index on a non-array variable [287]");
+ return makeexpr_bin(EK_INDEX, tp_integer, ex, ex2);
+ }
+}
+
+
+Expr *fake_dots_n_hats(ex)
+Expr *ex;
+{
+ for (;;) {
+ switch (curtok) {
+
+ case TOK_HAT:
+ case TOK_ADDR:
+ if (ex->val.type->kind == TK_POINTER)
+ ex = makeexpr_hat(ex, 0);
+ else {
+ ex->val.type = makepointertype(ex->val.type);
+ ex = makeexpr_un(EK_HAT, ex->val.type->basetype, ex);
+ }
+ gettok();
+ break;
+
+ case TOK_LBR:
+ do {
+ gettok();
+ ex = makeexpr_bin(EK_INDEX, tp_integer, ex, p_expr(tp_integer));
+ } while (curtok == TOK_COMMA);
+ if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ break;
+
+ case TOK_DOT:
+ gettok();
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ ex = makeexpr_dotq(ex, curtokcase, tp_integer);
+ gettok();
+ break;
+
+ case TOK_COLONCOLON:
+ gettok();
+ if (wexpecttok(TOK_IDENT)) {
+ ex = pascaltypecast(curtokmeaning->type, ex);
+ gettok();
+ }
+ break;
+
+ default:
+ return ex;
+ }
+ }
+}
+
+
+
+Static void bindnames(ex)
+Expr *ex;
+{
+ int i;
+ Symbol *sp;
+ Meaning *mp;
+
+ if (ex->kind == EK_NAME) {
+ sp = findsymbol_opt(fixpascalname(ex->val.s));
+ if (sp) {
+ mp = sp->mbase;
+ while (mp && !mp->isactive)
+ mp = mp->snext;
+ if (mp && !strcmp(mp->name, ex->val.s)) {
+ ex->kind = EK_VAR;
+ ex->val.i = (long)mp;
+ ex->val.type = mp->type;
+ }
+ }
+ }
+ i = ex->nargs;
+ while (--i >= 0)
+ bindnames(ex->args[i]);
+}
+
+
+
+void var_reference(mp)
+Meaning *mp;
+{
+ Meaning *mp2;
+
+ mp->refcount++;
+ if (mp->ctx && mp->ctx->kind == MK_FUNCTION &&
+ mp->ctx->needvarstruct &&
+ (mp->kind == MK_VAR ||
+ mp->kind == MK_VARREF ||
+ mp->kind == MK_VARMAC ||
+ mp->kind == MK_PARAM ||
+ mp->kind == MK_VARPARAM ||
+ (mp->kind == MK_CONST &&
+ (mp->type->kind == TK_ARRAY ||
+ mp->type->kind == TK_RECORD)))) {
+ if (debug>1) { fprintf(outf, "varstruct'ing %s\n", mp->name); }
+ if (!mp->varstructflag) {
+ mp->varstructflag = 1;
+ if (mp->constdefn && /* move init code into function body */
+ mp->kind != MK_VARMAC) {
+ mp2 = addmeaningafter(mp, curtoksym, MK_VAR);
+ curtoksym->mbase = mp2->snext; /* hide this fake variable */
+ mp2->snext = mp; /* remember true variable */
+ mp2->type = mp->type;
+ mp2->constdefn = mp->constdefn;
+ mp2->isforward = 1; /* declare it "static" */
+ mp2->refcount++; /* so it won't be purged! */
+ mp->constdefn = NULL;
+ mp->isforward = 0;
+ }
+ }
+ for (mp2 = curctx->ctx; mp2 != mp->ctx; mp2 = mp2->ctx)
+ mp2->varstructflag = 1;
+ mp2->varstructflag = 1;
+ }
+}
+
+
+
+Static Expr *p_variable(target)
+Type *target;
+{
+ Expr *ex, *ex2;
+ Meaning *mp;
+ Symbol *sym;
+
+ if (curtok != TOK_IDENT) {
+ warning("Expected a variable [289]");
+ return makeexpr_long(0);
+ }
+ if (!curtokmeaning) {
+ sym = curtoksym;
+ ex = makeexpr_name(curtokcase, tp_integer);
+ gettok();
+ if (curtok == TOK_LPAR) {
+ ex = makeexpr_bicall_0(ex->val.s, tp_integer);
+ do {
+ gettok();
+ insertarg(&ex, ex->nargs, p_expr(NULL));
+ } while (curtok == TOK_COMMA || curtok == TOK_ASSIGN);
+ if (!wneedtok(TOK_RPAR))
+ skippasttotoken(TOK_RPAR, TOK_SEMI);
+ }
+ if (!tryfuncmacro(&ex, NULL))
+ undefsym(sym);
+ return fake_dots_n_hats(ex);
+ }
+ var_reference(curtokmeaning);
+ mp = curtokmeaning;
+ if (mp->kind == MK_FIELD) {
+ ex = makeexpr_dot(copyexpr(withexprs[curtokint]), mp);
+ } else if (mp->kind == MK_CONST &&
+ mp->type->kind == TK_SET &&
+ mp->constdefn) {
+ ex = copyexpr(mp->constdefn);
+ mp = makestmttempvar(ex->val.type, name_SET);
+ ex2 = makeexpr(EK_MACARG, 0);
+ ex2->val.type = ex->val.type;
+ ex = replaceexprexpr(ex, ex2, makeexpr_var(mp), 0);
+ freeexpr(ex2);
+ } else if (mp->kind == MK_CONST &&
+ (mp == mp_false ||
+ mp == mp_true ||
+ mp->anyvarflag ||
+ (foldconsts > 0 &&
+ (mp->type->kind == TK_INTEGER ||
+ mp->type->kind == TK_BOOLEAN ||
+ mp->type->kind == TK_CHAR ||
+ mp->type->kind == TK_ENUM ||
+ mp->type->kind == TK_SUBR ||
+ mp->type->kind == TK_REAL)) ||
+ (foldstrconsts > 0 &&
+ (mp->type->kind == TK_STRING)))) {
+ if (mp->constdefn) {
+ ex = copyexpr(mp->constdefn);
+ if (ex->val.type == tp_int) /* kludge! */
+ ex->val.type = tp_integer;
+ } else
+ ex = makeexpr_val(copyvalue(mp->val));
+ } else if (mp->kind == MK_VARPARAM ||
+ mp->kind == MK_VARREF) {
+ ex = makeexpr_hat(makeexpr_var(mp), 0);
+ } else if (mp->kind == MK_VARMAC) {
+ ex = copyexpr(mp->constdefn);
+ bindnames(ex);
+ ex = gentle_cast(ex, mp->type);
+ ex->val.type = mp->type;
+ } else if (mp->kind == MK_SPVAR && mp->handler) {
+ gettok();
+ ex = (*mp->handler)(mp);
+ return dots_n_hats(ex, target);
+ } else if (mp->kind == MK_VAR ||
+ mp->kind == MK_CONST ||
+ mp->kind == MK_PARAM) {
+ ex = makeexpr_var(mp);
+ } else {
+ symclass(mp->sym);
+ ex = makeexpr_name(mp->name, tp_integer);
+ }
+ gettok();
+ return dots_n_hats(ex, target);
+}
+
+
+
+
+Expr *p_ord_expr()
+{
+ return makeexpr_charcast(p_expr(tp_integer));
+}
+
+
+
+Static Expr *makesmallsetconst(bits, type)
+long bits;
+Type *type;
+{
+ Expr *ex;
+
+ ex = makeexpr_long(bits);
+ ex->val.type = type;
+ if (smallsetconst != 2)
+ insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
+ return ex;
+}
+
+
+
+Expr *packset(ex, type)
+Expr *ex;
+Type *type;
+{
+ Meaning *mp;
+ Expr *ex2;
+ long max2;
+
+ if (ex->kind == EK_BICALL) {
+ if (!strcmp(ex->val.s, setexpandname) &&
+ (mp = istempvar(ex->args[0])) != NULL) {
+ canceltempvar(mp);
+ return grabarg(ex, 1);
+ }
+ if (!strcmp(ex->val.s, setunionname) &&
+ (mp = istempvar(ex->args[0])) != NULL &&
+ !exproccurs(ex->args[1], ex->args[0]) &&
+ !exproccurs(ex->args[2], ex->args[0])) {
+ canceltempvar(mp);
+ return makeexpr_bin(EK_BOR, type, packset(ex->args[1], type),
+ packset(ex->args[2], type));
+ }
+ if (!strcmp(ex->val.s, setaddname)) {
+ ex2 = makeexpr_bin(EK_LSH, type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ ex->args[1]);
+ ex = packset(ex->args[0], type);
+ if (checkconst(ex, 0))
+ return ex2;
+ else
+ return makeexpr_bin(EK_BOR, type, ex, ex2);
+ }
+ if (!strcmp(ex->val.s, setaddrangename)) {
+ if (ord_range(type->indextype, NULL, &max2) && max2 == setbits-1)
+ note("Range construction was implemented by a subtraction which may overflow [278]");
+ ex2 = makeexpr_minus(makeexpr_bin(EK_LSH, type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ makeexpr_plus(ex->args[2],
+ makeexpr_long(1))),
+ makeexpr_bin(EK_LSH, type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ ex->args[1]));
+ ex = packset(ex->args[0], type);
+ if (checkconst(ex, 0))
+ return ex2;
+ else
+ return makeexpr_bin(EK_BOR, type, ex, ex2);
+ }
+ }
+ return makeexpr_bicall_1(setpackname, type, ex);
+}
+
+
+
+#define MAXSETLIT 400
+
+Expr *p_setfactor(target, sure)
+Type *target;
+int sure;
+{
+ Expr *ex, *exmax = NULL, *ex2;
+ Expr *first[MAXSETLIT], *last[MAXSETLIT];
+ char doneflag[MAXSETLIT];
+ int i, j, num, donecount;
+ int isconst, guesstype;
+ long maxv, max2;
+ Value val;
+ Type *tp, *type;
+ Meaning *tvar;
+
+ if (curtok == TOK_LBRACE)
+ gettok();
+ else if (!wneedtok(TOK_LBR))
+ return makeexpr_long(0);
+ if (curtok == TOK_RBR || curtok == TOK_RBRACE) { /* empty set */
+ gettok();
+ val.type = tp_smallset;
+ val.i = 0;
+ val.s = NULL;
+ return makeexpr_val(val);
+ }
+ type = target;
+ guesstype = !sure;
+ maxv = -1;
+ isconst = 1;
+ num = 0;
+ for (;;) {
+ if (num >= MAXSETLIT) {
+ warning(format_d("Too many elements in set literal; max=%d [290]", MAXSETLIT));
+ ex = p_expr(type);
+ while (curtok != TOK_RBR && curtok != TOK_RBRACE) {
+ gettok();
+ ex = p_expr(type);
+ }
+ break;
+ }
+ if (guesstype && num == 0) {
+ ex = p_ord_expr();
+ type = ex->val.type;
+ } else {
+ ex = p_expr(type);
+ }
+ first[num] = ex = gentle_cast(ex, type);
+ doneflag[num] = 0;
+ if (curtok == TOK_DOTS || curtok == TOK_COLON) { /* UCSD? */
+ val = eval_expr(ex);
+ if (val.type) {
+ if (val.i > maxv) { /* In case of [127..0] */
+ maxv = val.i;
+ exmax = ex;
+ }
+ } else
+ isconst = 0;
+ gettok();
+ last[num] = ex = gentle_cast(p_expr(type), type);
+ } else {
+ last[num] = NULL;
+ }
+ val = eval_expr(ex);
+ if (val.type) {
+ if (val.i > maxv) {
+ maxv = val.i;
+ exmax = ex;
+ }
+ } else {
+ isconst = 0;
+ maxv = LONG_MAX;
+ }
+ num++;
+ if (curtok == TOK_COMMA)
+ gettok();
+ else
+ break;
+ }
+ if (curtok == TOK_RBRACE)
+ gettok();
+ else if (!wneedtok(TOK_RBR))
+ skippasttotoken(TOK_RBR, TOK_SEMI);
+ tp = first[0]->val.type;
+ if (guesstype) { /* must determine type */
+ if (maxv == LONG_MAX) {
+ if (target && ord_range(target, NULL, &max2))
+ maxv = max2;
+ else if (ord_range(tp, NULL, &max2) && max2 < 1000000 &&
+ (max2 >= defaultsetsize || num == 1))
+ maxv = max2;
+ else
+ maxv = defaultsetsize-1;
+ exmax = makeexpr_long(maxv);
+ } else
+ exmax = copyexpr(exmax);
+ if (!ord_range(tp, NULL, &max2) || maxv != max2)
+ tp = makesubrangetype(tp, makeexpr_long(0), exmax);
+ type = makesettype(tp);
+ } else
+ type = makesettype(type);
+ donecount = 0;
+ if (smallsetconst > 0) {
+ val.i = 0;
+ for (i = 0; i < num; i++) {
+ if (first[i]->kind == EK_CONST && first[i]->val.i < setbits &&
+ (!last[i] || (last[i]->kind == EK_CONST &&
+ last[i]->val.i >= 0 &&
+ last[i]->val.i < setbits))) {
+ if (last[i]) {
+ for (j = first[i]->val.i; j <= last[i]->val.i; j++)
+ val.i |= 1<<j;
+ } else
+ val.i |= 1 << first[i]->val.i;
+ doneflag[i] = 1;
+ donecount++;
+ }
+ }
+ }
+ if (donecount) {
+ ex = makesmallsetconst(val.i, tp_smallset);
+ } else
+ ex = NULL;
+ if (type->kind == TK_SMALLSET) {
+ for (i = 0; i < num; i++) {
+ if (!doneflag[i]) {
+ ex2 = makeexpr_bin(EK_LSH, type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ enum_to_int(first[i]));
+ if (last[i]) {
+ if (ord_range(type->indextype, NULL, &max2) && max2 == setbits-1)
+ note("Range construction was implemented by a subtraction which may overflow [278]");
+ ex2 = makeexpr_minus(makeexpr_bin(EK_LSH, type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ makeexpr_plus(enum_to_int(last[i]),
+ makeexpr_long(1))),
+ ex2);
+ }
+ if (ex)
+ ex = makeexpr_bin(EK_BOR, type, makeexpr_longcast(ex, 1), ex2);
+ else
+ ex = ex2;
+ }
+ }
+ } else {
+ tvar = makestmttempvar(type, name_SET);
+ if (!ex) {
+ val.type = tp_smallset;
+ val.i = 0;
+ val.s = NULL;
+ ex = makeexpr_val(val);
+ }
+ ex = makeexpr_bicall_2(setexpandname, type,
+ makeexpr_var(tvar), makeexpr_arglong(ex, 1));
+ for (i = 0; i < num; i++) {
+ if (!doneflag[i]) {
+ if (last[i])
+ ex = makeexpr_bicall_3(setaddrangename, type,
+ ex, makeexpr_arglong(enum_to_int(first[i]), 0),
+ makeexpr_arglong(enum_to_int(last[i]), 0));
+ else
+ ex = makeexpr_bicall_2(setaddname, type,
+ ex, makeexpr_arglong(enum_to_int(first[i]), 0));
+ }
+ }
+ }
+ return ex;
+}
+
+
+
+
+Expr *p_funcarglist(ex, args, firstarg, ismacro)
+Expr *ex;
+Meaning *args;
+int firstarg, ismacro;
+{
+ Meaning *mp, *mp2, *arglist = args, *prevarg = NULL;
+ Expr *ex2;
+ int i, fi, fakenum = -1, castit, isconf, isnonpos = 0;
+ Type *tp, *tp2;
+ char *name;
+
+ castit = castargs;
+ if (castit < 0)
+ castit = (prototypes == 0);
+ while (args) {
+ if (isnonpos) {
+ while (curtok == TOK_COMMA)
+ gettok();
+ if (curtok == TOK_RPAR) {
+ args = arglist;
+ i = firstarg;
+ while (args) {
+ if (ex->nargs <= i)
+ insertarg(&ex, ex->nargs, NULL);
+ if (!ex->args[i]) {
+ if (args->constdefn)
+ ex->args[i] = copyexpr(args->constdefn);
+ else {
+ warning(format_s("Missing value for parameter %s [291]",
+ args->name));
+ ex->args[i] = makeexpr_long(0);
+ }
+ }
+ args = args->xnext;
+ i++;
+ }
+ break;
+ }
+ }
+ if (args->isreturn || args->fakeparam) {
+ if (args->fakeparam) {
+ if (fakenum < 0)
+ fakenum = ex->nargs;
+ if (args->constdefn)
+ insertarg(&ex, ex->nargs, copyexpr(args->constdefn));
+ else
+ insertarg(&ex, ex->nargs, makeexpr_long(0));
+ }
+ args = args->xnext; /* return value parameter */
+ continue;
+ }
+ if (curtok == TOK_RPAR) {
+ if (args->constdefn) {
+ insertarg(&ex, ex->nargs, copyexpr(args->constdefn));
+ args = args->xnext;
+ continue;
+ } else {
+ if (ex->kind == EK_FUNCTION) {
+ name = ((Meaning *)ex->val.i)->name;
+ ex->kind = EK_BICALL;
+ ex->val.s = stralloc(name);
+ } else
+ name = "function";
+ warning(format_s("Too few arguments for %s [292]", name));
+ return ex;
+ }
+ }
+ if (curtok == TOK_COMMA) {
+ if (args->constdefn)
+ insertarg(&ex, ex->nargs, copyexpr(args->constdefn));
+ else {
+ warning(format_s("Missing parameter %s [293]", args->name));
+ insertarg(&ex, ex->nargs, makeexpr_long(0));
+ }
+ gettok();
+ args = args->xnext;
+ continue;
+ }
+ p_mech_spec(0);
+ if (curtok == TOK_IDENT) {
+ mp = arglist;
+ mp2 = NULL;
+ i = firstarg;
+ fi = -1;
+ while (mp && strcmp(curtokbuf, mp->sym->name)) {
+ if (mp->fakeparam) {
+ if (fi < 0)
+ fi = i;
+ } else
+ fi = -1;
+ i++;
+ mp2 = mp;
+ mp = mp->xnext;
+ }
+ if (mp &&
+ (peeknextchar() == ':' || !curtokmeaning || isnonpos)) {
+ gettok();
+ wneedtok(TOK_ASSIGN);
+ prevarg = mp2;
+ args = mp;
+ fakenum = fi;
+ isnonpos = 1;
+ } else
+ i = ex->nargs;
+ } else
+ i = ex->nargs;
+ while (ex->nargs <= i)
+ insertarg(&ex, ex->nargs, NULL);
+ if (ex->args[i])
+ warning(format_s("Multiple values for parameter %s [294]",
+ args->name));
+ tp = args->type;
+ ex2 = p_expr(tp);
+ if (args->kind == MK_VARPARAM)
+ tp = tp->basetype;
+ if (isfiletype(tp, 1) && is_std_file(ex2)) {
+ mp2 = makestmttempvar(tp_bigtext, name_TEMP);
+ ex2 = makeexpr_comma(
+ makeexpr_comma(makeexpr_assign(filebasename(makeexpr_var(mp2)),
+ ex2),
+ makeexpr_assign(filenamepart(makeexpr_var(mp2)),
+ makeexpr_string(""))),
+ makeexpr_var(mp2));
+ }
+ tp2 = ex2->val.type;
+ isconf = ((tp->kind == TK_ARRAY ||
+ tp->kind == TK_STRING) && tp->structdefd);
+ switch (args->kind) {
+
+ case MK_PARAM:
+ if (castit && tp->kind == TK_REAL &&
+ ex2->val.type->kind != TK_REAL)
+ ex2 = makeexpr_cast(ex2, tp);
+ else if (ord_type(tp)->kind == TK_INTEGER && !ismacro)
+ ex2 = makeexpr_arglong(ex2, long_type(tp));
+ else if (args->othername && args->rectype != tp &&
+ tp->kind != TK_STRING && args->type == tp2)
+ ex2 = makeexpr_addr(ex2);
+ else
+ ex2 = gentle_cast(ex2, tp);
+ ex->args[i] = ex2;
+ break;
+
+ case MK_VARPARAM:
+ if (args->type == tp_strptr && args->anyvarflag) {
+ ex->args[i] = strmax_func(ex2);
+ insertarg(&ex, ex->nargs-1, makeexpr_addr(ex2));
+ if (isnonpos)
+ note("Non-positional conformant parameters may not work [279]");
+ } else { /* regular VAR parameter */
+ if (!expr_is_lvalue(ex2) ||
+ (tp->kind == TK_REAL &&
+ ord_type(tp2)->kind == TK_INTEGER)) {
+ mp2 = makestmttempvar(tp, name_TEMP);
+ ex2 = makeexpr_comma(makeexpr_assign(makeexpr_var(mp2),
+ ex2),
+ makeexpr_addrf(makeexpr_var(mp2)));
+ } else
+ ex2 = makeexpr_addrf(ex2);
+ if (args->anyvarflag ||
+ (tp->kind == TK_POINTER && tp2->kind == TK_POINTER &&
+ (tp == tp_anyptr || tp2 == tp_anyptr))) {
+ if (!ismacro)
+ ex2 = makeexpr_cast(ex2, args->type);
+ } else {
+ if (tp2 != tp && !isconf &&
+ (tp2->kind != TK_STRING ||
+ tp->kind != TK_STRING))
+ warning(format_s("Type mismatch in VAR parameter %s [295]",
+ args->name));
+ }
+ ex->args[i] = ex2;
+ }
+ break;
+
+ default:
+ intwarning("p_funcarglist",
+ format_s("Parameter type is %s [296]",
+ meaningkindname(args->kind)));
+ break;
+ }
+ if (isconf && /* conformant array or string */
+ (!prevarg || prevarg->type != args->type)) {
+ while (tp->kind == TK_ARRAY && tp->structdefd) {
+ if (tp2->kind == TK_SMALLARRAY) {
+ warning("Trying to pass a small-array for a conformant array [297]");
+ /* this has a chance of working... */
+ ex->args[ex->nargs-1] =
+ makeexpr_addr(ex->args[ex->nargs-1]);
+ } else if (tp2->kind == TK_STRING) {
+ ex->args[fakenum++] =
+ makeexpr_arglong(makeexpr_long(1), integer16 == 0);
+ ex->args[fakenum++] =
+ makeexpr_arglong(strmax_func(ex->args[ex->nargs-1]),
+ integer16 == 0);
+ break;
+ } else if (tp2->kind != TK_ARRAY) {
+ warning("Type mismatch for conformant array [298]");
+ break;
+ }
+ ex->args[fakenum++] =
+ makeexpr_arglong(copyexpr(tp2->indextype->smin),
+ integer16 == 0);
+ ex->args[fakenum++] =
+ makeexpr_arglong(copyexpr(tp2->indextype->smax),
+ integer16 == 0);
+ tp = tp->basetype;
+ tp2 = tp2->basetype;
+ }
+ if (tp->kind == TK_STRING && tp->structdefd) {
+ ex->args[fakenum] =
+ makeexpr_arglong(strmax_func(ex->args[ex->nargs-1]),
+ integer16 == 0);
+ }
+ }
+ fakenum = -1;
+ if (!isnonpos) {
+ prevarg = args;
+ args = args->xnext;
+ if (args) {
+ if (curtok != TOK_RPAR && !wneedtok(TOK_COMMA))
+ skiptotoken2(TOK_RPAR, TOK_SEMI);
+ }
+ }
+ }
+ if (curtok == TOK_COMMA) {
+ if (ex->kind == EK_FUNCTION) {
+ name = ((Meaning *)ex->val.i)->name;
+ ex->kind = EK_BICALL;
+ ex->val.s = stralloc(name);
+ } else
+ name = "function";
+ warning(format_s("Too many arguments for %s [299]", name));
+ while (curtok == TOK_COMMA) {
+ gettok();
+ insertarg(&ex, ex->nargs, p_expr(tp_integer));
+ }
+ }
+ return ex;
+}
+
+
+
+Expr *replacemacargs(ex, fex)
+Expr *ex, *fex;
+{
+ int i;
+ Expr *ex2;
+
+ for (i = 0; i < ex->nargs; i++)
+ ex->args[i] = replacemacargs(ex->args[i], fex);
+ if (ex->kind == EK_MACARG) {
+ if (ex->val.i <= fex->nargs) {
+ ex2 = copyexpr(fex->args[ex->val.i - 1]);
+ } else {
+ ex2 = makeexpr_name("<meef>", tp_integer);
+ note("FuncMacro specified more arguments than call [280]");
+ }
+ freeexpr(ex);
+ return ex2;
+ }
+ return resimplify(ex);
+}
+
+
+Expr *p_noarglist(ex, mp, args)
+Expr *ex;
+Meaning *mp, *args;
+{
+ while (args && args->constdefn) {
+ insertarg(&ex, ex->nargs, copyexpr(args->constdefn));
+ args = args->xnext;
+ }
+ if (args) {
+ warning(format_s("Expected an argument list for %s [300]", mp->name));
+ ex->kind = EK_BICALL;
+ ex->val.s = stralloc(mp->name);
+ }
+ return ex;
+}
+
+
+void func_reference(func)
+Meaning *func;
+{
+ Meaning *mp;
+
+ if (func->ctx && func->ctx != curctx &&func->ctx->kind == MK_FUNCTION &&
+ func->ctx->varstructflag && !curctx->ctx->varstructflag) {
+ for (mp = curctx->ctx; mp != func->ctx; mp = mp->ctx)
+ mp->varstructflag = 1;
+ }
+}
+
+
+Expr *p_funccall(mp)
+Meaning *mp;
+{
+ Meaning *mp2, *tvar;
+ Expr *ex, *ex2;
+ int firstarg = 0;
+
+ func_reference(mp);
+ ex = makeexpr(EK_FUNCTION, 0);
+ ex->val.i = (long)mp;
+ ex->val.type = mp->type->basetype;
+ mp2 = mp->type->fbase;
+ if (mp2 && mp2->isreturn) { /* pointer to buffer for return value */
+ tvar = makestmttempvar(ex->val.type->basetype,
+ (ex->val.type->basetype->kind == TK_STRING) ? name_STRING : name_TEMP);
+ insertarg(&ex, 0, makeexpr_addr(makeexpr_var(tvar)));
+ mp2 = mp2->xnext;
+ firstarg++;
+ }
+ if (mp2 && curtok != TOK_LPAR) {
+ ex = p_noarglist(ex, mp, mp2);
+ } else if (curtok == TOK_LPAR) {
+ gettok();
+ ex = p_funcarglist(ex, mp2, firstarg, (mp->constdefn != NULL));
+ skipcloseparen();
+ }
+ if (mp->constdefn) {
+ ex2 = replacemacargs(copyexpr(mp->constdefn), ex);
+ ex2 = gentle_cast(ex2, ex->val.type);
+ ex2->val.type = ex->val.type;
+ freeexpr(ex);
+ return ex2;
+ }
+ return ex;
+}
+
+
+
+
+
+
+Expr *accumulate_strlit()
+{
+ char buf[256], ch, *cp, *cp2;
+ int len, i, danger = 0;
+
+ len = 0;
+ cp = buf;
+ for (;;) {
+ if (curtok == TOK_STRLIT) {
+ cp2 = curtokbuf;
+ i = curtokint;
+ while (--i >= 0) {
+ if (++len <= 255) {
+ ch = *cp++ = *cp2++;
+ if (ch & 128)
+ danger++;
+ }
+ }
+ } else if (curtok == TOK_HAT) { /* Turbo */
+ i = getchartok() & 0x1f;
+ if (++len <= 255)
+ *cp++ = i;
+ } else if (curtok == TOK_LPAR) { /* VAX */
+ Value val;
+ do {
+ gettok();
+ val = p_constant(tp_integer);
+ if (++len <= 255)
+ *cp++ = val.i;
+ } while (curtok == TOK_COMMA);
+ skipcloseparen();
+ continue;
+ } else
+ break;
+ gettok();
+ }
+ if (len > 255) {
+ warning("String literal too long [301]");
+ len = 255;
+ }
+ if (danger &&
+ !(unsignedchar == 1 ||
+ (unsignedchar != 0 && signedchars == 0)))
+ note(format_s("Character%s >= 128 encountered [281]", (danger > 1) ? "s" : ""));
+ return makeexpr_lstring(buf, len);
+}
+
+
+
+Expr *pascaltypecast(type, ex2)
+Type *type;
+Expr *ex2;
+{
+ if (type->kind == TK_POINTER || type->kind == TK_STRING ||
+ type->kind == TK_ARRAY)
+ ex2 = makeexpr_stringcast(ex2);
+ else
+ ex2 = makeexpr_charcast(ex2);
+ if ((ex2->val.type->kind == TK_INTEGER ||
+ ex2->val.type->kind == TK_CHAR ||
+ ex2->val.type->kind == TK_BOOLEAN ||
+ ex2->val.type->kind == TK_ENUM ||
+ ex2->val.type->kind == TK_SUBR ||
+ ex2->val.type->kind == TK_REAL ||
+ ex2->val.type->kind == TK_POINTER ||
+ ex2->val.type->kind == TK_STRING) &&
+ (type->kind == TK_INTEGER ||
+ type->kind == TK_CHAR ||
+ type->kind == TK_BOOLEAN ||
+ type->kind == TK_ENUM ||
+ type->kind == TK_SUBR ||
+ type->kind == TK_REAL ||
+ type->kind == TK_POINTER)) {
+ if (type->kind == TK_POINTER || ex2->val.type->kind == TK_POINTER)
+ return makeexpr_un(EK_CAST, type, ex2);
+ else
+ return makeexpr_un(EK_ACTCAST, type, ex2);
+ } else {
+ return makeexpr_hat(makeexpr_cast(makeexpr_addr(ex2),
+ makepointertype(type)), 0);
+ }
+}
+
+
+
+
+Static Expr *p_factor(target)
+Type *target;
+{
+ Expr *ex, *ex2;
+ Type *type;
+ Meaning *mp, *mp2;
+
+ switch (curtok) {
+
+ case TOK_INTLIT:
+ ex = makeexpr_long(curtokint);
+ gettok();
+ return ex;
+
+ case TOK_HEXLIT:
+ ex = makeexpr_long(curtokint);
+ insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
+ gettok();
+ return ex;
+
+ case TOK_OCTLIT:
+ ex = makeexpr_long(curtokint);
+ insertarg(&ex, 0, makeexpr_name("%#lo", tp_integer));
+ gettok();
+ return ex;
+
+ case TOK_MININT:
+ strcat(curtokbuf, ".0");
+
+ /* fall through */
+ case TOK_REALLIT:
+ ex = makeexpr_real(curtokbuf);
+ gettok();
+ return ex;
+
+ case TOK_HAT:
+ case TOK_STRLIT:
+ ex = accumulate_strlit();
+ return ex;
+
+ case TOK_LPAR:
+ gettok();
+ ex = p_expr(target);
+ skipcloseparen();
+ return dots_n_hats(ex, target);
+
+ case TOK_NOT:
+ case TOK_TWIDDLE:
+ gettok();
+ ex = p_factor(tp_integer);
+ if (ord_type(ex->val.type)->kind == TK_INTEGER)
+ return makeexpr_un(EK_BNOT, tp_integer, ex);
+ else
+ return makeexpr_not(ex);
+
+ case TOK_MINUS:
+ gettok();
+ if (curtok == TOK_MININT) {
+ gettok();
+ return makeexpr_long(MININT);
+ } else
+ return makeexpr_neg(p_factor(target));
+
+ case TOK_PLUS:
+ gettok();
+ return p_factor(target);
+
+ case TOK_ADDR:
+ gettok();
+ if (curtok == TOK_ADDR) {
+ gettok();
+ ex = p_factor(tp_proc);
+ if (ex->val.type->kind == TK_PROCPTR && ex->kind == EK_COMMA)
+ return grabarg(grabarg(grabarg(ex, 0), 1), 0);
+ if (ex->val.type->kind != TK_CPROCPTR)
+ warning("@@ allowed only for procedure pointers [302]");
+ return makeexpr_addrf(ex);
+ }
+ if (curtok == TOK_IDENT && 0 && /***/
+ curtokmeaning && (curtokmeaning->kind == MK_FUNCTION ||
+ curtokmeaning->kind == MK_SPECIAL)) {
+ if (curtokmeaning->ctx == nullctx)
+ warning(format_s("Can't take address of predefined object %s [303]",
+ curtokmeaning->name));
+ ex = makeexpr_name(curtokmeaning->name, tp_anyptr);
+ gettok();
+ } else {
+ ex = p_factor(tp_proc);
+ if (ex->val.type->kind == TK_PROCPTR) {
+ /* ex = makeexpr_dotq(ex, "proc", tp_anyptr); */
+ } else if (ex->val.type->kind == TK_CPROCPTR) {
+ ex = makeexpr_cast(ex, tp_anyptr);
+ } else
+ ex = makeexpr_addrf(ex);
+ }
+ return ex;
+
+ case TOK_LBR:
+ case TOK_LBRACE:
+ return p_setfactor(target && target->kind == TK_SET
+ ? target->indextype : NULL, 0);
+
+ case TOK_NIL:
+ gettok();
+ return makeexpr_nil();
+
+ case TOK_IF: /* nifty Pascal extension */
+ gettok();
+ ex = p_expr(tp_boolean);
+ wneedtok(TOK_THEN);
+ ex2 = p_expr(tp_integer);
+ if (wneedtok(TOK_ELSE))
+ return makeexpr_cond(ex, ex2, p_factor(ex2->val.type));
+ else
+ return makeexpr_cond(ex, ex2, makeexpr_long(0));
+
+ case TOK_IDENT:
+ mp = curtokmeaning;
+ switch ((mp) ? mp->kind : MK_VAR) {
+
+ case MK_TYPE:
+ gettok();
+ type = mp->type;
+ switch (curtok) {
+
+ case TOK_LPAR: /* Turbo type cast */
+ gettok();
+ ex2 = p_expr(type);
+ ex = pascaltypecast(type, ex2);
+ skipcloseparen();
+ return dots_n_hats(ex, target);
+
+ case TOK_LBR:
+ case TOK_LBRACE:
+ switch (type->kind) {
+
+ case TK_SET:
+ case TK_SMALLSET:
+ return p_setfactor(type->indextype, 1);
+
+ case TK_RECORD:
+ return p_constrecord(type, 0);
+
+ case TK_ARRAY:
+ case TK_SMALLARRAY:
+ return p_constarray(type, 0);
+
+ case TK_STRING:
+ return p_conststring(type, 0);
+
+ default:
+ warning("Bad type for constructor [304]");
+ skipparens();
+ return makeexpr_name(mp->name, mp->type);
+ }
+
+ default:
+ wexpected("an expression");
+ return makeexpr_name(mp->name, mp->type);
+ }
+
+ case MK_SPECIAL:
+ if (mp->handler && mp->isfunction &&
+ (curtok == TOK_LPAR || !target ||
+ (target->kind != TK_PROCPTR &&
+ target->kind != TK_CPROCPTR))) {
+ gettok();
+ if ((mp->sym->flags & LEAVEALONE) || mp->constdefn) {
+ ex = makeexpr_bicall_0(mp->name, tp_integer);
+ if (curtok == TOK_LPAR) {
+ do {
+ gettok();
+ insertarg(&ex, ex->nargs, p_expr(NULL));
+ } while (curtok == TOK_COMMA);
+ skipcloseparen();
+ }
+ tryfuncmacro(&ex, mp);
+ return ex;
+ }
+ ex = (*mp->handler)(mp);
+ if (!ex)
+ ex = makeexpr_long(0);
+ return ex;
+ } else {
+ if (target &&
+ (target->kind == TK_PROCPTR ||
+ target->kind == TK_CPROCPTR))
+ note("Using a built-in procedure as a procedure pointer [316]");
+ else
+ symclass(curtoksym);
+ gettok();
+ return makeexpr_name(mp->name, tp_integer);
+ }
+
+ case MK_FUNCTION:
+ mp->refcount++;
+ need_forward_decl(mp);
+ gettok();
+ if (mp->isfunction &&
+ (curtok == TOK_LPAR || !target ||
+ (target->kind != TK_PROCPTR &&
+ target->kind != TK_CPROCPTR))) {
+ ex = p_funccall(mp);
+ if (!mp->constdefn) {
+ if (mp->handler && !(mp->sym->flags & LEAVEALONE))
+ ex = (*mp->handler)(ex);
+ }
+ if (mp->cbase->kind == MK_VARPARAM) {
+ ex = makeexpr_hat(ex, 0); /* returns pointer to structured result */
+ }
+ return dots_n_hats(ex, target);
+ } else {
+ if (mp->handler && !(mp->sym->flags & LEAVEALONE))
+ note("Using a built-in procedure as a procedure pointer [316]");
+ if (target && target->kind == TK_CPROCPTR) {
+ type = maketype(TK_CPROCPTR);
+ type->basetype = mp->type;
+ type->escale = 0;
+ mp2 = makestmttempvar(type, name_TEMP);
+ ex = makeexpr_comma(
+ makeexpr_assign(
+ makeexpr_var(mp2),
+ makeexpr_name(mp->name, tp_text)),
+ makeexpr_var(mp2));
+ if (mp->ctx->kind == MK_FUNCTION)
+ warning("Procedure pointer to nested procedure [305]");
+ } else {
+ type = maketype(TK_PROCPTR);
+ type->basetype = mp->type;
+ type->escale = 1;
+ mp2 = makestmttempvar(type, name_TEMP);
+ ex = makeexpr_comma(
+ makeexpr_comma(
+ makeexpr_assign(
+ makeexpr_dotq(makeexpr_var(mp2),
+ "proc",
+ tp_anyptr),
+ makeexpr_name(mp->name, tp_text)),
+ /* handy pointer type */
+ makeexpr_assign(
+ makeexpr_dotq(makeexpr_var(mp2),
+ "link",
+ tp_anyptr),
+ makeexpr_ctx(mp->ctx))),
+ makeexpr_var(mp2));
+ }
+ return ex;
+ }
+
+ default:
+ return p_variable(target);
+ }
+
+ default:
+ wexpected("an expression");
+ return makeexpr_long(0);
+
+ }
+}
+
+
+
+
+Static Expr *p_powterm(target)
+Type *target;
+{
+ Expr *ex = p_factor(target);
+ Expr *ex2;
+ int i, castit;
+ long v;
+
+ if (curtok == TOK_STARSTAR) {
+ gettok();
+ ex2 = p_powterm(target);
+ if (ex->val.type->kind == TK_REAL ||
+ ex2->val.type->kind == TK_REAL) {
+ if (checkconst(ex2, 2)) {
+ ex = makeexpr_sqr(ex, 0);
+ } else if (checkconst(ex2, 3)) {
+ ex = makeexpr_sqr(ex, 1);
+ } else {
+ castit = castargs >= 0 ? castargs : (prototypes == 0);
+ if (ex->val.type->kind != TK_REAL && castit)
+ ex = makeexpr_cast(ex, tp_longreal);
+ if (ex2->val.type->kind != TK_REAL && castit)
+ ex2 = makeexpr_cast(ex2, tp_longreal);
+ ex = makeexpr_bicall_2("pow", tp_longreal, ex, ex2);
+ }
+ } else if (checkconst(ex, 2)) {
+ freeexpr(ex);
+ ex = makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(1), 1), ex2);
+ } else if (checkconst(ex, 0) ||
+ checkconst(ex, 1) ||
+ checkconst(ex2, 1)) {
+ freeexpr(ex2);
+ } else if (checkconst(ex2, 0)) {
+ freeexpr(ex);
+ freeexpr(ex2);
+ ex = makeexpr_long(1);
+ } else if (isliteralconst(ex, NULL) == 2 &&
+ isliteralconst(ex2, NULL) == 2 &&
+ ex2->val.i > 0) {
+ v = ex->val.i;
+ i = ex2->val.i;
+ while (--i > 0)
+ v *= ex->val.i;
+ freeexpr(ex);
+ freeexpr(ex2);
+ ex = makeexpr_long(v);
+ } else if (checkconst(ex2, 2)) {
+ ex = makeexpr_sqr(ex, 0);
+ } else if (checkconst(ex2, 3)) {
+ ex = makeexpr_sqr(ex, 1);
+ } else {
+ ex = makeexpr_bicall_2("ipow", tp_integer,
+ makeexpr_arglong(ex, 1),
+ makeexpr_arglong(ex2, 1));
+ }
+ }
+ return ex;
+}
+
+
+Static Expr *p_term(target)
+Type *target;
+{
+ Expr *ex = p_powterm(target);
+ Expr *ex2;
+ Type *type;
+ Meaning *tvar;
+ int useshort;
+
+ for (;;) {
+ checkkeyword(TOK_SHL);
+ checkkeyword(TOK_SHR);
+ checkkeyword(TOK_REM);
+ switch (curtok) {
+
+ case TOK_STAR:
+ gettok();
+ if (ex->val.type->kind == TK_SET ||
+ ex->val.type->kind == TK_SMALLSET) {
+ ex2 = p_powterm(ex->val.type);
+ type = mixsets(&ex, &ex2);
+ if (type->kind == TK_SMALLSET) {
+ ex = makeexpr_bin(EK_BAND, type, ex, ex2);
+ } else {
+ tvar = makestmttempvar(type, name_SET);
+ ex = makeexpr_bicall_3(setintname, type,
+ makeexpr_var(tvar),
+ ex, ex2);
+ }
+ } else
+ ex = makeexpr_times(ex, p_powterm(tp_integer));
+ break;
+
+ case TOK_SLASH:
+ gettok();
+ if (ex->val.type->kind == TK_SET ||
+ ex->val.type->kind == TK_SMALLSET) {
+ ex2 = p_powterm(ex->val.type);
+ type = mixsets(&ex, &ex2);
+ if (type->kind == TK_SMALLSET) {
+ ex = makeexpr_bin(EK_BXOR, type, ex, ex2);
+ } else {
+ tvar = makestmttempvar(type, name_SET);
+ ex = makeexpr_bicall_3(setxorname, type,
+ makeexpr_var(tvar),
+ ex, ex2);
+ }
+ } else
+ ex = makeexpr_divide(ex, p_powterm(tp_integer));
+ break;
+
+ case TOK_DIV:
+ gettok();
+ ex = makeexpr_div(ex, p_powterm(tp_integer));
+ break;
+
+ case TOK_REM:
+ gettok();
+ ex = makeexpr_rem(ex, p_powterm(tp_integer));
+ break;
+
+ case TOK_MOD:
+ gettok();
+ ex = makeexpr_mod(ex, p_powterm(tp_integer));
+ break;
+
+ case TOK_AND:
+ case TOK_AMP:
+ useshort = (curtok == TOK_AMP);
+ gettok();
+ ex2 = p_powterm(tp_integer);
+ if (ord_type(ex->val.type)->kind == TK_INTEGER)
+ ex = makeexpr_bin(EK_BAND, ex->val.type, ex, ex2);
+ else if (partial_eval_flag || useshort ||
+ (shortopt && nosideeffects(ex2, 1)))
+ ex = makeexpr_and(ex, ex2);
+ else
+ ex = makeexpr_bin(EK_BAND, tp_boolean, ex, ex2);
+ break;
+
+ case TOK_SHL:
+ gettok();
+ ex = makeexpr_bin(EK_LSH, ex->val.type, ex, p_powterm(tp_integer));
+ break;
+
+ case TOK_SHR:
+ gettok();
+ ex = force_unsigned(ex);
+ ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_powterm(tp_integer));
+ break;
+
+ default:
+ return ex;
+ }
+ }
+}
+
+
+
+Static Expr *p_sexpr(target)
+Type *target;
+{
+ Expr *ex, *ex2;
+ Type *type;
+ Meaning *tvar;
+ int useshort;
+
+ switch (curtok) {
+ case TOK_MINUS:
+ gettok();
+ if (curtok == TOK_MININT) {
+ gettok();
+ ex = makeexpr_long(MININT);
+ break;
+ }
+ ex = makeexpr_neg(p_term(target));
+ break;
+ case TOK_PLUS:
+ gettok();
+ /* fall through */
+ default:
+ ex = p_term(target);
+ break;
+ }
+ if (curtok == TOK_PLUS &&
+ (ex->val.type->kind == TK_STRING ||
+ ord_type(ex->val.type)->kind == TK_CHAR ||
+ ex->val.type->kind == TK_ARRAY)) {
+ while (curtok == TOK_PLUS) {
+ gettok();
+ ex = makeexpr_concat(ex, p_term(NULL), 0);
+ }
+ return ex;
+ } else {
+ for (;;) {
+ checkkeyword(TOK_XOR);
+ switch (curtok) {
+
+ case TOK_PLUS:
+ gettok();
+ if (ex->val.type->kind == TK_SET ||
+ ex->val.type->kind == TK_SMALLSET) {
+ ex2 = p_term(ex->val.type);
+ type = mixsets(&ex, &ex2);
+ if (type->kind == TK_SMALLSET) {
+ ex = makeexpr_bin(EK_BOR, type, ex, ex2);
+ } else {
+ tvar = makestmttempvar(type, name_SET);
+ ex = makeexpr_bicall_3(setunionname, type,
+ makeexpr_var(tvar),
+ ex, ex2);
+ }
+ } else
+ ex = makeexpr_plus(ex, p_term(tp_integer));
+ break;
+
+ case TOK_MINUS:
+ gettok();
+ if (ex->val.type->kind == TK_SET ||
+ ex->val.type->kind == TK_SMALLSET) {
+ ex2 = p_term(tp_integer);
+ type = mixsets(&ex, &ex2);
+ if (type->kind == TK_SMALLSET) {
+ ex = makeexpr_bin(EK_BAND, type, ex,
+ makeexpr_un(EK_BNOT, type, ex2));
+ } else {
+ tvar = makestmttempvar(type, name_SET);
+ ex = makeexpr_bicall_3(setdiffname, type,
+ makeexpr_var(tvar), ex, ex2);
+ }
+ } else
+ ex = makeexpr_minus(ex, p_term(tp_integer));
+ break;
+
+ case TOK_VBAR:
+ if (modula2)
+ return ex;
+ /* fall through */
+
+ case TOK_OR:
+ useshort = (curtok == TOK_VBAR);
+ gettok();
+ ex2 = p_term(tp_integer);
+ if (ord_type(ex->val.type)->kind == TK_INTEGER)
+ ex = makeexpr_bin(EK_BOR, ex->val.type, ex, ex2);
+ else if (partial_eval_flag || useshort ||
+ (shortopt && nosideeffects(ex2, 1)))
+ ex = makeexpr_or(ex, ex2);
+ else
+ ex = makeexpr_bin(EK_BOR, tp_boolean, ex, ex2);
+ break;
+
+ case TOK_XOR:
+ gettok();
+ ex2 = p_term(tp_integer);
+ ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, ex2);
+ break;
+
+ default:
+ return ex;
+ }
+ }
+ }
+}
+
+
+
+Expr *p_expr(target)
+Type *target;
+{
+ Expr *ex = p_sexpr(target);
+ Expr *ex2, *ex3, *ex4;
+ Type *type;
+ Meaning *tvar;
+ long mask, smin, smax;
+ int i, j;
+
+ switch (curtok) {
+
+ case TOK_EQ:
+ gettok();
+ return makeexpr_rel(EK_EQ, ex, p_sexpr(ex->val.type));
+
+ case TOK_NE:
+ gettok();
+ return makeexpr_rel(EK_NE, ex, p_sexpr(ex->val.type));
+
+ case TOK_LT:
+ gettok();
+ return makeexpr_rel(EK_LT, ex, p_sexpr(ex->val.type));
+
+ case TOK_GT:
+ gettok();
+ return makeexpr_rel(EK_GT, ex, p_sexpr(ex->val.type));
+
+ case TOK_LE:
+ gettok();
+ return makeexpr_rel(EK_LE, ex, p_sexpr(ex->val.type));
+
+ case TOK_GE:
+ gettok();
+ return makeexpr_rel(EK_GE, ex, p_sexpr(ex->val.type));
+
+ case TOK_IN:
+ gettok();
+ ex2 = p_sexpr(tp_smallset);
+ ex = gentle_cast(ex, ex2->val.type->indextype);
+ if (ex2->val.type->kind == TK_SMALLSET) {
+ if (!ord_range(ex->val.type, &smin, &smax)) {
+ smin = -1;
+ smax = setbits;
+ }
+ if (!nosideeffects(ex, 0)) {
+ tvar = makestmttempvar(ex->val.type, name_TEMP);
+ ex3 = makeexpr_assign(makeexpr_var(tvar), ex);
+ ex = makeexpr_var(tvar);
+ } else
+ ex3 = NULL;
+ ex4 = copyexpr(ex);
+ if (ex->kind == EK_CONST && smallsetconst)
+ ex = makesmallsetconst(1<<ex->val.i, ex2->val.type);
+ else
+ ex = makeexpr_bin(EK_LSH, ex2->val.type,
+ makeexpr_longcast(makeexpr_long(1), 1),
+ enum_to_int(ex));
+ ex = makeexpr_rel(EK_NE, makeexpr_bin(EK_BAND, tp_integer, ex, ex2),
+ makeexpr_long(0));
+ if (*name_SETBITS ||
+ ((ex4->kind == EK_CONST) ? ((unsigned long)ex4->val.i >= setbits)
+ : !(0 <= smin && smax < setbits))) {
+ ex = makeexpr_and(makeexpr_range(enum_to_int(ex4),
+ makeexpr_long(0),
+ makeexpr_setbits(), 0),
+ ex);
+ } else
+ freeexpr(ex4);
+ ex = makeexpr_comma(ex3, ex);
+ return ex;
+ } else {
+ ex3 = ex2;
+ while (ex3->kind == EK_BICALL &&
+ (!strcmp(ex3->val.s, setaddname) ||
+ !strcmp(ex3->val.s, setaddrangename)))
+ ex3 = ex3->args[0];
+ if (ex3->kind == EK_BICALL && !strcmp(ex3->val.s, setexpandname) &&
+ (tvar = istempvar(ex3->args[0])) != NULL &&
+ isconstexpr(ex3->args[1], &mask)) {
+ canceltempvar(tvar);
+ if (!nosideeffects(ex, 0)) {
+ tvar = makestmttempvar(ex->val.type, name_TEMP);
+ ex3 = makeexpr_assign(makeexpr_var(tvar), ex);
+ ex = makeexpr_var(tvar);
+ } else
+ ex3 = NULL;
+ type = ord_type(ex2->val.type->indextype);
+ ex4 = NULL;
+ i = 0;
+ while (i < setbits) {
+ if (mask & (1<<i++)) {
+ if (i+1 < setbits && (mask & (2<<i))) {
+ for (j = i; j < setbits && (mask & (1<<j)); j++) ;
+ ex4 = makeexpr_or(ex4,
+ makeexpr_range(copyexpr(ex),
+ makeexpr_val(make_ord(type, i-1)),
+ makeexpr_val(make_ord(type, j-1)), 1));
+ i = j;
+ } else {
+ ex4 = makeexpr_or(ex4,
+ makeexpr_rel(EK_EQ, copyexpr(ex),
+ makeexpr_val(make_ord(type, i-1))));
+ }
+ }
+ }
+ mask = 0;
+ for (;;) {
+ if (!strcmp(ex2->val.s, setaddrangename)) {
+ if (checkconst(ex2->args[1], 'a') &&
+ checkconst(ex2->args[2], 'z')) {
+ mask |= 0x1;
+ } else if (checkconst(ex2->args[1], 'A') &&
+ checkconst(ex2->args[2], 'Z')) {
+ mask |= 0x2;
+ } else if (checkconst(ex2->args[1], '0') &&
+ checkconst(ex2->args[2], '9')) {
+ mask |= 0x4;
+ } else {
+ ex4 = makeexpr_or(ex4,
+ makeexpr_range(copyexpr(ex), ex2->args[1], ex2->args[2], 1));
+ }
+ } else if (!strcmp(ex2->val.s, setaddname)) {
+ ex4 = makeexpr_or(ex4,
+ makeexpr_rel(EK_EQ, copyexpr(ex), ex2->args[1]));
+ } else
+ break;
+ ex2 = ex2->args[0];
+ }
+ /* do these now so that EK_OR optimizations will work: */
+ if (mask & 0x1)
+ ex4 = makeexpr_or(ex4, makeexpr_range(copyexpr(ex),
+ makeexpr_char('a'),
+ makeexpr_char('z'), 1));
+ if (mask & 0x2)
+ ex4 = makeexpr_or(ex4, makeexpr_range(copyexpr(ex),
+ makeexpr_char('A'),
+ makeexpr_char('Z'), 1));
+ if (mask & 0x4)
+ ex4 = makeexpr_or(ex4, makeexpr_range(copyexpr(ex),
+ makeexpr_char('0'),
+ makeexpr_char('9'), 1));
+ freeexpr(ex);
+ return makeexpr_comma(ex3, ex4);
+ }
+ return makeexpr_bicall_2(setinname, tp_boolean,
+ makeexpr_arglong(ex, 0), ex2);
+ }
+
+ default:
+ return ex;
+ }
+}
+
+
+
+
+
+
+
+/* Parse a C expression; used by VarMacro, etc. */
+
+Type *nametotype(name)
+char *name;
+{
+ if (!strcicmp(name, "malloc") ||
+ !strcicmp(name, mallocname)) {
+ return tp_anyptr;
+ }
+ return tp_integer;
+}
+
+
+int istypespec()
+{
+ switch (curtok) {
+
+ case TOK_CONST:
+ return 1;
+
+ case TOK_IDENT:
+ return !strcmp(curtokcase, "volatile") ||
+ !strcmp(curtokcase, "void") ||
+ !strcmp(curtokcase, "char") ||
+ !strcmp(curtokcase, "short") ||
+ !strcmp(curtokcase, "int") ||
+ !strcmp(curtokcase, "long") ||
+ !strcmp(curtokcase, "float") ||
+ !strcmp(curtokcase, "double") ||
+ !strcmp(curtokcase, "signed") ||
+ !strcmp(curtokcase, "unsigned") ||
+ !strcmp(curtokcase, "struct") ||
+ !strcmp(curtokcase, "union") ||
+ !strcmp(curtokcase, "class") ||
+ !strcmp(curtokcase, "enum") ||
+ !strcmp(curtokcase, "typedef") ||
+ (curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE);
+
+ default:
+ return 0;
+ }
+}
+
+
+
+Expr *pc_parentype(cp)
+char *cp;
+{
+ Expr *ex;
+
+ if (curtok == TOK_IDENT &&
+ curtokmeaning &&
+ curtokmeaning->kind == MK_TYPE) {
+ ex = makeexpr_type(curtokmeaning->type);
+ gettok();
+ skipcloseparen();
+ } else if (curtok == TOK_IDENT && !strcmp(curtokcase, "typedef")) {
+ ex = makeexpr_name(getparenstr(inbufptr), tp_integer);
+ gettok();
+ } else {
+ ex = makeexpr_name(getparenstr(cp), tp_integer);
+ gettok();
+ }
+ return ex;
+}
+
+
+
+
+Expr *pc_expr2();
+
+Expr *pc_factor()
+{
+ Expr *ex;
+ char *cp;
+ Strlist *sl;
+ int i;
+
+ switch (curtok) {
+
+ case TOK_BANG:
+ gettok();
+ return makeexpr_not(pc_expr2(14));
+
+ case TOK_TWIDDLE:
+ gettok();
+ return makeexpr_un(EK_BNOT, tp_integer, pc_expr2(14));
+
+ case TOK_PLPL:
+ gettok();
+ ex = pc_expr2(14);
+ return makeexpr_assign(ex, makeexpr_plus(copyexpr(ex), makeexpr_long(1)));
+
+ case TOK_MIMI:
+ gettok();
+ ex = pc_expr2(14);
+ return makeexpr_assign(ex, makeexpr_minus(copyexpr(ex), makeexpr_long(1)));
+
+ case TOK_STAR:
+ gettok();
+ ex = pc_expr2(14);
+ if (ex->val.type->kind != TK_POINTER)
+ ex->val.type = makepointertype(ex->val.type);
+ return makeexpr_hat(ex, 0);
+
+ case TOK_AMP:
+ gettok();
+ return makeexpr_addr(pc_expr2(14));
+
+ case TOK_PLUS:
+ gettok();
+ return pc_expr2(14);
+
+ case TOK_MINUS:
+ gettok();
+ return makeexpr_neg(pc_expr2(14));
+
+ case TOK_LPAR:
+ cp = inbufptr;
+ gettok();
+ if (istypespec()) {
+ ex = pc_parentype(cp);
+ return makeexpr_bin(EK_LITCAST, tp_integer, ex, pc_expr2(14));
+ }
+ ex = pc_expr();
+ skipcloseparen();
+ return ex;
+
+ case TOK_IDENT:
+ if (!strcmp(curtokcase, "sizeof")) {
+ gettok();
+ if (curtok != TOK_LPAR)
+ return makeexpr_sizeof(pc_expr2(14), 1);
+ cp = inbufptr;
+ gettok();
+ if (istypespec()) {
+ ex = makeexpr_sizeof(pc_parentype(cp), 1);
+ } else {
+ ex = makeexpr_sizeof(pc_expr(), 1);
+ skipcloseparen();
+ }
+ return ex;
+ }
+ if (curtoksym->flags & FMACREC) {
+ ex = makeexpr(EK_MACARG, 0);
+ ex->val.type = tp_integer;
+ ex->val.i = 0;
+ for (sl = funcmacroargs, i = 1; sl; sl = sl->next, i++) {
+ if (sl->value == (long)curtoksym) {
+ ex->val.i = i;
+ break;
+ }
+ }
+ } else
+ ex = makeexpr_name(curtokcase, nametotype(curtokcase));
+ gettok();
+ return ex;
+
+ case TOK_INTLIT:
+ ex = makeexpr_long(curtokint);
+ if (curtokbuf[strlen(curtokbuf)-1] == 'L')
+ ex = makeexpr_longcast(ex, 1);
+ gettok();
+ return ex;
+
+ case TOK_HEXLIT:
+ ex = makeexpr_long(curtokint);
+ insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
+ if (curtokbuf[strlen(curtokbuf)-1] == 'L')
+ ex = makeexpr_longcast(ex, 1);
+ gettok();
+ return ex;
+
+ case TOK_OCTLIT:
+ ex = makeexpr_long(curtokint);
+ insertarg(&ex, 0, makeexpr_name("%#lo", tp_integer));
+ if (curtokbuf[strlen(curtokbuf)-1] == 'L')
+ ex = makeexpr_longcast(ex, 1);
+ gettok();
+ return ex;
+
+ case TOK_REALLIT:
+ ex = makeexpr_real(curtokbuf);
+ gettok();
+ return ex;
+
+ case TOK_STRLIT:
+ ex = makeexpr_lstring(curtokbuf, curtokint);
+ gettok();
+ return ex;
+
+ case TOK_CHARLIT:
+ ex = makeexpr_char(curtokint);
+ gettok();
+ return ex;
+
+ default:
+ wexpected("a C expression");
+ return makeexpr_long(0);
+ }
+}
+
+
+
+
+#define pc_prec(pr) if (prec > (pr)) return ex; gettok();
+
+Expr *pc_expr2(prec)
+int prec;
+{
+ Expr *ex, *ex2;
+ int i;
+
+ ex = pc_factor();
+ for (;;) {
+ switch (curtok) {
+
+ case TOK_COMMA:
+ pc_prec(1);
+ ex = makeexpr_comma(ex, pc_expr2(2));
+ break;
+
+ case TOK_EQ:
+ pc_prec(2);
+ ex = makeexpr_assign(ex, pc_expr2(2));
+ break;
+
+ case TOK_QM:
+ pc_prec(3);
+ ex2 = pc_expr();
+ if (wneedtok(TOK_COLON))
+ ex = makeexpr_cond(ex, ex2, pc_expr2(3));
+ else
+ ex = makeexpr_cond(ex, ex2, makeexpr_long(0));
+ break;
+
+ case TOK_OROR:
+ pc_prec(4);
+ ex = makeexpr_or(ex, pc_expr2(5));
+ break;
+
+ case TOK_ANDAND:
+ pc_prec(5);
+ ex = makeexpr_and(ex, pc_expr2(6));
+ break;
+
+ case TOK_VBAR:
+ pc_prec(6);
+ ex = makeexpr_bin(EK_BOR, tp_integer, ex, pc_expr2(7));
+ break;
+
+ case TOK_HAT:
+ pc_prec(7);
+ ex = makeexpr_bin(EK_BXOR, tp_integer, ex, pc_expr2(8));
+ break;
+
+ case TOK_AMP:
+ pc_prec(8);
+ ex = makeexpr_bin(EK_BAND, tp_integer, ex, pc_expr2(9));
+ break;
+
+ case TOK_EQEQ:
+ pc_prec(9);
+ ex = makeexpr_rel(EK_EQ, ex, pc_expr2(10));
+ break;
+
+ case TOK_BANGEQ:
+ pc_prec(9);
+ ex = makeexpr_rel(EK_NE, ex, pc_expr2(10));
+ break;
+
+ case TOK_LT:
+ pc_prec(10);
+ ex = makeexpr_rel(EK_LT, ex, pc_expr2(11));
+ break;
+
+ case TOK_LE:
+ pc_prec(10);
+ ex = makeexpr_rel(EK_LE, ex, pc_expr2(11));
+ break;
+
+ case TOK_GT:
+ pc_prec(10);
+ ex = makeexpr_rel(EK_GT, ex, pc_expr2(11));
+ break;
+
+ case TOK_GE:
+ pc_prec(10);
+ ex = makeexpr_rel(EK_GE, ex, pc_expr2(11));
+ break;
+
+ case TOK_LTLT:
+ pc_prec(11);
+ ex = makeexpr_bin(EK_LSH, tp_integer, ex, pc_expr2(12));
+ break;
+
+ case TOK_GTGT:
+ pc_prec(11);
+ ex = makeexpr_bin(EK_RSH, tp_integer, ex, pc_expr2(12));
+ break;
+
+ case TOK_PLUS:
+ pc_prec(12);
+ ex = makeexpr_plus(ex, pc_expr2(13));
+ break;
+
+ case TOK_MINUS:
+ pc_prec(12);
+ ex = makeexpr_minus(ex, pc_expr2(13));
+ break;
+
+ case TOK_STAR:
+ pc_prec(13);
+ ex = makeexpr_times(ex, pc_expr2(14));
+ break;
+
+ case TOK_SLASH:
+ pc_prec(13);
+ ex = makeexpr_div(ex, pc_expr2(14));
+ break;
+
+ case TOK_PERC:
+ pc_prec(13);
+ ex = makeexpr_mod(ex, pc_expr2(14));
+ break;
+
+ case TOK_PLPL:
+ pc_prec(15);
+ ex = makeexpr_un(EK_POSTINC, tp_integer, ex);
+ break;
+
+ case TOK_MIMI:
+ pc_prec(15);
+ ex = makeexpr_un(EK_POSTDEC, tp_integer, ex);
+ break;
+
+ case TOK_LPAR:
+ pc_prec(16);
+ if (ex->kind == EK_NAME) {
+ ex->kind = EK_BICALL;
+ } else {
+ ex = makeexpr_un(EK_SPCALL, tp_integer, ex);
+ }
+ while (curtok != TOK_RPAR) {
+ insertarg(&ex, ex->nargs, pc_expr2(2));
+ if (curtok != TOK_RPAR)
+ if (!wneedtok(TOK_COMMA))
+ skiptotoken2(TOK_RPAR, TOK_SEMI);
+ }
+ gettok();
+ break;
+
+ case TOK_LBR:
+ pc_prec(16);
+ ex = makeexpr_index(ex, pc_expr(), NULL);
+ if (!wneedtok(TOK_RBR))
+ skippasttoken(TOK_RBR);
+ break;
+
+ case TOK_ARROW:
+ pc_prec(16);
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ if (ex->val.type->kind != TK_POINTER)
+ ex->val.type = makepointertype(ex->val.type);
+ ex = makeexpr_dotq(makeexpr_hat(ex, 0),
+ curtokcase, tp_integer);
+ gettok();
+ break;
+
+ case TOK_DOT:
+ pc_prec(16);
+ if (!wexpecttok(TOK_IDENT))
+ break;
+ ex = makeexpr_dotq(ex, curtokcase, tp_integer);
+ gettok();
+ break;
+
+ case TOK_COLONCOLON:
+ if (prec > 16)
+ return ex;
+ i = C_lex;
+ C_lex = 0;
+ gettok();
+ if (curtok == TOK_IDENT &&
+ curtokmeaning && curtokmeaning->kind == MK_TYPE) {
+ ex->val.type = curtokmeaning->type;
+ } else if (curtok == TOK_LPAR) {
+ gettok();
+ ex->val.type = p_type(NULL);
+ if (!wexpecttok(TOK_RPAR))
+ skiptotoken(TOK_RPAR);
+ } else
+ wexpected("a type name");
+ C_lex = i;
+ gettok();
+ break;
+
+ default:
+ return ex;
+ }
+ }
+}
+
+
+
+
+Expr *pc_expr()
+{
+ return pc_expr2(0);
+}
+
+
+
+Expr *pc_expr_str(buf)
+char *buf;
+{
+ Strlist *defsl, *sl;
+ Expr *ex;
+
+ defsl = NULL;
+ sl = strlist_append(&defsl, buf);
+ C_lex++;
+ push_input_strlist(defsl, buf);
+ ex = pc_expr();
+ if (curtok != TOK_EOF)
+ warning(format_s("Junk (%s) at end of C expression [306]",
+ tok_name(curtok)));
+ pop_input();
+ C_lex--;
+ strlist_empty(&defsl);
+ return ex;
+}
+
+
+
+
+
+
+/* Simplify an expression */
+
+Expr *fixexpr(ex, env)
+Expr *ex;
+int env;
+{
+ Expr *ex2, *ex3;
+ Type *type, *type2;
+ char *cp;
+ char sbuf[5];
+ int i, j;
+ Value val;
+
+ if (!ex)
+ return NULL;
+ if (debug>4) {fprintf(outf, "fixexpr("); dumpexpr(ex); fprintf(outf, ")\n");}
+ switch (ex->kind) {
+
+ case EK_BICALL:
+ ex2 = fix_bicall(ex, env);
+ if (ex2) {
+ ex = ex2;
+ break;
+ }
+ cp = ex->val.s;
+ if (!strcmp(cp, "strlen")) {
+ if (ex->args[0]->kind == EK_BICALL &&
+ !strcmp(ex->args[0]->val.s, "sprintf") &&
+ sprintf_value == 0) { /* does sprintf return char count? */
+ ex = grabarg(ex, 0);
+ strchange(&ex->val.s, "*sprintf");
+ ex = fixexpr(ex, env);
+ } else {
+ ex->args[0] = fixexpr(ex->args[0], ENV_EXPR);
+ }
+ } else if (!strcmp(cp, name_SETIO)) {
+ ex->args[0] = fixexpr(ex->args[0], ENV_BOOL);
+ } else if (!strcmp(cp, "~~SETIO")) {
+ ex->args[0] = fixexpr(ex->args[0], ENV_BOOL);
+ ex = makeexpr_cond(ex->args[0],
+ makeexpr_long(0),
+ makeexpr_bicall_1(name_ESCIO, tp_int, ex->args[1]));
+ } else if (!strcmp(cp, name_CHKIO)) {
+ ex->args[0] = fixexpr(ex->args[0], ENV_BOOL);
+ ex->args[2] = fixexpr(ex->args[2], env);
+ ex->args[3] = fixexpr(ex->args[3], env);
+ } else if (!strcmp(cp, "~~CHKIO")) {
+ ex->args[0] = fixexpr(ex->args[0], ENV_BOOL);
+ ex->args[2] = fixexpr(ex->args[2], env);
+ ex->args[3] = fixexpr(ex->args[3], env);
+ ex2 = makeexpr_bicall_1(name_ESCIO, tp_int, ex->args[1]);
+ if (ord_type(ex->args[3]->val.type)->kind != TK_INTEGER)
+ ex2 = makeexpr_cast(ex2, ex->args[3]->val.type);
+ ex = makeexpr_cond(ex->args[0], ex->args[2], ex2);
+ } else if (!strcmp(cp, "assert")) {
+ ex->args[0] = fixexpr(ex->args[0], ENV_BOOL);
+ } else if ((!strcmp(cp, setaddname) ||
+ !strcmp(cp, setaddrangename)) &&
+ (ex2 = ex->args[0])->kind == EK_BICALL &&
+ (!strcmp(ex2->val.s, setaddname) ||
+ !strcmp(ex2->val.s, setaddrangename))) {
+ while (ex2->kind == EK_BICALL &&
+ (!strcmp(ex2->val.s, setaddname) ||
+ !strcmp(ex2->val.s, setaddrangename) ||
+ !strcmp(ex2->val.s, setexpandname)))
+ ex2 = ex2->args[0];
+ if (nosideeffects(ex2, 1)) {
+ ex = makeexpr_comma(ex->args[0], ex);
+ ex->args[1]->args[0] = ex2;
+ ex = fixexpr(ex, env);
+ } else
+ for (i = 0; i < ex->nargs; i++)
+ ex->args[i] = fixexpr(ex->args[i], ENV_EXPR);
+ } else if (!strcmp(cp, setunionname) &&
+ (ex3 = singlevar(ex->args[0])) != NULL &&
+ ((i=1, exprsame(ex->args[0], ex->args[i], 0)) ||
+ (i=2, exprsame(ex->args[0], ex->args[i], 0))) &&
+ !exproccurs(ex3, ex->args[3-i]) &&
+ ex->args[3-i]->kind == EK_BICALL &&
+ (!strcmp(ex->args[3-i]->val.s, setaddname) ||
+ !strcmp(ex->args[3-i]->val.s, setaddrangename) ||
+ (!strcmp(ex->args[3-i]->val.s, setexpandname) &&
+ checkconst(ex->args[3-i]->args[1], 0))) &&
+ totempvar(ex->args[3-i])) {
+ if (!strcmp(ex->args[3-i]->val.s, setexpandname)) {
+ ex = grabarg(ex, 0);
+ } else {
+ ex = makeexpr_comma(ex, ex->args[3-i]);
+ ex->args[0]->args[3-i] = ex->args[1]->args[0];
+ ex->args[1]->args[0] = copyexpr(ex->args[0]->args[0]);
+ }
+ ex = fixexpr(ex, env);
+ } else if (!strcmp(cp, setdiffname) && *setremname &&
+ (ex3 = singlevar(ex->args[0])) != NULL &&
+ exprsame(ex->args[0], ex->args[1], 0) &&
+ !exproccurs(ex3, ex->args[2]) &&
+ ex->args[2]->kind == EK_BICALL &&
+ (!strcmp(ex->args[2]->val.s, setaddname) ||
+ (!strcmp(ex->args[2]->val.s, setexpandname) &&
+ checkconst(ex->args[2]->args[1], 0))) &&
+ totempvar(ex->args[2])) {
+ if (!strcmp(ex->args[2]->val.s, setexpandname)) {
+ ex = grabarg(ex, 0);
+ } else {
+ ex = makeexpr_comma(ex, ex->args[2]);
+ ex->args[0]->args[2] = ex->args[1]->args[0];
+ ex->args[1]->args[0] = copyexpr(ex->args[0]->args[0]);
+ strchange(&ex->args[1]->val.s, setremname);
+ }
+ ex = fixexpr(ex, env);
+ } else {
+ for (i = 0; i < ex->nargs; i++)
+ ex->args[i] = fixexpr(ex->args[i], ENV_EXPR);
+ ex = cleansprintf(ex);
+ if (!strcmp(cp, "sprintf")) {
+ if (checkstring(ex->args[1], "%s")) {
+ delfreearg(&ex, 1);
+ strchange(&ex->val.s, "strcpy");
+ ex = fixexpr(ex, env);
+ } else if (sprintf_value != 1 && env != ENV_STMT) {
+ if (*sprintfname) {
+ strchange(&ex->val.s, format_s("*%s", sprintfname));
+ } else {
+ strchange(&ex->val.s, "*sprintf");
+ ex = makeexpr_comma(ex, copyexpr(ex->args[0]));
+ }
+ }
+ } else if (!strcmp(cp, "strcpy")) {
+ if (env == ENV_STMT &&
+ ex->args[1]->kind == EK_BICALL &&
+ !strcmp(ex->args[1]->val.s, "strcpy") &&
+ nosideeffects(ex->args[1]->args[0], 1)) {
+ ex2 = ex->args[1];
+ ex->args[1] = copyexpr(ex2->args[0]);
+ ex = makeexpr_comma(ex2, ex);
+ }
+ } else if (!strcmp(cp, "memcpy")) {
+ strchange(&ex->val.s, format_s("*%s", memcpyname));
+ if (!strcmp(memcpyname, "*bcopy")) {
+ swapexprs(ex->args[0], ex->args[1]);
+ if (env != ENV_STMT)
+ ex = makeexpr_comma(ex, copyexpr(ex->args[1]));
+ }
+#if 0
+ } else if (!strcmp(cp, setunionname) &&
+ (ex3 = singlevar(ex->args[0])) != NULL &&
+ ((i=1, exprsame(ex->args[0], ex->args[i], 0)) ||
+ (i=2, exprsame(ex->args[0], ex->args[i], 0))) &&
+ !exproccurs(ex3, ex->args[3-i])) {
+ ep = &ex->args[3-i];
+ while ((ex2 = *ep)->kind == EK_BICALL &&
+ (!strcmp(ex2->val.s, setaddname) ||
+ !strcmp(ex2->val.s, setaddrangename)))
+ ep = &ex2->args[0];
+ if (ex2->kind == EK_BICALL &&
+ !strcmp(ex2->val.s, setexpandname) &&
+ checkconst(ex2->args[1], 0) &&
+ (mp = istempvar(ex2->args[0])) != NULL) {
+ if (ex2 == ex->args[3-i]) {
+ ex = grabarg(ex, i);
+ } else {
+ freeexpr(ex2);
+ *ep = ex->args[i];
+ ex = ex->args[3-i];
+ }
+ }
+ } else if (!strcmp(cp, setdiffname) && *setremname &&
+ (ex3 = singlevar(ex->args[0])) != NULL &&
+ exprsame(ex->args[0], ex->args[1], 0) &&
+ !exproccurs(ex3, ex->args[2])) {
+ ep = &ex->args[2];
+ while ((ex2 = *ep)->kind == EK_BICALL &&
+ !strcmp(ex2->val.s, setaddname))
+ ep = &ex2->args[0];
+ if (ex2->kind == EK_BICALL &&
+ !strcmp(ex2->val.s, setexpandname) &&
+ checkconst(ex2->args[1], 0) &&
+ (mp = istempvar(ex2->args[0])) != NULL) {
+ if (ex2 == ex->args[2]) {
+ ex = grabarg(ex, 1);
+ } else {
+ ex2 = ex->args[2];
+ while (ex2->kind == EK_BICALL &&
+ !strcmp(ex2->val.s, setaddname)) {
+ strchange(&ex2->val.s, setremname);
+ ex2 = ex2->args[0];
+ }
+ freeexpr(ex2);
+ *ep = ex->args[1];
+ ex = ex->args[2];
+ }
+ }
+#endif
+ } else if (!strcmp(cp, setexpandname) && env == ENV_STMT &&
+ checkconst(ex->args[1], 0)) {
+ ex = makeexpr_assign(makeexpr_hat(ex->args[0], 0),
+ ex->args[1]);
+ } else if (!strcmp(cp, getbitsname)) {
+ type = ex->args[0]->val.type;
+ if (type->kind == TK_POINTER)
+ type = type->basetype;
+ sbuf[0] = (type->issigned) ? 'S' : 'U';
+ sbuf[1] = (type->kind == TK_ARRAY) ? 'B' : 'S';
+ sbuf[2] = 0;
+ if (sbuf[1] == 'S' &&
+ type->smax->val.type == tp_boolean) {
+ ex = makeexpr_rel(EK_NE,
+ makeexpr_bin(EK_BAND, tp_integer,
+ ex->args[0],
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(1),
+ type->basetype
+ == tp_unsigned),
+ ex->args[1])),
+ makeexpr_long(0));
+ ex = fixexpr(ex, env);
+ } else
+ strchange(&ex->val.s, format_s(cp, sbuf));
+ } else if (!strcmp(cp, putbitsname)) {
+ type = ex->args[0]->val.type;
+ if (type->kind == TK_POINTER)
+ type = type->basetype;
+ sbuf[0] = (type->issigned) ? 'S' : 'U';
+ sbuf[1] = (type->kind == TK_ARRAY) ? 'B' : 'S';
+ sbuf[2] = 0;
+ if (sbuf[1] == 'S' &&
+ type->smax->val.type == tp_boolean) {
+ ex = makeexpr_assign(ex->args[0],
+ makeexpr_bin(EK_BOR, tp_integer,
+ copyexpr(ex->args[0]),
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(ex->args[2],
+ type->basetype
+ == tp_unsigned),
+ ex->args[1])));
+ } else
+ strchange(&ex->val.s, format_s(cp, sbuf));
+ } else if (!strcmp(cp, storebitsname)) {
+ type = ex->args[0]->val.type;
+ if (type->kind == TK_POINTER)
+ type = type->basetype;
+ sbuf[0] = (type->issigned) ? 'S' : 'U';
+ sbuf[1] = (type->kind == TK_ARRAY) ? 'B' : 'S';
+ sbuf[2] = 0;
+ strchange(&ex->val.s, format_s(cp, sbuf));
+ } else if (!strcmp(cp, clrbitsname)) {
+ type = ex->args[0]->val.type;
+ if (type->kind == TK_POINTER)
+ type = type->basetype;
+ sbuf[0] = (type->kind == TK_ARRAY) ? 'B' : 'S';
+ sbuf[1] = 0;
+ if (sbuf[0] == 'S' &&
+ type->smax->val.type == tp_boolean) {
+ ex = makeexpr_assign(ex->args[0],
+ makeexpr_bin(EK_BAND, tp_integer,
+ copyexpr(ex->args[0]),
+ makeexpr_un(EK_BNOT, tp_integer,
+ makeexpr_bin(EK_LSH, tp_integer,
+ makeexpr_longcast(makeexpr_long(1),
+ type->basetype
+ == tp_unsigned),
+ ex->args[1]))));
+ } else
+ strchange(&ex->val.s, format_s(cp, sbuf));
+ } else if (!strcmp(cp, "fopen")) {
+ if (which_lang == LANG_HP &&
+ ex->args[0]->kind == EK_CONST &&
+ ex->args[0]->val.type->kind == TK_STRING &&
+ ex->args[0]->val.i >= 1 &&
+ ex->args[0]->val.i <= 2 &&
+ isdigit(ex->args[0]->val.s[0]) &&
+ (ex->args[0]->val.i == 1 ||
+ isdigit(ex->args[0]->val.s[1]))) {
+ strchange(&ex->val.s, "fdopen");
+ ex->args[0] = makeexpr_long(atoi(ex->args[0]->val.s));
+ }
+ }
+ }
+ break;
+
+ case EK_NOT:
+ ex = makeexpr_not(fixexpr(grabarg(ex, 0), ENV_BOOL));
+ break;
+
+ case EK_AND:
+ case EK_OR:
+ for (i = 0; i < ex->nargs; ) {
+ ex->args[i] = fixexpr(ex->args[i], ENV_BOOL);
+ if (checkconst(ex->args[i], (ex->kind == EK_OR) ? 0 : 1) &&
+ ex->nargs > 1)
+ delfreearg(&ex, i);
+ else if (checkconst(ex->args[i], (ex->kind == EK_OR) ? 1 : 0))
+ return grabarg(ex, i);
+ else
+ i++;
+ }
+ if (ex->nargs == 1)
+ ex = grabarg(ex, 0);
+ break;
+
+ case EK_EQ:
+ case EK_NE:
+ ex->args[0] = fixexpr(ex->args[0], ENV_EXPR);
+ ex->args[1] = fixexpr(ex->args[1], ENV_EXPR);
+ if (checkconst(ex->args[1], 0) && env == ENV_BOOL &&
+ ord_type(ex->args[1]->val.type)->kind != TK_ENUM &&
+ (implicitzero > 0 ||
+ (implicitzero < 0 && ex->args[0]->kind == EK_BICALL &&
+ boolean_bicall(ex->args[0]->val.s)))) {
+ if (ex->kind == EK_EQ)
+ ex = makeexpr_not(grabarg(ex, 0));
+ else {
+ ex = grabarg(ex, 0);
+ ex->val.type = tp_boolean;
+ }
+ }
+ break;
+
+ case EK_COND:
+ ex->args[0] = fixexpr(ex->args[0], ENV_BOOL);
+#if 0
+ val = eval_expr(ex->args[0]);
+#else
+ val = ex->args[0]->val;
+ if (ex->args[0]->kind != EK_CONST)
+ val.type = NULL;
+#endif
+ if (val.type == tp_boolean) {
+ ex = grabarg(ex, (val.i) ? 1 : 2);
+ ex = fixexpr(ex, env);
+ } else {
+ ex->args[1] = fixexpr(ex->args[1], env);
+ ex->args[2] = fixexpr(ex->args[2], env);
+ }
+ break;
+
+ case EK_COMMA:
+ for (i = 0; i < ex->nargs; ) {
+ j = (i < ex->nargs-1);
+ ex->args[i] = fixexpr(ex->args[i], j ? ENV_STMT : env);
+ if (nosideeffects(ex->args[i], 1) && j) {
+ delfreearg(&ex, i);
+ } else if (ex->args[i]->kind == EK_COMMA) {
+ ex2 = ex->args[i];
+ ex->args[i++] = ex2->args[0];
+ for (j = 1; j < ex2->nargs; j++)
+ insertarg(&ex, i++, ex2->args[j]);
+ FREE(ex2);
+ } else
+ i++;
+ }
+ if (ex->nargs == 1)
+ ex = grabarg(ex, 0);
+ break;
+
+ case EK_CHECKNIL:
+ ex->args[0] = fixexpr(ex->args[0], ENV_EXPR);
+ if (ex->nargs == 2) {
+ ex->args[1] = fixexpr(ex->args[1], ENV_EXPR);
+ ex2 = makeexpr_assign(copyexpr(ex->args[1]), ex->args[0]);
+ ex3 = ex->args[1];
+ } else {
+ ex2 = copyexpr(ex->args[0]);
+ ex3 = ex->args[0];
+ }
+ type = ex->args[0]->val.type;
+ type2 = ex->val.type;
+ ex = makeexpr_cond(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
+ ex3,
+ makeexpr_cast(makeexpr_bicall_0(name_NILCHECK,
+ tp_int),
+ type));
+ ex->val.type = type2;
+ ex = fixexpr(ex, env);
+ break;
+
+ case EK_CAST:
+ case EK_ACTCAST:
+ if (env == ENV_STMT) {
+ ex = fixexpr(grabarg(ex, 0), ENV_STMT);
+ } else {
+ ex->args[0] = fixexpr(ex->args[0], ENV_EXPR);
+ }
+ break;
+
+ default:
+ for (i = 0; i < ex->nargs; i++)
+ ex->args[i] = fixexpr(ex->args[i], ENV_EXPR);
+ break;
+ }
+ if (debug>4) {fprintf(outf, "fixexpr returns "); dumpexpr(ex); fprintf(outf, "\n");}
+ return fix_expression(ex, env);
+}
+
+
+
+
+
+
+
+
+/* Output an expression */
+
+
+#define bitOp(k) ((k)==EK_BAND || (k)==EK_BOR || (k)==EK_BXOR)
+
+#define shfOp(k) ((k)==EK_LSH || (k)==EK_RSH)
+
+#define logOp(k) ((k)==EK_AND || (k)==EK_OR)
+
+#define relOp(k) ((k)==EK_EQ || (k)==EK_LT || (k)==EK_GT || \
+ (k)==EK_NE || (k)==EK_GE || (k)==EK_LE)
+
+#define mathOp(k) ((k)==EK_PLUS || (k)==EK_TIMES || (k)==EK_NEG || \
+ (k)==EK_DIV || (k)==EK_DIVIDE || (k)==EK_MOD)
+
+#define divOp(k) ((k)==EK_DIV || (k)==EK_DIVIDE)
+
+
+Static int incompat(ex, num, prec)
+Expr *ex;
+int num, prec;
+{
+ Expr *subex = ex->args[num];
+
+ if (extraparens == 0)
+ return prec;
+ if (ex->kind == subex->kind) {
+ if (logOp(ex->kind) || bitOp(ex->kind) ||
+ (divOp(ex->kind) && num == 0))
+ return -99; /* not even invisible parens */
+ else if (extraparens != 2)
+ return prec;
+ }
+ if (extraparens == 2)
+ return 15;
+ if (divOp(ex->kind) && num == 0 &&
+ (subex->kind == EK_TIMES || divOp(subex->kind)))
+ return -99;
+ if (bitOp(ex->kind) || shfOp(ex->kind))
+ return 15;
+ if (relOp(ex->kind) && relOp(subex->kind))
+ return 15;
+ if ((relOp(ex->kind) || logOp(ex->kind)) && bitOp(subex->kind))
+ return 15;
+ if (ex->kind == EK_COMMA)
+ return 15;
+ if (ex->kind == EK_ASSIGN && relOp(subex->kind))
+ return 15;
+ if (extraparens != 1)
+ return prec;
+ if (ex->kind == EK_ASSIGN)
+ return prec;
+ if (relOp(ex->kind) && mathOp(subex->kind))
+ return prec;
+ return 15;
+}
+
+
+
+
+#define EXTRASPACE() if (spaceexprs == 1) output(" ")
+#define NICESPACE() if (spaceexprs != 0) output(" ")
+
+#define setprec(p) \
+ if ((subprec=(p)) <= prec) { \
+ parens = 1; output("("); \
+ }
+
+#define setprec2(p) \
+ if ((subprec=(p)) <= prec) { \
+ parens = 1; output("("); \
+ } else if (prec != -99) { \
+ parens = 2; output((breakparens == 1) ? "\010" : "\003"); \
+ }
+
+#define setprec3(p) \
+ if ((subprec=(p)) <= prec) { \
+ parens = 1; output("("); \
+ } else if (prec != -99) { \
+ parens = 2; output((prec > 2 && breakparens != 0) ? "\010" \
+ : "\003"); \
+ }
+
+
+Static void outop3(breakbefore, name)
+int breakbefore;
+char *name;
+{
+ if (breakbefore & BRK_LEFT) {
+ output("\002");
+ if (breakbefore & BRK_RPREF)
+ output("\013");
+ }
+ output(name);
+ if (breakbefore & BRK_HANG)
+ output("\015");
+ if (breakbefore & BRK_RIGHT) {
+ output("\002");
+ if (breakbefore & BRK_LPREF)
+ output("\013");
+ }
+}
+
+#define outop(name) do { \
+ NICESPACE(); outop3(breakflag, name); NICESPACE(); \
+} while (0)
+
+#define outop2(name) do { \
+ EXTRASPACE(); outop3(breakflag, name); EXTRASPACE(); \
+} while (0)
+
+#define checkbreak(code) do { \
+ breakflag=(code); \
+ if ((prec != -99) && (breakflag & BRK_ALLNONE)) output("\007"); \
+} while (0)
+
+
+Static void out_ctx(ctx, address)
+Meaning *ctx;
+int address;
+{
+ Meaning *ctx2;
+ int breakflag = breakbeforedot;
+
+ if (ctx->kind == MK_FUNCTION && ctx->varstructflag) {
+ if (curctx != ctx) {
+ if (address && curctx->ctx && curctx->ctx != ctx) {
+ output("\003");
+ if (breakflag & BRK_ALLNONE)
+ output("\007");
+ }
+ output(format_s(name_LINK, curctx->ctx->name));
+ ctx2 = curctx->ctx;
+ while (ctx2 && ctx2 != ctx) {
+ outop2("->");
+ output(format_s(name_LINK, ctx2->ctx->name));
+ ctx2 = ctx2->ctx;
+ }
+ if (ctx2 != ctx)
+ intwarning("out_ctx",
+ format_s("variable from %s not present in context path [307]",
+ ctx->name));
+ if (address && curctx->ctx && curctx->ctx != ctx)
+ output("\004");
+ if (!address)
+ outop2("->");
+ } else {
+ if (address) {
+ output("&");
+ EXTRASPACE();
+ }
+ output(format_s(name_VARS, curctx->name));
+ if (!address) {
+ outop2(".");
+ }
+ }
+ } else {
+ if (address)
+ output("NULL");
+ }
+}
+
+
+
+void out_var(mp, prec)
+Meaning *mp;
+int prec;
+{
+ switch (mp->kind) {
+
+ case MK_CONST:
+ output(mp->name);
+ return;
+
+ case MK_VAR:
+ case MK_VARREF:
+ case MK_VARMAC:
+ case MK_PARAM:
+ case MK_VARPARAM:
+ if (mp->varstructflag) {
+ output("\003");
+ out_ctx(mp->ctx, 0);
+ output(mp->name);
+ output("\004");
+ } else
+ output(mp->name);
+ return;
+
+ default:
+ if (mp->name)
+ output(mp->name);
+ else
+ intwarning("out_var", "mp->sym == NULL [308]");
+ return;
+ }
+}
+
+
+
+Static int scanfield(variants, unions, lev, mp, field)
+Meaning **variants, *mp, *field;
+short *unions;
+int lev;
+{
+ int i, num, breakflag;
+ Value v;
+
+ unions[lev] = (mp && mp->kind == MK_VARIANT);
+ while (mp && mp->kind == MK_FIELD) {
+ if (mp == field) {
+ for (i = 0; i < lev; i++) {
+ v = variants[i]->val; /* sidestep a Sun 386i compiler bug */
+ num = ord_value(v);
+ breakflag = breakbeforedot;
+ if (!unions[i]) {
+ output(format_s(name_UNION, ""));
+ outop2(".");
+ }
+ if (variants[i]->ctx->cnext ||
+ variants[i]->ctx->kind != MK_FIELD) {
+ output(format_s(name_VARIANT, variantfieldname(num)));
+ outop2(".");
+ }
+ }
+ output(mp->name);
+ return 1;
+ }
+ mp = mp->cnext;
+ }
+ while (mp && mp->kind == MK_VARIANT) {
+ variants[lev] = mp;
+ if (scanfield(variants, unions, lev+1, mp->ctx, field))
+ return 1;
+ mp = mp->cnext;
+ }
+ return 0;
+}
+
+
+void out_field(mp)
+Meaning *mp;
+{
+ Meaning *variants[50];
+ short unions[51];
+
+ if (!scanfield(variants, unions, 0, mp->rectype->fbase, mp))
+ intwarning("out_field", "field name not in tree [309]");
+ else if (mp->warnifused) {
+ if (mp->rectype->meaning)
+ note(format_ss("Reference to field %s of record %s [282]",
+ mp->name, mp->rectype->meaning->name));
+ else
+ note(format_s("Reference to field %s [282]", mp->name));
+ }
+}
+
+
+
+
+Static void wrexpr(ex, prec)
+Expr *ex;
+int prec;
+{
+ short parens = 0;
+ int subprec, i, j, minusflag, breakflag = 0;
+ int saveindent;
+ Expr *ex2, *ex3;
+ char *cp;
+ Meaning *mp;
+ Symbol *sp;
+
+ if (debug>2) { fprintf(outf,"wrexpr{"); dumpexpr(ex); fprintf(outf,", %d}\n", prec); }
+ switch (ex->kind) {
+
+ case EK_VAR:
+ mp = (Meaning *)ex->val.i;
+ if (mp->warnifused)
+ note(format_s("Reference to %s [283]", mp->name));
+ out_var(mp, prec);
+ break;
+
+ case EK_NAME:
+ output(ex->val.s);
+ break;
+
+ case EK_MACARG:
+ output("<meef>");
+ intwarning("wrexpr", "Stray EK_MACARG encountered [310]");
+ break;
+
+ case EK_CTX:
+ out_ctx((Meaning *)ex->val.i, 1);
+ break;
+
+ case EK_CONST:
+ if (ex->nargs > 0)
+ cp = value_name(ex->val, ex->args[0]->val.s, 0);
+ else
+ cp = value_name(ex->val, NULL, 0);
+ if (*cp == '-')
+ setprec(14);
+ output(cp);
+ break;
+
+ case EK_LONGCONST:
+ if (ex->nargs > 0)
+ cp = value_name(ex->val, ex->args[0]->val.s, 1);
+ else
+ cp = value_name(ex->val, NULL, 1);
+ if (*cp == '-')
+ setprec(14);
+ output(cp);
+ break;
+
+ case EK_STRUCTCONST:
+ ex3 = NULL;
+ for (i = 0; i < ex->nargs; i++) {
+ ex2 = ex->args[i];
+ if (ex2->kind == EK_STRUCTOF) {
+ j = ex2->val.i;
+ ex2 = ex2->args[0];
+ } else
+ j = 1;
+ if (ex2->kind == EK_VAR) {
+ mp = (Meaning *)ex2->val.i;
+ if (mp->kind == MK_CONST &&
+ mp->val.type &&
+ (mp->val.type->kind == TK_RECORD ||
+ mp->val.type->kind == TK_ARRAY)) {
+ if (foldconsts != 1)
+ note(format_s("Expanding constant %s into another constant [284]",
+ mp->name));
+ ex2 = (Expr *)mp->val.i;
+ }
+ }
+ while (--j >= 0) {
+ if (ex3) {
+ if (ex3->kind == EK_STRUCTCONST ||
+ ex2->kind == EK_STRUCTCONST)
+ output(",\n");
+ else if (spacecommas)
+ output(",\001 ");
+ else
+ output(",\001");
+ }
+ if (ex2->kind == EK_STRUCTCONST) {
+ output("{ \005");
+ saveindent = outindent;
+ moreindent(extrainitindent);
+ out_expr(ex2);
+ outindent = saveindent;
+ output(" }");
+ } else
+ out_expr(ex2);
+ ex3 = ex2;
+ }
+ }
+ break;
+
+ case EK_FUNCTION:
+ mp = (Meaning *)ex->val.i;
+ sp = findsymbol_opt(mp->name);
+ if ((sp && (sp->flags & WARNLIBR)) || mp->warnifused)
+ note(format_s("Called procedure %s [285]", mp->name));
+ output(mp->name);
+ if (spacefuncs)
+ output(" ");
+ output("(\002");
+ j = sp ? (sp->flags & FUNCBREAK) : 0;
+ if (j == FALLBREAK)
+ output("\007");
+ for (i = 0; i < ex->nargs; i++) {
+ if ((j == FSPCARG1 && i == 1) ||
+ (j == FSPCARG2 && i == 2) ||
+ (j == FSPCARG3 && i == 3))
+ if (spacecommas)
+ output(",\011 ");
+ else
+ output(",\011");
+ else if (i > 0)
+ if (spacecommas)
+ output(",\002 ");
+ else
+ output(",\002");
+ out_expr(ex->args[i]);
+ }
+ if (mp->ctx->kind == MK_FUNCTION && mp->ctx->varstructflag) {
+ if (i > 0)
+ if (spacecommas)
+ output(",\002 ");
+ else
+ output(",\002");
+ out_ctx(mp->ctx, 1);
+ }
+ output(")");
+ break;
+
+ case EK_BICALL:
+ cp = ex->val.s;
+ while (*cp == '*')
+ cp++;
+ sp = findsymbol_opt(cp);
+ if (sp && (sp->flags & WARNLIBR))
+ note(format_s("Called library procedure %s [286]", cp));
+ output(cp);
+ if (spacefuncs)
+ output(" ");
+ output("(\002");
+ j = sp ? (sp->flags & FUNCBREAK) : 0;
+ if (j == FALLBREAK)
+ output("\007");
+ for (i = 0; i < ex->nargs; i++) {
+ if ((j == FSPCARG1 && i == 1) ||
+ (j == FSPCARG2 && i == 2) ||
+ (j == FSPCARG3 && i == 3))
+ if (spacecommas)
+ output(",\011 ");
+ else
+ output(",\011");
+ else if (i > 0)
+ if (spacecommas)
+ output(",\002 ");
+ else
+ output(",\002");
+ out_expr(ex->args[i]);
+ }
+ output(")");
+ break;
+
+ case EK_SPCALL:
+ setprec(16);
+ if (starfunctions) {
+ output("(\002*");
+ wrexpr(ex->args[0], 13);
+ output(")");
+ } else
+ wrexpr(ex->args[0], subprec-1);
+ if (spacefuncs)
+ output(" ");
+ output("(\002");
+ for (i = 1; i < ex->nargs; i++) {
+ if (i > 1)
+ if (spacecommas)
+ output(",\002 ");
+ else
+ output(",\002");
+ out_expr(ex->args[i]);
+ }
+ output(")");
+ break;
+
+ case EK_INDEX:
+ setprec(16);
+ wrexpr(ex->args[0], subprec-1);
+ if (lookback(1) == ']')
+ output("\001");
+ output("[");
+ out_expr(ex->args[1]);
+ output("]");
+ break;
+
+ case EK_DOT:
+ setprec2(16);
+ checkbreak(breakbeforedot);
+ if (ex->args[0]->kind == EK_HAT) {
+ wrexpr(ex->args[0]->args[0], subprec-1);
+ outop2("->");
+ } else if (ex->args[0]->kind == EK_CTX) {
+ out_ctx((Meaning *)ex->args[0]->val.i, 0);
+ } else {
+ wrexpr(ex->args[0], subprec-1);
+ outop2(".");
+ }
+ if (ex->val.i)
+ out_field((Meaning *)ex->val.i);
+ else
+ output(ex->val.s);
+ break;
+
+ case EK_POSTINC:
+ if (prec == 0 && !postincrement) {
+ setprec(14);
+ output("++");
+ EXTRASPACE();
+ wrexpr(ex->args[0], subprec);
+ } else {
+ setprec(15);
+ wrexpr(ex->args[0], subprec);
+ EXTRASPACE();
+ output("++");
+ }
+ break;
+
+ case EK_POSTDEC:
+ if (prec == 0 && !postincrement) {
+ setprec(14);
+ output("--");
+ EXTRASPACE();
+ wrexpr(ex->args[0], subprec);
+ } else {
+ setprec(15);
+ wrexpr(ex->args[0], subprec);
+ EXTRASPACE();
+ output("--");
+ }
+ break;
+
+ case EK_HAT:
+ setprec(14);
+ if (lookback_prn(1) == '/')
+ output(" ");
+ output("*");
+ EXTRASPACE();
+ wrexpr(ex->args[0], subprec-1);
+ break;
+
+ case EK_ADDR:
+ setprec(14);
+ if (lookback_prn(1) == '&')
+ output(" ");
+ output("&");
+ EXTRASPACE();
+ wrexpr(ex->args[0], subprec-1);
+ break;
+
+ case EK_NEG:
+ setprec(14);
+ output("-");
+ EXTRASPACE();
+ if (ex->args[0]->kind == EK_TIMES)
+ wrexpr(ex->args[0], 12);
+ else
+ wrexpr(ex->args[0], subprec-1);
+ break;
+
+ case EK_NOT:
+ setprec(14);
+ output("!");
+ EXTRASPACE();
+ wrexpr(ex->args[0], subprec-1);
+ break;
+
+ case EK_BNOT:
+ setprec(14);
+ output("~");
+ EXTRASPACE();
+ wrexpr(ex->args[0], subprec-1);
+ break;
+
+ case EK_CAST:
+ case EK_ACTCAST:
+ if (similartypes(ex->val.type, ex->args[0]->val.type)) {
+ wrexpr(ex->args[0], prec);
+ } else if (ord_type(ex->args[0]->val.type)->kind == TK_ENUM &&
+ ex->val.type == tp_int && !useenum) {
+ wrexpr(ex->args[0], prec);
+ } else {
+ setprec2(14);
+ output("(");
+ out_type(ex->val.type, 0);
+ output(")\002");
+ EXTRASPACE();
+ if (extraparens != 0)
+ wrexpr(ex->args[0], 15);
+ else
+ wrexpr(ex->args[0], subprec-1);
+ }
+ break;
+
+ case EK_LITCAST:
+ setprec2(14);
+ output("(");
+ out_expr(ex->args[0]);
+ output(")\002");
+ EXTRASPACE();
+ if (extraparens != 0)
+ wrexpr(ex->args[1], 15);
+ else
+ wrexpr(ex->args[1], subprec-1);
+ break;
+
+ case EK_SIZEOF:
+ setprec(14);
+ output("sizeof");
+ if (spacefuncs)
+ output(" ");
+ output("(");
+ out_expr(ex->args[0]);
+ output(")");
+ break;
+
+ case EK_TYPENAME:
+ out_type(ex->val.type, 1);
+ break;
+
+ case EK_TIMES:
+ setprec2(13);
+ checkbreak(breakbeforearith);
+ ex2 = copyexpr(ex);
+ if (expr_looks_neg(ex2->args[ex2->nargs-1])) {
+ ex2->args[0] = makeexpr_neg(ex2->args[0]);
+ ex2->args[ex2->nargs-1] = makeexpr_neg(ex2->args[ex2->nargs-1]);
+ }
+ wrexpr(ex2->args[0], incompat(ex2, 0, subprec-1));
+ for (i = 1; i < ex2->nargs; i++) {
+ outop("*");
+ wrexpr(ex2->args[i], incompat(ex2, i, subprec));
+ }
+ freeexpr(ex2);
+ break;
+
+ case EK_DIV:
+ case EK_DIVIDE:
+ setprec2(13);
+ checkbreak(breakbeforearith);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec-1));
+ outop("/");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec));
+ break;
+
+ case EK_MOD:
+ setprec2(13);
+ checkbreak(breakbeforearith);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec-1));
+ outop("%");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec));
+ break;
+
+ case EK_PLUS:
+ setprec2(12);
+ checkbreak(breakbeforearith);
+ ex2 = copyexpr(ex);
+ minusflag = 0;
+ if (expr_looks_neg(ex2->args[0])) {
+ j = 1;
+ while (j < ex2->nargs && expr_looks_neg(ex2->args[j])) j++;
+ if (j < ex2->nargs)
+ swapexprs(ex2->args[0], ex2->args[j]);
+ } else if (ex2->val.i && ex2->nargs == 2) { /* this was originally "a-b" */
+ if (isliteralconst(ex2->args[1], NULL) != 2) {
+ if (expr_neg_cost(ex2->args[1]) <= 0) {
+ minusflag = 1;
+ } else if (expr_neg_cost(ex2->args[0]) <= 0) {
+ swapexprs(ex2->args[0], ex2->args[1]);
+ if (isliteralconst(ex2->args[0], NULL) != 2)
+ minusflag = 1;
+ }
+ }
+ }
+ wrexpr(ex2->args[0], incompat(ex, 0, subprec));
+ for (i = 1; i < ex2->nargs; i++) {
+ if (expr_looks_neg(ex2->args[i]) || minusflag) {
+ outop("-");
+ ex2->args[i] = makeexpr_neg(ex2->args[i]);
+ } else
+ outop("+");
+ wrexpr(ex2->args[i], incompat(ex, i, subprec));
+ }
+ freeexpr(ex2);
+ break;
+
+ case EK_LSH:
+ setprec3(11);
+ checkbreak(breakbeforearith);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop("<<");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec));
+ break;
+
+ case EK_RSH:
+ setprec3(11);
+ checkbreak(breakbeforearith);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop(">>");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec));
+ break;
+
+ case EK_LT:
+ setprec2(10);
+ checkbreak(breakbeforerel);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop("<");
+ wrexpr(ex->args[1], incompat(ex, 0, subprec));
+ break;
+
+ case EK_GT:
+ setprec2(10);
+ checkbreak(breakbeforerel);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop(">");
+ wrexpr(ex->args[1], incompat(ex, 0, subprec));
+ break;
+
+ case EK_LE:
+ setprec2(10);
+ checkbreak(breakbeforerel);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop("<=");
+ wrexpr(ex->args[1], incompat(ex, 0, subprec));
+ break;
+
+ case EK_GE:
+ setprec2(10);
+ checkbreak(breakbeforerel);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop(">=");
+ wrexpr(ex->args[1], incompat(ex, 0, subprec));
+ break;
+
+ case EK_EQ:
+ setprec2(9);
+ checkbreak(breakbeforerel);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop("==");
+ wrexpr(ex->args[1], incompat(ex, 0, subprec));
+ break;
+
+ case EK_NE:
+ setprec2(9);
+ checkbreak(breakbeforerel);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec));
+ outop("!=");
+ wrexpr(ex->args[1], incompat(ex, 0, subprec));
+ break;
+
+ case EK_BAND:
+ setprec3(8);
+ if (ex->val.type == tp_boolean)
+ checkbreak(breakbeforelog);
+ else
+ checkbreak(breakbeforearith);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec-1));
+ outop("&");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec-1));
+ break;
+
+ case EK_BXOR:
+ setprec3(7);
+ checkbreak(breakbeforearith);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec-1));
+ outop("^");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec-1));
+ break;
+
+ case EK_BOR:
+ setprec3(6);
+ if (ex->val.type == tp_boolean)
+ checkbreak(breakbeforelog);
+ else
+ checkbreak(breakbeforearith);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec-1));
+ outop("|");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec-1));
+ break;
+
+ case EK_AND:
+ setprec3(5);
+ checkbreak(breakbeforelog);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec-1));
+ outop("&&");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec-1));
+ break;
+
+ case EK_OR:
+ setprec3(4);
+ checkbreak(breakbeforelog);
+ wrexpr(ex->args[0], incompat(ex, 0, subprec-1));
+ outop("||");
+ wrexpr(ex->args[1], incompat(ex, 1, subprec-1));
+ break;
+
+ case EK_COND:
+ setprec3(3);
+ i = 0;
+ for (;;) {
+ i++;
+ if (extraparens != 0)
+ wrexpr(ex->args[0], 15);
+ else
+ wrexpr(ex->args[0], subprec);
+ NICESPACE();
+ output("\002?");
+ NICESPACE();
+ out_expr(ex->args[1]);
+ if (ex->args[2]->kind == EK_COND) {
+ NICESPACE();
+ output("\002:");
+ NICESPACE();
+ ex = ex->args[2];
+ } else {
+ NICESPACE();
+ output((i == 1) ? "\017:" : "\002:");
+ NICESPACE();
+ wrexpr(ex->args[2], subprec-1);
+ break;
+ }
+ }
+ break;
+
+ case EK_ASSIGN:
+ if (ex->args[1]->kind == EK_PLUS &&
+ exprsame(ex->args[1]->args[0], ex->args[0], 2) &&
+ ex->args[1]->args[1]->kind == EK_CONST &&
+ ex->args[1]->args[1]->val.type->kind == TK_INTEGER &&
+ abs(ex->args[1]->args[1]->val.i) == 1) {
+ if (prec == 0 && postincrement) {
+ setprec(15);
+ wrexpr(ex->args[0], subprec);
+ EXTRASPACE();
+ if (ex->args[1]->args[1]->val.i == 1)
+ output("++");
+ else
+ output("--");
+ } else {
+ setprec(14);
+ if (ex->args[1]->args[1]->val.i == 1)
+ output("++");
+ else
+ output("--");
+ EXTRASPACE();
+ wrexpr(ex->args[0], subprec-1);
+ }
+ } else {
+ setprec2(2);
+ checkbreak(breakbeforeassign);
+ wrexpr(ex->args[0], subprec);
+ ex2 = copyexpr(ex->args[1]);
+ j = -1;
+ switch (ex2->kind) {
+
+ case EK_PLUS:
+ case EK_TIMES:
+ case EK_BAND:
+ case EK_BOR:
+ case EK_BXOR:
+ for (i = 0; i < ex2->nargs; i++) {
+ if (exprsame(ex->args[0], ex2->args[i], 2)) {
+ j = i;
+ break;
+ }
+ if (ex2->val.type->kind == TK_REAL)
+ break; /* non-commutative */
+ }
+ break;
+
+ case EK_DIVIDE:
+ case EK_DIV:
+ case EK_MOD:
+ case EK_LSH:
+ case EK_RSH:
+ if (exprsame(ex->args[0], ex2->args[0], 2))
+ j = 0;
+ break;
+
+ default:
+ break;
+ }
+ if (j >= 0) {
+ if (ex2->nargs == 2)
+ ex2 = grabarg(ex2, 1-j);
+ else
+ delfreearg(&ex2, j);
+ switch (ex->args[1]->kind) {
+
+ case EK_PLUS:
+ if (expr_looks_neg(ex2)) {
+ outop("-=");
+ ex2 = makeexpr_neg(ex2);
+ } else
+ outop("+=");
+ break;
+
+ case EK_TIMES:
+ outop("*=");
+ break;
+
+ case EK_DIVIDE:
+ case EK_DIV:
+ outop("/=");
+ break;
+
+ case EK_MOD:
+ outop("%=");
+ break;
+
+ case EK_LSH:
+ outop("<<=");
+ break;
+
+ case EK_RSH:
+ outop(">>=");
+ break;
+
+ case EK_BAND:
+ outop("&=");
+ break;
+
+ case EK_BOR:
+ outop("|=");
+ break;
+
+ case EK_BXOR:
+ outop("^=");
+ break;
+
+ default:
+ break;
+ }
+ } else {
+ output(" ");
+ outop3(breakbeforeassign, "=");
+ output(" ");
+ }
+ if (extraparens != 0 &&
+ (ex2->kind == EK_EQ || ex2->kind == EK_NE ||
+ ex2->kind == EK_GT || ex2->kind == EK_LT ||
+ ex2->kind == EK_GE || ex2->kind == EK_LE ||
+ ex2->kind == EK_AND || ex2->kind == EK_OR))
+ wrexpr(ex2, 16);
+ else
+ wrexpr(ex2, subprec-1);
+ freeexpr(ex2);
+ }
+ break;
+
+ case EK_COMMA:
+ setprec3(1);
+ for (i = 0; i < ex->nargs-1; i++) {
+ wrexpr(ex->args[i], subprec);
+ output(",\002");
+ if (spacecommas)
+ NICESPACE();
+ }
+ wrexpr(ex->args[ex->nargs-1], subprec);
+ break;
+
+ default:
+ intwarning("wrexpr", "bad ex->kind [311]");
+ }
+ switch (parens) {
+ case 1:
+ output(")");
+ break;
+ case 2:
+ output("\004");
+ break;
+ }
+}
+
+
+
+/* will parenthesize assignments and "," operators */
+
+void out_expr(ex)
+Expr *ex;
+{
+ wrexpr(ex, 2);
+}
+
+
+
+/* will not parenthesize anything at top level */
+
+void out_expr_top(ex)
+Expr *ex;
+{
+ wrexpr(ex, 0);
+}
+
+
+
+/* will parenthesize unless only writing a factor */
+
+void out_expr_factor(ex)
+Expr *ex;
+{
+ wrexpr(ex, 15);
+}
+
+
+
+/* will parenthesize always */
+
+void out_expr_parens(ex)
+Expr *ex;
+{
+ output("(");
+ wrexpr(ex, 1);
+ output(")");
+}
+
+
+
+/* evaluate expression for side effects only */
+/* no top-level parentheses */
+
+void out_expr_stmt(ex)
+Expr *ex;
+{
+ wrexpr(ex, 0);
+}
+
+
+
+/* evaluate expression for boolean (zero/non-zero) result only */
+/* parenthesizes like out_expr() */
+
+void out_expr_bool(ex)
+Expr *ex;
+{
+ wrexpr(ex, 2);
+}
+
+
+
+
+/* End. */
+
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/stuff.c b/MultiSource/Benchmarks/MallocBench/p2c/stuff.c
new file mode 100644
index 00000000..37a0dd9f
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/stuff.c
@@ -0,0 +1,839 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+#define PROTO_STUFF_C
+#include "trans.h"
+
+
+
+
+
+
+/* Called regularly, for debugging purposes */
+
+void debughook()
+{
+#if 0
+ Symbol *sp;
+ Meaning *mp;
+ static int flag = 0;
+
+ sp = findsymbol_opt("DEFSTIPPLES");
+ if (sp) {
+ mp = sp->mbase;
+ if (mp) {
+ flag = 1;
+ if (mp->sym != sp || mp->snext)
+ intwarning("debughook", "Inconsistent!");
+ } else
+ if (flag)
+ intwarning("debughook", "Missing!");
+ }
+#endif
+}
+
+
+
+
+
+
+/* The "Strlist" data type, like in NEWASM */
+
+
+/* Add a string to end of strlist */
+
+Strlist *strlist_append(base, s)
+register Strlist **base;
+register char *s;
+{
+ register Strlist *p;
+
+ while (*base)
+ base = &(*base)->next;
+ *base = p = ALLOCV(sizeof(Strlist) + strlen(s), Strlist, strlists);
+ p->next = NULL;
+ p->value = 0;
+ strcpy(p->s, s);
+ return p;
+}
+
+
+
+/* Insert a string at front of strlist */
+
+Strlist *strlist_insert(base, s)
+register Strlist **base;
+register char *s;
+{
+ register Strlist *p;
+
+ p = ALLOCV(sizeof(Strlist) + strlen(s), Strlist, strlists);
+ p->next = *base;
+ *base = p;
+ p->value = 0;
+ strcpy(p->s, s);
+ return p;
+}
+
+
+
+/* Add a string to a sorted strlist */
+
+Strlist *strlist_add(base, s)
+register Strlist **base;
+register char *s;
+{
+ register Strlist *p;
+
+ while ((p = *base) && strcmp(p->s, s) < 0)
+ base = &p->next;
+ if (!p || strcmp(p->s, s)) {
+ p = ALLOCV(sizeof(Strlist) + strlen(s), Strlist, strlists);
+ p->next = *base;
+ *base = p;
+ strcpy(p->s, s);
+ }
+ p->value = 0;
+ return p;
+}
+
+
+
+/* Append two strlists together */
+
+void strlist_mix(base, sl)
+register Strlist **base;
+Strlist *sl;
+{
+ if (sl) {
+ while (*base)
+ base = &(*base)->next;
+ *base = sl;
+ }
+}
+
+
+
+/* Remove the first element of a strlist */
+
+void strlist_eat(base)
+register Strlist **base;
+{
+ register Strlist *p;
+
+ if ((p = *base) != NULL) {
+ *base = p->next;
+ FREE(p);
+ }
+}
+
+
+
+/* Remove all elements of a strlist */
+
+void strlist_empty(base)
+register Strlist **base;
+{
+ register Strlist *p;
+
+ if (!base) {
+ intwarning("strlist_empty", "NULL base pointer [312]");
+ return;
+ }
+ while ((p = *base) != NULL) {
+ *base = p->next;
+ FREE(p);
+ }
+}
+
+
+
+/* Remove first occurrence of a given string */
+
+void strlist_remove(base, s)
+register Strlist **base;
+register char *s;
+{
+ register Strlist *p;
+
+ while ((p = *base) != NULL) {
+ if (!strcmp(p->s, s)) {
+ *base = p->next;
+ FREE(p);
+ } else
+ base = &p->next;
+ }
+}
+
+
+
+/* Remove a given entry from a strlist */
+
+void strlist_delete(base, sl)
+register Strlist **base, *sl;
+{
+ register Strlist *p;
+
+ while ((p = *base) && p != sl)
+ base = &p->next;
+ if (p) {
+ *base = p->next;
+ FREE(p);
+ }
+}
+
+
+
+/* Find the first occurrence of a string */
+
+Strlist *strlist_find(base, s)
+register Strlist *base;
+register char *s;
+{
+ if (!s)
+ return NULL;
+ while (base && strcmp(base->s, s))
+ base = base->next;
+ return base;
+}
+
+
+
+/* Case-insensitive version of strlist_find */
+
+Strlist *strlist_cifind(base, s)
+register Strlist *base;
+register char *s;
+{
+ if (!s)
+ return NULL;
+ while (base && strcicmp(base->s, s))
+ base = base->next;
+ return base;
+}
+
+
+
+
+
+
+/* String comparisons */
+
+
+int strcincmp(s1, s2, n)
+register char *s1, *s2;
+register int n;
+{
+ register unsigned char ch1, ch2;
+
+ while (--n >= 0) {
+ if (!(ch1 = *s1++))
+ return (*s2) ? -1 : 0;
+ if (!(ch2 = *s2++))
+ return 1;
+ if (islower(ch1))
+ ch1 = _toupper(ch1);
+ if (islower(ch2))
+ ch2 = _toupper(ch2);
+ if (ch1 != ch2)
+ return ch1 - ch2;
+ }
+ return 0;
+}
+
+
+
+int strcicmp(s1, s2)
+register char *s1, *s2;
+{
+ register unsigned char ch1, ch2;
+
+ for (;;) {
+ if (!(ch1 = *s1++))
+ return (*s2) ? -1 : 0;
+ if (!(ch2 = *s2++))
+ return 1;
+ if (islower(ch1))
+ ch1 = _toupper(ch1);
+ if (islower(ch2))
+ ch2 = _toupper(ch2);
+ if (ch1 != ch2)
+ return ch1 - ch2;
+ }
+}
+
+
+
+
+
+
+/* File name munching */
+
+
+void fixfname(fn, ext)
+char *fn, *ext;
+{
+ char *cp, *cp2;
+
+ if (!ext)
+ return;
+ cp = my_strrchr(fn, '.');
+ cp2 = my_strrchr(fn, '/');
+ if (cp && (!cp2 || cp > cp2)) {
+ if (!cp[1]) /* remove trailing '.' */
+ *cp = 0;
+ } else {
+ strcat(fn, ".");
+ strcat(fn, ext);
+ }
+}
+
+
+
+void removesuffix(fn)
+char *fn;
+{
+ char *cp, *cp2;
+
+ cp = my_strrchr(fn, '.');
+ if (!cp)
+ return;
+#if defined(unix) || defined(__unix)
+ cp2 = my_strrchr(fn, '/');
+ if (cp2 && cp < cp2)
+ return;
+#endif
+ *cp = 0;
+}
+
+
+
+
+
+
+/* Dynamically-allocated strings */
+
+
+char *stralloc(s)
+char *s;
+{
+ register char *buf = ALLOC(strlen(s) + 1, char, strings);
+ strcpy(buf, s);
+ return buf;
+}
+
+
+
+void strchange(v, s)
+char **v, *s;
+{
+ s = stralloc(s); /* do this first in case **v and *s overlap */
+ FREE(*v);
+ *v = s;
+}
+
+
+
+
+
+/* Handy string formatting */
+
+#define NUMBUF 8
+static char *(formatbuf[NUMBUF]);
+static int nextformat = -1;
+
+#define getformat() ((nextformat=(nextformat+1)%NUMBUF), formatbuf[nextformat])
+
+
+#define FF_UCASE 0x1
+#define FF_LCASE 0x2
+#define FF_REMSUFF 0x4
+#define FF_UNDER 0x8 /* Thanks to William Bader for suggesting these */
+#define FF_PRESERVE 0x10
+#define FF_REMSLASH 0x20
+#define FF_REMUNDER 0x40
+
+Static void cvcase(buf, flags)
+char *buf;
+int flags;
+{
+ char *cp, *cp2;
+ int ulflag, i;
+
+ if (flags & FF_PRESERVE) {
+ ulflag = 0;
+ for (cp = buf; *cp; cp++) {
+ if (isupper(*cp))
+ ulflag |= 1;
+ else if (islower(*cp))
+ ulflag |= 2;
+ }
+ if (ulflag == 3)
+ flags &= ~(FF_UCASE | FF_LCASE);
+ }
+ if ((flags & FF_UNDER) && *buf) {
+ for (cp = buf + 1; *cp; cp++) {
+ if (isupper(*cp) && islower(cp[-1])) {
+ for (i = strlen(cp); i >= 0; i--)
+ cp[i+1] = cp[i];
+ *cp++ = '_';
+ }
+ }
+ }
+ if (flags & FF_UCASE) {
+ if (flags & FF_LCASE) {
+ for (cp = buf; *cp; cp++) {
+ if (cp == buf || !isalpha(cp[-1]))
+ *cp = toupper(*cp);
+ else
+ *cp = tolower(*cp);
+ }
+ } else
+ upc(buf);
+ } else if (flags & FF_LCASE)
+ lwc(buf);
+ if (flags & FF_REMUNDER) {
+ for (cp = cp2 = buf; *cp; cp++) {
+ if (isalnum(*cp))
+ *cp2++ = *cp;
+ }
+ if (cp2 > buf)
+ *cp2 = 0;
+ }
+}
+
+
+char *format_gen(fmt, i1, i2, dbl, s1, s2, s3)
+char *fmt;
+long i1, i2;
+double dbl;
+char *s1, *s2, *s3;
+{
+ char *buf = getformat();
+ char *dst = buf, *src = fmt, *cp, *cp2, *saves2 = s2;
+ int wid, prec;
+ int flags;
+ char fmtbuf[50], *fp;
+
+ debughook();
+ while (*src) {
+ if (*src != '%') {
+ *dst++ = *src++;
+ continue;
+ }
+ src++;
+ wid = -1;
+ prec = -1;
+ flags = 0;
+ fp = fmtbuf;
+ *fp++ = '%';
+ for (;;) {
+ if (*src == '-' || *src == '+' || *src == ' ' || *src == '#') {
+ *fp++ = *src;
+ } else if (*src == '^') {
+ flags |= FF_UCASE;
+ } else if (*src == '_') {
+ flags |= FF_LCASE;
+ } else if (*src == 'R') {
+ flags |= FF_REMSUFF;
+ } else if (*src == '~') {
+ flags |= FF_UNDER;
+ } else if (*src == '!') {
+ flags |= FF_REMUNDER;
+ } else if (*src == '?') {
+ flags |= FF_PRESERVE;
+ } else if (*src == '/') {
+ flags |= FF_REMSLASH;
+ } else
+ break;
+ src++;
+ }
+ if (isdigit(*src)) {
+ wid = 0;
+ while (isdigit(*src))
+ wid = wid*10 + (*fp++ = *src++) - '0';
+ } else if (*src == '*') {
+ src++;
+ wid = i1;
+ sprintf(fp, "%d", wid);
+ fp = fp + strlen(fp);
+ if (wid < 0)
+ wid = -wid;
+ i1 = i2;
+ }
+ if (*src == '.') {
+ if (*++src == '*') {
+ prec = i1;
+ i1 = i2;
+ src++;
+ } else {
+ prec = 0;
+ while (isdigit(*src))
+ prec = prec*10 + (*src++) - '0';
+ }
+ sprintf(fp, ".%d", prec);
+ fp = fp + strlen(fp);
+ }
+ if (*src == 'l' || *src == 'h')
+ src++;
+ switch (*src) {
+
+ case '%':
+ *dst++ = '%';
+ break;
+
+ case 'H':
+ strcpy(dst, p2c_home);
+ dst = dst + strlen(dst);
+ break;
+
+ case 'd':
+ case 'i':
+ case 'o':
+ case 'u':
+ case 'x':
+ case 'X':
+ *fp++ = 'l';
+ *fp++ = *src;
+ *fp = 0;
+ sprintf(dst, fmtbuf, i1);
+ i1 = i2;
+ cvcase(dst, flags);
+ dst = dst + strlen(dst);
+ break;
+
+ case 'c':
+ *fp++ = *src;
+ *fp = 0;
+ sprintf(dst, fmtbuf, (int)i1);
+ i1 = i2;
+ cvcase(dst, flags);
+ dst = dst + strlen(dst);
+ break;
+
+ case 'e':
+ case 'E':
+ case 'f':
+ case 'g':
+ case 'G':
+ *fp++ = *src;
+ *fp++ = 0;
+ sprintf(dst, fmtbuf, dbl);
+ cvcase(dst, flags);
+ dst = dst + strlen(dst);
+ break;
+
+ case 's':
+ case 'S':
+ *fp++ = 's';
+ *fp = 0;
+ if (*src == 'S' && saves2) {
+ cp = saves2;
+ } else {
+ cp = s1;
+ s1 = s2;
+ s2 = s3;
+ }
+ if (flags & FF_REMSUFF) {
+ cp = format_s("%s", cp);
+ removesuffix(cp);
+ }
+ if (flags & FF_REMSLASH) {
+ cp2 = cp + strlen(cp);
+ while (cp2 >= cp &&
+ *cp2 != '/' && *cp2 != '\\' &&
+ *cp2 != ']' && *cp2 != ':')
+ cp2--;
+ if (cp2[1])
+ cp = cp2 + 1;
+ }
+ sprintf(dst, fmtbuf, cp);
+ cvcase(dst, flags);
+ dst = dst + strlen(dst);
+ break;
+
+ }
+ src++;
+ }
+ *dst = 0;
+ return buf;
+}
+
+
+
+
+char *format_none(fmt)
+char *fmt;
+{
+ return format_gen(fmt, 0L, 0L, 0.0, NULL, NULL, NULL);
+}
+
+
+char *format_d(fmt, a1)
+char *fmt;
+int a1;
+{
+ return format_gen(fmt, a1, 0L, (double)a1, NULL, NULL, NULL);
+}
+
+
+char *format_g(fmt, a1)
+char *fmt;
+double a1;
+{
+ return format_gen(fmt, (long)a1, 0L, a1, NULL, NULL, NULL);
+}
+
+
+char *format_s(fmt, a1)
+char *fmt, *a1;
+{
+ return format_gen(fmt, 0L, 0L, 0.0, a1, NULL, NULL);
+}
+
+
+char *format_ss(fmt, a1, a2)
+char *fmt, *a1, *a2;
+{
+ return format_gen(fmt, 0L, 0L, 0.0, a1, a2, NULL);
+}
+
+
+char *format_sd(fmt, a1, a2)
+char *fmt, *a1;
+int a2;
+{
+ return format_gen(fmt, a2, 0L, (double)a2, a1, NULL, NULL);
+}
+
+
+char *format_ds(fmt, a1, a2)
+char *fmt, *a2;
+long a1;
+{
+ return format_gen(fmt, a1, 0L, (double)a1, a2, NULL, NULL);
+}
+
+
+char *format_dd(fmt, a1, a2)
+char *fmt;
+long a1, a2;
+{
+ return format_gen(fmt, a1, a2, (double)a1, NULL, NULL, NULL);
+}
+
+
+char *format_sss(fmt, a1, a2, a3)
+char *fmt, *a1, *a2, *a3;
+{
+ return format_gen(fmt, 0L, 0L, 0.0, a1, a2, a3);
+}
+
+
+char *format_ssd(fmt, a1, a2, a3)
+char *fmt, *a1, *a2;
+long a3;
+{
+ return format_gen(fmt, a3, 0L, (double)a3, a1, a2, NULL);
+}
+
+
+char *format_sds(fmt, a1, a2, a3)
+char *fmt, *a1, *a3;
+long a2;
+{
+ return format_gen(fmt, a2, 0L, (double)a2, a1, a3, NULL);
+}
+
+
+
+
+/* String conversions */
+
+int my_toupper(c)
+int c;
+{
+ if (islower(c))
+ return _toupper(c);
+ else
+ return c;
+}
+
+
+int my_tolower(c)
+int c;
+{
+ if (isupper(c))
+ return _tolower(c);
+ else
+ return c;
+}
+
+
+void upc(s)
+register char *s;
+{
+ for (; *s; s++)
+ *s = toupper(*s);
+}
+
+
+void lwc(s)
+register char *s;
+{
+ for (; *s; s++)
+ *s = tolower(*s);
+}
+
+
+char *strupper(s)
+register char *s;
+{
+ char *dest = getformat();
+ register char *s2 = dest;
+ while (*s)
+ *s2++ = toupper(*s++);
+ *s2 = 0;
+ return dest;
+}
+
+
+char *strlower(s)
+register char *s;
+{
+ char *dest = getformat();
+ register char *s2 = dest;
+ while (*s)
+ *s2++ = tolower(*s++);
+ *s2 = 0;
+ return dest;
+}
+
+
+
+char *my_strchr(cp, c)
+register char *cp;
+int c;
+{
+ while (*cp && *cp != c)
+ cp++;
+ if (*cp)
+ return cp;
+ else
+ return NULL;
+}
+
+
+char *my_strrchr(cp, c)
+register char *cp;
+int c;
+{
+ register char *cp2 = NULL;
+ while (*cp) {
+ if (*cp == c)
+ cp2 = cp;
+ cp++;
+ }
+ return cp2;
+}
+
+
+char *my_strtok(cp, delim)
+char *cp, *delim;
+{
+ static char *ptr;
+
+ if (cp)
+ ptr = cp;
+ while (*ptr && my_strchr(delim, *ptr))
+ ptr++;
+ if (!*ptr)
+ return NULL;
+ cp = ptr;
+ while (*ptr && !my_strchr(delim, *ptr))
+ ptr++;
+ *ptr++ = 0;
+ return cp;
+}
+
+
+
+long my_strtol(buf, ret, base)
+char *buf, **ret;
+int base;
+{
+ unsigned long val = 0;
+ int dig, sign = 1;
+
+ while (isspace(*buf))
+ buf++;
+ if (*buf == '+')
+ buf++;
+ else if (*buf == '-') {
+ sign = -1;
+ buf++;
+ }
+ if (*buf == '0') {
+ if ((buf[1] == 'x' || buf[1] == 'X') &&
+ (base == 0 || base == 16)) {
+ buf++;
+ base = 16;
+ } else if (base == 0)
+ base = 8;
+ buf++;
+ }
+ for (;;) {
+ if (isdigit(*buf))
+ dig = *buf - '0';
+ else if (*buf >= 'a')
+ dig = *buf - 'a' + 10;
+ else if (*buf >= 'A')
+ dig = *buf - 'A' + 10;
+ else
+ break;
+ if (dig >= base)
+ break;
+ val = val * base + dig;
+ buf++;
+ }
+ if (ret)
+ *ret = buf;
+ if (sign > 0)
+ return val;
+ else
+ return -val;
+}
+
+
+
+
+void init_stuff()
+{
+ int i;
+
+ for (i = 0; i < NUMBUF; i++)
+ formatbuf[i] = ALLOC(1000, char, misc);
+}
+
+
+
+
+/* End. */
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/trans.c b/MultiSource/Benchmarks/MallocBench/p2c/trans.c
new file mode 100644
index 00000000..430e7ae5
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/trans.c
@@ -0,0 +1,1512 @@
+/* "p2c", a Pascal to C translator.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+
+#define define_globals
+#define PROTO_TRANS_C
+#include "trans.h"
+
+#include <time.h>
+
+
+
+
+
+
+/* Roadmap:
+
+ trans.h Declarations for all public global variables, types,
+ and macros. Functions are declared in separate
+ files p2c.{proto,hdrs} which are created
+ mechanically by the makeproto program.
+
+ trans.c Main program. Parses the p2crc file. Also reserves
+ storage for public globals in trans.h.
+
+ stuff.c Miscellaneous support routines.
+
+ out.c Routines to handle the writing of C code to the output
+ file. This includes line breaking and indentation
+ support.
+
+ comment.c Routines for managing comments and comment lists.
+
+ lex.c Lexical analyzer. Manages input files and streams,
+ splits input stream into Pascal tokens. Parses
+ compiler directives and special comments. Also keeps
+ the symbol table.
+
+ parse.c Parsing and writing statements and blocks.
+
+ decl.c Parsing and writing declarations.
+
+ expr.c Manipulating expressions.
+
+ pexpr.c Parsing and writing expressions.
+
+ funcs.c Built-in special functions and procedures.
+
+ dir.c Interface file to "external" functions and procedures
+ such as hpmods and citmods.
+
+ hpmods.c Definitions for HP-supplied Pascal modules.
+
+ citmods.c Definitions for some Caltech-local Pascal modules.
+ (Outside of Caltech this file is mostly useful
+ as a large body of examples of how to write your
+ own translator extensions.)
+
+
+ p2crc Control file (read when p2c starts up).
+
+ p2c.h Header file used by translated programs.
+
+ p2clib.c Run-time library used by translated programs.
+
+*/
+
+
+
+
+Static Strlist *tweaksymbols, *synonyms;
+Strlist *addmacros;
+
+
+
+Static void initrc()
+{
+ int i;
+
+ for (i = 0; i < numparams; i++) {
+ switch (rctable[i].kind) {
+ case 'S':
+ case 'B':
+ *((short *)rctable[i].ptr) = rctable[i].def;
+ break;
+ case 'I':
+ case 'D':
+ *((int *)rctable[i].ptr) = rctable[i].def;
+ break;
+ case 'L':
+ *((long *)rctable[i].ptr) = rctable[i].def;
+ break;
+ case 'R':
+ *((double *)rctable[i].ptr) = rctable[i].def/100.0;
+ break;
+ case 'U':
+ case 'C':
+ *((char *)rctable[i].ptr) = 0;
+ break;
+ case 'A':
+ *((Strlist **)rctable[i].ptr) = NULL;
+ break;
+ case 'X':
+ if (rctable[i].def == 1)
+ *((Strlist **)rctable[i].ptr) = NULL;
+ break;
+ }
+ rcprevvalues[i] = NULL;
+ }
+ tweaksymbols = NULL;
+ synonyms = NULL;
+ addmacros = NULL;
+ varmacros = NULL;
+ constmacros = NULL;
+ fieldmacros = NULL;
+ funcmacros = NULL;
+}
+
+
+
+Static int readrc(rcname, need)
+char *rcname;
+int need;
+{
+ FILE *rc;
+ char buf[500], *cp, *cp2;
+ long val = 0;
+ int i;
+ Strlist *sl;
+
+ rc = fopen(rcname, "r");
+ if (!rc) {
+ if (need)
+ perror(rcname);
+ return 0;
+ }
+ while (fgets(buf, 500, rc)) {
+ cp = my_strtok(buf, " =\t\n");
+ if (cp && *cp != '#') {
+ upc(cp);
+ i = numparams;
+ while (--i >= 0 && strcmp(rctable[i].name, cp)) ;
+ if (i >= 0) {
+ if (rctable[i].kind != 'M') {
+ cp = my_strtok(NULL, " =\t\n");
+ if (cp && *cp == '#')
+ cp = NULL;
+ if (cp && (isdigit(*cp) || *cp == '-' || *cp == '+'))
+ val = atol(cp);
+ else
+ val = rctable[i].def;
+ }
+ switch (rctable[i].kind) {
+
+ case 'S':
+ *((short *)rctable[i].ptr) = val;
+ break;
+
+ case 'I':
+ *((int *)rctable[i].ptr) = val;
+ break;
+
+ case 'D':
+ *((int *)rctable[i].ptr) =
+ parsedelta(cp, rctable[i].def);
+ break;
+
+ case 'L':
+ *((long *)rctable[i].ptr) = val;
+ break;
+
+ case 'R':
+ if (cp && (isdigit(*cp) || *cp == '-' || *cp == '.'))
+ *((double *)rctable[i].ptr) = atof(cp);
+ else
+ *((double *)rctable[i].ptr) = rctable[i].def/100.0;
+ break;
+
+ case 'U':
+ if (cp)
+ upc(cp);
+
+ /* fall through */
+ case 'C':
+ val = rctable[i].def;
+ strncpy((char *)rctable[i].ptr, cp ? cp : "", val-1);
+ ((char *)rctable[i].ptr)[val-1] = 0;
+ break;
+
+ case 'F':
+ while (cp && *cp != '#') {
+ sl = strlist_append(&tweaksymbols,
+ format_s("*%s", cp));
+ sl->value = rctable[i].def;
+ cp = my_strtok(NULL, " \t\n");
+ }
+ break;
+
+ case 'G':
+ while (cp && *cp != '#') {
+ sl = strlist_append(&tweaksymbols, cp);
+ sl->value = rctable[i].def;
+ cp = my_strtok(NULL, " \t\n");
+ }
+ break;
+
+ case 'A':
+ while (cp && *cp != '#') {
+ strlist_insert((Strlist **)rctable[i].ptr, cp);
+ cp = my_strtok(NULL, " \t\n");
+ }
+ break;
+
+ case 'M':
+ cp = my_strtok(NULL, "\n");
+ if (cp) {
+ while (isspace(*cp)) cp++;
+ for (cp2 = cp; *cp2 && *cp2 != '#'; cp2++) ;
+ *cp2 = 0;
+ if (*cp) {
+ sl = strlist_append(&addmacros, cp);
+ sl->value = rctable[i].def;
+ }
+ }
+ break;
+
+ case 'B':
+ if (cp)
+ val = parse_breakstr(cp);
+ if (val != -1)
+ *((short *)rctable[i].ptr) = val;
+ break;
+
+ case 'X':
+ switch (rctable[i].def) {
+
+ case 1: /* strlist with string values */
+ if (cp) {
+ sl = strlist_append((Strlist **)rctable[i].ptr, cp);
+ cp = my_strtok(NULL, " =\t\n");
+ if (cp && *cp != '#')
+ sl->value = (long)stralloc(cp);
+ }
+ break;
+
+ case 2: /* Include */
+ if (cp)
+ readrc(format_s(cp, infname), 1);
+ break;
+
+ case 3: /* Synonym */
+ if (cp) {
+ sl = strlist_append(&synonyms, cp);
+ cp = my_strtok(NULL, " =\t\n");
+ if (cp && *cp != '#')
+ sl->value = (long)stralloc(cp);
+ }
+ break;
+
+ }
+ }
+ } else
+ fprintf(stderr, "warning: can't understand %s in %s\n", cp, rcname);
+ }
+ }
+ fclose(rc);
+ return 1;
+}
+
+
+Static void postrc()
+{
+ int longbits;
+ unsigned long val;
+
+ which_unix = UNIX_ANY;
+ if (!strcmp(target, "CHIPMUNK") ||
+ !strcmp(target, "HPUX-300") ||
+ !strcmp(target, "SUN-68K") ||
+ !strcmp(target, "BSD-VAX")) {
+ signedchars = 1;
+ sizeof_char = 8;
+ sizeof_short = 16;
+ sizeof_int = sizeof_long = sizeof_pointer = 32;
+ sizeof_enum = 32;
+ sizeof_float = 32;
+ sizeof_double = 64;
+ if (!strcmp(target, "CHIPMUNK") ||
+ !strcmp(target, "HPUX-300"))
+ which_unix = UNIX_SYSV;
+ else
+ which_unix = UNIX_BSD;
+ } else if (!strcmp(target, "LSC-MAC")) {
+ signedchars = 1;
+ if (prototypes < 0)
+ prototypes = 1;
+ if (fullprototyping < 0)
+ fullprototyping = 0;
+ if (voidstar < 0)
+ voidstar = 1;
+ sizeof_char = 8;
+ sizeof_short = sizeof_int = 16;
+ sizeof_long = sizeof_pointer = 32;
+ } else if (!strcmp(target, "BSD")) {
+ which_unix = UNIX_BSD;
+ } else if (!strcmp(target, "SYSV")) {
+ which_unix = UNIX_SYSV;
+ } else if (*target) {
+ fprintf(stderr, "p2c: warning: don't understand target name %s\n", target);
+ }
+ if (ansiC > 0) {
+ if (sprintf_value < 0)
+ sprintf_value = 0;
+ if (castnull < 0)
+ castnull = 0;
+ }
+ if (useenum < 0)
+ useenum = (ansiC != 0) ? 1 : 0;
+ if (void_args < 0)
+ void_args = (ansiC > 0 && prototypes != 0) ? 1 : 0;
+ if (prototypes < 0)
+ prototypes = (cplus > 0) ? 2 : (ansiC > 0) ? 1 : 0;
+ if (prototypes == 0)
+ fullprototyping = 0;
+ else if (fullprototyping < 0)
+ fullprototyping = 1;
+ if (useAnyptrMacros < 0)
+ useAnyptrMacros = (ansiC > 0 || cplus > 0) ? 2 : 1;
+ if (usePPMacros < 0)
+ usePPMacros = (ansiC > 0 || cplus > 0) ? 0 : 2;
+ if (voidstar < 0)
+ voidstar = (ansiC > 0 || cplus > 0) ? 1 : 0;
+ if (hassignedchar < 0)
+ hassignedchar = (ansiC > 0) ? 1 : 0;
+ if (useconsts < 0)
+ useconsts = (ansiC > 0 || cplus > 0) ? 1 : 0;
+ if (copystructs < 0)
+ copystructs = (ansiC != 0 || cplus > 0) ? 3 : 0;
+ if (copystructfuncs < 0)
+ copystructfuncs = (ansiC > 0 || cplus > 0) ? 0 : 1;
+ if (starfunctions < 0)
+ starfunctions = (ansiC > 0) ? 0 : 1;
+ if (variablearrays < 0)
+ variablearrays = (ansiC > 1) ? 1 : 0;
+ if (initpacstrings < 0)
+ initpacstrings = (ansiC > 0) ? 1 : 0;
+ if (*memcpyname) {
+ if (ansiC > 0 || which_unix == UNIX_SYSV)
+ strcpy(memcpyname, "memcpy");
+ else if (which_unix == UNIX_BSD)
+ strcpy(memcpyname, "bcopy");
+ }
+ sizeof_integer = (sizeof_int >= 32) ? sizeof_int : sizeof_long;
+ integername = (sizeof_int >= 32) ? "int" : "long";
+ if (sizeof_integer && sizeof_integer < 32)
+ fprintf(stderr, "Warning: long integers have less than 32 bits\n");
+ if (sizeof_int >= 32 && sizeof_long > sizeof_int && prototypes == 0)
+ fprintf(stderr, "Warning: translated code assumes int and long are the same");
+ if (setbits < 0)
+ setbits = (sizeof_integer > 0) ? sizeof_integer : 32;
+ ucharname = (*name_UCHAR) ? name_UCHAR :
+ (signedchars == 0) ? "char" : "unsigned char";
+ scharname = (*name_SCHAR) ? name_SCHAR :
+ (signedchars == 1) ? "char" :
+ (useAnyptrMacros == 1) ? "Signed char" : "signed char";
+ for (longbits = 1, val = LONG_MAX; val >>= 1; longbits++) ;
+ if (sizeof_char) {
+ if (sizeof_char < 8 && ansiC > 0)
+ fprintf(stderr, "Warning: chars have less than 8 bits\n");
+ if (sizeof_char > longbits) {
+ min_schar = LONG_MIN;
+ max_schar = LONG_MAX;
+ } else {
+ min_schar = - (1<<(sizeof_char-1));
+ max_schar = (1<<(sizeof_char-1)) - 1;
+ }
+ if (sizeof_char >= longbits)
+ max_uchar = LONG_MAX;
+ else
+ max_uchar = (1<<sizeof_char) - 1;
+ } else {
+ min_schar = -128; /* Ansi-required minimum maxima */
+ max_schar = 127;
+ max_uchar = 255;
+ }
+ if (sizeof_short) {
+ if (sizeof_short < 16 && ansiC > 0)
+ fprintf(stderr, "Warning: shorts have less than 16 bits\n");
+ if (sizeof_short > longbits) {
+ min_sshort = LONG_MIN;
+ max_sshort = LONG_MAX;
+ } else {
+ min_sshort = - (1<<(sizeof_short-1));
+ max_sshort = (1<<(sizeof_short-1)) - 1;
+ }
+ if (sizeof_short >= longbits)
+ max_ushort = LONG_MAX;
+ else
+ max_ushort = (1<<sizeof_short) - 1;
+ } else {
+ min_sshort = -32768; /* Ansi-required minimum maxima */
+ max_sshort = 32767;
+ max_ushort = 65535;
+ }
+ if (symcase < 0)
+ symcase = 1;
+ if (smallsetconst == -2)
+ smallsetconst = (*name_SETBITS) ? -1 : 1;
+ hpux_lang = 0;
+ if (!strcmp(language, "TURBO")) {
+ which_lang = LANG_TURBO;
+ } else if (!strcmp(language, "UCSD")) {
+ which_lang = LANG_UCSD;
+ } else if (!strcmp(language, "MPW")) {
+ which_lang = LANG_MPW;
+ } else if (!strcmp(language, "HPUX") || !strcmp(language, "HP-UX")) {
+ which_lang = LANG_HP;
+ hpux_lang = 1;
+ } else if (!strcmp(language, "OREGON")) {
+ which_lang = LANG_OREGON;
+ } else if (!strcmp(language, "VAX") || !strcmp(language, "VMS")) {
+ which_lang = LANG_VAX;
+ } else if (!strncmp(language, "MODULA", 6)) {
+ which_lang = LANG_MODULA;
+ } else if (!strncmp(language, "BERK", 4) ||
+ !strcmp(language, "SUN")) {
+ which_lang = LANG_BERK;
+ } else {
+ if (*language && strcmp(language, "HP") && strcmp(language, "MODCAL"))
+ fprintf(stderr, "Warning: Language %s not recognized, using HP\n", language);
+ which_lang = LANG_HP;
+ }
+ if (modula2 < 0)
+ modula2 = (which_lang == LANG_MODULA) ? 1 : 0;
+ if (pascalcasesens < 0)
+ pascalcasesens = (which_lang == LANG_MODULA) ? 2 :
+ (which_lang == LANG_BERK) ? 3 : 0;
+ if (implementationmodules < 0)
+ implementationmodules = (which_lang == LANG_VAX) ? 1 : 0;
+ if (integer16 < 0)
+ integer16 = (which_lang == LANG_TURBO ||
+ which_lang == LANG_MPW) ? 1 : 0;
+ if (doublereals < 0)
+ doublereals = (hpux_lang ||
+ which_lang == LANG_OREGON ||
+ which_lang == LANG_VAX) ? 0 : 1;
+ if (pascalenumsize < 0)
+ pascalenumsize = (which_lang == LANG_HP) ? 16 : 8;
+ if (storefilenames < 0)
+ storefilenames = (which_lang == LANG_TURBO) ? 1 : 0;
+ if (charfiletext < 0)
+ charfiletext = (which_lang == LANG_BERK) ? 1 : 0;
+ if (readwriteopen < 0)
+ readwriteopen = (which_lang == LANG_TURBO) ? 1 : 0;
+ if (literalfilesflag < 0)
+ literalfilesflag = (which_lang == LANG_BERK) ? 2 : 0;
+ if (newlinespace < 0)
+ newlinespace = (which_lang == LANG_TURBO) ? 0 : 1;
+ if (nestedcomments < 0)
+ nestedcomments = (which_lang == LANG_TURBO ||
+ which_lang == LANG_MPW ||
+ which_lang == LANG_UCSD ||
+ which_lang == LANG_BERK) ? 2 : 0;
+ if (importall < 0)
+ importall = (which_lang == LANG_HP) ? 1 : 0;
+ if (seek_base < 0)
+ seek_base = (which_lang == LANG_TURBO ||
+ which_lang == LANG_MPW ||
+ which_lang == LANG_UCSD) ? 0 : 1;
+ if (unsignedchar < 0 && signedchars == 0)
+ unsignedchar = 2;
+ if (hasstaticlinks < 0)
+ hasstaticlinks = (which_lang == LANG_HP) ? 1 : 0;
+ if (dollar_idents < 0)
+ dollar_idents = (which_lang == LANG_OREGON ||
+ which_lang == LANG_VAX) ? 1 : 0;
+ if (ignorenonalpha < 0)
+ ignorenonalpha = (which_lang == LANG_UCSD) ? 1 : 0;
+ if (stringtrunclimit < 0)
+ stringtrunclimit = (which_lang == LANG_TURBO) ? 80 : 0;
+ if (defaultsetsize < 0)
+ defaultsetsize = (which_lang == LANG_VAX) ? 256 :
+ (which_lang == LANG_BERK) ? 128 :
+ (which_lang == LANG_MPW) ? 2040 : 8192;
+ if (enumbyte < 0)
+ enumbyte = (which_lang == LANG_HP) ? 0 : 1;
+ if (!*filenamefilter && (which_lang == LANG_OREGON ||
+ which_lang == LANG_BERK))
+ strcpy(filenamefilter, "P_trimname");
+ charname = (useAnyptrMacros) ? "Char" :
+ (unsignedchar == 1) ? ucharname :
+ (unsignedchar == 0) ? scharname : "char";
+ if (!*memcpyname)
+ strcpy(memcpyname, "memcpy");
+ if (!*mallocname)
+ strcpy(mallocname, "malloc");
+ if (!*freename)
+ strcpy(freename, "free");
+ fix_parameters();
+}
+
+
+
+
+void saveoldfile(fname)
+char *fname;
+{
+#if defined(unix) || defined(__unix) || defined(CAN_LINK)
+ (void) unlink(format_s("%s~", fname));
+ if (link(fname, format_s("%s~", fname)) == 0)
+ (void) unlink(fname);
+#endif
+}
+
+
+
+#ifndef __STDC__
+# ifdef NO_GETENV
+# define getenv(x) NULL
+# else
+extern char *getenv PP((char *));
+# endif
+#endif
+
+Static long starting_time;
+
+Static void openlogfile()
+{
+ char *name, *uname;
+
+ if (*codefname == '<')
+ name = format_ss(logfnfmt, infname, infname);
+ else
+ name = format_ss(logfnfmt, infname, codefname);
+ if (!name)
+ name = format_s("%s.log", codefname);
+ saveoldfile(name);
+ logf = fopen(name, "w");
+ if (logf) {
+ fprintf(logf, "\nTranslation of %s to %s by p2c %s\n",
+ infname, codefname, P2C_VERSION);
+ fprintf(logf, "Translated");
+ uname = getenv("USER");
+ if (uname)
+ fprintf(logf, " by %s", uname);
+ time(&starting_time);
+ fprintf(logf, " on %s", ctime(&starting_time));
+ fprintf(logf, "\n\n");
+ } else {
+ perror(name);
+ verbose = 0;
+ }
+}
+
+
+void closelogfile()
+{
+ long ending_time;
+
+ if (logf) {
+ fprintf(logf, "\n\n");
+#if defined(unix) || defined(__unix)
+ fprintf(logf, "Total memory used: %ld bytes.\n", (long)sbrk(0));
+#endif
+ time(&ending_time);
+ fprintf(logf, "Processed %d source lines in %ld:%ld seconds.\n",
+ inf_ltotal,
+ (ending_time - starting_time) / 60,
+ (ending_time - starting_time) % 60);
+ fprintf(logf, "\n\nTranslation completed on %s", ctime(&ending_time));
+ fclose(logf);
+ }
+}
+
+
+
+
+void showinitfile()
+{
+ FILE *f;
+ int ch;
+ char *name;
+
+ name = format_s("%H/%s", "p2crc");
+ printf("# Copy of file %%H/p2crc => %s:\n\n", name);
+ f = fopen(name, "r");
+ if (!f) {
+ perror(name);
+ exit(1);
+ }
+ while ((ch = getc(f)) != EOF)
+ putchar(ch);
+ fclose(f);
+ exit(0);
+}
+
+
+
+
+void usage()
+{
+ fprintf(stderr, "usage: p2c [options] file [modulename] [-h file.h] [-o file.c]\n");
+ exit(EXIT_FAILURE);
+}
+
+
+
+int main(argc, argv)
+int argc;
+char **argv;
+{
+ int numsearch;
+ char *searchlist[50];
+ char infnbuf[200], codefnbuf[200], hdrfnbuf[200], *cp;
+ Symbol *sp;
+ Strlist *sl;
+ int i, nobuffer = 0, savequiet;
+
+ i = 0;
+ while (i < argc && strcmp(argv[i], "-H")) i++;
+ if (i < argc-1)
+ p2c_home = argv[i+1];
+ else {
+ cp = getenv("P2C_HOME");
+ if (cp)
+ p2c_home = cp;
+ }
+ init_stuff();
+ i = 0;
+ while (i < argc && strcmp(argv[i], "-i")) i++;
+ if (i < argc)
+ showinitfile();
+ initrc();
+ setup_dir();
+ infname = infnbuf;
+ *infname = 0;
+ i = 0;
+ while (i < argc && argv[i][0] == '-') i++;
+ if (i >= argc)
+ strcpy(infname, argv[i]);
+ i = 0;
+ while (i < argc && strcmp(argv[i], "-v")) i++;
+ if (i >= argc) {
+ cp = getenv("P2CRC");
+ if (cp)
+ readrc(cp, 1);
+ else
+ readrc(format_s("%H/%s", "p2crc"), 1);
+ }
+ i = 0;
+ while (i < argc && strcmp(argv[i], "-c")) i++;
+ if (i < argc-1) {
+ if (strcmp(argv[i+1], "-"))
+ readrc(argv[i+1], 1);
+ } else
+ if (!readrc("p2crc", 0))
+ readrc(".p2crc", 0);
+ codefname = codefnbuf;
+ *codefname = 0;
+ hdrfname = hdrfnbuf;
+ *hdrfname = 0;
+ requested_module = NULL;
+ found_module = 0;
+ error_crash = 0;
+#ifdef CONSERVE_MEMORY
+ conserve_mem = CONSERVE_MEMORY;
+#else
+ conserve_mem = 1;
+#endif
+ regression = 0;
+ verbose = 0;
+ partialdump = 1;
+ numsearch = 0;
+ argc--, argv++;
+ while (argc > 0) {
+ if (**argv == '-' && (*argv)[1]) {
+ if (!strcmp(*argv, "-a")) {
+ ansiC = 1;
+ } else if (argv[0][1] == 'L') {
+ if (strlen(*argv) == 2 && argc > 1) {
+ strcpy(language, ++*argv);
+ --argc;
+ } else
+ strcpy(language, *argv + 2);
+ upc(language);
+ } else if (!strcmp(*argv, "-q")) {
+ quietmode = 1;
+ } else if (!strcmp(*argv, "-o")) {
+ if (*codefname || --argc <= 0)
+ usage();
+ strcpy(codefname, *++argv);
+ } else if (!strcmp(*argv, "-h")) {
+ if (*hdrfname || --argc <= 0)
+ usage();
+ strcpy(hdrfname, *++argv);
+ } else if (!strcmp(*argv, "-s")) {
+ if (--argc <= 0)
+ usage();
+ cp = *++argv;
+ if (!strcmp(cp, "-"))
+ librfiles = NULL;
+ else
+ searchlist[numsearch++] = cp;
+ } else if (!strcmp(*argv, "-c")) {
+ if (--argc <= 0)
+ usage();
+ argv++;
+ /* already done above */
+ } else if (!strcmp(*argv, "-v")) {
+ /* already done above */
+ } else if (!strcmp(*argv, "-H")) {
+ /* already done above */
+ } else if (argv[0][1] == 'I') {
+ if (strlen(*argv) == 2 && argc > 1) {
+ strlist_append(&importdirs, ++*argv);
+ --argc;
+ } else
+ strlist_append(&importdirs, *argv + 2);
+ } else if (argv[0][1] == 'p') {
+ if (strlen(*argv) == 2)
+ showprogress = 25;
+ else
+ showprogress = atoi(*argv + 2);
+ nobuffer = 1;
+ } else if (!strcmp(*argv, "-e")) {
+ copysource++;
+ } else if (!strcmp(*argv, "-t")) {
+ tokentrace++;
+ } else if (!strcmp(*argv, "-x")) {
+ error_crash++;
+ } else if (argv[0][1] == 'E') {
+ if (strlen(*argv) == 2)
+ maxerrors = 0;
+ else
+ maxerrors = atoi(*argv + 2);
+ } else if (!strcmp(*argv, "-F")) {
+ partialdump = 0;
+ } else if (argv[0][1] == 'd') {
+ nobuffer = 1;
+ if (strlen(*argv) == 2)
+ debug = 1;
+ else
+ debug = atoi(*argv + 2);
+ } else if (argv[0][1] == 'B') {
+ if (strlen(*argv) == 2)
+ i = 1;
+ else
+ i = atoi(*argv + 2);
+ if (argc == 2 &&
+ strlen(argv[1]) > 2 &&
+ !strcmp(argv[1] + strlen(argv[1]) - 2, ".c")) {
+ testlinebreaker(i, argv[1]);
+ exit(EXIT_SUCCESS);
+ } else
+ testlinebreaker(i, NULL);
+ } else if (argv[0][1] == 'C') {
+ if (strlen(*argv) == 2)
+ cmtdebug = 1;
+ else
+ cmtdebug = atoi(*argv + 2);
+ } else if (!strcmp(*argv, "-R")) {
+ regression = 1;
+ } else if (argv[0][1] == 'V') {
+ if (strlen(*argv) == 2)
+ verbose = 1;
+ else
+ verbose = atoi(*argv + 2);
+ } else if (argv[0][1] == 'M') {
+ if (strlen(*argv) == 2)
+ conserve_mem = 1;
+ else
+ conserve_mem = atoi(*argv + 2);
+ } else
+ usage();
+ } else if (!*infname) {
+ strcpy(infname, *argv);
+ } else if (!requested_module) {
+ requested_module = stralloc(*argv);
+ } else
+ usage();
+ argc--, argv++;
+ }
+ if (requested_module && !*codefname)
+ strcpy(codefname, format_ss(modulefnfmt, infname, requested_module));
+ if (*infname && strcmp(infname, "-")) {
+ if (strlen(infname) > 2 &&
+ !strcmp(infname + strlen(infname) - 2, ".c")) {
+ fprintf(stderr, "What is wrong with this picture?\n");
+ exit(EXIT_FAILURE);
+ }
+ inf = fopen(infname, "r");
+ if (!inf) {
+ perror(infname);
+ exit(EXIT_FAILURE);
+ }
+ if (!*codefname)
+ strcpy(codefname, format_s(codefnfmt, infname));
+ } else {
+ strcpy(infname, "<stdin>");
+ inf = stdin;
+ if (!*codefname)
+ strcpy(codefname, "-");
+ }
+ if (strcmp(codefname, "-")) {
+ saveoldfile(codefname);
+ codef = fopen(codefname, "w");
+ if (!codef) {
+ perror(codefname);
+ exit(EXIT_FAILURE);
+ }
+ fprintf(codef, "/* Output from p2c, the Pascal-to-C translator */\n");
+ } else {
+ strcpy(codefname, "<stdout>");
+ codef = stdout;
+ }
+ if (nobuffer)
+ setbuf(codef, NULL); /* for debugging */
+ outf = codef;
+ outf_lnum = 1;
+ logf = NULL;
+ if (verbose)
+ openlogfile();
+ setup_complete = 0;
+ init_lex();
+ leadingcomments();
+ postrc();
+ setup_comment(); /* must call this first */
+ setup_lex(); /* must call this second */
+ setup_out();
+ setup_decl(); /* must call *after* setup_lex() */
+ setup_parse();
+ setup_funcs();
+ for (sl = tweaksymbols; sl; sl = sl->next) {
+ cp = sl->s;
+ if (*cp == '*') {
+ cp++;
+ if (!pascalcasesens)
+ upc(cp);
+ }
+ sp = findsymbol(cp);
+ if (sl->value & FUNCBREAK)
+ sp->flags &= ~FUNCBREAK;
+ sp->flags |= sl->value;
+ }
+ strlist_empty(&tweaksymbols);
+ for (sl = synonyms; sl; sl = sl->next) {
+ if (!pascalcasesens)
+ upc(sl->s);
+ sp = findsymbol(sl->s);
+ sp->flags |= SSYNONYM;
+ if (sl->value) {
+ if (!pascalcasesens)
+ upc((char *)sl->value);
+ strlist_append(&sp->symbolnames, "===")->value =
+ (long)findsymbol((char *)sl->value);
+ } else
+ strlist_append(&sp->symbolnames, "===")->value = 0;
+ }
+ strlist_empty(&synonyms);
+ for (sl = addmacros; sl; sl = sl->next) {
+ defmacro(sl->s, sl->value, "<macro>", 0);
+ }
+ strlist_empty(&addmacros);
+ handle_nameof();
+ setup_complete = 1;
+ savequiet = quietmode;
+ quietmode = 1;
+ for (sl = librfiles; sl; sl = sl->next)
+ (void)p_search(format_none(sl->s), "pas", 0);
+ for (i = 0; i < numsearch; i++)
+ (void)p_search(format_none(searchlist[i]), "pas", 1);
+ quietmode = savequiet;
+ p_program();
+ end_source();
+ flushcomments(NULL, -1, -1);
+ showendnotes();
+ check_unused_macros();
+ printf("\n");
+ if (!showprogress)
+ fprintf(stderr, "\n");
+ output("\n");
+ if (requested_module && !found_module)
+ error(format_s("Module \"%s\" not found in file", requested_module));
+ if (codef != stdout)
+ output("\n\n/* End. */\n");
+ if (inf != stdin)
+ fclose(inf);
+ if (codef != stdout)
+ fclose(codef);
+ closelogfile();
+ mem_summary();
+ if (!quietmode)
+ fprintf(stderr, "Translation completed.\n");
+ exit(EXIT_SUCCESS);
+}
+
+
+
+
+int outmem()
+{
+ fprintf(stderr, "p2c: Out of memory!\n");
+ exit(EXIT_FAILURE);
+}
+
+
+
+#if !defined(NO_ISBOGUS) && (defined(mc68000) || defined(m68k) || defined(vax))
+int ISBOGUS(p)
+char *p;
+{
+ unsigned long ip = (unsigned long)p;
+
+ if (ip < 0) {
+ if (ip < (unsigned long)&ip)
+ return 1; /* below the start of the stack */
+ } else if (ip >= 512) {
+ if (ip > (unsigned long)sbrk(0))
+ return 1; /* past the end of memory */
+ } else
+ return 1;
+ return 0;
+}
+#else
+#define ISBOGUS(p) 0
+#endif
+
+
+
+
+
+
+char *meaningkindname(kind)
+enum meaningkind kind;
+{
+#ifdef HASDUMPS
+ if ((unsigned int)kind < (unsigned int)MK_LAST)
+ return meaningkindnames[(int) kind];
+ else
+#endif /*HASDUMPS*/
+ return format_d("<meaning %d>", (int) kind);
+}
+
+char *typekindname(kind)
+enum typekind kind;
+{
+#ifdef HASDUMPS
+ if ((unsigned int)kind < (unsigned int)TK_LAST)
+ return typekindnames[(int) kind];
+ else
+#endif /*HASDUMPS*/
+ return format_d("<type %d>", (int) kind);
+}
+
+char *exprkindname(kind)
+enum exprkind kind;
+{
+#ifdef HASDUMPS
+ if ((unsigned int)kind < (unsigned int)EK_LAST)
+ return exprkindnames[(int) kind];
+ else
+#endif /*HASDUMPS*/
+ return format_d("<expr %d>", (int) kind);
+}
+
+char *stmtkindname(kind)
+enum stmtkind kind;
+{
+#ifdef HASDUMPS
+ if ((unsigned int)kind < (unsigned int)SK_LAST)
+ return stmtkindnames[(int) kind];
+ else
+#endif /*HASDUMPS*/
+ return format_d("<stmt %d>", (int) kind);
+}
+
+
+
+void dumptype(tp)
+Type *tp;
+{
+ if (!tp) {
+ fprintf(outf, "<NULL>\n");
+ return;
+ }
+ if (ISBOGUS(tp)) {
+ fprintf(outf, "0x%lX\n", tp);
+ return;
+ }
+ fprintf(outf, " Type %lx, kind=%s", tp, typekindname(tp->kind));
+#ifdef HASDUMPS
+ fprintf(outf, ", meaning=%lx, basetype=%lx, indextype=%lx\n",
+ tp->meaning, tp->basetype, tp->indextype);
+ tp->dumped = 1;
+ if (tp->basetype)
+ dumptype(tp->basetype);
+ if (tp->indextype)
+ dumptype(tp->indextype);
+#else
+ fprintf(outf, "\n");
+#endif /*HASDUMPS*/
+}
+
+
+void dumpmeaning(mp)
+Meaning *mp;
+{
+ if (!mp) {
+ fprintf(outf, "<NULL>\n");
+ return;
+ }
+ if (ISBOGUS(mp)) {
+ fprintf(outf, "0x%lX\n", mp);
+ return;
+ }
+ fprintf(outf, " Meaning %lx, name=%s, kind=%s", mp, ((mp->name) ? mp->name : "<null>"),
+ meaningkindname(mp->kind));
+#ifdef HASDUMPS
+ fprintf(outf, ", ctx=%lx, cbase=%lx, cnext=%lx, type=%lx\n",
+ mp->ctx, mp->cbase, mp->cnext, mp->type);
+ if (mp->type && !mp->type->dumped)
+ dumptype(mp->type);
+ mp->dumped = 1;
+#else
+ fprintf(outf, "\n");
+#endif /*HASDUMPS*/
+}
+
+
+void dumpsymtable(sym)
+Symbol *sym;
+{
+ Meaning *mp;
+
+ if (sym) {
+ dumpsymtable(sym->left);
+#ifdef HASDUMPS
+ if ((sym->mbase && !sym->mbase->dumped) ||
+ (sym->fbase && !sym->fbase->dumped))
+#endif
+ {
+ fprintf(outf, "Symbol %s:\n", sym->name);
+ for (mp = sym->mbase; mp; mp = mp->snext)
+ dumpmeaning(mp);
+ for (mp = sym->fbase; mp; mp = mp->snext)
+ dumpmeaning(mp);
+ fprintf(outf, "\n");
+ }
+ dumpsymtable(sym->right);
+ }
+}
+
+
+void dumptypename(tp, waddr)
+Type *tp;
+int waddr;
+{
+#ifdef HASDUMPS
+ if (!tp) {
+ fprintf(outf, "<NULL>");
+ return;
+ }
+ if (ISBOGUS(tp)) {
+ fprintf(outf, "0x%lX", tp);
+ return;
+ }
+ if (tp == tp_int) fprintf(outf, "I");
+ else if (tp == tp_sint) fprintf(outf, "SI");
+ else if (tp == tp_uint) fprintf(outf, "UI");
+ else if (tp == tp_integer) fprintf(outf, "L");
+ else if (tp == tp_unsigned) fprintf(outf, "UL");
+ else if (tp == tp_char) fprintf(outf, "C");
+ else if (tp == tp_schar) fprintf(outf, "UC");
+ else if (tp == tp_uchar) fprintf(outf, "SC");
+ else if (tp == tp_boolean) fprintf(outf, "B");
+ else if (tp == tp_longreal) fprintf(outf, "R");
+ else if (tp == tp_real) fprintf(outf, "F");
+ else if (tp == tp_anyptr) fprintf(outf, "A");
+ else if (tp == tp_void) fprintf(outf, "V");
+ else if (tp == tp_text) fprintf(outf, "T");
+ else if (tp == tp_bigtext) fprintf(outf, "BT");
+ else if (tp == tp_sshort) fprintf(outf, "SS");
+ else if (tp == tp_ushort) fprintf(outf, "US");
+ else if (tp == tp_abyte) fprintf(outf, "AB");
+ else if (tp == tp_sbyte) fprintf(outf, "SB");
+ else if (tp == tp_ubyte) fprintf(outf, "UB");
+ else if (tp == tp_str255) fprintf(outf, "S");
+ else if (tp == tp_strptr) fprintf(outf, "SP");
+ else if (tp == tp_charptr) fprintf(outf, "CP");
+ else if (tp == tp_smallset) fprintf(outf, "SMS");
+ else if (tp == tp_proc) fprintf(outf, "PR");
+ else if (tp == tp_jmp_buf) fprintf(outf, "JB");
+ else {
+ if (tp->meaning && !ISBOGUS(tp->meaning) &&
+ tp->meaning->name && !ISBOGUS(tp->meaning->name) &&
+ tp->meaning->name[0]) {
+ fprintf(outf, "%s", tp->meaning->name);
+ if (tp->dumped)
+ return;
+ fprintf(outf, "=");
+ waddr = 1;
+ }
+ if (waddr) {
+ fprintf(outf, "%lX", tp);
+ if (tp->dumped)
+ return;
+ fprintf(outf, ":");
+ tp->dumped = 1;
+ }
+ switch (tp->kind) {
+
+ case TK_STRING:
+ fprintf(outf, "Str");
+ if (tp->structdefd)
+ fprintf(outf, "Conf");
+ break;
+
+ case TK_SUBR:
+ dumptypename(tp->basetype, 0);
+ break;
+
+ case TK_POINTER:
+ fprintf(outf, "^");
+ dumptypename(tp->basetype, 0);
+ break;
+
+ case TK_SMALLARRAY:
+ fprintf(outf, "Sm");
+ /* fall through */
+
+ case TK_ARRAY:
+ fprintf(outf, "Ar");
+ if (tp->structdefd)
+ fprintf(outf, "Conf");
+ fprintf(outf, "{");
+ dumptypename(tp->indextype, 0);
+ fprintf(outf, "}");
+ if (tp->smin) {
+ fprintf(outf, "Skip(");
+ dumpexpr(tp->smin);
+ fprintf(outf, ")");
+ }
+ if (tp->smax) {
+ fprintf(outf, "/");
+ if (!ISBOGUS(tp->smax))
+ dumptypename(tp->smax->val.type, 0);
+ fprintf(outf, "{%d%s}", tp->escale,
+ tp->issigned ? "S" : "U");
+ }
+ fprintf(outf, ":");
+ dumptypename(tp->basetype, 0);
+ break;
+
+ case TK_SMALLSET:
+ fprintf(outf, "Sm");
+ /* fall through */
+
+ case TK_SET:
+ fprintf(outf, "Set{");
+ dumptypename(tp->indextype, 0);
+ fprintf(outf, "}");
+ break;
+
+ case TK_FILE:
+ fprintf(outf, "File{");
+ dumptypename(tp->basetype, 0);
+ fprintf(outf, "}");
+ break;
+
+ case TK_BIGFILE:
+ fprintf(outf, "BigFile{");
+ dumptypename(tp->basetype, 0);
+ fprintf(outf, "}");
+ break;
+
+ case TK_FUNCTION:
+ fprintf(outf, "Func");
+ if (tp->issigned)
+ fprintf(outf, "Link");
+ fprintf(outf, "{");
+ dumptypename(tp->basetype, 0);
+ fprintf(outf, "}");
+ break;
+
+ case TK_CPROCPTR:
+ fprintf(outf, "C");
+ /* fall through */
+
+ case TK_PROCPTR:
+ fprintf(outf, "Proc%d{", tp->escale);
+ dumptypename(tp->basetype, 0);
+ fprintf(outf, "}");
+ break;
+
+ default:
+ fprintf(outf, "%s", typekindname(tp->kind));
+ break;
+
+ }
+ if (tp->kind != TK_ARRAY && tp->kind != TK_SMALLARRAY &&
+ (tp->smin || tp->smax)) {
+ fprintf(outf, "{");
+ dumpexpr(tp->smin);
+ fprintf(outf, "..");
+ dumpexpr(tp->smax);
+ fprintf(outf, "}");
+ }
+ }
+#else
+ fprintf(outf, "%lX", tp);
+#endif
+}
+
+
+void dumptypename_file(f, tp)
+FILE *f;
+Type *tp;
+{
+ FILE *save = outf;
+ outf = f;
+ dumptypename(tp, 1);
+ outf = save;
+}
+
+
+void dumpexpr(ex)
+Expr *ex;
+{
+ int i;
+ Type *type;
+ char *name;
+
+ if (!ex) {
+ fprintf(outf, "<NULL>");
+ return;
+ }
+ if (ISBOGUS(ex)) {
+ fprintf(outf, "0x%lX", ex);
+ return;
+ }
+ if (ex->kind == EK_CONST && ex->val.type == tp_integer &&
+ ex->nargs == 0 && !ex->val.s) {
+ fprintf(outf, "%ld", ex->val.i);
+ return;
+ }
+ if (ex->kind == EK_LONGCONST && ex->val.type == tp_integer &&
+ ex->nargs == 0 && !ex->val.s) {
+ fprintf(outf, "%ldL", ex->val.i);
+ return;
+ }
+ name = exprkindname(ex->kind);
+ if (!strncmp(name, "EK_", 3))
+ name += 3;
+ fprintf(outf, "%s", name);
+#ifdef HASDUMPS
+
+ type = ex->val.type;
+ fprintf(outf, "/");
+ dumptypename(type, 1);
+ if (ex->val.i) {
+ switch (ex->kind) {
+
+ case EK_VAR:
+ case EK_FUNCTION:
+ case EK_CTX:
+ if (ISBOGUS(ex->val.i))
+ fprintf(outf, "[0x%lX]", ex->val.i);
+ else
+ fprintf(outf, "[\"%s\"]", ((Meaning *)ex->val.i)->name);
+ break;
+
+ default:
+ fprintf(outf, "[i=%ld]", ex->val.i);
+ break;
+ }
+ }
+ if (ISBOGUS(ex->val.s))
+ fprintf(outf, "[0x%lX]", ex->val.s);
+ else if (ex->val.s) {
+ switch (ex->kind) {
+
+ case EK_BICALL:
+ case EK_NAME:
+ case EK_DOT:
+ fprintf(outf, "[s=\"%s\"]", ex->val.s);
+ break;
+
+ default:
+ switch (ex->val.type ? ex->val.type->kind : TK_VOID) {
+ case TK_STRING:
+ fprintf(outf, "[s=%s]", makeCstring(ex->val.s, ex->val.i));
+ break;
+ case TK_REAL:
+ fprintf(outf, "[s=%s]", ex->val.s);
+ break;
+ default:
+ fprintf(outf, "[s=%lx]", ex->val.s);
+ }
+ break;
+ }
+ }
+ if (ex->nargs > 0) {
+ fprintf(outf, "(");
+ if (ex->nargs < 10) {
+ for (i = 0; i < ex->nargs; i++) {
+ if (i)
+ fprintf(outf, ", ");
+ dumpexpr(ex->args[i]);
+ }
+ } else
+ fprintf(outf, "...");
+ fprintf(outf, ")");
+ }
+#endif
+}
+
+
+void dumpexpr_file(f, ex)
+FILE *f;
+Expr *ex;
+{
+ FILE *save = outf;
+ outf = f;
+ dumpexpr(ex);
+ outf = save;
+}
+
+
+void innerdumpstmt(sp, indent)
+Stmt *sp;
+int indent;
+{
+#ifdef HASDUMPS
+ if (!sp) {
+ fprintf(outf, "<NULL>\n");
+ return;
+ }
+ while (sp) {
+ if (ISBOGUS(sp)) {
+ fprintf(outf, "0x%lX\n", sp);
+ return;
+ }
+ fprintf(outf, "%s", stmtkindname(sp->kind));
+ if (sp->exp1) {
+ fprintf(outf, ", exp1=");
+ dumpexpr(sp->exp1);
+ }
+ if (sp->exp2) {
+ fprintf(outf, ", exp2=");
+ dumpexpr(sp->exp2);
+ }
+ if (sp->exp3) {
+ fprintf(outf, ", exp3=");
+ dumpexpr(sp->exp3);
+ }
+ fprintf(outf, "\n");
+ if (sp->stm1) {
+ fprintf(outf, "%*sstm1=", indent, "");
+ innerdumpstmt(sp->stm1, indent+5);
+ }
+ if (sp->stm2) {
+ fprintf(outf, "%*sstm2=", indent, "");
+ innerdumpstmt(sp->stm2, indent+5);
+ }
+ sp = sp->next;
+ if (sp) {
+ if (indent > 5)
+ fprintf(outf, "%*s", indent-5, "");
+ fprintf(outf, "next=");
+ }
+ }
+#endif
+}
+
+
+void dumpstmt(sp, indent)
+Stmt *sp;
+int indent;
+{
+ fprintf(outf, "%*s", indent, "");
+ innerdumpstmt(sp, indent);
+}
+
+
+void dumpstmt_file(f, sp)
+FILE *f;
+Stmt *sp;
+{
+ FILE *save = outf;
+ Stmt *savenext = NULL;
+ outf = f;
+ if (sp) {
+ savenext = sp->next;
+ sp->next = NULL;
+ }
+ dumpstmt(sp, 5);
+ if (sp)
+ sp->next = savenext;
+ outf = save;
+}
+
+
+
+void wrapup()
+{
+ int i;
+
+ for (i = 0; i < SYMHASHSIZE; i++)
+ dumpsymtable(symtab[i]);
+}
+
+
+
+
+void mem_summary()
+{
+#ifdef TEST_MALLOC
+ printf("Summary of memory allocated but not freed:\n");
+ printf("Total bytes = %d of %d\n", final_bytes, total_bytes);
+ printf("Expressions = %d of %d\n", final_exprs, total_exprs);
+ printf("Meanings = %d of %d (%d of %d)\n",
+ final_meanings, total_meanings,
+ final_meanings / sizeof(Meaning),
+ total_meanings / sizeof(Meaning));
+ printf("Strings = %d of %d\n", final_strings, total_strings);
+ printf("Symbols = %d of %d\n", final_symbols, total_symbols);
+ printf("Types = %d of %d (%d of %d)\n", final_types, total_types,
+ final_types / sizeof(Type), total_types / sizeof(Type));
+ printf("Statements = %d of %d (%d of %d)\n", final_stmts, total_stmts,
+ final_stmts / sizeof(Stmt), total_stmts / sizeof(Stmt));
+ printf("Strlists = %d of %d\n", final_strlists, total_strlists);
+ printf("Literals = %d of %d\n", final_literals, total_literals);
+ printf("Ctxstacks = %d of %d\n", final_ctxstacks, total_ctxstacks);
+ printf("Temp vars = %d of %d\n", final_tempvars, total_tempvars);
+ printf("Input recs = %d of %d\n", final_inprecs, total_inprecs);
+ printf("Parens = %d of %d\n", final_parens, total_parens);
+ printf("Ptr Descs = %d of %d\n", final_ptrdescs, total_ptrdescs);
+ printf("Other = %d of %d\n", final_misc, total_misc);
+ printf("\n");
+#endif
+}
+
+
+#ifdef TEST_MALLOC
+
+anyptr memlist;
+
+anyptr test_malloc(size, total, final)
+int size, *total, *final;
+{
+ anyptr p;
+
+ p = malloc(size + 3*sizeof(long));
+#if 1
+ ((anyptr *)p)[0] = memlist;
+ memlist = p;
+ ((long *)p)[1] = size;
+ ((int **)p)[2] = final;
+ total_bytes += size;
+ final_bytes += size;
+ *total += size;
+ *final += size;
+#endif
+ return (anyptr)((long *)p + 3);
+}
+
+void test_free(p)
+anyptr p;
+{
+#if 1
+ final_bytes -= ((long *)p)[1-3];
+ *((int **)p)[2-3] -= ((long *)p)[1-3];
+ ((long *)p)[1-3] *= -1;
+#endif
+}
+
+anyptr test_realloc(p, size)
+anyptr p;
+int size;
+{
+ anyptr p2;
+
+ p2 = test_malloc(size, &total_misc, &final_misc);
+ memcpy(p2, p, size);
+ test_free(p);
+ return p2;
+}
+
+#endif /* TEST_MALLOC */
+
+
+
+
+/* End. */
+
+
diff --git a/MultiSource/Benchmarks/MallocBench/p2c/trans.h b/MultiSource/Benchmarks/MallocBench/p2c/trans.h
new file mode 100644
index 00000000..13b8575b
--- /dev/null
+++ b/MultiSource/Benchmarks/MallocBench/p2c/trans.h
@@ -0,0 +1,1867 @@
+/* "p2c", a Pascal to C translator, version 1.20.
+ Copyright (C) 1989, 1990, 1991 Free Software Foundation.
+ Author: Dave Gillespie.
+ Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation (any version).
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+
+
+
+#ifdef __STDC__
+# define PP(x) x /* use true prototypes */
+# define PV() (void)
+# define Anyptr void
+# define __CAT__(a,b)a##b
+#else
+# define PP(x) () /* use old-style declarations */
+# define PV() ()
+# define Anyptr char
+# define __ID__(a)a
+# define __CAT__(a,b)__ID__(a)b
+#endif
+
+#define Static /* For debugging purposes */
+
+
+
+#include <stdio.h>
+
+
+/* If the following heuristic fails, compile -DBSD=0 for non-BSD systems,
+ or -DBSD=1 for BSD systems. */
+
+#ifdef M_XENIX
+# define BSD 0
+#endif
+
+#ifdef FILE /* a #define in BSD, a typedef in SYSV (hp-ux, at least) */
+# ifndef BSD
+# define BSD 1
+# endif
+#endif
+
+#ifdef BSD
+# if !BSD
+# undef BSD
+# endif
+#endif
+
+
+#ifdef __STDC__
+/* # include <stddef.h> */
+# include <stdlib.h>
+# include <limits.h>
+#else
+# ifndef BSD
+# include <malloc.h>
+# include <memory.h>
+# include <values.h>
+# endif
+# define EXIT_SUCCESS 0
+# define EXIT_FAILURE 1
+# define CHAR_BIT 8
+# define LONG_MAX (((unsigned long)~0L) >> 1)
+# define LONG_MIN (- LONG_MAX - 1)
+#endif
+
+
+
+#if defined(BSD) && !defined(__STDC__)
+# include <strings.h>
+# define memcpy(a,b,n) bcopy(b,a,n)
+# define memcmp(a,b,n) bcmp(a,b,n)
+char *malloc(), *realloc();
+#else
+# include <string.h>
+#endif
+
+#include <ctype.h>
+
+
+#ifdef __GNUC__ /* Fast, in-line version of strcmp */
+# define strcmp(a,b) ({ char *_aa = (a), *_bb = (b); int _diff; \
+ for (;;) { \
+ if (!*_aa && !*_bb) { _diff = 0; break; } \
+ if (*_aa++ != *_bb++) \
+ { _diff = _aa[-1] - _bb[-1]; break; } \
+ } _diff; })
+#endif
+
+
+#if defined(HASDUMPS) && defined(define_globals)
+# define DEFDUMPS
+#endif
+
+
+
+/* Constants */
+
+#undef MININT /* we want the Pascal definitions, not the local C definitions */
+#undef MAXINT
+
+#define MININT 0x80000000
+#define MAXINT 0x7fffffff
+
+
+#ifndef EXIT_SUCCESS
+# define EXIT_SUCCESS 0
+# define EXIT_FAILURE 1
+#endif
+
+
+#ifndef P2C_HOME
+# ifdef citPWS
+# define P2C_HOME "/lib/p2c"
+# else
+# define P2C_HOME "/usr/local/p2c" /* sounds reasonable... */
+# endif
+#endif
+
+#ifdef define_globals
+char *p2c_home = P2C_HOME;
+#else
+extern char *p2c_home;
+#endif
+
+#define P2C_VERSION "1.20"
+
+
+
+
+/* Types */
+
+#ifdef __STDC__
+typedef void *anyptr;
+#else
+typedef char *anyptr;
+#endif
+
+typedef unsigned char uchar;
+
+
+
+/* Ought to rearrange token assignments at the next full re-compile */
+
+typedef enum E_token {
+ TOK_NONE,
+
+ /* reserved words */
+ TOK_AND, TOK_ARRAY, TOK_BEGIN, TOK_CASE, TOK_CONST,
+ TOK_DIV, TOK_DO, TOK_DOWNTO, TOK_ELSE, TOK_END,
+ TOK_FILE, TOK_FOR, TOK_FUNCTION, TOK_GOTO, TOK_IF,
+ TOK_IN, TOK_LABEL, TOK_MOD, TOK_NIL, TOK_NOT,
+ TOK_OF, TOK_OR, TOK_PACKED, TOK_PROCEDURE, TOK_PROGRAM,
+ TOK_RECORD, TOK_REPEAT, TOK_SET, TOK_THEN, TOK_TO,
+ TOK_TYPE, TOK_UNTIL, TOK_VAR, TOK_WHILE, TOK_WITH,
+
+ /* symbols */
+ TOK_DOLLAR, TOK_STRLIT, TOK_LPAR, TOK_RPAR, TOK_STAR,
+ TOK_PLUS, TOK_COMMA, TOK_MINUS, TOK_DOT, TOK_DOTS,
+ TOK_SLASH, TOK_INTLIT, TOK_REALLIT, TOK_COLON, TOK_ASSIGN,
+ TOK_SEMI, TOK_NE, TOK_LT, TOK_GT, TOK_LE, TOK_GE,
+ TOK_EQ, TOK_LBR, TOK_RBR, TOK_HAT,
+ TOK_INCLUDE, TOK_ENDIF,
+ TOK_IDENT, TOK_MININT, TOK_EOF,
+
+ /* C symbols */
+ TOK_ARROW, TOK_AMP, TOK_VBAR, TOK_BANG,
+ TOK_TWIDDLE, TOK_PERC, TOK_QM,
+ TOK_LTLT, TOK_GTGT, TOK_EQEQ, TOK_BANGEQ,
+ TOK_PLPL, TOK_MIMI, TOK_ANDAND, TOK_OROR,
+ TOK_LBRACE, TOK_RBRACE, TOK_CHARLIT,
+
+ /* HP Pascal tokens */
+ TOK_ANYVAR, TOK_EXPORT, TOK_IMPLEMENT, TOK_IMPORT, TOK_MODULE,
+ TOK_OTHERWISE, TOK_RECOVER, TOK_TRY,
+
+ /* Turbo Pascal tokens */
+ TOK_SHL, TOK_SHR, TOK_XOR, TOK_INLINE, TOK_ABSOLUTE,
+ TOK_INTERRUPT, TOK_ADDR, TOK_HEXLIT,
+
+ /* Oregon Software Pascal tokens */
+ TOK_ORIGIN, TOK_INTFONLY,
+
+ /* VAX Pascal tokens */
+ TOK_REM, TOK_VALUE, TOK_VARYING, TOK_OCTLIT, TOK_COLONCOLON,
+ TOK_STARSTAR,
+
+ /* Modula-2 tokens */
+ TOK_BY, TOK_DEFINITION, TOK_ELSIF, TOK_FROM, TOK_LOOP,
+ TOK_POINTER, TOK_QUALIFIED, TOK_RETURN,
+
+ /* UCSD Pascal tokens */
+ TOK_SEGMENT,
+
+ TOK_LAST
+} Token;
+
+#ifdef define_globals
+char *toknames[(int)TOK_LAST] = { "",
+ "AND", "ARRAY", "BEGIN", "CASE", "CONST",
+ "DIV", "DO", "DOWNTO", "ELSE", "END",
+ "FILE", "FOR", "FUNCTION", "GOTO", "IF",
+ "IN", "LABEL", "MOD", "NIL", "NOT",
+ "OF", "OR", "PACKED", "PROCEDURE", "PROGRAM",
+ "RECORD", "REPEAT", "SET", "THEN", "TO",
+ "TYPE", "UNTIL", "VAR", "WHILE", "WITH",
+
+ "a '$'", "a string literal", "a '('", "a ')'", "a '*'",
+ "a '+'", "a comma", "a '-'", "a '.'", "'..'",
+ "a '/'", "an integer", "a real number", "a colon", "a ':='",
+ "a semicolon", "a '<>'", "a '<'", "a '>'", "a '<='", "a '>='",
+ "an '='", "a '['", "a ']'", "a '^'",
+ "an \"include\" file", "$end$",
+ "an identifier", "an integer", "end of file",
+
+ "an '->'", "an '&'", "a '|'", "a '!'",
+ "a '~'", "a '%'", "a '?'",
+ "a '<<'", "a '>>'", "a '=='", "a '!='",
+ "a '++'", "a '--'", "a '&&'", "a '||'",
+ "a '{'", "a '}'", "a character literal",
+
+ "ANYVAR", "EXPORT", "IMPLEMENT", "IMPORT", "MODULE",
+ "OTHERWISE", "RECOVER", "TRY",
+
+ "SHL", "SHR", "XOR", "INLINE", "ABSOLUTE",
+ "INTERRUPT", "an '@'", "a hex integer",
+
+ "ORIGIN", "INTF-ONLY",
+
+ "REM", "VALUE", "VARYING", "an octal integer", "a '::'",
+ "a '**'",
+
+ "BY", "DEFINITION", "ELSIF", "FROM", "LOOP",
+ "POINTER", "QUALIFIED", "RETURN",
+
+ "SEGMENT"
+} ;
+#else
+extern char *toknames[];
+#endif /*define_globals*/
+
+typedef struct S_strlist {
+ struct S_strlist *next;
+ long value;
+ char s[1];
+} Strlist;
+
+
+
+typedef struct S_value {
+ struct S_type *type;
+ long i;
+ char *s;
+} Value;
+
+
+
+/* "Symbol" notes:
+ *
+ * The symbol table is used for several things. Mainly it records all
+ * identifiers in the Pascal program (normally converted to upper case).
+ * Also used for recording certain properties about C and Pascal names.
+ *
+ * The symbol table is a hash table of binary trees.
+ */
+
+#define AVOIDNAME 0x1 /* Avoid this name in C code */
+#define WARNNAME 0x2 /* Warn if using this name in C code */
+#define AVOIDGLOB 0x4 /* Avoid C name except private to module */
+#define NOSIDEEFF 0x8 /* Function by this name has no side effects */
+#define STRUCTF 0x10 /* Function by this name is a StructFunction */
+#define STRLAPF 0x20 /* Function by this name is a StrlapFunction */
+#define LEAVEALONE 0x40 /* Do not use custom handler for function */
+#define DETERMF 0x80 /* Function by this name is Deterministic */
+#define FMACREC 0x100 /* Used by FieldMacro stuff */
+#define AVOIDFIELD 0x200 /* Avoid this name as a struct field name */
+#define NEEDSTATIC 0x400 /* This name must be declared static */
+#define KWPOSS 0x800 /* This word may be a keyword */
+#define FUNCBREAK 0x7000 /* Line breaking flags (see sys.p2crc) */
+# define FALLBREAK 0x1000 /* Break at all commas if at any */
+# define FSPCARG1 0x2000 /* First argument is special */
+# define FSPCARG2 0x3000 /* First two arguments are special */
+# define FSPCARG3 0x4000 /* First three arguments are special */
+#define WARNLIBR 0x8000 /* Warn for all uses of this library function */
+#define FWDPARAM 0x10000 /* Was a param name for forward-declared func */
+#define SSYNONYM 0x20000 /* Symbol is a synonym for another */
+
+typedef struct S_symbol {
+ struct S_symbol *left; /* Left pointer in binary tree */
+ struct S_symbol *right; /* Right pointer in binary tree */
+ struct S_meaning *mbase; /* First normal meaning for this symbol */
+ struct S_meaning *fbase; /* First record-field meaning for this symbol */
+ Strlist *symbolnames; /* List of NameOf's for this name */
+ long flags; /* (above) */
+ Token kwtok; /* Token, if symbol is a keyword */
+ char name[1]; /* Pascal name (actually variable-sized) */
+} Symbol;
+
+
+
+/* "Meaning" notes:
+ *
+ * This represents one meaning of a symbol (see below). Meanings are
+ * organized in a tree of contexts (i.e., scopes), and also in linked
+ * lists of meanings per symbol. Fields described in the following are
+ * undefined for kinds where they are not listed. Other fields are
+ * defined in all kinds of meanings.
+ *
+ * MK_MODULE: Program, module, or unit.
+ * mp->anyvarflag = 1 if main program, 0 if module.
+ * mp->cbase => First meaning in module's context.
+ *
+ * MK_CONST: Pascal CONST.
+ * mp->type => Type of constant, same as mp->constdefn->type & mp->val.type.
+ * mp->anyvarflag = 1 if FoldConstants was true when defined.
+ * mp->constdefn => Expression for the value of the constant.
+ * mp->val = Value of the const, if can be evaluated, else val.type is NULL.
+ * mp->xnext => Next constant in enumeration, else NULL.
+ * mp->isreturn = 1 if constant was declared as a macro (with #define).
+ *
+ * MK_TYPE: Pascal type name.
+ * mp->type => Type which name represents.
+ *
+ * MK_VAR: Normal variable.
+ * mp->type => Type of variable.
+ * mp->constdefn => Initializer for variable, else NULL.
+ * mp->varstructflag = 1 if variable is in parent function's varstruct.
+ * mp->isforward = 1 if should be declared static.
+ * mp->isfunction = 1 if should be declared extern.
+ * mp->namedfile = 1 if this file variable has a shadow file-name variable.
+ * mp->bufferedfile = 1 if this file variable has a shadow buffer variable.
+ * mp->val.s => name format string if temporary var, else NULL.
+ *
+ * MK_VARREF: Variable always referenced through a pointer.
+ * mp->type => Type "pointer to T" where T is type of variable.
+ * mp->constdefn => Initializer for the pointer, else NULL.
+ * (Others same as for MK_VAR.)
+ *
+ * MK_VARMAC: Variable which has a VarMacro.
+ * mp->type => Type of variable.
+ * mp->constdefn => Expression for VarMacro definition.
+ * (Others same as for MK_VAR.)
+ *
+ * MK_SPVAR: Special variable.
+ * mp->handler => C function to parse and translate the special variable.
+ *
+ * MK_FIELD: Record/struct field name.
+ * mp->ctx, cbase = unused (unlike other meanings).
+ * mp->cnext => Next field in record or variant.
+ * mp->type => Type of field (base type if a bit-field).
+ * mp->rectype => Type of containing record.
+ * mp->constdefn => Expression for definition if FieldMacro, else NULL.
+ * mp->val.i = Number of bits if bit-field, or 0 if normal field.
+ * mp->val.type => True type of bit-field, else same as mp->type.
+ * mp->isforward = 1 if tag field for following variant, else 0.
+ * mp->namedfile = 1 if this file field has a shadow file-name field.
+ * mp->bufferedfile = 1 if this file field has a shadow buffer field.
+ *
+ * MK_VARIANT: Header for variant record case.
+ * mp->ctx => First field in variant (unlike other meanings).
+ * mp->cbase = unused (unlike other meanings).
+ * mp->cnext => Next variant in record (or next sub-variant in variant).
+ * mp->rectype => Type of containing record.
+ * mp->val = Tag value of variant.
+ *
+ * MK_LABEL: Statement label.
+ * mp->val.i => Case number if used by non-local gotos, else -1.
+ * mp->xnext => MK_VAR representing associated jmp_buf variable.
+ * (All optional fields are unused.)
+ *
+ * MK_FUNCTION: Procedure or function.
+ * mp->type => TK_FUNCTION type.
+ * mp->cbase => First meaning in procedure's context (when isfunction is 1,
+ * this will always be the return-value meaning.)
+ * mp->val.i => Body of the function (cast to Stmt *).
+ * mp->constdefn => Expression for definition if FuncMacro, else NULL.
+ * mp->handler => C function to adjust parse tree if predefined, else NULL.
+ * mp->isfunction = 1 if function, 0 if procedure.
+ * mp->isforward = 1 if function has been declared forward.
+ * mp->varstructflag = 1 if function has a varstruct.
+ * mp->needvarstruct = 1 if no varstruct yet but may need one.
+ * mp->namedfile = 1 if function should be declared "inline".
+ *
+ * MK_SPECIAL: Special, irregular built-in function.
+ * mp->handler => C function to parse and translate the special function.
+ * mp->constdefn => Expression for definition if FuncMacro, else NULL.
+ * mp->isfunction = 1 if function, 0 if procedure.
+ *
+ * MK_PARAM: Procedure or function parameter, or function return value.
+ * mp->type => Type of parameter.
+ * mp->isreturn = 1 if a function return value (not on parameter list).
+ * mp->xnext => Next parameter of function.
+ * mp->fakeparam = 1 if a fake parameter (e.g., conformant array size).
+ * mp->othername => Name of true param if this one is a local copy.
+ * mp->rectype => Type of true param if this one is a local copy.
+ * If a normal copy param, will be "pointer to" mp->type.
+ * If copied for varstruct reasons, will be same as mp->type.
+ * mp->varstructflag = 1 if variable is in parent function's varstruct.
+ *
+ * MK_VARPARAM: VAR parameter, or StructFunction return value.
+ * mp->type => Type "pointer to T" where T is type of parameter.
+ * mp->anyvarflag = 1 if no type checking is to be applied to parameter.
+ * mp->isreturn = 1 if a StructFunction return value (will be first param).
+ * (Others same as for MK_PARAM.)
+ *
+ * MK_VARPARAM with mp->type == tp_anyptr: Turbo "typeless var" parameter.
+ * mp->type = tp_anyptr.
+ * mp->anyvarflag = 1.
+ * (Others same as for MK_PARAM.)
+ *
+ * MK_VARPARAM with mp->type == tp_strptr: HP Pascal "var s:string" parameter.
+ * mp->type = tp_strptr.
+ * mp->anyvarflag = 1 if a separate "strmax" parameter is passed.
+ * (Others same as for MK_PARAM.)
+ *
+ * MK_SYNONYM: Meaning which should be treated as identical to another.
+ * mp->xnext => Actual meaning to be used.
+ *
+ */
+
+enum meaningkind {
+ MK_NONE, MK_SPECIAL,
+ MK_MODULE, MK_FUNCTION, MK_CONST, MK_VAR, MK_TYPE,
+ MK_FIELD, MK_LABEL, MK_VARIANT,
+ MK_PARAM, MK_VARPARAM, MK_VARREF, MK_VARMAC,
+ MK_SPVAR, MK_SYNONYM,
+ MK_LAST
+} ;
+
+#ifdef DEFDUMPS
+char *meaningkindnames[(int)MK_LAST] = {
+ "MK_NONE", "MK_SPECIAL",
+ "MK_MODULE", "MK_FUNCTION", "MK_CONST", "MK_VAR", "MK_TYPE",
+ "MK_FIELD", "MK_LABEL", "MK_VARIANT",
+ "MK_PARAM", "MK_VARPARAM", "MK_VARREF", "MK_VARMAC",
+ "MK_SPVAR", "MK_SYNONYM"
+} ;
+#endif /*DEFDUMPS*/
+
+typedef struct S_meaning {
+ struct S_meaning *snext; /* Next meaning for this symbol */
+ struct S_meaning *cnext; /* Next meaning in this meaning's context */
+ struct S_meaning *cbase; /* First meaning in this context */
+ struct S_meaning *ctx; /* Context of this meaning */
+ struct S_meaning *xnext; /* (above) */
+ struct S_meaning *dtype; /* Declared type name, if any */
+ struct S_symbol *sym; /* Symbol of which this is a meaning */
+ struct S_type *type; /* (above) */
+ struct S_type *rectype; /* (above) */
+ struct S_expr *constdefn; /* (above) */
+ enum meaningkind kind; /* Kind of meaning */
+ unsigned needvarstruct:1, /* (above) */
+ varstructflag:1, /* (above) */
+ wasdeclared:1, /* Declaration has been written for meaning */
+ istemporary:1, /* Is a temporary variable */
+ isforward:1, /* (above) */
+ isfunction:1, /* (above) */
+ anyvarflag:1, /* (above) */
+ isactive:1, /* Meaning is currently in scope */
+ exported:1, /* Meaning is visible outside this module */
+ warnifused:1, /* WarnNames was 1 when meaning was declared */
+ dumped:1, /* Has been dumped (for debugging) */
+ isreturn:1, /* (above) */
+ fakeparam:1, /* (above) */
+ namedfile:1, /* (above) */
+ bufferedfile:1, /* (above) */
+ volatilequal:1, /* Object has C "volatile" qualifier */
+ constqual:1, /* Object has C "const" qualifier */
+ dummy17:1, dummy18:1, dummy19:1,
+ dummy20:1, dummy21:1, dummy22:1, dummy23:1, dummy24:1, dummy25:1,
+ dummy26:1, dummy27:1, dummy28:1, dummy29:1, dummy30:1, dummy31:1;
+ Value val; /* (above) */
+ int refcount; /* Number of references to meaning in program */
+ char *name; /* Print name (i.e., C name) of the meaning */
+ char *othername; /* (above) */
+ struct S_expr *(*handler)(); /* Custom translator for procedure */
+ Strlist *comments; /* Comments associated with meaning */
+} Meaning;
+
+
+
+/* "Type" notes:
+ *
+ * This struct represents a data type. Types are stored in a strange
+ * cross between Pascal and C semantics. (This usually works out okay.)
+ *
+ * TK_INTEGER: Base integer type.
+ * The following types are TK_INTEGER:
+ * tp_integer, tp_unsigned, tp_int, tp_uint, tp_sint.
+ * All other integer types are represented by subranges.
+ * tp->smin => Minimum value for integer.
+ * tp->smax => Maximum value for integer.
+ *
+ * TK_CHAR: Base character type.
+ * The following types are TK_CHAR: tp_char, tp_schar, tp_uchar.
+ * All other character types are represented by subranges.
+ * tp->smin => Minimum value for character.
+ * tp->smax => Maximum value for character.
+ *
+ * TK_BOOLEAN: Boolean type.
+ * The only TK_BOOLEAN type is tp_boolean.
+ * tp->smin => "False" expression.
+ * tp->smax => "True" expression.
+ *
+ * TK_REAL: Real types.
+ * The only TK_REAL types are tp_real, tp_longreal, and/or the SINGLE type.
+ *
+ * TK_VOID: C "void" type.
+ * The only TK_VOID type is tp_void.
+ *
+ * TK_SUBR: Subrange of ordinal type.
+ * tp->basetype => a TK_INTEGER, TK_CHAR, TK_BOOLEAN, or TK_ENUM type.
+ * tp->smin => Minimum ordinal value for subrange.
+ * tp->smax => Maximum ordinal value for subrange.
+ *
+ * TK_ENUM: Enumerated type.
+ * tp->fbase => First enumeration constant.
+ * tp->smin => Minimum value (zero).
+ * tp->smax => Maximum value (number of choices minus 1).
+ *
+ * TK_POINTER: Pointer type.
+ * tp->basetype => Base type of pointer.
+ * tp->smin => EK_NAME for type if not-yet-resolved forward; else NULL.
+ * tp->fbase => Actual type name for tp->basetype, or NULL.
+ * Only one pointer type is ever generated for a given other type;
+ * each tp->pointertype points back to that type if it has been generated.
+ *
+ * TK_STRING: Pascal string or VARYING OF CHAR type.
+ * tp->basetype => tp_char.
+ * tp->indextype => TK_SUBR from 0 to maximum string length.
+ * tp->structdefd = 1 if type is for a conformant VARYING OF CHAR parameter.
+ *
+ * TK_RECORD: Pascal record/C struct type.
+ * tp->fbase => First field in record.
+ * tp->structdefd = 1 if struct type has been declared in output.
+ *
+ * TK_ARRAY with smax == NULL: Normal array type.
+ * tp->basetype => Element type of array.
+ * tp->indextype => Index type (usually a TK_SUBR).
+ * tp->smin => Integer constant if SkipIndices was used, else NULL.
+ * tp->smax = NULL.
+ * tp->structdefd = 1 if type is for a conformant array parameter.
+ * tp->fbase => Actual type name for tp->basetype, or NULL.
+ *
+ * TK_ARRAY with smax != NULL: Large packed array type.
+ * tp->basetype => Element type of C array (tp_ubyte/tp_sbyte/tp_sshort).
+ * tp->indextype => Index type (usually a TK_SUBR).
+ * tp->smin => Integer constant if SkipIndices was used, else NULL.
+ * tp->smax => EK_TYPENAME for element type of Pascal array.
+ * tp->escale = log-base-two of number of bits per packed element, else 0.
+ * tp->issigned = 1 if packed array elements are signed, 0 if unsigned.
+ * tp->structdefd = 1 if type is for a conformant array parameter.
+ * tp->fbase => Actual type name for tp->basetype, or NULL.
+ *
+ * TK_SMALLARRAY: Packed array fitting within a single integer.
+ * (Same as for packed TK_ARRAY.)
+ *
+ * TK_SET: Normal set type.
+ * tp->basetype => tp_integer.
+ * tp->indextype => Element type of the set.
+ *
+ * TK_SMALLSET: Set fitting within a single integer.
+ * (Same as for TK_SET.)
+ *
+ * TK_FILE: File type (corresponds to C "FILE" type).
+ * tp->basetype => Type of file elements, or tp_abyte if UCSD untyped file.
+ * A Pascal "file" variable is represented as a TK_POINTER to a TK_FILE.
+ *
+ * TK_BIGFILE: File type with attached buffers and name.
+ * tp->basetype => Type of file elements, or tp_abyte if UCSD untyped file.
+ * A Pascal "file" variable is represented directly as a TK_BIGFILE.
+ *
+ * TK_FUNCTION: Procedure or procedure-pointer type.
+ * tp->basetype => Return type of function, or tp_void if procedure.
+ * tp->issigned = 1 if type has a generic static link.
+ * tp->fbase => First argument (or StructFunction return buffer pointer).
+ *
+ * TK_PROCPTR: Procedure pointer with static link.
+ * tp->basetype => TK_FUNCTION type.
+ * tp->fbase => Internal Meaning struct associated with basetype.
+ * tp->escale = Value of StaticLinks when type was declared.
+ *
+ * TK_CPROCPTR: Procedure pointer without static link.
+ * tp->basetype => TK_FUNCTION type.
+ * tp->fbase => Internal Meaning struct associated with basetype.
+ * tp->escale = Value of StaticLinks = 0.
+ *
+ * TK_SPECIAL: Special strange data type.
+ * Only TK_SPECIAL type at present is tp_jmp_buf.
+ *
+ */
+
+enum typekind {
+ TK_NONE,
+ TK_INTEGER, TK_CHAR, TK_BOOLEAN, TK_REAL, TK_VOID,
+ TK_SUBR, TK_ENUM, TK_POINTER, TK_STRING,
+ TK_RECORD, TK_ARRAY, TK_SET, TK_FILE, TK_FUNCTION,
+ TK_PROCPTR, TK_SMALLSET, TK_SMALLARRAY, TK_CPROCPTR,
+ TK_SPECIAL, TK_BIGFILE,
+ TK_LAST
+} ;
+
+#ifdef DEFDUMPS
+char *typekindnames[(int)TK_LAST] = {
+ "TK_NONE",
+ "TK_INTEGER", "TK_CHAR", "TK_BOOLEAN", "TK_REAL", "TK_VOID",
+ "TK_SUBR", "TK_ENUM", "TK_POINTER", "TK_STRING",
+ "TK_RECORD", "TK_ARRAY", "TK_SET", "TK_FILE", "TK_FUNCTION",
+ "TK_PROCPTR", "TK_SMALLSET", "TK_SMALLARRAY", "TK_CPROCPTR",
+ "TK_SPECIAL", "TK_BIGFILE"
+} ;
+#endif /*DEFDUMPS*/
+
+typedef struct S_type {
+ enum typekind kind; /* Kind of type */
+ struct S_type *basetype; /* (above) */
+ struct S_type *indextype; /* (above) */
+ struct S_type *pointertype; /* Pointer to this type */
+ struct S_meaning *meaning; /* Name of this type, if any */
+ struct S_meaning *fbase; /* (above) */
+ struct S_expr *smin; /* (above) */
+ struct S_expr *smax; /* (above) */
+ unsigned issigned:1, /* (above) */
+ dumped:1, /* Has been dumped (for debugging) */
+ structdefd:1, /* (above) */
+ preserved:1; /* Declared with preservetypes = 1 */
+ short escale; /* (above) */
+} Type;
+
+
+/* "Expr" notes:
+ *
+ * Expression trees generally reflect C notation and semantics. For example,
+ * EK_ASSIGN is not generated for string arguments; these would get an
+ * EK_BICALL to strcpy instead.
+ *
+ * The data type of each expression node is stored in its "val.type" field.
+ * The rest of the "val" field is used only when shown below.
+ * The "nargs" field always contains the number of arguments; the "args"
+ * array is allocated to that size and will contain non-NULL Expr pointers.
+ *
+ * EK_EQ, EK_NE, EK_LT, EK_GT, EK_LE, EK_GE: Relational operators.
+ * ep->nargs = 2.
+ *
+ * EK_PLUS: Addition.
+ * ep->nargs >= 2.
+ *
+ * EK_NEG: Negation.
+ * ep->nargs = 1.
+ *
+ * EK_TIMES: Multiplication.
+ * ep->nargs >= 2.
+ *
+ * EK_DIVIDE: Real division.
+ * ep->nargs = 2.
+ *
+ * EK_DIV: Integer division.
+ * ep->nargs = 2.
+ *
+ * EK_MOD: Integer modulo (C "%" operator).
+ * ep->nargs = 2.
+ *
+ * EK_OR, EK_AND: Logical operators (C "&&" and "||").
+ * ep->nargs = 2.
+ *
+ * EK_NOT: Logical NOT (C "!" operator).
+ * ep->nargs = 1.
+ *
+ * EK_BAND, EK_BOR, EK_BXOR: Bitwise operators (C "&", "|", "^").
+ * ep->nargs = 2.
+ *
+ * EK_BNOT: Bitwise NOT (C "~" operator).
+ * ep->nargs = 1.
+ *
+ * EK_LSH, EK_RSH: Shift operators.
+ * ep->nargs = 2.
+ *
+ * EK_HAT: Pointer dereference.
+ * ep->nargs = 1.
+ *
+ * EK_INDEX: Array indexing.
+ * ep->nargs = 2.
+ *
+ * EK_CAST: "Soft" type cast, change data type retaining value.
+ * ep->type => New data type.
+ * ep->nargs = 1.
+ *
+ * EK_ACTCAST: "Active" type cast, performs a computation as result of cast.
+ * ep->type => New data type.
+ * ep->nargs = 1.
+ *
+ * EK_LITCAST: Literal type cast.
+ * ep->nargs = 2.
+ * ep->args[0] => EK_TYPENAME expression for name of new data type.
+ * ep->args[1] => Argument of cast.
+ *
+ * EK_DOT: Struct field extraction.
+ * ep->nargs = 1. (Only one of the following will be nonzero:)
+ * ep->val.i => MK_FIELD being extracted (cast to Meaning *), else 0.
+ * ep->val.s => Literal name of field being extracted, else NULL.
+ *
+ * EK_COND: C conditional expression.
+ * ep->nargs = 3.
+ * ep->args[0] => Condition expression.
+ * ep->args[1] => "Then" expression.
+ * ep->args[2] => "Else" expression.
+ *
+ * EK_ADDR: Address-of operator.
+ * ep->nargs = 1.
+ *
+ * EK_SIZEOF: Size-of operator.
+ * ep->nargs = 1.
+ * ep->args[0] => Argument expression, may be EK_TYPENAME.
+ *
+ * EK_CONST: Literal constant.
+ * ep->nargs = 0 or 1.
+ * ep->val = Value of constant.
+ * ep->args[0] => EK_NAME of printf format string for constant, if any.
+ *
+ * EK_LONGCONST: Literal constant, type "long int".
+ * (Same as for EK_CONST.)
+ *
+ * EK_VAR: Variable name.
+ * ep->nargs = 0.
+ * ep->val.i => Variable being referenced (cast to Meaning *).
+ *
+ * EK_ASSIGN: Assignment operator.
+ * ep->nargs = 2.
+ * ep->args[0] => Destination l-value expression.
+ * ep->args[1] => Source expression.
+ *
+ * EK_POSTINC, EK_POSTDEC: Post-increment/post-decrement operators.
+ * ep->nargs = 1.
+ *
+ * EK_MACARG: Placeholder for argument in expression for FuncMacro, etc.
+ * ep->nargs = 0.
+ * ep->val.i = Code selecting which argument.
+ *
+ * EK_CHECKNIL: Null-pointer check.
+ * ep->nargs = 1.
+ *
+ * EK_BICALL: Call to literal function name.
+ * ep->val.s => Name of function.
+ *
+ * EK_STRUCTCONST: Structured constant.
+ * ep->nargs = Number of elements in constant.
+ * (Note: constdefn points to an EK_CONST whose val.i points to this.)
+ *
+ * EK_STRUCTOF: Repeated element in structured constant.
+ * ep->nargs = 1.
+ * ep->val.i = Number of repetitions.
+ *
+ * EK_COMMA: C comma operator.
+ * ep->nargs >= 2.
+ *
+ * EK_NAME: Literal variable name.
+ * ep->nargs = 0.
+ * ep->val.s => Name of variable.
+ *
+ * EK_CTX: Name of a context, with static links.
+ * ep->nargs = 0.
+ * ep->val.i => MK_FUNCTION or MK_MODULE to name (cast to Meaning *).
+ *
+ * EK_SPCALL: Special function call.
+ * ep->nargs = 1 + number of arguments to function.
+ * ep->args[0] => Expression which is the function to call.
+ *
+ * EK_TYPENAME: Type name.
+ * ep->nargs = 0.
+ * ep->val.type => Type whose name should be printed.
+ *
+ * EK_FUNCTION: Normal function call.
+ * ep->val.i => MK_FUNCTION being called (cast to Meaning *).
+ *
+ */
+
+enum exprkind {
+ EK_EQ, EK_NE, EK_LT, EK_GT, EK_LE, EK_GE,
+ EK_PLUS, EK_NEG, EK_TIMES, EK_DIVIDE,
+ EK_DIV, EK_MOD,
+ EK_OR, EK_AND, EK_NOT,
+ EK_BAND, EK_BOR, EK_BXOR, EK_BNOT, EK_LSH, EK_RSH,
+ EK_HAT, EK_INDEX, EK_CAST, EK_DOT, EK_COND,
+ EK_ADDR, EK_SIZEOF, EK_ACTCAST,
+ EK_CONST, EK_VAR, EK_FUNCTION,
+ EK_ASSIGN, EK_POSTINC, EK_POSTDEC, EK_CHECKNIL,
+ EK_MACARG, EK_BICALL, EK_STRUCTCONST, EK_STRUCTOF,
+ EK_COMMA, EK_LONGCONST, EK_NAME, EK_CTX, EK_SPCALL,
+ EK_LITCAST, EK_TYPENAME,
+ EK_LAST
+} ;
+
+#ifdef DEFDUMPS
+char *exprkindnames[(int)EK_LAST] = {
+ "EK_EQ", "EK_NE", "EK_LT", "EK_GT", "EK_LE", "EK_GE",
+ "EK_PLUS", "EK_NEG", "EK_TIMES", "EK_DIVIDE",
+ "EK_DIV", "EK_MOD",
+ "EK_OR", "EK_AND", "EK_NOT",
+ "EK_BAND", "EK_BOR", "EK_BXOR", "EK_BNOT", "EK_LSH", "EK_RSH",
+ "EK_HAT", "EK_INDEX", "EK_CAST", "EK_DOT", "EK_COND",
+ "EK_ADDR", "EK_SIZEOF", "EK_ACTCAST",
+ "EK_CONST", "EK_VAR", "EK_FUNCTION",
+ "EK_ASSIGN", "EK_POSTINC", "EK_POSTDEC", "EK_CHECKNIL",
+ "EK_MACARG", "EK_BICALL", "EK_STRUCTCONST", "EK_STRUCTOF",
+ "EK_COMMA", "EK_LONGCONST", "EK_NAME", "EK_CTX", "EK_SPCALL",
+ "EK_LITCAST", "EK_TYPENAME"
+} ;
+#endif /*DEFDUMPS*/
+
+typedef struct S_expr {
+ enum exprkind kind;
+ short nargs;
+ Value val;
+ struct S_expr *args[1]; /* (Actually, variable-sized) */
+} Expr;
+
+
+
+/* "Stmt" notes.
+ *
+ * Statements form linked lists along the "next" pointers.
+ * All other pointers are NULL and unused unless shown below.
+ *
+ * SK_ASSIGN: Assignment or function call (C expression statement).
+ * sp->exp1 => Expression to be evaluated.
+ *
+ * SK_RETURN: C "return" statement.
+ * sp->exp1 => Value to return, else NULL.
+ *
+ * SK_CASE: C "switch" statement.
+ * sp->exp1 => Switch selector expression.
+ * sp->stm1 => List of SK_CASELABEL statements, followed by list of
+ * statements that make up the "default:" clause.
+ *
+ * SK_CASELABEL: C "case" label.
+ * sp->exp1 => Case value.
+ * sp->stm1 => List of SK_CASELABELs labelling the same clause, followed
+ * by list of statements in that clause.
+ *
+ * SK_CASECHECK: Case-value-range-error, occurs in "default:" clause.
+ *
+ * SK_IF: C "if" statement.
+ * sp->exp1 => Conditional expression.
+ * sp->exp2 => Constant expression, "1" if this "if" should be else-if'd
+ * on to parent "if". NULL => follow ElseIf parameter.
+ * sp->stm1 => "Then" clause.
+ * sp->stm2 => "Else" clause.
+ *
+ * SK_FOR: C "for" statement.
+ * sp->exp1 => Initialization expression (may be NULL).
+ * sp->exp2 => Conditional expression (may be NULL).
+ * sp->exp3 => Iteration expression (may be NULL).
+ * sp->stm1 => Loop body.
+ *
+ * SK_REPEAT: C "do-while" statement.
+ * sp->exp1 => Conditional expression (True = continue loop).
+ * sp->stm1 => Loop body.
+ *
+ * SK_WHILE: C "while" statement.
+ * sp->exp1 => Conditional expression.
+ * sp->stm1 => Loop body.
+ *
+ * SK_BREAK: C "break" statement.
+ *
+ * SK_CONTINUE: C "continue" statement.
+ *
+ * SK_TRY: HP Pascal TRY-RECOVER statement.
+ * sp->exp1->val.i = Global serial number of the TRY statement.
+ * sp->exp2 = Non-NULL if must generate a label for RECOVER block.
+ * sp->stm1 => TRY block.
+ * sp->stm2 => RECOVER block.
+ *
+ * SK_GOTO: C "goto" statement.
+ * sp->exp1 => EK_NAME for the label number or name.
+ *
+ * SK_LABEL: C statement label.
+ * sp->exp1 => EK_NAME for the label number of name.
+ *
+ * SK_HEADER: Function/module header.
+ * sp->exp1 => EK_VAR pointing to MK_FUNCTION or MK_MODULE.
+ * (This always comes first in a context's statement list.)
+ *
+ * SK_BODY: Body of function/module.
+ * sp->stm1 => SK_HEADER that begins the body.
+ * (This exists only during fixblock.)
+ *
+ */
+
+enum stmtkind {
+ SK_ASSIGN, SK_RETURN,
+ SK_CASE, SK_CASELABEL, SK_IF,
+ SK_FOR, SK_REPEAT, SK_WHILE, SK_BREAK, SK_CONTINUE,
+ SK_TRY, SK_GOTO, SK_LABEL,
+ SK_HEADER, SK_CASECHECK, SK_BODY,
+ SK_LAST
+} ;
+
+#ifdef DEFDUMPS
+char *stmtkindnames[(int)SK_LAST] = {
+ "SK_ASSIGN", "SK_RETURN",
+ "SK_CASE", "SK_CASELABEL", "SK_IF",
+ "SK_FOR", "SK_REPEAT", "SK_WHILE", "SK_BREAK", "SK_CONTINUE",
+ "SK_TRY", "SK_GOTO", "SK_LABEL",
+ "SK_HEADER", "SK_CASECHECK", "SK_BODY"
+} ;
+#endif /*DEFDUMPS*/
+
+typedef struct S_stmt {
+ enum stmtkind kind;
+ struct S_stmt *next, *stm1, *stm2;
+ struct S_expr *exp1, *exp2, *exp3;
+ long serial;
+} Stmt;
+
+
+
+/* Flags for out_declarator(): */
+
+#define ODECL_CHARSTAR 0x1
+#define ODECL_FREEARRAY 0x2
+#define ODECL_FUNCTION 0x4
+#define ODECL_HEADER 0x8
+#define ODECL_FORWARD 0x10
+#define ODECL_DECL 0x20
+#define ODECL_NOPRES 0x40
+
+
+/* Flags for fixexpr(): */
+
+#define ENV_EXPR 0 /* return value needed */
+#define ENV_STMT 1 /* return value ignored */
+#define ENV_BOOL 2 /* boolean return value needed */
+
+
+/* Flags for defmacro(): */
+#define MAC_VAR 0 /* VarMacro */
+#define MAC_CONST 1 /* ConstMacro */
+#define MAC_FIELD 2 /* FieldMacro */
+#define MAC_FUNC 3 /* FuncMacro */
+
+#define FMACRECname "<rec>"
+
+
+/* Kinds of comment lines: */
+#define CMT_SHIFT 24
+#define CMT_MASK ((1L<<CMT_SHIFT)-1)
+#define CMT_KMASK ((1<<(32-CMT_SHIFT))-1)
+#define CMT_DONE 0 /* comment that has already been printed */
+#define CMT_PRE 1 /* comment line preceding subject */
+#define CMT_POST 2 /* comment line following subject */
+#define CMT_TRAIL 4 /* comment at end of line of code */
+#define CMT_ONBEGIN 6 /* comment on "begin" of procedure */
+#define CMT_ONEND 7 /* comment on "end" of procedure */
+#define CMT_ONELSE 8 /* comment on "else" keyword */
+#define CMT_NOT 256 /* negation of above, for searches */
+
+#ifdef define_globals
+char *CMT_NAMES[] = { "DONE", "PRE", "POST", "3", "TRAIL", "5",
+ "BEGIN", "END", "ELSE" };
+#else
+extern char *CMT_NAMES[];
+#endif
+
+#define getcommentkind(cmt) (((cmt)->value >> CMT_SHIFT) & CMT_KMASK)
+
+
+/* Kinds of operator line-breaking: */
+#define BRK_LEFT 0x1
+#define BRK_RIGHT 0x2
+#define BRK_LPREF 0x4
+#define BRK_RPREF 0x8
+#define BRK_ALLNONE 0x10
+#define BRK_HANG 0x20
+
+
+
+
+/* Translation parameters: */
+
+#ifdef define_parameters
+# define extern
+#endif /* define_parameters */
+
+extern enum {
+ UNIX_ANY, UNIX_BSD, UNIX_SYSV
+} which_unix;
+
+extern enum {
+ LANG_HP, LANG_UCSD, LANG_TURBO, LANG_OREGON, LANG_VAX,
+ LANG_MODULA, LANG_MPW, LANG_BERK
+} which_lang;
+
+extern short debug, tokentrace, quietmode, cmtdebug, copysource;
+extern int nobanner, showprogress, maxerrors;
+extern short hpux_lang, integer16, doublereals, pascalenumsize;
+extern short needsignedbyte, unsignedchar, importall;
+extern short nestedcomments, pascalsignif, pascalcasesens;
+extern short dollar_idents, ignorenonalpha, modula2;
+extern short ansiC, cplus, signedchars, signedfield, signedshift;
+extern short hassignedchar, voidstar, symcase, ucconsts, csignif;
+extern short copystructs, usevextern, implementationmodules;
+extern short useAnyptrMacros, usePPMacros;
+extern short sprintf_value;
+extern char codefnfmt[40], modulefnfmt[40], logfnfmt[40];
+extern char headerfnfmt[40], headerfnfmt2[40], includefnfmt[40];
+extern char selfincludefmt[40];
+extern char constformat[40], moduleformat[40], functionformat[40];
+extern char varformat[40], fieldformat[40], typeformat[40];
+extern char enumformat[40], symbolformat[40];
+extern char p2c_h_name[40], exportsymbol[40], export_symbol[40];
+extern char externalias[40];
+extern char memcpyname[40], sprintfname[40];
+extern char roundname[40], divname[40], modname[40], remname[40];
+extern char strposname[40], strcicmpname[40];
+extern char strsubname[40], strdeletename[40], strinsertname[40];
+extern char strmovename[40], strpadname[40];
+extern char strltrimname[40], strrtrimname[40], strrptname[40];
+extern char absname[40], oddname[40], evenname[40], swapname[40];
+extern char mallocname[40], freename[40], freervaluename[40];
+extern char randrealname[40], randintname[40], randomizename[40];
+extern char skipspacename[40], readlnname[40], freopenname[40];
+extern char eofname[40], eolnname[40], fileposname[40], maxposname[40];
+extern char setunionname[40], setintname[40], setdiffname[40];
+extern char setinname[40], setaddname[40], setaddrangename[40];
+extern char setremname[40];
+extern char setequalname[40], subsetname[40], setxorname[40];
+extern char setcopyname[40], setexpandname[40], setpackname[40];
+extern char getbitsname[40], clrbitsname[40], putbitsname[40];
+extern char declbufname[40], declbufncname[40];
+extern char resetbufname[40], setupbufname[40];
+extern char getfbufname[40], chargetfbufname[40], arraygetfbufname[40];
+extern char putfbufname[40], charputfbufname[40], arrayputfbufname[40];
+extern char getname[40], chargetname[40], arraygetname[40];
+extern char putname[40], charputname[40], arrayputname[40];
+extern char eofbufname[40], fileposbufname[40];
+extern char storebitsname[40], signextname[40];
+extern char filenotfoundname[40], filenotopenname[40];
+extern char filewriteerrorname[40], badinputformatname[40], endoffilename[40];
+extern short strcpyleft;
+extern char language[40], target[40];
+extern int sizeof_char, sizeof_short, sizeof_integer, sizeof_pointer,
+ sizeof_double, sizeof_float, sizeof_enum, sizeof_int, sizeof_long;
+extern short size_t_long;
+extern int setbits, defaultsetsize, seek_base, integerwidth, realwidth;
+extern short quoteincludes, expandincludes, collectnest;
+extern int phystabsize, intabsize, linewidth, maxlinewidth;
+extern int majorspace, minorspace, functionspace, minfuncspace;
+extern int casespacing, caselimit;
+extern int returnlimit, breaklimit, continuelimit;
+extern short nullstmtline, shortcircuit, shortopt, usecommas, elseif;
+extern short usereturns, usebreaks, infloopstyle, reusefieldnames;
+extern short bracesalways, braceline, bracecombine, braceelse, braceelseline;
+extern short newlinefunctions;
+extern short eatcomments, spitcomments, spitorphancomments;
+extern short commentafter, blankafter;
+extern int tabsize, blockindent, bodyindent, argindent;
+extern int switchindent, caseindent, labelindent;
+extern int openbraceindent, closebraceindent;
+extern int funcopenindent, funccloseindent;
+extern int structindent, structinitindent, extrainitindent;
+extern int constindent, commentindent, bracecommentindent, commentoverindent;
+extern int declcommentindent;
+extern int minspacing, minspacingthresh;
+extern int extraindent, bumpindent;
+extern double overwidepenalty, overwideextrapenalty;
+extern double commabreakpenalty, commabreakextrapenalty;
+extern double assignbreakpenalty, assignbreakextrapenalty;
+extern double specialargbreakpenalty;
+extern double opbreakpenalty, opbreakextrapenalty, exhyphenpenalty;
+extern double logbreakpenalty, logbreakextrapenalty;
+extern double relbreakpenalty, relbreakextrapenalty;
+extern double morebreakpenalty, morebreakextrapenalty;
+extern double parenbreakpenalty, parenbreakextrapenalty;
+extern double qmarkbreakpenalty, qmarkbreakextrapenalty;
+extern double wrongsidepenalty, earlybreakpenalty, extraindentpenalty;
+extern double bumpindentpenalty, nobumpindentpenalty;
+extern double indentamountpenalty, sameindentpenalty;
+extern double showbadlimit;
+extern long maxalts;
+extern short breakbeforearith, breakbeforerel, breakbeforelog;
+extern short breakbeforedot, breakbeforeassign;
+extern short for_allornone;
+extern short extraparens, breakparens, returnparens;
+extern short variablearrays, initpacstrings, stararrays;
+extern short spaceexprs, spacefuncs, spacecommas, implicitzero, starindex;
+extern int casetabs;
+extern short starfunctions, mixfields, alloczeronil, postincrement;
+extern short mixvars, mixtypes, mixinits, nullcharconst, castnull, addindex;
+extern short highcharints, highcharbits, hasstaticlinks;
+extern short mainlocals, storefilenames, addrstdfiles, readwriteopen;
+extern short charfiletext, messagestderr, literalfilesflag, structfilesflag;
+extern short printfonly, mixwritelns, usegets, newlinespace, binarymode;
+extern char openmode[40], filenamefilter[40];
+extern short atan2flag, div_po2, mod_po2, assumebits, assumesigns;
+extern short fullstrwrite, fullstrread, whilefgets, buildreads, buildwrites;
+extern short foldconsts, foldstrconsts, charconsts, useconsts, useundef;
+extern short elimdeadcode, offsetforloops, forevalorder;
+extern short smallsetconst, bigsetconst, lelerange, unsignedtrick;
+extern short useisalpha, useisspace, usestrncmp;
+extern short casecheck, arraycheck, rangecheck, nilcheck, malloccheck;
+extern short checkfileopen, checkfileisopen, checkfilewrite;
+extern short checkreadformat, checkfileeof, checkstdineof, checkfileseek;
+extern short squeezesubr, useenum, enumbyte, packing, packsigned, keepnulls;
+extern short compenums, formatstrings, alwayscopyvalues;
+extern short use_static, var_static, void_args, prototypes, fullprototyping;
+extern short procptrprototypes, promote_enums;
+extern short preservetypes, preservepointers, preservestrings;
+extern short castargs, castlongargs, promoteargs, fixpromotedargs;
+extern short varstrings, varfiles, copystructfuncs;
+extern long skipindices;
+extern short stringleaders;
+extern int stringceiling, stringdefault, stringtrunclimit, longstringsize;
+extern short warnnames, warnmacros;
+extern Strlist *importfrom, *importdirs, *includedirs, *includefrom;
+extern Strlist *librfiles, *bufferedfiles, *unbufferedfiles;
+extern Strlist *externwords, *cexternwords;
+extern Strlist *varmacros, *constmacros, *fieldmacros;
+extern Strlist *funcmacros, *funcmacroargs, *nameoflist;
+extern Strlist *specialmallocs, *specialfrees, *specialsizeofs;
+extern Strlist *initialcalls, *eatnotes, *literalfiles, *structfiles;
+
+extern char fixedcomment[40], permanentcomment[40], interfacecomment[40];
+extern char embedcomment[40], skipcomment[40], noskipcomment[40];
+extern char signedcomment[40], unsignedcomment[40];
+
+extern char name_RETV[40], name_STRMAX[40], name_LINK[40];
+extern char name_COPYPAR[40], name_TEMP[40], name_DUMMY[40];
+extern char name_LOC[40], name_VARS[40], name_STRUCT[40];
+extern char name_FAKESTRUCT[40], name_AHIGH[40], name_ALOW[40];
+extern char name_UNION[40], name_VARIANT[40], name_LABEL[40], name_LABVAR[40];
+extern char name_WITH[40], name_FOR[40], name_ENUM[40];
+extern char name_PTR[40], name_STRING[40], name_SET[40];
+extern char name_PROCEDURE[40], name_MAIN[40], name_UNITINIT[40];
+extern char name_HSYMBOL[40], name_GSYMBOL[40];
+extern char name_SETBITS[40], name_UCHAR[40], name_SCHAR[40];
+extern char name_BOOLEAN[40], name_TRUE[40], name_FALSE[40], name_NULL[40];
+extern char name_ESCAPECODE[40], name_IORESULT[40];
+extern char name_ARGC[40], name_ARGV[40];
+extern char name_ESCAPE[40], name_ESCIO[40], name_CHKIO[40], name_SETIO[40];
+extern char name_OUTMEM[40], name_CASECHECK[40], name_NILCHECK[40];
+extern char name_FNSIZE[40], name_FNVAR[40];
+extern char alternatename1[40], alternatename2[40], alternatename[40];
+
+
+#ifndef define_parameters
+extern
+#endif
+struct rcstruct {
+ char kind;
+ char chgmode;
+ char *name;
+ anyptr ptr;
+ long def;
+} rctable[]
+#ifdef define_parameters
+ = {
+ 'S', 'R', "DEBUG", (anyptr) &debug, 0,
+ 'I', 'R', "SHOWPROGRESS", (anyptr) &showprogress, 0,
+ 'S', 'V', "TOKENTRACE", (anyptr) &tokentrace, 0,
+ 'S', 'V', "QUIET", (anyptr) &quietmode, 0,
+ 'S', 'V', "COPYSOURCE", (anyptr) &copysource, 0,
+ 'I', 'R', "MAXERRORS", (anyptr) &maxerrors, 0,
+ 'X', ' ', "INCLUDE", (anyptr) NULL, 2,
+
+/* INPUT LANGUAGE */
+ 'U', 'T', "LANGUAGE", (anyptr) language, 40,
+ 'S', 'V', "MODULA2", (anyptr) &modula2, -1,
+ 'S', 'T', "INTEGER16", (anyptr) &integer16, -1,
+ 'S', 'T', "DOUBLEREALS", (anyptr) &doublereals, -1,
+ 'S', 'V', "UNSIGNEDCHAR", (anyptr) &unsignedchar, -1,
+ 'S', 'V', "NEEDSIGNEDBYTE", (anyptr) &needsignedbyte, 0,
+ 'S', 'V', "PASCALENUMSIZE", (anyptr) &pascalenumsize, -1,
+ 'S', 'V', "NESTEDCOMMENTS", (anyptr) &nestedcomments, -1,
+ 'S', 'V', "IMPORTALL", (anyptr) &importall, -1,
+ 'S', 'V', "IMPLMODULES", (anyptr) &implementationmodules, -1,
+ 'A', 'V', "EXTERNWORDS", (anyptr) &externwords, 0,
+ 'A', 'V', "CEXTERNWORDS", (anyptr) &cexternwords, 0,
+ 'S', 'V', "PASCALSIGNIF", (anyptr) &pascalsignif, -1,
+ 'S', 'V', "PASCALCASESENS", (anyptr) &pascalcasesens, -1,
+ 'S', 'V', "DOLLARIDENTS", (anyptr) &dollar_idents, -1,
+ 'S', 'V', "IGNORENONALPHA", (anyptr) &ignorenonalpha, -1,
+ 'I', 'V', "SEEKBASE", (anyptr) &seek_base, -1,
+ 'I', 'R', "INPUTTABSIZE", (anyptr) &intabsize, 8,
+
+/* TARGET LANGUAGE */
+ 'S', 'T', "ANSIC", (anyptr) &ansiC, -1,
+ 'S', 'T', "C++", (anyptr) &cplus, -1,
+ 'S', 'T', "VOID*", (anyptr) &voidstar, -1,
+ 'S', 'T', "HASSIGNEDCHAR", (anyptr) &hassignedchar, -1,
+ 'S', 'V', "CASTNULL", (anyptr) &castnull, -1,
+ 'S', 'V', "COPYSTRUCTS", (anyptr) &copystructs, -1,
+ 'S', 'V', "VARIABLEARRAYS", (anyptr) &variablearrays, -1,
+ 'S', 'V', "INITPACSTRINGS", (anyptr) &initpacstrings, -1,
+ 'S', 'V', "REUSEFIELDNAMES", (anyptr) &reusefieldnames, 1,
+ 'S', 'V', "USEVEXTERN", (anyptr) &usevextern, 1,
+ 'S', 'V', "CSIGNIF", (anyptr) &csignif, -1,
+ 'S', 'V', "USEANYPTRMACROS", (anyptr) &useAnyptrMacros, -1,
+ 'S', 'V', "USEPPMACROS", (anyptr) &usePPMacros, -1,
+
+/* TARGET MACHINE */
+ 'U', 'T', "TARGET", (anyptr) target, 40,
+ 'S', 'T', "SIGNEDCHAR", (anyptr) &signedchars, -1,
+ 'S', 'T', "SIGNEDFIELD", (anyptr) &signedfield, -1,
+ 'S', 'T', "SIGNEDSHIFT", (anyptr) &signedshift, -1,
+ 'I', 'T', "CHARSIZE", (anyptr) &sizeof_char, 0,
+ 'I', 'T', "SHORTSIZE", (anyptr) &sizeof_short, 0,
+ 'I', 'T', "INTSIZE", (anyptr) &sizeof_int, 0,
+ 'I', 'T', "LONGSIZE", (anyptr) &sizeof_long, 0,
+ 'I', 'T', "PTRSIZE", (anyptr) &sizeof_pointer, 0,
+ 'I', 'T', "DOUBLESIZE", (anyptr) &sizeof_double, 0,
+ 'I', 'T', "FLOATSIZE", (anyptr) &sizeof_float, 0,
+ 'I', 'T', "ENUMSIZE", (anyptr) &sizeof_enum, 0,
+ 'S', 'T', "SIZE_T_LONG", (anyptr) &size_t_long, -1,
+
+/* BRACES */
+ 'S', 'V', "NULLSTMTLINE", (anyptr) &nullstmtline, 0,
+ 'S', 'V', "BRACESALWAYS", (anyptr) &bracesalways, -1,
+ 'S', 'V', "BRACELINE", (anyptr) &braceline, -1,
+ 'S', 'V', "BRACECOMBINE", (anyptr) &bracecombine, 0,
+ 'S', 'V', "BRACEELSE", (anyptr) &braceelse, 0,
+ 'S', 'V', "BRACEELSELINE", (anyptr) &braceelseline, 0,
+ 'S', 'V', "ELSEIF", (anyptr) &elseif, -1,
+ 'S', 'V', "NEWLINEFUNCS", (anyptr) &newlinefunctions, 0,
+
+/* INDENTATION */
+ 'I', 'R', "PHYSTABSIZE", (anyptr) &phystabsize, 8,
+ 'D', 'R', "INDENT", (anyptr) &tabsize, 2,
+ 'D', 'R', "BLOCKINDENT", (anyptr) &blockindent, 0,
+ 'D', 'R', "BODYINDENT", (anyptr) &bodyindent, 0,
+ 'D', 'R', "FUNCARGINDENT", (anyptr) &argindent, 1000,
+ 'D', 'R', "OPENBRACEINDENT", (anyptr) &openbraceindent, 0,
+ 'D', 'R', "CLOSEBRACEINDENT",(anyptr) &closebraceindent, 0,
+ 'D', 'R', "FUNCOPENINDENT", (anyptr) &funcopenindent, 0,
+ 'D', 'R', "FUNCCLOSEINDENT", (anyptr) &funccloseindent, 0,
+ 'D', 'R', "SWITCHINDENT", (anyptr) &switchindent, 0,
+ 'D', 'R', "CASEINDENT", (anyptr) &caseindent, -2,
+ 'D', 'R', "LABELINDENT", (anyptr) &labelindent, 1000,
+ 'D', 'R', "STRUCTINDENT", (anyptr) &structindent, 0,
+ 'D', 'R', "STRUCTINITINDENT",(anyptr) &structinitindent, 0,
+ 'D', 'R', "EXTRAINITINDENT", (anyptr) &extrainitindent, 2,
+ 'I', 'R', "EXTRAINDENT", (anyptr) &extraindent, 2,
+ 'I', 'R', "BUMPINDENT", (anyptr) &bumpindent, 1,
+ 'D', 'R', "CONSTINDENT", (anyptr) &constindent, 1024,
+ 'D', 'R', "COMMENTINDENT", (anyptr) &commentindent, 3,
+ 'D', 'R', "BRACECOMMENTINDENT",(anyptr)&bracecommentindent, 2,
+ 'D', 'R', "DECLCOMMENTINDENT",(anyptr)&declcommentindent, -999,
+ 'D', 'R', "COMMENTOVERINDENT",(anyptr)&commentoverindent, 4, /*1000*/
+ 'I', 'R', "MINSPACING", (anyptr) &minspacing, 2,
+ 'I', 'R', "MINSPACINGTHRESH",(anyptr) &minspacingthresh, -1,
+
+/* LINE BREAKING */
+ 'I', 'R', "LINEWIDTH", (anyptr) &linewidth, 78,
+ 'I', 'R', "MAXLINEWIDTH", (anyptr) &maxlinewidth, 90,
+ 'R', 'V', "OVERWIDEPENALTY", (anyptr) &overwidepenalty, 2500,
+ 'R', 'V', "OVERWIDEEXTRAPENALTY", (anyptr) &overwideextrapenalty, 100,
+ 'R', 'V', "COMMABREAKPENALTY", (anyptr) &commabreakpenalty, 1000,
+ 'R', 'V', "COMMABREAKEXTRAPENALTY",(anyptr) &commabreakextrapenalty, 500,
+ 'R', 'V', "ASSIGNBREAKPENALTY", (anyptr) &assignbreakpenalty, 5000,
+ 'R', 'V', "ASSIGNBREAKEXTRAPENALTY",(anyptr)&assignbreakextrapenalty, 3000,
+ 'R', 'V', "SPECIALARGBREAKPENALTY",(anyptr) &specialargbreakpenalty, 500,
+ 'R', 'V', "OPBREAKPENALTY", (anyptr) &opbreakpenalty, 2500,
+ 'R', 'V', "OPBREAKEXTRAPENALTY", (anyptr) &opbreakextrapenalty, 2000,
+ 'R', 'V', "LOGBREAKPENALTY", (anyptr) &logbreakpenalty, 500,
+ 'R', 'V', "LOGBREAKEXTRAPENALTY", (anyptr) &logbreakextrapenalty, 100,
+ 'R', 'V', "RELBREAKPENALTY", (anyptr) &relbreakpenalty, 2000,
+ 'R', 'V', "RELBREAKEXTRAPENALTY", (anyptr) &relbreakextrapenalty, 1000,
+ 'R', 'V', "EXHYPHENPENALTY", (anyptr) &exhyphenpenalty, 1000,
+ 'R', 'V', "MOREBREAKPENALTY", (anyptr) &morebreakpenalty, -500,
+ 'R', 'V', "MOREBREAKEXTRAPENALTY", (anyptr) &morebreakextrapenalty, -300,
+ 'R', 'V', "QMARKBREAKPENALTY", (anyptr) &qmarkbreakpenalty, 5000,
+ 'R', 'V', "QMARKBREAKEXTRAPENALTY",(anyptr) &qmarkbreakextrapenalty, 3000,
+ 'R', 'V', "PARENBREAKPENALTY", (anyptr) &parenbreakpenalty, 2500,
+ 'R', 'V', "PARENBREAKEXTRAPENALTY",(anyptr) &parenbreakextrapenalty, 1000,
+ 'R', 'V', "WRONGSIDEPENALTY", (anyptr) &wrongsidepenalty, 1000,
+ 'R', 'V', "EARLYBREAKPENALTY", (anyptr) &earlybreakpenalty, 100,
+ 'R', 'V', "EXTRAINDENTPENALTY", (anyptr) &extraindentpenalty, 3000,
+ 'R', 'V', "BUMPINDENTPENALTY", (anyptr) &bumpindentpenalty, 1000,
+ 'R', 'V', "NOBUMPINDENTPENALTY", (anyptr) &nobumpindentpenalty, 2500,
+ 'R', 'V', "INDENTAMOUNTPENALTY", (anyptr) &indentamountpenalty, 50,
+ 'R', 'V', "SAMEINDENTPENALTY", (anyptr) &sameindentpenalty, 500,
+ 'R', 'V', "SHOWBADLIMIT", (anyptr) &showbadlimit, -120,
+ 'L', 'R', "MAXLINEBREAKTRIES", (anyptr) &maxalts, 5000,
+ 'G', 'V', "ALLORNONEBREAK", (anyptr) NULL, FALLBREAK,
+ 'G', 'V', "ONESPECIALARG", (anyptr) NULL, FSPCARG1,
+ 'G', 'V', "TWOSPECIALARGS", (anyptr) NULL, FSPCARG2,
+ 'G', 'V', "THREESPECIALARGS",(anyptr) NULL, FSPCARG3,
+ 'B', 'V', "BREAKARITH", (anyptr) &breakbeforearith, BRK_RIGHT,
+ 'B', 'V', "BREAKREL", (anyptr) &breakbeforerel, BRK_RIGHT,
+ 'B', 'V', "BREAKLOG", (anyptr) &breakbeforelog, BRK_RIGHT,
+ 'B', 'V', "BREAKDOT", (anyptr) &breakbeforedot, BRK_RIGHT,
+ 'B', 'V', "BREAKASSIGN", (anyptr) &breakbeforeassign, BRK_RIGHT,
+ 'S', 'V', "FOR_ALLORNONE", (anyptr) &for_allornone, 1,
+
+/* COMMENTS AND BLANK LINES */
+ 'S', 'V', "NOBANNER", (anyptr) &nobanner, 0,
+ 'S', 'V', "EATCOMMENTS", (anyptr) &eatcomments, 0,
+ 'S', 'V', "SPITCOMMENTS", (anyptr) &spitcomments, 0,
+ 'S', 'V', "SPITORPHANCOMMENTS",(anyptr)&spitorphancomments, 0,
+ 'S', 'V', "COMMENTAFTER", (anyptr) &commentafter, -1,
+ 'S', 'V', "BLANKAFTER", (anyptr) &blankafter, 1,
+ 'A', 'V', "EATNOTES", (anyptr) &eatnotes, 0,
+
+/* SPECIAL COMMENTS */
+ 'C', 'V', "FIXEDCOMMENT", (anyptr) fixedcomment, 40,
+ 'C', 'V', "PERMANENTCOMMENT",(anyptr) permanentcomment, 40,
+ 'C', 'V', "INTERFACECOMMENT",(anyptr) interfacecomment, 40,
+ 'C', 'V', "EMBEDCOMMENT", (anyptr) embedcomment, 40,
+ 'C', 'V', "SKIPCOMMENT", (anyptr) skipcomment, 40,
+ 'C', 'V', "NOSKIPCOMMENT", (anyptr) noskipcomment, 40,
+ 'C', 'V', "SIGNEDCOMMENT", (anyptr) signedcomment, 40,
+ 'C', 'V', "UNSIGNEDCOMMENT", (anyptr) unsignedcomment, 40,
+
+/* STYLISTIC OPTIONS */
+ 'I', 'V', "MAJORSPACING", (anyptr) &majorspace, 2,
+ 'I', 'V', "MINORSPACING", (anyptr) &minorspace, 1,
+ 'I', 'V', "FUNCSPACING", (anyptr) &functionspace, 2,
+ 'I', 'V', "MINFUNCSPACING", (anyptr) &minfuncspace, 1,
+ 'S', 'V', "EXTRAPARENS", (anyptr) &extraparens, -1,
+ 'S', 'V', "BREAKADDPARENS", (anyptr) &breakparens, -1,
+ 'S', 'V', "RETURNPARENS", (anyptr) &returnparens, -1,
+ 'S', 'V', "SPACEEXPRS", (anyptr) &spaceexprs, -1,
+ 'S', 'V', "SPACEFUNCS", (anyptr) &spacefuncs, 0,
+ 'S', 'V', "SPACECOMMAS", (anyptr) &spacecommas, 1,
+ 'S', 'V', "IMPLICITZERO", (anyptr) &implicitzero, -1,
+ 'S', 'V', "STARINDEX", (anyptr) &starindex, -1,
+ 'S', 'V', "ADDINDEX", (anyptr) &addindex, -1,
+ 'S', 'V', "STARARRAYS", (anyptr) &stararrays, 1,
+ 'S', 'V', "STARFUNCTIONS", (anyptr) &starfunctions, -1,
+ 'S', 'V', "POSTINCREMENT", (anyptr) &postincrement, 1,
+ 'S', 'V', "MIXVARS", (anyptr) &mixvars, -1,
+ 'S', 'V', "MIXTYPES", (anyptr) &mixtypes, -1,
+ 'S', 'V', "MIXFIELDS", (anyptr) &mixfields, -1,
+ 'S', 'V', "MIXINITS", (anyptr) &mixinits, -1,
+ 'S', 'V', "MAINLOCALS", (anyptr) &mainlocals, 1,
+ 'S', 'V', "NULLCHAR", (anyptr) &nullcharconst, 1,
+ 'S', 'V', "HIGHCHARINT", (anyptr) &highcharints, 1,
+ 'I', 'V', "CASESPACING", (anyptr) &casespacing, 1,
+ 'D', 'V', "CASETABS", (anyptr) &casetabs, 1000,
+ 'I', 'V', "CASELIMIT", (anyptr) &caselimit, 9,
+ 'S', 'V', "USECOMMAS", (anyptr) &usecommas, -1,
+ 'S', 'V', "USERETURNS", (anyptr) &usereturns, 1,
+ 'I', 'V', "RETURNLIMIT", (anyptr) &returnlimit, 3,
+ 'S', 'V', "USEBREAKS", (anyptr) &usebreaks, 1,
+ 'I', 'V', "BREAKLIMIT", (anyptr) &breaklimit, 2,
+ 'I', 'V', "CONTINUELIMIT", (anyptr) &continuelimit, 5,
+ 'S', 'V', "INFLOOPSTYLE", (anyptr) &infloopstyle, 0,
+
+/* NAMING CONVENTIONS */
+ 'C', 'V', "CODEFILENAME", (anyptr) codefnfmt, 40,
+ 'C', 'V', "MODULEFILENAME", (anyptr) modulefnfmt, 40,
+ 'C', 'V', "HEADERFILENAME", (anyptr) headerfnfmt, 40,
+ 'C', 'V', "HEADERFILENAME2", (anyptr) headerfnfmt2, 40,
+ 'C', 'V', "SELFINCLUDENAME", (anyptr) selfincludefmt, 40,
+ 'C', 'V', "LOGFILENAME", (anyptr) logfnfmt, 40,
+ 'C', 'V', "INCLUDEFILENAME", (anyptr) includefnfmt, 40,
+ 'S', 'V', "SYMCASE", (anyptr) &symcase, -1,
+ 'C', 'V', "SYMBOLFORMAT", (anyptr) symbolformat, 40,
+ 'C', 'V', "CONSTFORMAT", (anyptr) constformat, 40,
+ 'C', 'V', "MODULEFORMAT", (anyptr) moduleformat, 40,
+ 'C', 'V', "FUNCTIONFORMAT", (anyptr) functionformat, 40,
+ 'C', 'V', "VARFORMAT", (anyptr) varformat, 40,
+ 'C', 'V', "FIELDFORMAT", (anyptr) fieldformat, 40,
+ 'C', 'V', "TYPEFORMAT", (anyptr) typeformat, 40,
+ 'C', 'V', "ENUMFORMAT", (anyptr) enumformat, 40,
+ 'C', 'V', "RETURNVALUENAME", (anyptr) name_RETV, 40,
+ 'C', 'V', "UNITINITNAME", (anyptr) name_UNITINIT, 40,
+ 'C', 'V', "HSYMBOLNAME", (anyptr) name_HSYMBOL, 40,
+ 'C', 'V', "GSYMBOLNAME", (anyptr) name_GSYMBOL, 40,
+ 'C', 'V', "STRINGMAXNAME", (anyptr) name_STRMAX, 40,
+ 'C', 'V', "ARRAYMINNAME", (anyptr) name_ALOW, 40,
+ 'C', 'V', "ARRAYMAXNAME", (anyptr) name_AHIGH, 40,
+ 'C', 'V', "COPYPARNAME", (anyptr) name_COPYPAR, 40,
+ 'C', 'V', "STATICLINKNAME", (anyptr) name_LINK, 40,
+ 'C', 'V', "LOCALVARSSTRUCT", (anyptr) name_LOC, 40,
+ 'C', 'V', "LOCALVARSNAME", (anyptr) name_VARS, 40,
+ 'C', 'V', "FWDSTRUCTNAME", (anyptr) name_STRUCT, 40,
+ 'C', 'V', "ENUMLISTNAME", (anyptr) name_ENUM, 40,
+ 'C', 'V', "UNIONNAME", (anyptr) name_UNION, 40,
+ 'C', 'V', "UNIONPARTNAME", (anyptr) name_VARIANT, 40,
+ 'C', 'V', "FAKESTRUCTNAME", (anyptr) name_FAKESTRUCT, 40,
+ 'C', 'V', "LABELNAME", (anyptr) name_LABEL, 40,
+ 'C', 'V', "LABELVARNAME", (anyptr) name_LABVAR, 40,
+ 'C', 'V', "TEMPNAME", (anyptr) name_TEMP, 40,
+ 'C', 'V', "DUMMYNAME", (anyptr) name_DUMMY, 40,
+ 'C', 'V', "FORNAME", (anyptr) name_FOR, 40,
+ 'C', 'V', "WITHNAME", (anyptr) name_WITH, 40,
+ 'C', 'V', "PTRNAME", (anyptr) name_PTR, 40,
+ 'C', 'V', "STRINGNAME", (anyptr) name_STRING, 40,
+ 'C', 'V', "SETNAME", (anyptr) name_SET, 40,
+ 'C', 'V', "FNVARNAME", (anyptr) name_FNVAR, 40,
+ 'C', 'V', "FNSIZENAME", (anyptr) name_FNSIZE, 40,
+ 'C', 'V', "ALTERNATENAME1", (anyptr) alternatename1, 40,
+ 'C', 'V', "ALTERNATENAME2", (anyptr) alternatename2, 40,
+ 'C', 'V', "ALTERNATENAME", (anyptr) alternatename, 40,
+ 'C', 'V', "EXPORTSYMBOL", (anyptr) exportsymbol, 40,
+ 'C', 'V', "EXPORT_SYMBOL", (anyptr) export_symbol, 40,
+ 'C', 'V', "ALIAS", (anyptr) externalias, 40,
+ 'X', 'V', "SYNONYM", (anyptr) NULL, 3,
+ 'X', 'V', "NAMEOF", (anyptr) &nameoflist, 1,
+ 'G', 'V', "AVOIDNAME", (anyptr) NULL, AVOIDNAME,
+ 'G', 'V', "AVOIDGLOBALNAME", (anyptr) NULL, AVOIDGLOB,
+ 'G', 'V', "WARNNAME", (anyptr) NULL, WARNNAME,
+ 'G', 'V', "NOSIDEEFFECTS", (anyptr) NULL, NOSIDEEFF,
+ 'G', 'V', "STRUCTFUNCTION", (anyptr) NULL, STRUCTF,
+ 'G', 'V', "STRLAPFUNCTION", (anyptr) NULL, STRLAPF,
+ 'F', 'V', "LEAVEALONE", (anyptr) NULL, LEAVEALONE,
+ 'G', 'V', "DETERMINISTIC", (anyptr) NULL, DETERMF,
+ 'G', 'V', "NEEDSTATIC", (anyptr) NULL, NEEDSTATIC,
+ 'S', 'V', "WARNNAMES", (anyptr) &warnnames, 0,
+ 'M', 'V', "VARMACRO", (anyptr) NULL, MAC_VAR,
+ 'M', 'V', "CONSTMACRO", (anyptr) NULL, MAC_CONST,
+ 'M', 'V', "FIELDMACRO", (anyptr) NULL, MAC_FIELD,
+ 'M', 'V', "FUNCMACRO", (anyptr) NULL, MAC_FUNC,
+ 'S', 'V', "WARNMACROS", (anyptr) &warnmacros, 0,
+
+/* CODING OPTIONS */
+ 'A', 'V', "INITIALCALLS", (anyptr) &initialcalls, 0,
+ 'S', 'V', "EXPANDINCLUDES", (anyptr) &expandincludes, -1,
+ 'S', 'V', "COLLECTNEST", (anyptr) &collectnest, 1,
+ 'S', 'V', "SHORTCIRCUIT", (anyptr) &shortcircuit, -1,
+ 'S', 'V', "SHORTOPT", (anyptr) &shortopt, 1,
+ 'S', 'V', "ELIMDEADCODE", (anyptr) &elimdeadcode, 1,
+ 'S', 'V', "FOLDCONSTANTS", (anyptr) &foldconsts, -1,
+ 'S', 'V', "FOLDSTRCONSTANTS",(anyptr) &foldstrconsts, -1,
+ 'S', 'V', "CHARCONSTS", (anyptr) &charconsts, 1,
+ 'S', 'V', "USECONSTS", (anyptr) &useconsts, -1,
+ 'S', 'V', "USEUNDEF", (anyptr) &useundef, 1,
+ 'L', 'V', "SKIPINDICES", (anyptr) &skipindices, 0,
+ 'S', 'V', "OFFSETFORLOOPS", (anyptr) &offsetforloops, 1,
+ 'S', 'V', "FOREVALORDER", (anyptr) &forevalorder, 0,
+ 'S', 'V', "STRINGLEADERS", (anyptr) &stringleaders, 2,
+ 'S', 'V', "STOREFILENAMES", (anyptr) &storefilenames, -1,
+ 'S', 'V', "CHARFILETEXT", (anyptr) &charfiletext, -1,
+ 'S', 'V', "SQUEEZESUBR", (anyptr) &squeezesubr, 1,
+ 'S', 'T', "USEENUM", (anyptr) &useenum, -1,
+ 'S', 'V', "SQUEEZEENUM", (anyptr) &enumbyte, -1,
+ 'S', 'V', "COMPENUMS", (anyptr) &compenums, -1,
+ 'S', 'V', "PRESERVETYPES", (anyptr) &preservetypes, 1,
+ 'S', 'V', "PRESERVEPOINTERS",(anyptr) &preservepointers, 0,
+ 'S', 'V', "PRESERVESTRINGS", (anyptr) &preservestrings, -1,
+ 'S', 'V', "PACKING", (anyptr) &packing, 1,
+ 'S', 'V', "PACKSIGNED", (anyptr) &packsigned, 1,
+ 'I', 'V', "STRINGCEILING", (anyptr) &stringceiling, 255,
+ 'I', 'V', "STRINGDEFAULT", (anyptr) &stringdefault, 255,
+ 'I', 'V', "STRINGTRUNCLIMIT",(anyptr) &stringtrunclimit, -1,
+ 'I', 'V', "LONGSTRINGSIZE", (anyptr) &longstringsize, -1,
+ 'S', 'V', "KEEPNULLS", (anyptr) &keepnulls, 0,
+ 'S', 'V', "HIGHCHARBITS", (anyptr) &highcharbits, -1,
+ 'S', 'V', "ALWAYSCOPYVALUES",(anyptr) &alwayscopyvalues, 0,
+ 'S', 'V', "STATICFUNCTIONS", (anyptr) &use_static, 1,
+ 'S', 'V', "STATICVARIABLES", (anyptr) &var_static, 1,
+ 'S', 'V', "VOIDARGS", (anyptr) &void_args, -1,
+ 'S', 'V', "PROTOTYPES", (anyptr) &prototypes, -1,
+ 'S', 'V', "FULLPROTOTYPING", (anyptr) &fullprototyping, -1,
+ 'S', 'V', "PROCPTRPROTOTYPES",(anyptr)&procptrprototypes, 1,
+ 'S', 'V', "CASTARGS", (anyptr) &castargs, -1,
+ 'S', 'V', "CASTLONGARGS", (anyptr) &castlongargs, -1,
+ 'S', 'V', "PROMOTEARGS", (anyptr) &promoteargs, -1,
+ 'S', 'V', "FIXPROMOTEDARGS", (anyptr) &fixpromotedargs, 1,
+ 'S', 'V', "PROMOTEENUMS", (anyptr) &promote_enums, -1,
+ 'S', 'V', "STATICLINKS", (anyptr) &hasstaticlinks, -1,
+ 'S', 'V', "VARSTRINGS", (anyptr) &varstrings, 0,
+ 'S', 'V', "VARFILES", (anyptr) &varfiles, 1,
+ 'S', 'V', "ADDRSTDFILES", (anyptr) &addrstdfiles, 0,
+ 'S', 'V', "COPYSTRUCTFUNCS", (anyptr) &copystructfuncs, -1,
+ 'S', 'V', "ATAN2", (anyptr) &atan2flag, 0,
+ 'S', 'V', "BITWISEMOD", (anyptr) &mod_po2, -1,
+ 'S', 'V', "BITWISEDIV", (anyptr) &div_po2, -1,
+ 'S', 'V', "ASSUMEBITS", (anyptr) &assumebits, 0,
+ 'S', 'V', "ASSUMESIGNS", (anyptr) &assumesigns, 1,
+ 'S', 'V', "ALLOCZERONIL", (anyptr) &alloczeronil, 0,
+ 'S', 'V', "PRINTFONLY", (anyptr) &printfonly, -1,
+ 'S', 'V', "MIXWRITELNS", (anyptr) &mixwritelns, 1,
+ 'S', 'V', "MESSAGESTDERR", (anyptr) &messagestderr, 1,
+ 'I', 'V', "INTEGERWIDTH", (anyptr) &integerwidth, -1,
+ 'I', 'V', "REALWIDTH", (anyptr) &realwidth, 12,
+ 'S', 'V', "FORMATSTRINGS", (anyptr) &formatstrings, 0,
+ 'S', 'V', "WHILEFGETS", (anyptr) &whilefgets, 1,
+ 'S', 'V', "USEGETS", (anyptr) &usegets, 1,
+ 'S', 'V', "NEWLINESPACE", (anyptr) &newlinespace, -1,
+ 'S', 'V', "BUILDREADS", (anyptr) &buildreads, 1,
+ 'S', 'V', "BUILDWRITES", (anyptr) &buildwrites, 1,
+ 'S', 'V', "BINARYMODE", (anyptr) &binarymode, 1,
+ 'S', 'V', "READWRITEOPEN", (anyptr) &readwriteopen, -1,
+ 'C', 'V', "OPENMODE", (anyptr) openmode, 40,
+ 'S', 'V', "LITERALFILES", (anyptr) &literalfilesflag, -1,
+ 'A', 'V', "LITERALFILE", (anyptr) &literalfiles, 0,
+ 'S', 'V', "STRUCTFILES", (anyptr) &structfilesflag, 0,
+ 'A', 'V', "STRUCTFILE", (anyptr) &structfiles, 0,
+ 'C', 'V', "FILENAMEFILTER", (anyptr) filenamefilter, 40,
+ 'S', 'V', "FULLSTRWRITE", (anyptr) &fullstrwrite, -1,
+ 'S', 'V', "FULLSTRREAD", (anyptr) &fullstrread, 1,
+ 'I', 'R', "SETBITS", (anyptr) &setbits, -1,
+ 'I', 'V', "DEFAULTSETSIZE", (anyptr) &defaultsetsize, -1,
+ 'S', 'V', "SMALLSETCONST", (anyptr) &smallsetconst, -2,
+ 'S', 'V', "BIGSETCONST", (anyptr) &bigsetconst, 1,
+ 'S', 'V', "LELERANGE", (anyptr) &lelerange, 0,
+ 'S', 'V', "UNSIGNEDTRICK", (anyptr) &unsignedtrick, 1,
+ 'S', 'V', "USEISALPHA", (anyptr) &useisalpha, 1,
+ 'S', 'V', "USEISSPACE", (anyptr) &useisspace, 0,
+ 'S', 'V', "USESTRNCMP", (anyptr) &usestrncmp, 1,
+
+/* TARGET LIBRARY */
+ 'G', 'V', "WARNLIBRARY", (anyptr) NULL, WARNLIBR,
+ 'S', 'V', "QUOTEINCLUDES", (anyptr) &quoteincludes, 1,
+ 'X', 'V', "IMPORTFROM", (anyptr) &importfrom, 1,
+ 'A', 'V', "IMPORTDIR", (anyptr) &importdirs, 0,
+ 'A', 'V', "INCLUDEDIR", (anyptr) &includedirs, 0,
+ 'X', 'V', "INCLUDEFROM", (anyptr) &includefrom, 1,
+ 'A', 'V', "LIBRARYFILE", (anyptr) &librfiles, 0,
+ 'C', 'V', "HEADERNAME", (anyptr) p2c_h_name, 40,
+ 'C', 'V', "PROCTYPENAME", (anyptr) name_PROCEDURE, 40,
+ 'C', 'V', "UCHARNAME", (anyptr) name_UCHAR, 40,
+ 'C', 'V', "SCHARNAME", (anyptr) name_SCHAR, 40,
+ 'C', 'V', "BOOLEANNAME", (anyptr) name_BOOLEAN, 40,
+ 'C', 'V', "TRUENAME", (anyptr) name_TRUE, 40,
+ 'C', 'V', "FALSENAME", (anyptr) name_FALSE, 40,
+ 'C', 'V', "NULLNAME", (anyptr) name_NULL, 40,
+ 'C', 'V', "ESCAPECODENAME", (anyptr) name_ESCAPECODE, 40,
+ 'C', 'V', "IORESULTNAME", (anyptr) name_IORESULT, 40,
+ 'C', 'V', "ARGCNAME", (anyptr) name_ARGC, 40,
+ 'C', 'V', "ARGVNAME", (anyptr) name_ARGV, 40,
+ 'C', 'V', "MAINNAME", (anyptr) name_MAIN, 40,
+ 'C', 'V', "ESCAPENAME", (anyptr) name_ESCAPE, 40,
+ 'C', 'V', "ESCIONAME", (anyptr) name_ESCIO, 40,
+ 'C', 'V', "CHECKIONAME", (anyptr) name_CHKIO, 40,
+ 'C', 'V', "SETIONAME", (anyptr) name_SETIO, 40,
+ 'C', 'V', "FILENOTFOUNDNAME",(anyptr) filenotfoundname, 40,
+ 'C', 'V', "FILENOTOPENNAME", (anyptr) filenotopenname, 40,
+ 'C', 'V', "FILEWRITEERRORNAME",(anyptr)filewriteerrorname,40,
+ 'C', 'V', "BADINPUTFORMATNAME",(anyptr)badinputformatname,40,
+ 'C', 'V', "ENDOFFILENAME", (anyptr) endoffilename, 40,
+ 'C', 'V', "OUTMEMNAME", (anyptr) name_OUTMEM, 40,
+ 'C', 'V', "CASECHECKNAME", (anyptr) name_CASECHECK, 40,
+ 'C', 'V', "NILCHECKNAME", (anyptr) name_NILCHECK, 40,
+ 'C', 'V', "SETBITSNAME", (anyptr) name_SETBITS, 40,
+ 'S', 'V', "SPRINTFVALUE", (anyptr) &sprintf_value, -1,
+ 'C', 'V', "SPRINTFNAME", (anyptr) sprintfname, 40,
+ 'C', 'V', "MEMCPYNAME", (anyptr) memcpyname, 40,
+ 'C', 'V', "ROUNDNAME", (anyptr) roundname, 40,
+ 'C', 'V', "DIVNAME", (anyptr) divname, 40,
+ 'C', 'V', "MODNAME", (anyptr) modname, 40,
+ 'C', 'V', "REMNAME", (anyptr) remname, 40,
+ 'C', 'V', "STRCICMPNAME", (anyptr) strcicmpname, 40,
+ 'C', 'V', "STRSUBNAME", (anyptr) strsubname, 40,
+ 'C', 'V', "STRPOSNAME", (anyptr) strposname, 40,
+ 'S', 'V', "STRCPYLEFT", (anyptr) &strcpyleft, 1,
+ 'C', 'V', "STRDELETENAME", (anyptr) strdeletename, 40,
+ 'C', 'V', "STRINSERTNAME", (anyptr) strinsertname, 40,
+ 'C', 'V', "STRMOVENAME", (anyptr) strmovename, 40,
+ 'C', 'V', "STRLTRIMNAME", (anyptr) strltrimname, 40,
+ 'C', 'V', "STRRTRIMNAME", (anyptr) strrtrimname, 40,
+ 'C', 'V', "STRRPTNAME", (anyptr) strrptname, 40,
+ 'C', 'V', "STRPADNAME", (anyptr) strpadname, 40,
+ 'C', 'V', "ABSNAME", (anyptr) absname, 40,
+ 'C', 'V', "ODDNAME", (anyptr) oddname, 40,
+ 'C', 'V', "EVENNAME", (anyptr) evenname, 40,
+ 'C', 'V', "SWAPNAME", (anyptr) swapname, 40,
+ 'C', 'V', "MALLOCNAME", (anyptr) mallocname, 40,
+ 'C', 'V', "FREENAME", (anyptr) freename, 40,
+ 'C', 'V', "FREERVALUENAME", (anyptr) freervaluename, 40,
+ 'X', 'V', "SPECIALMALLOC", (anyptr) &specialmallocs, 1,
+ 'X', 'V', "SPECIALFREE", (anyptr) &specialfrees, 1,
+ 'X', 'V', "SPECIALSIZEOF", (anyptr) &specialsizeofs, 1,
+ 'C', 'V', "RANDREALNAME", (anyptr) randrealname, 40,
+ 'C', 'V', "RANDINTNAME", (anyptr) randintname, 40,
+ 'C', 'V', "RANDOMIZENAME", (anyptr) randomizename, 40,
+ 'C', 'V', "SKIPSPACENAME", (anyptr) skipspacename, 40,
+ 'C', 'V', "READLNNAME", (anyptr) readlnname, 40,
+ 'C', 'V', "FREOPENNAME", (anyptr) freopenname, 40,
+ 'C', 'V', "EOFNAME", (anyptr) eofname, 40,
+ 'C', 'V', "EOLNNAME", (anyptr) eolnname, 40,
+ 'C', 'V', "FILEPOSNAME", (anyptr) fileposname, 40,
+ 'C', 'V', "MAXPOSNAME", (anyptr) maxposname, 40,
+ 'C', 'V', "SETUNIONNAME", (anyptr) setunionname, 40,
+ 'C', 'V', "SETINTNAME", (anyptr) setintname, 40,
+ 'C', 'V', "SETDIFFNAME", (anyptr) setdiffname, 40,
+ 'C', 'V', "SETXORNAME", (anyptr) setxorname, 40,
+ 'C', 'V', "SETINNAME", (anyptr) setinname, 40,
+ 'C', 'V', "SETADDNAME", (anyptr) setaddname, 40,
+ 'C', 'V', "SETADDRANGENAME", (anyptr) setaddrangename, 40,
+ 'C', 'V', "SETREMNAME", (anyptr) setremname, 40,
+ 'C', 'V', "SETEQUALNAME", (anyptr) setequalname, 40,
+ 'C', 'V', "SUBSETNAME", (anyptr) subsetname, 40,
+ 'C', 'V', "SETCOPYNAME", (anyptr) setcopyname, 40,
+ 'C', 'V', "SETEXPANDNAME", (anyptr) setexpandname, 40,
+ 'C', 'V', "SETPACKNAME", (anyptr) setpackname, 40,
+ 'C', 'V', "SIGNEXTENDNAME", (anyptr) signextname, 40,
+ 'C', 'V', "GETBITSNAME", (anyptr) getbitsname, 40,
+ 'C', 'V', "CLRBITSNAME", (anyptr) clrbitsname, 40,
+ 'C', 'V', "PUTBITSNAME", (anyptr) putbitsname, 40,
+ 'C', 'V', "STOREBITSNAME", (anyptr) storebitsname, 40,
+ 'C', 'V', "DECLBUFNAME", (anyptr) declbufname, 40,
+ 'C', 'V', "DECLBUFNCNAME", (anyptr) declbufncname, 40,
+ 'A', 'V', "BUFFEREDFILE", (anyptr) &bufferedfiles, 0,
+ 'A', 'V', "UNBUFFEREDFILE", (anyptr) &unbufferedfiles, 0,
+ 'C', 'V', "RESETBUFNAME", (anyptr) resetbufname, 40,
+ 'C', 'V', "SETUPBUFNAME", (anyptr) setupbufname, 40,
+ 'C', 'V', "GETFBUFNAME", (anyptr) getfbufname, 40,
+ 'C', 'V', "CHARGETFBUFNAME", (anyptr) chargetfbufname, 40,
+ 'C', 'V', "ARRAYGETFBUFNAME",(anyptr) arraygetfbufname, 40,
+ 'C', 'V', "PUTFBUFNAME", (anyptr) putfbufname, 40,
+ 'C', 'V', "CHARPUTFBUFNAME", (anyptr) charputfbufname, 40,
+ 'C', 'V', "ARRAYPUTFBUFNAME",(anyptr) arrayputfbufname, 40,
+ 'C', 'V', "GETNAME", (anyptr) getname, 40,
+ 'C', 'V', "CHARGETNAME", (anyptr) chargetname, 40,
+ 'C', 'V', "ARRAYGETNAME", (anyptr) arraygetname, 40,
+ 'C', 'V', "PUTNAME", (anyptr) putname, 40,
+ 'C', 'V', "CHARPUTNAME", (anyptr) charputname, 40,
+ 'C', 'V', "ARRAYPUTNAME", (anyptr) arrayputname, 40,
+ 'C', 'V', "EOFBUFNAME", (anyptr) eofbufname, 40,
+ 'C', 'V', "FILEPOSBUFNAME", (anyptr) fileposbufname, 40,
+
+/* RANGE CHECKING */
+ 'S', 'V', "CASECHECK", (anyptr) &casecheck, 0,
+ 'S', 'V', "ARRAYCHECK", (anyptr) &arraycheck, 0,
+ 'S', 'V', "RANGECHECK", (anyptr) &rangecheck, 0,
+ 'S', 'V', "NILCHECK", (anyptr) &nilcheck, 0,
+ 'S', 'V', "MALLOCCHECK", (anyptr) &malloccheck, 0,
+ 'S', 'V', "CHECKFILEOPEN", (anyptr) &checkfileopen, 1,
+ 'S', 'V', "CHECKFILEISOPEN", (anyptr) &checkfileisopen, 0,
+ 'S', 'V', "CHECKFILEWRITE", (anyptr) &checkfilewrite, 2,
+ 'S', 'V', "CHECKREADFORMAT", (anyptr) &checkreadformat, 2,
+ 'S', 'V', "CHECKFILEEOF", (anyptr) &checkfileeof, 2,
+ 'S', 'V', "CHECKSTDINEOF", (anyptr) &checkstdineof, 2,
+ 'S', 'V', "CHECKFILESEEK", (anyptr) &checkfileseek, 2,
+}
+#endif /* define_parameters */
+ ;
+
+
+#undef extern
+
+
+#ifdef define_parameters
+ int numparams = sizeof(rctable) / sizeof(struct rcstruct);
+ Strlist *rcprevvalues[sizeof(rctable) / sizeof(struct rcstruct)];
+#else
+ extern int numparams;
+ extern Strlist *rcprevvalues[];
+#endif /* define_parameters */
+
+
+
+/* Global variables: */
+
+#ifdef define_globals
+# define extern
+#endif /* define_globals */
+
+
+extern char *charname, *ucharname, *scharname, *integername;
+extern long min_schar, max_schar, max_uchar;
+extern long min_sshort, max_sshort, max_ushort;
+
+extern char *alloctemp;
+extern short error_crash;
+extern int total_bytes, total_exprs, total_meanings, total_strings;
+extern int total_symbols, total_types, total_stmts, total_strlists;
+extern int total_literals, total_ctxstacks, total_tempvars, total_inprecs;
+extern int total_parens, total_ptrdescs, total_misc;
+extern int final_bytes, final_exprs, final_meanings, final_strings;
+extern int final_symbols, final_types, final_stmts, final_strlists;
+extern int final_literals, final_ctxstacks, final_tempvars, final_inprecs;
+extern int final_parens, final_ptrdescs, final_misc;
+
+extern char *infname, *outfname, *codefname, *hdrfname;
+extern char *requested_module;
+extern FILE *inf, *outf, *codef, *hdrf, *logf;
+extern short setup_complete, found_module;
+extern short regression, verbose, conserve_mem;
+extern int inf_lnum, inf_ltotal;
+
+extern int outindent, outputmode;
+extern int outf_lnum;
+extern short dontbreaklines;
+
+extern Token curtok;
+extern char curtokbuf[256], curtokcase[256];
+extern char *inbufptr;
+extern int inbufindent;
+extern long curtokint;
+extern Symbol *curtoksym;
+extern Meaning *curtokmeaning;
+extern Strlist *curcomments;
+extern Strlist **keepingstrlist;
+extern short ignore_directives, skipping_module;
+extern short C_lex;
+extern char sysprog_flag, partial_eval_flag, iocheck_flag;
+extern char range_flag, ovflcheck_flag, stackcheck_flag;
+extern short switch_strpos;
+extern int fixedflag;
+extern int numimports;
+extern Strlist *tempoptionlist;
+extern long curserial, serialcount;
+extern int notephase;
+extern Strlist *permimports;
+extern int permflag;
+
+#define SYMHASHSIZE 293
+extern Symbol *(symtab[SYMHASHSIZE]);
+extern short partialdump;
+
+#define MAXWITHS 100
+extern int withlevel;
+extern Type *withlist[MAXWITHS];
+extern Expr *withexprs[MAXWITHS];
+
+extern Token blockkind;
+extern Meaning *curctx, *curctxlast, *nullctx;
+
+extern int fixexpr_tryblock;
+extern short fixexpr_tryflag;
+
+extern Type *tp_integer, *tp_char, *tp_boolean, *tp_real, *tp_longreal;
+extern Type *tp_anyptr, *tp_jmp_buf, *tp_schar, *tp_uchar, *tp_charptr;
+extern Type *tp_int, *tp_sshort, *tp_ushort, *tp_abyte, *tp_sbyte, *tp_ubyte;
+extern Type *tp_void, *tp_str255, *tp_strptr, *tp_text, *tp_bigtext;
+extern Type *tp_unsigned, *tp_uint, *tp_sint, *tp_smallset, *tp_proc;
+extern Meaning *mp_string, *mp_true, *mp_false;
+extern Meaning *mp_input, *mp_output, *mp_stderr;
+extern Meaning *mp_maxint, *mp_minint, *mp_escapecode, *mp_ioresult;
+extern Meaning *mp_uchar, *mp_schar, *mp_unsigned, *mp_uint;
+extern Meaning *mp_str_hp, *mp_str_turbo;
+extern Meaning *mp_val_modula, *mp_val_turbo;
+extern Meaning *mp_blockread_ucsd, *mp_blockread_turbo;
+extern Meaning *mp_blockwrite_ucsd, *mp_blockwrite_turbo;
+extern Meaning *mp_dec_dec, *mp_dec_turbo;
+extern Expr *ex_input, *ex_output;
+extern Strlist *attrlist;
+
+
+#ifndef define_globals
+# undef extern
+#endif
+
+
+
+
+/* Function declarations are created automatically by "makeproto" */
+
+#include "p2c.hdrs"
+
+#include "p2c.proto"
+
+
+
+/* Our library omits declarations for these functions! */
+
+int link PP( (char *, char *) );
+int unlink PP( (char *) );
+
+
+
+#define minspcthresh ((minspacingthresh >= 0) ? minspacingthresh : minspacing)
+
+#define delfreearg(ex, n) freeexpr((*(ex))->args[n]), deletearg(ex, n)
+#define delsimpfreearg(ex, n) freeexpr((*(ex))->args[n]), delsimparg(ex, n)
+
+#define swapexprs(a,b) do {register Expr *t=(a);(a)=(b);(b)=(t);} while (0)
+#define swapstmts(a,b) do {register Stmt *t=(a);(a)=(b);(b)=(t);} while (0)
+
+#define CHECKORDEXPR(ex,v) ((ex)->kind==EK_CONST ? (ex)->val.i - (v) : -2)
+
+#define FCheck(flag) ((flag) == 1 || (!iocheck_flag && (flag)))
+#define checkeof(fex) (isvar(fex, mp_input) ? FCheck(checkstdineof) \
+ : FCheck(checkfileeof))
+
+
+#ifdef TEST_MALLOC /* Memory testing */
+
+#define ALLOC(N,TYPE,NAME) \
+ (TYPE *) test_malloc((unsigned)((N)*sizeof(TYPE)), \
+ &__CAT__(total_,NAME), &__CAT__(final_,NAME))
+
+#define ALLOCV(N,TYPE,NAME) \
+ (TYPE *) test_malloc((unsigned)(N), \
+ &__CAT__(total_,NAME), &__CAT__(final_,NAME))
+
+#define REALLOC(P,N,TYPE) \
+ (TYPE *) test_realloc((char *)(P), (unsigned)((N)*sizeof(TYPE)))
+
+#define FREE(P) test_free((char*)(P))
+
+#else /* not TEST_MALLOC */
+
+/* If p2c always halts immediately with an out-of-memory error, try
+ recompiling all modules with BROKEN_OR defined. */
+#ifdef BROKEN_OR
+
+#define ALLOC(N,TYPE,NAME) \
+ ((alloctemp = malloc((unsigned)((N)*sizeof(TYPE)))), \
+ (alloctemp ? (TYPE *) alloctemp : (TYPE *) outmem()))
+
+#define ALLOCV(N,TYPE,NAME) \
+ ((alloctemp = malloc((unsigned)(N))), \
+ (alloctemp ? (TYPE *) alloctemp : (TYPE *) outmem()))
+
+#define REALLOC(P,N,TYPE) \
+ ((alloctemp = realloc((char*)(P), (unsigned)((N)*sizeof(TYPE)))), \
+ (alloctemp ? (TYPE *) alloctemp : (TYPE *) outmem()))
+
+#define FREE(P) free((char*)(P))
+
+#else /* not BROKEN_OR */
+
+#define ALLOC(N,TYPE,NAME) \
+ ((alloctemp = malloc((unsigned)((N)*sizeof(TYPE)))) || outmem(), \
+ (TYPE *) alloctemp)
+
+#define ALLOCV(N,TYPE,NAME) \
+ ((alloctemp = malloc((unsigned)(N))) || outmem(), \
+ (TYPE *) alloctemp)
+
+#define REALLOC(P,N,TYPE) \
+ ((alloctemp = realloc((char*)(P), (unsigned)((N)*sizeof(TYPE)))) || outmem(), \
+ (TYPE *) alloctemp)
+
+#define FREE(P) free((char*)(P))
+
+#endif /* BROKEN_OR */
+#endif /* TEST_MALLOC */
+
+
+#define MIN(a,b) ((a) < (b) ? (a) : (b))
+#define MAX(a,b) ((a) > (b) ? (a) : (b))
+
+
+
+#ifdef toupper
+# undef toupper
+# undef tolower
+# define toupper(c) my_toupper(c)
+# define tolower(c) my_tolower(c)
+#endif
+
+#ifndef _toupper
+# if 'A' == 65 && 'a' == 97
+# define _toupper(c) ((c)-'a'+'A')
+# define _tolower(c) ((c)-'A'+'a')
+# else
+# ifdef toupper
+# undef toupper /* hope these are shadowing real functions, */
+# undef tolower /* because my_toupper calls _toupper! */
+# endif
+# define _toupper(c) toupper(c)
+# define _tolower(c) tolower(c)
+# endif
+#endif
+
+
+
+
+/* End. */
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 22:06:53 +0000