From ead21292bec98f26bb1dee99af4552954a3aaa51 Mon Sep 17 00:00:00 2001 From: Paul Kimpel Date: Sun, 12 Jun 2016 16:39:44 -0700 Subject: [PATCH] Commit Rich Cornwell's original transcriptions for Heriot-Watt Pascal, patches, and run-time system. --- PASCAL-Heriot-Watt/PASCRUN.DISK.alg_m | 479 +++ PASCAL-Heriot-Watt/PATCHES.PASCAL.card | 1344 +++++++++ PASCAL-Heriot-Watt/README.txt | 37 + PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m | 3700 ++++++++++++++++++++++++ 4 files changed, 5560 insertions(+) create mode 100644 PASCAL-Heriot-Watt/PASCRUN.DISK.alg_m create mode 100644 PASCAL-Heriot-Watt/PATCHES.PASCAL.card create mode 100644 PASCAL-Heriot-Watt/README.txt create mode 100644 PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m diff --git a/PASCAL-Heriot-Watt/PASCRUN.DISK.alg_m b/PASCAL-Heriot-Watt/PASCRUN.DISK.alg_m new file mode 100644 index 0000000..f65915b --- /dev/null +++ b/PASCAL-Heriot-Watt/PASCRUN.DISK.alg_m @@ -0,0 +1,479 @@ +?execute object/reader +?common=3 +?file newtape = pascrun/disk serial +?data card +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00001 +% % 00002 +% the pascal run time-system. % 00003 +% --------------------------- % 00004 +% % 00005 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00006 +begin% 00007 +integer v00167,v00168,v00169;% 00008 +file input "input" (2,10);% 00009 +file output 1 (2,17);% 00010 +% 00011 +define procedu =procedure#,% 00012 + functn =real procedure#,% 00013 + downto =step -1 until#,% 00014 + upto =step 1 until#,% 00015 + b =boolean#,% 00016 + f00603 =input#,% 00017 + f00742 =output#,% 00018 + lastch =[5:6]#,% 00019 + bufsize =[13:8]#,% 00020 + bufpnt =[21:8]#,% 00021 + eof =[22:1]#,% 00022 + eoln =[23:1]#,% 00023 + inp =[24:1]#,% 00024 + outp =[25:1]#,% 00025 + endfound=[26:1]#,% 00026 + memsize =10000#,% 00027 + maxint =549755813887#;% 00028 +% 00029 +array mem[0:memsize div 1022,0:1022], text,char[0:0], temptext[0:19],% 00030 + v00603[0:9], v00742[0:16];% 00031 +integer mempnt,t,t1,i00603,i00742;% 00032 +pointer charpnt,textpnt;% 00033 +label terminate;% 00034 +format termmess ("**** program execution terminated at line ",i*,"."),% 00035 + checkerr ("**** the value ",i*," is not in the range ",i*,"..",% 00036 + i*,"."),% 00037 + errmark (x*,"x"),% 00038 + concaterr("**** concat error: [",i*,":",i*,":",i*,"]"),% 00039 + illegalcc("**** illegal carriage control character:"""",a1,""");%00040 +switch format errmess :=% 00041 + (),% 00042 + ("**** no reading while eof is true."), %1 00043 + ("**** no writing while eof is false."), %2 00044 + ("**** illegal character,"), %3 00045 + ("**** overflow error."), %4 00046 + ("**** no reset/rewrite on input/output."), %5 00047 + ("**** line image overflow."); %6 00048 +monitor expovr:=realoverflow;% 00049 +% 00050 +integer procedure numdigits(n);% 00051 +value n; integer n;% 00052 +numdigits:=if n<0 then 1+numdigits(-n) else% 00053 + if n>9 then 1+numdigits(n div 10) else 1;% 00054 +% 00055 +procedure runerr(errnum,linenum); %*** run time error *** 00056 +value errnum,linenum;% 00057 +integer errnum,linenum;% 00058 +begin% 00059 + write(output,errmess[errnum]);% 00060 + write(output,termmess,numdigits(linenum),linenum);% 00061 + go to terminate;% 00062 +end of runner;% 00063 +% 00064 +integer procedure check(val,lim1,lim2,linenum);% 00065 +value val,lim1,lim2,linenum;% 00066 +integer val,lim1,lim2,linenum;% 00067 +begin% 00068 + if vallim2 then% 00069 + begin write(output,checkerr,numdigits(val),val,numdigits(lim1),% 00070 + lim1,numdigits(lim2),lim2);% 00071 + runerr(4,linenum);% 00072 + end;% 00073 + check:=val;% 00074 +end of check;% 00075 +% 00076 +alpha procedure curdat;% 00077 +curdat:=" "&time(5)[41:35:36];% 00078 +% 00079 +alpha procedure weekda;% 00080 +weekda:=time(6)&" "[41:5:6];% 00081 +% 00082 +integer procedure trunc(x,linenum);% 00083 +value x,linenum;% 00084 +real x; integer linenum;% 00085 +begin% 00086 + if abs(x)>maxint then runerr(4,linenum);% 00087 + trunc:=if x<0 then -entier(-x) else entier(x);% 00088 +end of trunc; 00089 +% 00090 +integer procedure round(x,linenum);% 00091 +value x,linenum;% 00092 +real x; integer linenum;% 00093 +begin% 00094 + if abs(x)>maxint then runerr(4,linenum);% 00095 + round:=x;% 00096 +end of round;% 00097 +% 00098 +boolean procedure odd(n);% 00099 +value n; integer n;% 00100 +odd:=n mod 2 = 1;% 00101 +% 00102 +real procedure sqr(x,linenum);% 00103 +value x,linenum;% 00104 +real x; integer linenum;% 00105 +begin% 00106 + if abs(x)>2.0769187@34 then runerr(4,linenum);% 00107 + sqr:=x|x;% 00108 +end of sqr;% 00109 +% 00110 +boolean procedure incl1(a,b); %*** is the set "a" included 00111 +value a,b; real a,b; %*** in the set "b". 00112 +incl1:=real(boolean(a) and not boolean(b))=0;% 00113 +% 00114 +boolean procedure incl2(a,b); %*** is the set "b" included 00115 +value a,b; real a,b; %*** in the set "a". 00116 +incl2:=real(boolean(b) and not boolean(a))=0;% 00117 +% 00118 +boolean procedure intst(a,b); %*** is the value "a" an element00119 +value a,b; real a,b; %*** in the set "b". 00120 +intst:=if a<0 or b>38 then false else 0&b[0:38-a:1]=1;% 00121 +% 00122 +procedure new(p,size);% 00123 +value size; real p; integer size;% 00124 +begin% 00125 + p:=if mempnt+size>memsize then 0 else mempnt;% 00126 + mempnt:=mempnt+size;% 00127 +end of new;% 00128 +% 00129 +procedure dispose(p,size);% 00130 +value size; real p; integer size;% 00131 +begin% 00132 +end of dispose;% 00133 +% 00134 +procedure pack(a,llim,ulim,i,z,linenum);% 00135 +value llim,ulim,i,linenum;% 00136 +array a[*]; alpha z;% 00137 +integer llim,ulim,i,linenum;% 00138 +begin;% 00139 + z:=0;% 00140 + for t1:=0 step 1 until 6 do% 00141 + z:=a[check(i+t1,llim,ulim,linenum)] & z [41:35:36];% 00142 +end;% 00143 +% 00144 +procedure unpack(z,a,llim,ulim,i,linenum);% 00145 +value z,llim,ulim,i,linenum;% 00146 +array a[*]; alpha z;% 00147 +integer llim,ulim,i,linenum;% 00148 +for t1:=0 step 1 until 6 do% 00149 +a[check(i+t1,llim,ulim,linenum)]:= 0 & z [5:41-6|t1:6];% 00150 +% 00151 +real procedure concat(a,b,as,bs,n,linenum);% 00152 +value a,b,as,bs,n,linenum;% 00153 +real a,b; integer as,bs,n,linenum;% 00154 +begin% 00155 + if as<1 or bs<1 or n<0 or as+n>48 or bs+n>48 then% 00156 + begin% 00157 + write(output,concaterr,numdigits(as),as,numdigits(bs),% 00158 + bs,numdigits(n),n);% 00159 + runerr(0,linenum);% 00160 + end; 00161 + concat:=a & b [47-as:47-bs:n];% 00162 +end of concat;% 00163 +% 00164 +boolean procedure bit(n,linenum);% %*** set bit no "n" in a word. 00165 +value n,linenum; integer n,linenum;% 00166 +bit:=boolean(0 & 1 [38-check(n,0,38,linenum):0:1]);% 00167 +% 00168 +boolean procedure bits(n1,n2,linenum); %*** set bits "n1".."n2". 00169 +value n1,n2,linenum;% 00170 +integer n1,n2,linenum;% 00171 +bits:=boolean(0 & 3"7777777777777" [38-check(n1,0,38,linenum):38:% 00172 + check(n2,0,38,linenum)-n1+1]);% 00173 +% 00174 +procedure rline(f,buf,info);% 00175 +file f; array buf[0]; integer info;% 00176 +begin% 00177 + label endfile;% 00178 + info.eoln:=0; info.bufpnt:=1;% 00179 + read(f,999,buf[*]) [endfile];% 00180 + replace charpnt by pointer(buf[*]) for 1;% 00181 + info.lastch:=char[0];% 00182 + if false then% 00183 + begin endfile: info.endfound:=1;% 00184 + end;% 00185 +end of rline;% 00186 +% 00187 +real procedure pread(f,buf,info,mode,linenum);% 00188 +value mode,linenum;% 00189 +file f; array buf[0];% 00190 +integer info,mode,linenum;% 00191 +begin% 00192 + define getchar=% 00193 + begin% 00194 + if boolean(info.eoln) then% 00195 + begin% 00196 + rline(f,buf,info); ch:=info.lastch;% 00197 + end else% 00198 + if info.bufpnt=info.bufsize then% 00199 + begin ch:=" "; info.eoln:=1 end else% 00200 + begin% 00201 + replace charpnt by pointer(buf[*])+info.bufpnt for 1;% 00202 + ch:=char[0]; info.bufpnt:=info.bufpnt+1;% 00203 + end end of getchar#;% 00204 +% 00205 + define readerr(errnum)=% 00206 + begin 00207 + write(output,999,buf[*]);% 00208 + write(output,errmark,info.bufpnt-1);% 00209 + runerr(errnum,linenum);% 00210 + end readerr#;% 00211 +% 00212 + real res; alpha ch;% 00213 + boolean negative,negexp; integer power,exp;% 00214 + label overflow,return;% 00215 +% 00216 + if boolean(info.eof) then runerr(1,linenum);% 00217 + if boolean(info.endfound) then% 00218 + begin% 00219 + info.eof:=1; pread:=0;% 00220 + go to return;% 00221 + end;% 00222 + if mode=1 then %*** mode = char *** 00223 + begin% 00224 + pread:=info.lastch; getchar; info.lastch:=ch;% 00225 + end else% 00226 + begin %*** mode = real/integer *** 00227 + ch:=info.lastch;% 00228 + while ch=" " and not boolean(info.endfound) do getchar;% 00229 + if boolean(info.endfound) then% 00230 + begin% 00231 + info.eof:=1; pread:=0;% 00232 + go to return;% 00233 + end;% 00234 + if ch="+" or ch="-" then begin negative:=ch="-"; getchar end;% 00235 + if ch>9 then readerr(3);% 00236 + res:=ch; getchar;% 00237 + while ch{9 do begin res:=10|res+ch; getchar end;% 00238 + if mode=3 then % mode = real. 00239 + begin% 00240 + if ch="." then% 00241 + begin% 00242 + getchar; if ch>9 then readerr(3);% 00243 + while ch{9 do begin res:=10|res+ch;power:=power-1;getchar end;00244 + end;% 00245 + if ch="e" then% 00246 + begin% 00247 + getchar;% 00248 + if ch="+" or ch="-" then begin negexp:=ch="-"; getchar end;% 00249 + if ch>9 then readerr(3);% 00250 + while ch{9 do begin exp:=10|exp+ch; getchar end;% 00251 + if negexp then exp:=-exp;% 00252 + end; 00253 + power:=power+exp;% 00254 + realoverflow:=overflow; res:=res|10*power;% 00255 + if false then overflow: readerr(4);% 00256 + realoverflow:=0;% 00257 + end else if res>maxint then readerr(4);% 00258 + pread:=if negative then -res else res;% 00259 + info.lastch:=ch;% 00260 + end;% 00261 +return:% 00262 +end of pread;% 00263 +% 00264 +% 00265 +procedure wline(f,buf,info); %*** print a line.*** 00266 +file f; array buf[0]; integer info;% 00267 +begin% 00268 + alpha cc;% 00269 + if boolean(info.outp) then% 00270 + begin% 00271 + replace charpnt by pointer(buf[*]) for 1; cc:=char[0];% 00272 + replace pointer(buf[*]) by " ";% 00273 + if cc=" " then write(output,999,buf[*]) else% 00274 + if cc="+" then write(output[no],999,buf[*]) else% 00275 + begin% 00276 + if cc="0" then write(output) else% 00277 + if cc="-" then write(output[dbl]) else% 00278 + if cc="1" then write(output[page]) else% 00279 + write(output,illegalcc,cc);% 00280 + write(output,999,buf[*]);% 00281 + end;% 00282 + end else write(f,999,buf[*]);% 00283 + replace pointer(buf[*]) by " " for info.bufsize;% 00284 + info.bufpnt:=0;% 00285 +end of wline;% 00286 +% 00287 +% 00288 +procedure chfil(f);% 00289 +file f;% 00290 +begin% 00291 + array a[0:6];% 00292 + search(f,a[*]);% 00293 + if a[0]=-1 then% 00294 + begin% 00295 + f.areas := 20;% 00296 + f.areasize := 300;% 00297 + end;% 00298 +end of chfil;% 00299 +% 00300 +% 00301 +procedure walfa(f,buf,info,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,aleng,00302 + linenum);% 00303 +value a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,aleng,linenum;% 00304 +file f; array buf[0]; integer info,aleng,linenum;% 00305 +alpha a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12;% 00306 +begin% 00307 + alpha a; pointer pnt;% 00308 + label exit;% 00309 + if not boolean(info.eof) then runerr(2,linenum);% 00310 + if info.bufpnt+aleng}info.bufsize then wline(f,buf,info);% 00311 + pnt:=pointer(buf[*])+info.bufpnt;% 00312 + info.bufpnt:=info.bufpnt+aleng;% 00313 + for a:=a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12 do% 00314 + begin% 00315 + text[0]:=a;% 00316 + replace pnt:pnt by textpnt for min(aleng,7);% 00317 + aleng:=aleng-7; if aleng{0 then go to exit;% 00318 + end;% 00319 +exit:% 00320 +end of walfa;% 00321 +% 00322 +% 00323 +procedure pwrite(f,buf,info,e,emode,m,n,linenum);% 00324 +value e,emode,m,n,linenum;% 00325 +file f; array buf[0]; real e; 00326 +integer info,emode,m,n,linenum;% 00327 +begin% 00328 + integer nchars,nexp,i; pointer cpnt;% 00329 + define putchar(c)= % puts a character into temptext 00330 + begin char[0]:=c; nchars:=nchars+1;% 00331 + replace cpnt:cpnt by charpnt for 1;% 00332 + end#;% 00333 +% 00334 + procedure putint(n); % puts an integer into temptext 00335 + value n; integer n; % with zero suppression. 00336 + if n{9 then putchar(n) else% 00337 + begin putint(n div 10); putchar(entier(n mod 10)) end;% 00338 +% 00339 + cpnt:=pointer(temptext[*]);% 00340 + if not boolean(info.eof) then runerr(2,linenum);% 00341 + if emode=1 then %*** mode = integer *** 00342 + begin% 00343 + if e<0 then begin putchar("-"); e:=-e end;% 00344 + putint(e);% 00345 + end else% 00346 + if emode=2 then %*** mode = real *** 00347 + begin% 00348 + putchar(" ");% 00349 + if e<0 then begin putchar("-"); e:=-e end;% 00350 + if e>maxint or n<0 then % floating-point. 00351 + begin% 00352 + if e>0 then% 00353 + begin% 00354 + while e<1 do begin nexp:=nexp-1; e:=10|e end;% 00355 + while e}10 do begin nexp:=nexp+1; e:=e/10 end;% 00356 + end; 00357 + i:=max(m-8,1);% 00358 + e:=e+0.5|10*(-i);% 00359 + if e geq 10 then begin nexp:=nexp+1; e:=e/10 end;% 00360 + putchar(entier(e)); e:=e-entier(e); putchar(".");% 00361 + do begin% 00362 + e:=10|e; putchar(entier(e));% 00363 + e:=e-entier(e); i:=i-1;% 00364 + end until i{0;% 00365 + putchar("e");% 00366 + if nexp<0 then begin putchar("-"); nexp:=-nexp end% 00367 + else putchar("+");% 00368 + putchar(nexp div 10); putchar(entier(nexp mod 10));% 00369 + end else% 00370 + begin % fixed-point. 00371 + e:=e+0.5|10*(-n);% 00372 + putint(entier(e)); putchar("."); e:=e-entier(e);% 00373 + if n>150 then runerr(6,linenum);% 00374 + for i:=1 step 1 until n do% 00375 + begin e:=10|e; putchar(entier(e));% 00376 + e:=e-entier(e);% 00377 + end end end else% 00378 + if emode=3 then %*** mode = boolean *** 00379 + begin% 00380 + if e<0.5 then replace cpnt by "false" else replace cpnt by "true";00381 + nchars:=if e<0.5 then 5 else 4;% 00382 + end else% 00383 + if emode=5 then %*** mode = alfa *** 00384 + begin% 00385 + text[0]:=e; nchars:=min(m,7);% 00386 + replace cpnt:cpnt by textpnt for 7;% 00387 + end else% 00388 + begin %*** mode = char *** 00389 + putchar(e);% 00390 + end;% 00391 + if nchars>m then m:=nchars;% 00392 + if info.bufpnt+m>info.bufsize then wline(f,buf,info);% 00393 + if m>info.bufsize then runerr(6,linenum);% 00394 + replace pointer(buf[*])+(info.bufpnt+m-nchars) by% 00395 + pointer(temptext[*]) for nchars;% 00396 + info.bufpnt:=info.bufpnt+m;% 00397 +end of pwrite;% 00398 +% 00399 +% 00400 +procedure put(f,buf,info,linenum);% 00401 +value linenum;% 00402 +file f; array buf[*];% 00403 +integer info,linenum;% 00404 +begin% 00405 + if info.bufsize=0 then% 00406 + begin% 00407 + if not boolean(info.eof) then runerr(2,linenum);% 00408 + write(f,1023,buf[*]);% 00409 + end else pwrite(f,buf,info,info.lastch,4,1,1,linenum);% 00410 +end of put;% 00411 +% 00412 +% 00413 +procedure get(f,buf,info,linenum);% 00414 +value linenum;% 00415 +file f; array buf[*];% 00416 +integer info,linenum;% 00417 +begin% 00418 + alpha x; label endfile;% 00419 + if info.bufsize=0 then% 00420 + begin% 00421 + if boolean(info.eof) then runerr(1,linenum);% 00422 + read(f,1023,buf[*]) [endfile];% 00423 + if false then endfile: info.eof:=1;% 00424 + end else x:=pread(f,buf,info,1,linenum);% 00425 +end of get; 00426 +% 00427 +% 00428 +procedure ppage(f,buf,info,linenum);% 00429 +value linenum;% 00430 +file f; array buf[*];% 00431 +integer info,linenum;% 00432 +begin% 00433 + if not boolean(info.eof) then runerr(2,linenum);% 00434 + write(f[page]);% 00435 +end of ppage;% 00436 +% 00437 +% 00438 +procedure reset(f,buf,info,linenum);% 00439 +value linenum;% 00440 +file f; array buf[*];% 00441 +integer info,linenum;% 00442 +begin% 00443 + if boolean(info.inp) or boolean(info.outp) then runerr(5,linenum);% 00444 + rewind(f); info.eof:=0; info.eoln:=0; info.bufpnt:=0;% 00445 + info.endfound:=0;% 00446 + if info.bufsize=0 then get(f,buf,info,linenum)% 00447 + else rline(f,buf,info);% 00448 +end of reset;% 00449 +% 00450 +procedure rewrite(f,buf,info,linenum);% 00451 +value linenum;% 00452 +file f; array buf[*];% 00453 +integer info,linenum;% 00454 +begin% 00455 + if boolean(info.inp) or boolean(info.outp) then runerr(5,linenum);% 00456 + rewind(f); info.eof:=1; info.bufpnt:=0; info.endfound:=0;% 00457 + if info.bufsize>0 then% 00458 + replace pointer(buf[*]) by " " for info.bufsize;% 00459 +end of rewrite;% 00460 +% 00461 +% 00462 +procedure init(inputdecl);% 00463 +value inputdecl;% 00464 +boolean inputdecl;% 00465 +begin% 00466 + mempnt:=1;% 00467 + charpnt:=pointer(char[*])+7; textpnt:=pointer(text[*])+1;% 00468 + t:=0; t.bufsize:=80; t.bufpnt:=80; t.eoln:=1; t.inp:=1;% 00469 + i00603:=t; if inputdecl then rline(input,v00603,i00603);% 00470 + t:=0; t.bufsize:=132; t.eoln:=1; t.outp:=1; t.eof:=1;% 00471 + i00742:=t;% 00472 + replace pointer(v00742[*]) by " " for 17 words;% 00473 +end of init;% 00474 +?end. diff --git a/PASCAL-Heriot-Watt/PATCHES.PASCAL.card b/PASCAL-Heriot-Watt/PATCHES.PASCAL.card new file mode 100644 index 0000000..3134c1b --- /dev/null +++ b/PASCAL-Heriot-Watt/PATCHES.PASCAL.card @@ -0,0 +1,1344 @@ +?execute object/reader +?common=3 +?file newtape = patch/pascal serial +?data card +$# patch 1 for pascal.xvi.o contains 10 cards. correct spelling & tabulation +$: patch to correct spelling in some error messages, currect tabulation of code +$: or comments, and to correct the call on the procedure to give a new page. +$: *** note that error(71) is now no longer used - see patch 513. +$: is was used once, but incorrectly. error(63) is called in its place. +$: *** note that the algol code file "pascrun"/"disk" has been renamed +$: "pascal"/"prelude". it is no longer referenced directly in this compiler +$: nils a otte, univeristy of natal, durban. aug - nov 1977. +$: + begin ; % null %*** 4) rewrite 50203000 + gen("put",3,5); %*** 5) page 50204000 + gen("ppage",5,3); % 50208000 + block; %*** compile procedure body *** 80646000 + compstat; %*** compile statement part *** 80691000 + (" 41 alfa constants may not be longer than 7 characters."), 91045000 + (" 55 procedure nesting depth + no of records is too great."), 91060000 + (" 87 end-of-input encountered unexpectedly."), 91094000 + (" 97 too many files in use."), 91104000 +end of b5700 pascal compiler.. .........................................99001000 +$# patch 2 for pascal contains 171 cards. +$: patch to merge dag langmyhrs ppp10 to ppp11 cosy patches +$: with nils ottes modified ppp10 source. +$: david a cooper , heriot-watt university, january 1978. +$: +file card "source" (1,10,30); % source code file 10035000 +file lines 1 (1,17); % print file 10036000 +file pascalgol disk serial [20:600] (1,10,30,save 0); % code 10037000 +array paramtab, forwparam1, forwparam2[0:maxparams]; 10109000 +file xreffile disk serial [20:3000] (1,3,30); 10137000 +alpha array xbuff[0:2]; 10138500 +boolean xinb; 10138550 +integer array symkind[0:62]; %used in error recovery. 10149000 + error100mess (//"100 illegal save constant in """""s""""" option10188500 + the value 07 is substituted"/" so this error does not increment th10188600 +e compilation errors count."//),% 10188700 + packedsy=61#, assertsy=62#; 10211000 +% 20181500 +% 20181550 + if errnum=100 20181600 + then numerrs:=numerrs-1;% * error number 100 alone should not 20181650 +% * prevent the xalgol compilation being 20181700 +% * zipped as the value 7 is substituted 20181750 +% * for a bad save constant in an "s" 20181800 +% * option. 20181850 +% 20181900 +% 20181950 + 7(initial),middle,initial; 20308000 + "400read", "6readln", "50reset", "6unpack", "50write", 20373000 + "6qqjzxl" do 20373500 + if decl then ax := -ax; 20520000 + abs(a[2]) leq abs(b[2]); 20539000 +% 20541100 +% 20541150 +% 20541200 +boolean procedure xrefinput(a); 20541250 +array a[0]; 20541300 +begin 20541350 + label eof; 20541400 + integer i; 20541450 +% 20541500 + read(xreffile,3,xbuff[*])[eof]; 20541550 + for i:=0,1,2 do 20541600 + a[i] := xbuff[i]; 20541650 + if false then eof: begin 20541700 + close(xreffile,release); 20541750 + xinb := true; 20541800 + end; 20541850 + xrefinput := xinb; 20541900 +% 20541950 +end of xrefinput; 20541960 + a2 := -a2; 20570000 +boolean lparfound,savexrefopt; 20842000 + savexrefopt := xrefoption; xrefoption := false; 20847500 + if savexrefopt then newxref(curname1,curname2,thislevel, 20861500 + false); 20861550 + xrefoption := savexrefopt; 20868500 +% assert 62 assertsy initial 30075500 + if curname1="6assert" then assertsy else 30165500 + end% 30280000 +% 30280025 +% 30280050 +% the following lines decode any occurrence of the "s" option and 30280075 +% sets the global integer variable "savefactor" which controls the 30280100 +% type of compilation initiated by the zip. there are three legal forms 30280125 +% of the "s" option as follows.- 30280150 +% 30280175 +% "s-" will give no zip ie. pascal syntax check only 30280200 +% "s+" will give a zip for compile and go 30280225 +% "s??" will give a zip for compile to library 30280250 +% where ?? is the two digit decimal save 30280275 +% constant given the object code file 30280300 +% nb. if the save constant is to be 30280325 +% less than 10 the first digit 30280350 +% must be included ie. a "0". 30280375 +% 30280400 +% 30280425 + else 30280450 + if cx="s" then 30280475 + begin 30280500 + if c="-" then savefactor:=-1 else 30280525 + if c="+" then savefactor:= 0 else 30280550 + if c leq 9 then 30280575 + begin 30280600 + savefactor := 10 | c; nextchar; 30280625 + savefactor := savefactor + c; 30280650 + if c gtr 9 then error(100); 30280675 + end 30280700 + else 30280720 + begin 30280735 + error(100); 30280750 + savefactor := 7; 30280765 + end; 30280780 + end; 30280800 +% 30280825 +% 30280850 +% 30280875 +integer exprlevel,tx,expinvarcnt;% 40018000 + boolean inbracket,inrecord,simplevar; 40087000 + simplevar := false; 40099000 + curtype := thisid.type; simplevar := true; 40104000 + simplevar := false; 40109000 + expinvarcnt:=expinvarcnt+1;% 40120500 + expinvarcnt:=expinvarcnt-1;% 40121500 + simplevariable := simplevar; 40199500 + if expinvarcnt=0 then writeexpr; % 40751000 + label efh; 50201500 + %*** 6) open & close (input) for 50204500 + % cumulative frequency count 50204550 + begin 50208100 + gen("qqjzxl",6,2); 50208200 + insymbol; 50208300 + go to efh; % 50208400 + end; 50208500 + efh: 50219500 + exprlevel := 1; 60346500 + if thisid.idclass=var or 60354000 + thisid.idclass=const and boolean(thisid.formal) then % 60354500 + exprlevel := 0; 60383500 +procedure assertstat; 60391100 +begin 60391200 + gen("if not(",7,1); 60391400 + insymbol; boolexpr; 60391500 + gen(") then",7,2); gen("runerr(",7,1); gen("7,",2,6); 60391600 + genint(cardcnt); gen(";",1,7); 60391700 +end of assertstat; 60391800 + if curname1="6qqjzxl" then filehandling(6) else 60443500 + if cursy=assertsy then assertstat else 60457500 + if param then gen("0",1,7) else begin 80129000 + gen("0:",2,6); 80129100 + genint(recsize-1); 80129200 + end 80129300 + forwparam1[numparams] := curname1; 80177500 + forwparam2[numparams] := curname2; 80177600 + integer index, ctype, numforwards, t, tx, i; 80403000 + alpha t3; 80403500 + label ll1; % 80447010 + label ll2; % 80496010 + label ll3; % 80542010 + if curlevel geq maxtables then error(101) else 80543500 + blocktab[curlevel+1] := numblocks := numblocks + 1; 80543600 + nametab3[curlevel,thisindex].forwarddef := 0; 80553000 + t := nametab3[curlevel,thisindex].info; 80554500 + tx := t + paramtab[t]; 80554600 + for i:=t+1 step 1 until tx do 80554700 + newname(forwparam1[i],forwparam2[i],curlevel+1); 80554800 + replace pointer(nametab1[curlevel+1,*]) by 0 80637500 + for maxnames+1 words; 80637600 + if curlevel geq lastrec then error(101); % 80643000 +% 90014100 +% 90014200 +savefactor:=0;% * default zip is compile and go unless 90014300 +% * changed by the use of the "s" option 90014400 +% 90014500 +% 90014600 +% 90042100 +% the following lines add a "0" onto the front of the program name or90042200 +% the first six characters thereof if it is longer than six characters 90042300 +% thus giving the name of the xalgol object code file produced. 90042400 +% 90042500 + progname := curname1.[35:36]; prognamelength := min(6,curlength)+1;90042600 +% 90042700 +% 90042800 +begin% 90090400 + write(line ,noerrors);% 90090500 + if err[100]% 90090600 + then write(line ,error100mess);% 90090700 + if savefactor}0 then% *a zip is required 90090800 +%voidt 90111000 +end% 90129500 + ("100 illegal save constant in """""s""""" option. the value 07 is91106500 +substituted"/" so this error does not increment the compilation erro91106600 +rs count."),% 91106700 + ("101 procedures/functions nested too deep."), 91106800 + rewind(xreffile); 92003500 + sort(printxref,xrefinput,0,xrefmax,xrefcompare,3,1000,6000); 92005000 +$# patch 500 for pascal.xvi.o contains 5 cards. prt cells 25 to 30 +$: this patch corrects the documentation for the compilers prt cells 25 to 27 +$: (not 21 to 23). furthermore. it uses prt cell 30 for the card count (in place +$: of 27) to be consistant with the other system compilers. prt cells 27 is used +$: for the page count formerly at sequence 10134000. +$: nils otte, univeristy of natal, durban. aug - nov 1977. +$: +integer numerrs, % @r+25: number of errors in program. 10029000 + savefactor, % @r+26: savefactor for code file. 10030000 + pagecnt, % @r+27: number of pages printed. 10033800 + cardcnt; % @r+30: number of cards read. 10034000 + integer linecnt, errinx; % pagecnt @ prt+27 10134000 +$# patch 501 for pascal.xvi.o contains 3 cards. "prt25" for user-s pascal prog. +$: this patch incorporates the pre-defined identifier "prt25" located +$: at prt cell 25 as per documentation. (the documentation must be +$: amended to delete prt26 and prt27 from the pre-defined identifier list.) +$: ** note that file pascal/prelude must be updated for "prt25". +$: the variable "prt25" may be set by the q common = n control card. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + newname("50prt25",0,0); %*** "prt25" *** 20369100 + t3:=inttype; t3.idclass:=var; % global integer variable 20369200 + nametab3[0,thisindex] := t3; 20369300 +$# patch 502 for pascal.xvi.o contains 3 cards. line count when debugging +$: to correct the line count when the debugging option to list the algol +$: code generated is set (*$d+ *), otherwise lines per page goes wrong. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: +define linesperpage = 60 #, 10038000 + if dumpoption then begin if (linecnt:=linecnt+1)}linesperpage 20149000 + then heading; write(line,10,algolcard[*]) end; 20149100 +$# patch 503 for pascal.xvi.o contains 9 cards. integer to real for typetab1 +$: when more than 63 entries were entered in the "typetab*" arrays, the +$: pascal compiler was discontinued due to integer overflow, which could occur +$: in a number of procedures as a result of assigning to an integer an array +$: element whose exponent field was not zero. the field "arrtype" is +$: [43:10] and has the 4 high order bits in the exponent field. this patch +$: alters the declarations of all identifier to which "typetab1" may be +$: assigned from integer to real to correct this error. +$: nils a otte, university of natal, durban. aug - nov 1977. + integer it; real t; 50225000 + integer it; real t; 50285000 + integer casetype,addr,maxaddr,index,ctype,tx,sx, t3,llim,ulim,i; 70244000 + real t1, cval; 70246000 + integer level1000, typ, nam, namtab, i, j, recsize; 80020000 + alpha t1, fname; 80022000 + integer firstparam, curkind, p1, px, i, t3; real t; 80148000 + integer index, ctype, numforwards, t3, tx, i; 80403000 + real t, cval; 80404000 +$# patch 504 for pascal.xvi.o contains 23 cards. implement forward declarations +$: forward declarations of procedures ended in chaos due to the parameters and +$: their types not being kept, resulting in globals being referenced where +$: possible, and forward declarations of functions did not work at all. +$: the problem was that the information on the parameters was being stored +$: in the "nametab*" rows for the current level, which were being set to zero +$: on exit from procedure blocks at that level thereafter. +$: this patch corrects the error by marking the entries for parameters of +$: forward procedures and functions, setting to zero only those elements which +$: are not so marked on exit from a block, and unmarking the relevant parameters +$: when the procedure or function is defined. the marking of the parameters +$: is done in such a way that the same identifier name may be used at the same +$: level without syntax error x to report that the identifier is already defined +$: the unmarking replaces the identifier name in "nametab*" to allow for the +$: same name or one that hashes to the same place to have been used previously +$: and now deleted. +$: nils a otte, university of natal, durban. aug - nov 1977. + if found and thisid.idclass}func then 80548000 + nametab3[curlevel,thisindex].forwarddef:=0; 80553000 + (thisid.idclass=func and not fun) then error(43); 80555100 + tx:=(t:=thisid.info)+paramtab[t]; % unmark forward parms 80556000 + for i:=t+1 step 1 until tx do % to allow reference 80557000 + begin t3:=paramtab[i].paramname; 80558000 + curname1:=abs(nametab1[curlevel+1,t3]); 80559000 + curname2:= nametab1[curlevel+1,t3]; 80560000 + nametab1[curlevel+1,t3]:=0; 80561000 + newname(curname1,curname2,curlevel+1); 80562000 + if t3!thisindex then begin 80563000 + paramtab[i].paramname:=thisindex; 80564000 + nametab3[curlevel+1,thisindex] := 80565000 + nametab3[curlevel+1,t3]; 80565010 + end end; % of unmarking forward parameters. 80566000 + tx:=(t:=nametab3[curlevel,index].info)+paramtab[t]; 80636100 + for i:=t+1 step 1 until tx do % mark forward parameters 80636200 + nametab1[curlevel+1,paramtab[i].paramname].[46:1] := 1; 80636210 + tx:=curfunc; curfunc:=if fun then index else -1; 80645000 + for i:=0 step 1 until maxnames do % leave forward parameters 80647000 + if nametab1[curlevel,i]>0 then nametab1[curlevel,i]:=0; 80648000 + curlevel:=curlevel-1; curfunc:=tx; 80649000 + for i:=lastrec step 1 until toprec-1 do % clear record decs 80693000 +$# patch 505 for pascal.xvi.o contains 9 cards. check for hash table full +$: when ther are "maxnames" identifiers at one level, the "nametab*" rows +$: become full and this used to put the compiler into an infinite loop, +$: either in "newname" or "searchtab". this patch inserts test for wrap around +$: leading back to the hashed starting point, for which it gives syntax error +$: 40, too many identifiers declared. +$: nils a otte, university of natal, durban. aug - nov 1977. +define hash(hash1) = entier((hash1) mod maxnames) #; 20202000 +begin alpha tname; integer wraparound; 20209000 + wraparound:=thisindex:=hash(curname1); 20210000 + if thisindex=wraparound then tname:=0; % table is full 20216100 + alpha tname; integer wraparound; 20237100 + wraparound:=thisindex:=hash(name1); 20238000 + if thisindex=wraparound then % table at this level is full 20244100 + begin error(40); name1:=tname; name2:=nametab2[tab,thisindex]20244200 + end; 20244300 +$# patch 506 for pascal.xvi.o contains 2 cards. reserved word ending at cc 80 +$: if a reserved word ended at card column 79 or 80 and if the "boldface" for +$: reserved words option is set (*$r+ *), an invalid index occurred in the +$: scanner "insymbol". the problem is cured by correctly computing the starting +$: and ending point of the reserved words. +$: nils a otte, university of natal, durban. aug - nov 1977. + begin t1 := cardlength-charcnt-curlength-1; 30178000 + for curlength+real(charcnt=0); 30181000 +$# patch 507 for pascal.xvi.o contains 5 cards. "variable", "simplevariable" +$: in procedure "variable", "simplevariable" is set true if a subscript is +$: simple, resulting in algol code being written prematurely during recursive +$: calls on procedure "expression", which in some cases lead to algol syntax +$: errors. since writing the algol code is dependant on "exprlevel" being zero, +$: this patch bumps its value prior to analysing the subscript, and sets +$: "simplevariable" false afterwards. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + exprlevel := exprlevel+1; % do not "writeexpr" yet 40120900 + exprlevel := exprlevel-1; 40121100 + simplevariable := false; % recursion on "variable" 40121200 + exprlevel := exprlevel+1; 60063900 + exprlevel := exprlevel-1; 60065100 +$# patch 509 for pascal.xvi.o contains 1 card. "concat" a function of any type +$: the intrinsic function "concat" could only be assigned to a variable declared +$: "real" to avoid type conflict syntax errors. this patch makes "concat" +$: typeless. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + curtype := 0; % alfatype or realtype 50050000 +$# patch 511 for pascal.xvi.o contains 7 cards. allow up-level addressing +$: to allow up-level identifier references. formerly, references to global +$: identifiers which were not in the outer block were flagged by syntax error +$: 5, up-level addressing not implemented due to hardware restriction. +$: although the restriction exists in extended algol, it is not true that the +$: restriction is due to hardware, for up-level addressing is allowed in +$: compatible algol with the caution that it is inefficient (the implementation +$: is similar to an array element reference). +$: this patch permits such gobal references, except +$: (1) that if the control variable of a for statement is not local or in the +$: outer block (ptr) a warning is issued (in the form of a syntax error, +$: but the error count is not incremented), and +$: (2) the restriction is still applied to function names. the message for +$: syntax error is amended accordingly. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + if errnum<0 then errnum:=abs(errnum) else 20180900 +$ %if thislevel>1 and thislevel1 nd thislevel!curlevel then error5; 50244000 +$ %if thislevel.1 and thislevel!curlevel then error5; 50306000 + if thislevel!curlevel-1 or thisindex!curfunc then error(5); 60091000 + if thislevel>1 and thislevel0 do 60025000 + begin numpointers := numpointers-1; 60026000 + if numsyms+4 } maxsyms then writeexpr; 60027000 + replace pointer(symtab[numsyms+1]) by 60028000 + "00-1)div00 1022,00 t mod00 1022]"; 60029000 + numsyms := numsyms+4; 60030000 + end; % of while 60031000 + writeexpr; gen( ",", 1,7 ); 60032000 + end writesexpr; 60033000 + 60034000 + %error(95); % structured assignement not implemented. 60063000 + gen("assign(",7,1); writesexpr; 60064000 + expression; writesexpr; 60065000 + genint(typetab1[lefttype].size); gen(")",1,7); 60066000 + if typetab1[lefttype].size!typetab1[curtype].size 60067000 + then error(95); 60068000 + end; 60087000 + checktypes( lefttype, curtype ); 60088000 + (" 95 size of structures in assignment are not the same."), 91102000 +$# patch 513 for pascal.xvi.o contains 16 cards. fix pointers via pointers +$: to correct the code generated for chained references through the heap, +$: ie for pointers to pointers. the offset for components within records +$: was incorrectly being added to the record in the leftmost reference, ie the +$: innermost, instead of at the expected level. +$: for example, the following two references would both be translated to +$: the same algol code equivalent to heap[heap[id+ipart+icomp]]; +$: id@.part@.comp, id@.part.comp@, +$: when the first should have been: heap[heap[id+ipart]+icomp]. +$: in addition, this patch improves the compilers code for generating the +$: "mem" array subscript. +$: nils a otte, university of natal, durban. 1977-11-14 +$: + if numsyms+6 { maxsyms then 40175000 + numsyms := numsyms+2; 40180400 + if numpointers > 0 % pointer via pointer 40180500 + then begin replace pointer(symtab[numsyms+1]) by 40180600 + "00-1)div00 1022,00 t mod00 1022]"; 40180700 + numsyms := numsyms+4; 40180800 + end 40180900 + else numpointers := 1; 40181000 + % inbracket := false; 40191100 + begin numpointers := numpointers-1; 40193000 + if numsyms+4 { maxsyms 40194000 + then begin replace pointer(symtab[numsyms+1]) by 40194100 + "00-1)div00 1022,00 t mod00 1022]"; 40194200 + numsyms := numsyms+4; 40194308 + end 40194400 + else error(63); % expression is too long for symtab[*] 40195000 +$# patch 514 for pascal.xvi.o contains 2 cards. process time function for run +$: patch to change the name of the function on the b5700 version which supplies +$: the process time used by the pascal program on the current run from "elapsed" +$: which means platform time, to "cputime" which is the widely accepted term +$: for this quantity. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + newname("7cputim","e",0); nametab3[0,thisindex]:=t3; 20390000 + if curname1="7cputim" and curname2="e" then % "cputime" 40452000 +$# patch 516 for pascal.xvi.o contains 2 cards. correct "no listing" error +$: this patch corrects an error whereby if listing was turned off +$: and page throw was invoked, a heading was printed regardless. +$: david a cooper, heriot-watt university.....june, 1978 +$: + if cx="l" then if c=1 then 30264000 + if listoption then heading else 30264500 +$# patch 517 for pascal.xvi.o contains 2 cards. +$: this patch corrects an error that caused a file declaration +$: to have its name string split over two lines in the generated xalgol. +$: also changes symtab from type real to type alpha. +$: david a cooper, heriot-watt university.....june, 1978 +$: +alpha array symtab[0:maxsyms]; % used by "expression". 10144000 + if algolcnt lss 14 then writealgol; 80103000 +$# patch 518 for pascal.xvi.o. contains 224 cards. +$: this patch changes the way that multi-dimension arrays +$: representing records are declared. previosly they wre declared +$: the wrong way round for xalgol. this patch sorts the dimensions +$: into ascending order form left to right and generates appropriate +$: defines and code for handling the arrays. +$: stuart anderson, computer science, heriot-watt university, june.....1978. +$: + define 10156200 + permsub = 0 #, maxtotalsubscrs = 100#, 10156300 + arrnam = 1 #; 10156400 + array arrsubpermtab[0:1,0:maxtotalsubscrs]; 10156500 + integer passpermtab, maxpermtab, rememberposn; 10156600 +$ 40080000 + boolean simplevariable,insidebrackets,insideparens; 40080100 +$ 40105000 + if insideparens and typetab1[curtype].struct > 0 and 40105100 + typetab1[curtype].form < files then 40105200 + putid("h",1000|thislevel+thisindex,5) 40105300 + else 40105400 + putid("v",1000|thislevel+thisindex,5); 40105500 + insideparens := true; 40258100 + insideparens := false; 40259100 +$ 50243000 + genid("h",1000|thislevel+thisindex,5); 50243100 +$ 50307000 + genid("h",1000|thislevel+thisindex,5); 50307100 +$set voidt 80052000 +$pop voidt 80064000 + define 80064005 + lowsubs = 0 #, 80064010 + hisubs = 1 #, 80064015 + nextsubs= 2 #, 80064020 + maxnoofsubscripts = 20 #, 80064025 + stoppersubtab = 21 #; 80064030 + array arrsubscriptrange[0:2,0:maxnoofsubscripts]; 80064035 + integer firstrange, nextfreeentry, passsubrange, prevpass, 80064040 + mp, posno, subdiff; 80064045 + if arrayvar then gen(";",1,7) else arrayvar := true; 80064050 + if not param then 80064055 + begin 80064060 + gen("define",7,2); 80064065 + genid("v",level1000+nam,5); 80064070 + gen("[",1,7); 80064075 + end; 80064080 + firstrange := stoppersubtab; nextfreeentry := 0; 80064085 + posno := 1; 80064090 + mp := 10; firstdim := true; 80064095 + do 80064100 + begin 80064105 + if firstdim then firstdim := false else 80064110 + begin 80064111 + if not param then gen(",",1,7); 80064112 + end; 80064113 + if not param then genid("v",(level1000+nam)|mp+posno,if mp=10 80064115 + then 6 else 7); posno := posno + 1; 80064120 + if posno = mp then mp := mp|10; 80064125 + if nextfreeentry = stoppersubtab then 80064130 + begin 80064135 + error(0); 80064140 + end 80064145 + else 80064150 + begin 80064155 + arrsubscriptrange[lowsubs,nextfreeentry]:=typetab2[typ]; 80064160 + arrsubscriptrange[hisubs,nextfreeentry] := typetab3[typ]; 80064165 + end; 80064170 + subdiff := typetab3[typ] - typetab2[typ]; 80064175 + if firstrange = stoppersubtab then 80064180 + begin 80064185 + firstrange := nextfreeentry; 80064190 + nextfreeentry := nextfreeentry + 1; 80064195 + arrsubscriptrange[nextsubs,firstrange] := stoppersubtab; 80064200 + end 80064205 + else 80064210 + begin 80064215 + passsubrange := firstrange; 80064220 + prevpass := stoppersubtab; nextfreeentry:=nextfreeentry+1;80064225 + while(subdiff } arrsubscriptrange[hisubs,passsubrange] 80064230 + -arrsubscriptrange[lowsubs,passsubrange]) and 80064235 + (arrsubscriptrange[nextsubs,passsubrange] ! 80064240 + stoppersubtab) do 80064245 + begin 80064250 + prevpass := passsubrange; 80064255 + passsubrange := arrsubscriptrange[nextsubs, 8006426 + passsubrange]; 80064265 + end; 80064270 + if prevpass = stoppersubtab then 80064275 + begin 80064280 + if subdiff } arrsubscriptrange[hisubs, 80064285 + passsubrange] - 80064290 + arrsubscriptrange[lowsubs, 80064295 + passsubrange] then 80064300 + begin 80064305 + arrsubscriptrange[nextsubs,passsubrange] := 80064310 + nextfreeentry - 1; 80064315 + arrsubscriptrange[nextsubs,nextfreeentry-1] := 80064320 + stoppersubtab; 80064325 + end 80064330 + else 80064335 + begin 80064340 + arrsubscriptrange[nextsubs,nextfreeentry-1] := 80064345 + firstrange; 80064350 + firstrange := nextfreeentry-1; 80064355 + end 80064360 + end 80064365 + else 80064370 + begin 80064375 + if subdiff } arrsubscriptrange[hisubs,passsubrange] -80064380 + arrsubscriptrange[lowsubs,passsubrange] 80064385 + then 80064390 + begin 80064395 + arrsubscriptrange[nextsubs,passsubrange] := 80064400 + nextfreeentry - 1; 80064405 + arrsubscriptrange[nextsubs,nextfreeentry-1] := 80064410 + stoppersubtab; 80064415 + end 80064420 + else 80064425 + begin 80064430 + arrsubscriptrange[nextsubs,prevpass] := 80064435 + nextfreeentry -1; 80064440 + arrsubscriptrange[nextsubs,nextfreeentry-1] := 80064445 + passsubrange; 80064450 + end 80064455 + end 80064460 + end;typ:=if t1.form = arrays then t1.arrtype else realtype; 80064465 + t1 := typetab1[typ]; 80064470 + end until t1.struct = 0 ; 80064475 + if not param then 80064480 + begin 80064485 + gen("]=",2,6); 80064490 + genid("h",level1000+nam,5); 80064495 + gen("[",1,7); 80064500 + passsubrange:= firstrange; firstdim := true; 80064505 + while passsubrange ! stoppersubtab do 80064510 + begin 80064515 + if firstdim then firstdim := false else gen(",",1,7); 80064520 + genid("v",(level1000+nam)|(if passsubrange>9 then 100 else 8006453 + 10)+passsubrange+1,if passsubrange>9 then 7 else 6); 80064535 + passsubrange := arrsubscriptrange[nextsubs,passsubrange]; 80064540 + end; 80064545 + gen("]#;",3,5); 80064550 + end; 80064555 + passsubrange := firstrange; 80064560 + firstdim := true; gen("array",6,3); genid("h",level1000+nam,5); 80064565 + gen("[",1,7); 80064570 + while passsubrange ! stoppersubtab do 80064575 + begin 80064580 + if maxpermtab leq maxtotalsubscrs and param then 80064585 + begin 80064590 + arrsubpermtab[arrnam,maxpermtab] := 80064595 + if firstdim then nam else -1; 80064600 + arrsubpermtab[permsub,maxpermtab] := passsubrange; 80064605 + maxpermtab := maxpermtab + 1; 80064610 + end 80064615 + else 80064620 + begin 80064625 + if maxpermtab > maxtotalsubscrs then error(0); 80064630 + end; 80064640 + if firstdim then firstdim := false else gen(",",1,7); 80064645 + genint(arrsubscriptrange[lowsubs,passsubrange]); 80064650 + if not param then 80064655 + begin 80064660 + gen(":",1,7); 80064665 + genint(arrsubscriptrange[hisubs,passsubrange]); 80064670 + end; 80064675 + passsubrange := arrsubscriptrange[nextsubs,passsubrange]; 80064680 + end; 80064685 + gen("]",1,7); 80064950 +$ 80421000 + if curlevel > 1 then 80421010 + begin 80421020 + integer namofthing,diff; 80421030 + boolean firsttime; 80421040 + gen("begin",6,3); 80421050 + if maxpermtab > 0 then 80421060 + begin 80421070 + passpermtab := 0; 80421080 + do 80421090 + begin 80421100 + rememberposn := passpermtab; 80421110 + gen("define",7,2); 80421120 + namofthing := arrsubpermtab[arrnam,passpermtab]; 80421130 + genid("v",1000|curlevel+namofthing,5); 80421140 + gen("[",1,7); 80421150 + firsttime := true; 80421160 + do 80421170 + begin 80421180 + if firsttime then firsttime := false else gen(",",180421190 + ,7);80421200 + diff := passpermtab-rememberposn+1; 80421210 + genid("v",(1000+curlevel+namofthing)|(if diff>9 then 100 else 80421220 + 10)+diff,(if diff > 9 then 7 else 6)); 80421230 + passpermtab := passpermtab + 1; end 80421270 + until passpermtab = maxpermtab or 80421280 + arrsubpermtab[arrnam,passpermtab] ! -1; 80421290 + gen("]",1,7); 80421300 + gen("=",1,7); 80421310 + genid("h",1000|curlevel+namofthing,5); 80421320 + gen("[",1,7); 80421340 + passpermtab := rememberposn; firsttime := true; 80421350 + do 80421360 + begin 80421370 + if firsttime then firsttime := false else gen(",", 80421380 + 1,7);80421390 + diff := arrsubpermtab[permsub,passpermtab]+1; 80421400 + genid("v",(1000|curlevel+namofthing)|(if diff>9 then80421410 + 100 else 10)+diff,(if diff>9 then 7 else 6)); 80421420 + passpermtab := passpermtab +1; 80421430 + end 80421440 + until passpermtab = maxpermtab or 80421450 + arrsubpermtab[arrnam,passpermtab] ! -1; 80421460 + gen("]#;",3,5); 80421470 + end 80421480 + until passpermtab = maxpermtab; 80421490 + maxpermtab := 0; 80421500 + end 80421510 + end; 80421520 +$ 80608000 + begin 80608010 + begin 80608020 + integer nam,t1,scratch; 80608030 + nam := paramtab[i].[9:10]; 80608040 + scratch := nametab3[curlevel+1,nam]; 80608050 + scratch := scratch.type; 80608060 + t1 := typetab1[scratch]; 80608070 + if t1.struct ! 0 and t1.form < files then 80608080 + genid("h",1000|(curlevel+1)+nam,5) 80608090 + else 80608100 + genid("v",1000|(curlevel+1)+nam,5); 80608110 + end; 80608120 + maxpermtab := 0; 90070100 + insideparens := false; 90070200 +$# patch 519 for pascal.xvi.o. contains 1 cards. increase runtime stack. +$: + " xalgol stack = 2048; stack = 1024; end."; % 90120500 +$# patch 600 for pascal.xvi.o. contains 22 cards. dags dec77 patches. +$: patches received from d.langmyhr and transposed from cosy format by +$: david a cooper. february 1978. +$: + if(f1 neq set or rt neq emptyset) % 20813000 + and % 20813050 + (f2 neq set or lt neq emptyset) then % 20813100 + if(f1 neq pointers or rt neq niltype) % 20814000 + and % 20814050 + (f2 neq pointers or lt neq niltype) then % 20814100 + begin error(63); % 40023000 +$ 50059000 + gen("pread(",6,2); writeexpr; gen(",",1,7); % 50079000 +$ 50080000 +$ 50081000 + genid("f",fileid,5); gen(",",1,7); % 50082000 + if f=numeric then % 50086010 + begin % 50086050 + gen(",",1,7); genint(typetab2[curtype]); % 50086100 + gen(",",1,7); genint(typetab3[curtype]); % 50086150 + end else gen(",0,0,",4,4); % 50086200 +$ set voidt 50088000 +$ pop voidt 50093000 + if namtab.idclass=func then gen("functn",7,2) % 80037000 + else gen("procedu",8,1); % 80038000 + if found and (thisid.idclass=proc or thisid.idclass=func) then 80548000 +$#patch 601 for pascal.xvi.o.contains 147 cards. extende set mods. +$: patches received from d.langmyhr and transposed from cosy format by +$: david a cooper. february 1978. +$: this patch modifies the set handling routines to allow sets of 0..93 +$: elements +$: nb. the run time system must be changed accordingly..... +$: --- --- ---- ------ ---- -- ------- ---------------- +% 40052050 +% 40052055 +procedure split(splitinx,width); % 40052100 +value splitinx, width; % 40052150 +integer splitinx, width; % 40052200 +begin % 40052250 + integer i; % 40052300 +% 40052350 + if numsyms+width leq maxsyms then % 40052400 + begin % 40052450 + for i:=numsyms step -1 until splitinx do % 40052500 + symtab[i+width] := symtab[i]; % 40052550 + for i:=1 step 1 until width do % 40052600 + symtab[splitinx+i-1] := "3000000"; % 40052650 + numsyms := numsyms + width; % 40052700 + end % 40052750 + else 40052800 + begin % 40052830 + error(63); % 40052860 + numsyms := 1; % 40052890 + end; % 40052900 +end of split; % 40052950 +% 40052960 +% 40052965 + end; % 40188005 +if typetab1[curtype].form=set then % *** set variables 40188010 +begin % --- --- --------- 40188025 + integer thissyml, i; % 40188050 +% 40188075 + split(startsym,1); symtab[startsym] := "sload("; % 40188100 + if simplevar then % 40188125 + begin % 40188150 + putsym(","); % 40188175 + putid("w",1000|thislevel+thisindex,5); % 40188200 + end % 40188225 + else % 40188250 + if inbracket and not inrecord then % 40188275 + begin % 40188300 + putsym(","); thissyml := numsyms; % 40188325 + putconst(0); putsym(" "); putsym(","); % 40188350 + for I:=startsym+1 step 1 until thissyml do % 40188375 + puttext(symtab[i]); 40188400 + puttext(" 1] "); % 40188425 + end % 40188450 + else % 40188475 + begin % 40188500 + thissyml := numsyms; % 40188525 + if inbracket then putsym("]"); % 40188550 + for i:=1 step 1 until numpointers do % 40188575 + begin % 40188600 + puttext("-1)div"); puttext(" 1022,"); % 40188625 + puttext(" t mod"); puttext(" 1022]"); % 40188650 + end; % 40188675 + putsym(","); % 40188700 + for i:=startsym+1 step 1 until thissyml do % 40188725 + puttext(symtab[i]); % 40188775 + puttext(" +1 "); % 40188800 + if inbracket then putsym("]"); % 40188825 + for i:=1 step 1 until numpointers do % 40188850 + begin % 40188875 + puttext("-1)div"); puttext(" 1022,"); % 40188900 + puttext(" t mod"); puttext(" 1022]"); % 40188915 + end; % 40188930 + numpointers := 0; % 40188945 + end; 40188960 + putsym(","); putconst(cardcnt); putsym(")"); % 40188975 +end of set variables; % 40188990 +$ 40198000 + if typetab1[thisid.type].form=set then 40274200 + begin % 40274220 + gen(",",1,7); % 40274240 + genid("w",1000|thislevel+thisindex,5); % 40274260 + end; % 40274280 + boolean first, splitted; % 40296000 + puttext("setbs("); puttext(" 3,2,"); putconst(cardcnt); % 40529000 + putsym(")"); % 40529300 + curtype := emptyset; curmode := number; % 40529600 + startsym := numsyms + 1; % 40533500 + puttext(" setb("); % 40536000 + putsym(","); symtab[startsym] := "setbs("; % 40544000 + if splitted then putsym(")"); % 40551500 + if cursy=comma then % 40552000 + begin % 40552200 + split(startsym,1); symtab[startsym] := "sunio("; % 40552400 + putsym(","); % 40552600 + splitted := true; % 40552800 + end; % 40552850 + newtype; t1 := set; t1.size := 2; t1.struct := 0; % 40558000 + curmode := number; % 40561000 + if curtype=booltype then % 40587000 + if cursy neq andsy then error(64); 40593000 + end else % 40593100 + if f=set then % 40593200 + begin % 40593300 + if cursy=asterisk then % 40593400 + begin % 40593500 + split(startsym,1); symtab[startsym] := "sints("; % 40593600 + putsym(","); % 40593700 + end else error(64); % 40593800 + mode := number; % 40593900 + if f=set then putsym(")"); % 40608500 + split(startsym,1); % 40650000 + if cursy=plus then symtab[startsym] := "sunio(" else % 40651000 + if cursy=minus then symtab[startsym] := "sdiff(" else % 40652000 + error(64); % 40653000 + putsym(","); mode := number; % 40654000 +$ 40655000 + if f=set then putsym(")"); % 40668500 +$ 40688000 + if cursy=eqlsy then symtab[startsym] := "sequa(" % 40713000 + else 40713150 + if cursy=neqsy then % 40713300 + begin % 40714000 + split(startsym,1); symtab[startsym]:= " not "; % 40714150 + symtab[startsym+1] := "sequa("; % 40714300 + if typetab1[lefttype].form=set then % 60080100 + begin % 60080200 + symtab[1] := "sstor("; numsyms := numsyms - 3; % 60080300 + expression; % 60080400 + putsym(")"); checktypes(lefttype,curtype); % 60080500 + writeexpr; % 60080600 + end else % 60080700 + if typetab2[tx] lss 0 or typetab3[tx] gtr 93 then error(51); 70210000 + t1.size := tsize := 2; typetab1[typeindex] := t1; % 70214000 + if t1.form=set then % 80046200 + begin % 80046400 + gen(",",1,7); genid("w",level1000+nam,5); % 80046600 + end; % 80046800 + if t1.form=set then % 80064700 + begin % 80064750 + gen(",0",2,6); % 80064800 + if not param then gen(":1",2,6); % 80064850 + end; % 80064900 + begin % 80608105 + if t1.form=set then % 80608111 + begin % 80608113 + gen(",",1,7); % 80608115 + genid("w",1000|(curlevel+1)+nam,5); % 80608117 + end; 80608118 + end; % 80608119 + if typetab1[nametab3[curlevel+1,paramtab[i].paramname].type80627200 + ].form=set 80627205 + then begin % 80627400 + gen(",",1,7); % 80627600 + genid("w",1000|(curlevel+1)+paramtab[i].paramname 80627800 + ,5); % 80627801 + end; 80627850 +$#patch 602 for pascal.xvi./ contains 5 cards. correct representation of "nil". +$: received from dag langhymr on 6/07/78. +$: david a cooper , heriot-watt university... july 1978. +niltype := 6; %*** type of "nil" *** 20363000 +t1.form := pointers; typetab1[6] := t1; 20364000 +emptyset := 7; % 20364500 +t1.form := set; typetab1[7] := t1; 20365000 +numtypes := 7; % 20365500 +$# patch 603 for pascal xvi.o contains 6 cards. correct to patch 601 +$: david a cooper & s o anderson, heriot-watt university. ust august 1978 +$: + integer startsym,firstsym,mode,type1,f; 40618000 + putdummy; startsym := firstsym := numsyms; 40621000 + split(firstsym,1); 40650000 + if cursy = plus then symtab[firstsym] := "sunio(" else 40651000 + if cursy = minus then symtab[firstsym] := "sdiff(" else 40652000 + error(64); 40653000 +$# patch 614 for pascal.xvi.o. contains 7 cards. +$ 40105100 +$ 40105200 +$ 40105300 +$ 40105400 + if insideparens and simplevar and typetab1[curtype].struct > 0 and 40198500 + typetab1[curtype].form < files then symtab[startsym].[35:6] := 40198600 + "h"; 40198700 +$# patch 700 for pascal.xvi.o has 179 cards. reduce thrashing by code change +$: to improve run time efficiency by reaarranging the the compilers code. +$: the compiler had a high overlay i/o time and high elapsed time in relation +$: to the process time, and observation of the b5700 confirmed that it was +$: thrashing in 32k. this patch attempts to reduce the core requirements by +$: rearranging the segmentation of the code. large segments are eliminated +$: so as to avoid pulling code that will not be executed into core and to +$: release code segments as so as execution has passed. for example, the +$: cross reference routines were all contained in the large outer block code +$: segment which included various utility routines. +$: a feature which contributed significantly to large segments was the high +$: number of "defines" which resulted in sizeable sections of code being +$: generated in-line, sometimes many times in one segment. these "defines" +$: were readily changed into procedures. (a side effect of virtually eliminating +$: defines for code is that the "bend" option no longer results in numerous +$: blank lines repeating the same sequence number for every "end" in the nested +$: defines.) +$: nils a otte, university of natal, durban aug - nov 1977. +$: +$ 10167000 +$ 10168000 +$ 10169000 + value name1,name2,table,decl; 20016000 + real name1,name2; 20017000 + integer table; boolean decl; 20018000 + forward; 20019000 +procedure printerrors; forward; 20020000 +procedure heading; %*** prints a heading at start of new page.20026000 +begin define newsegment = here #; 20027000 +end of heading; 20033000 +procedure printline; %*** prints a pascal source code line 20036000 +begin define newsegment = here #; 20037000 +end of printline; 20047000 +procedure newcard; %*** reads a new pascsal source code card 20050000 +begin define result = icard[*], etc #; 20051000 + replace xlinepnt by " " for 16 words; 20056000 + replace linepnt by cardpnt for 10 words, xlinepnt for 6 words; 20057000 +end of newcard; 20061000 +define gen(gen1,gen2,gen3) = geni(true,gen1,gen3,gen2) #, 20063100 +genid(genid1,genid2,genid3)= geni(false,genid1,genid2,genid3) #; 20063200 + 20063300 +procedure geni(gent, txt, num, n); 20063400 +value gent, txt, num, n; 20063500 +boolean gent; alpha txt; integer num, n; 20063600 +begin define start = num #, ndig = n #; 20063700 + 20063800 + if gent then %*** generate a text "txt", consisting of 20064000 + text[0] := txt; 20067000 +end 20070000 +else %*** generate an algol identifier. 20073000 + ch[0] := txt; 20076000 +end end geni; 20079000 +procedure genint( n ); 20082000 +value n; integer n; 20083000 +begin define result = algol code #; 20084000 + integer nabs, nsize; 20085000 +end of genint; 20097000 +procedure writealgol; %*** writes a completed algol card to 20145000 + define newsegment = here #; 20146100 + define newsegment = here #; 20168100 + define newsegment = here #; 20180100 + define newsegment = here #; 20193100 +alpha thisid, curname1, curname2, tname; % used in scanner 20205000 +procedure searchtab( tab ); %*** search name table "tab" for the 20208000 +value tab; integer tab; %*** identifier just read. 20208100 +end of searchtab; 20221000 +procedure search; %*** search all tables currently in use. 20223000 +begin define result = thisid #; 20224000 +end of search; 20233000 +procedure newname( name1, name2, tab ); 20236000 +value name1, name2, tab; 20236100 +alpha name1, name2; integer tab; 20236200 +end of newname; 20250000 + define newsegment = here #; 20515100 + define newsegment = here #; 20533100 + define newsegment = here #; 20546100 +procedure checktypes(lefttype, righttype ); 20802000 +value lefttype, righttype; integer lefttype, righttype; 20803000 +begin 20804000 + real tt1, tt2; integer f1, f2, lt, rt; 20805000 +end of checktypes; 20838000 +procedure fileparam( defaultfile ); %*** checks the first parameter 20844000 +value defaultfile; integer defaultfile;%*** to see if it is a file. 20844100 +begin define results = filename & lparfound #; 20845000 +end of fileparam; 20869000 +real curval; integer curlength; 20872000 + 20873000 +procedure constant( cval, ctype ); 20874000 +real cval; integer ctype; 20875000 +begin 20876000 + integer tform; boolean signed, negative; 20876100 +end of constant; 20921000 +$ 30082000 +alpha c, cx; %( curname1 & curname2 moved to 20205000 ) 30083000 +integer lastcharpos; %( curval, curlength moved to 20872000 ) 30084000 +procedure insymbol; %*** identifies the next symbol ****** 30087000 +begin 30087100 + 30087200 + procedure nextchar; %*** gets the next character. 30088000 + end of nextchar; 30093000 +$ set voidt 30095000 +$ pop voidt 30098000 + define t1 = exp #; % used at 30178000 30099100 + begin define newsegment = here #; 30261100 + end newsegement; 30282200 +$ 40016000 +$ 40017000 +integer exprlevel; 40018000 +define putsym(s) = puttext( (s)&1[41:5:6] ) #; 40029000 +$ set voidt 40029900 +$ pop voidt 40033000 +define putdummy = puttext("3000000") #; 40041000 +$ set voidt 40042000 +$ pop voidt 40044000 +procedure writeexpr; %*** write generated algol expression 40053000 + real sx; integer t1, tx; 40054100 +end of writeexpr; 40066000 +procedure checkexpr( llim, ulim ); %*** write code to check value 40069000 + value llim, ulim; integer llim, ulim; 40069100 +begin define check = value #; 40070000 +end of checkexpr; 40077000 + integer t1, t5; % used once each 40086100 + t1:=t.firstwithsym; t5:=t.lastwithsym; 40094000 + for t1:=t1 step 1 until t5 do puttext(withtab[t1]); 40095000 + define t1 = t #; % used at 405558000 40298000 +$ set voidt 40299000 +$ pop voidt 40309000 + 40331000 + procedure parameter; %*** check that the function has 1 param.40332000 + begin 40333000 + insymbol; 40334000 + if cursy=lpar 40335000 + then begin 40336000 + putsym("("); insymbol; expression; 40337000 + if typetab1[curtype].form=numeric then curtype:=inttype; 40338000 + if cursy!rpar then begin error(3); skip(rpar) end; 40339000 + putsym(")"); if cursy=rpar then insymbol; 40340000 + end else error(3); % or error(58) 40341000 + end of parameter; 40342000 + 40350000 +$ 60396000 + begin label labfound; 60399000 + thisid.idclass=const and boolean(thisid.formal) or 60423000 + thisid.idclass=func 60423200 + then assignment else 60424000 +$ set voidt 70013000 +$ pop voidt 70016000 + value rectab,firstaddr; 70018000 + integer rectab,firstaddr,lastaddr; 70019000 +$ set voidt 70022000 +$ pop voidt 70034000 + 70035000 +procedure typedecl( ttype, tsize ); %***** type declaration ***** 70036000 + integer ttype, tsize; %**************************** 70037000 +begin 70038000 + integer recinx, arrstruct, tx, sx, t, n; real t1, t2, t3; 70039000 + boolean first, packed; 70040000 + 70041000 +$ 70042000 + end typerr; 70048000 + procedure subrange; %*** subrange declaration *** 70050000 + begin %**************************** 70051000 + real valx1, valx2, t1; 70052000 + integer typex1, typex2; 70053000 + 70054000 + constant(valx1,typex1); 70055000 + if typetab1[typex1].form>char then error(11); 70056000 + if cursy!doubledot then error(53); 70057000 + insymbol; 70058000 + constant(valx2,typex2); 70059000 + if typex1>0 and typex2>0 then 70060000 + if typex1!typex2 then error(11) else 70061000 + if valx1>valx2 then error(54); 70062000 + if (t1:=typetab1[typex1].form) = symbolic then t1:=subtype; 70063000 + newtype; ttype:=typeindex; 70064000 + t1.size:=tsize:=1; t1.struct:=0; t1.maintype:=typex1; 70065000 + typetab1[typeindex]:=t1; 70066000 + typetab2[typeindex]:=valx1; typetab3[typeindex]:=valx2; 70067000 + end of subrange; 70068000 + 70069000 + define dec = pointer #; 70117100 + define dec = array #; 70143100 + define dec = file #; 70180100 + define dec = set #; 70200100 + define dec = record #; 70220100 + label casepart, exit; 70247000 + begin define dec = variant #; 70285100 + label casetypeid; 70285200 + end; 70349100 + define dec = file #; 80066100 + gen(""/",2,6); 80107000 + define dec = label #; 80424100 + define dec = const #; 80447100 + define dec = type #; 80475100 + define dec = var #; 80496100 + if cursy=funcsy or cursy=procsy % 80540900 + then begin define dec = code #; 80540910 + end of segment for procedure declarations; 80648100 +$# patch 701 for pascal.xvi.o contains 14 cards. reduce thrashing by array cuts +$: to improve run time efficiency by reducing array sizes. the most significant +$: contribution to the compilers thrashing behaviour was the excessively large +$: data arrays. this patch succeeds in drastically reducing the core requirement +$: of the compiler by making most of the large arrays much smaller without +$: imposing unreasonable restrictions. in particular, the three arrays, +$: nametab1, nametab2, nametab3 wre ehach [0:50, 0:1022], and have been reduced +$: to [0:30, 0:307]. these reductions have not prevented the compilation of +$: a large pascal program of about 4000 lines, namely the p4 pascal compiler +$: from zurich. in fact, priot to the changes introduced by patches 700 & 701, +$: the p4 pascal compiler took 60 minutes elapsed time to compile, which was +$: reduced to 9 minutes by these patches, while the process time has remained +$: constant at 9 minutes. +$:**** note that if "maxnames" is changed then there are 7 defines in the file +$: pascal/prelude that must also be changed. +$: "maxnames" was chosen as a prime number as it is used as a modulus for a hash +$: function. the pascal identifiers are translated to algol names using level +$: and hash index. hence changing "maxnames" changes the algol names for +$: "input", "output", & "prt25". +$: nils a otte, university of natal, durban aug - nov 1977. +$: +define maxtables = 30 #, %max number of levels in identifier table.10042000 + maxnames =307 #, %max names in each roe of identifier table.10043000 + % only used in with statement to test 10044001 + maxcases =64 #, %max labels in a case-statement. 10045000 + maxlabs =50 #, %max number of labels. 10046000 + maxparams =200 #, %max number of parameters in whole program.10047000 + maxtypes =250 #, %max number of different types. 10048000 + maxconsts =100 #, %size of constant table. 10049000 + maxwithsyms= 70 #, %max number of symbols used by with-statms.10051000 + maxsyms =200 #, %max number of symbols in one expression. 10052000 + listlength =100 #, %max length of var and param lists. 10053000 + maxextfiles=10 #, %max number of external files. 10054000 + maxfiles =10 #, %max number of files declared at one time. 10055000 + maxpntrs =10 #; %max number of undeclared pointers. 10056000 +$# patch 702 for pascal.xvi.o contains 4 cards. boolean array "err" 120 to 4 +$: to extend the reductions of patch 701 to the boolean array "err" for noting +$: the syntax errors that have occurred. this patch compresses the array from +$: 120 words to 4 words by using 32 bits in each word. +$: in addition, this patch inserts the error count on the left of the line +$: which reports the syntax errors. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: +array errp[0:3]; % holds 128 bits % records error messages used. 10156000 +define err[err1] = boolean(0&errp[err1.[6:2]][0:err1.[4:5]:1]) #; 10156108 + errp[errnum.[6:2]]:=errp[errnum.[6:2]] & 1[errnum.[4:5]:0:1]; 20182000 + replace pointer(errline[0])+4 by numerrs for 4 digits; 20194900 +$# patch 703 for pascal.xvi.o contains 6 cards. reduce thrashing by save core +$: to improve run-time efficiency by reducing non-overlayable areas. +$: this patch reduces the save core requirements by decreasing the file block +$: sizes and also the number of buffers without unduly retarding the compilation +$: speed. the size of the disk areas is kept a multiple of the original block +$: size where relevant to avoid incompatibility problemes. comparable reductions +$: in block sizes of the object program are also made. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: +file card "source" (1,10,38); % pascal source code input file 10035000 +file pascalgol disk serial [20:300] (1,10,30,save 0); % algol code file10037000 +file xreffile disk serial [20:3000] (1,3,30); % for cross reference 10137000 + if recsize=1 or recsize=10 then genint(30) 80119000 + gen(",save",6,3); 80122000 + gen("30);", 4,4); 80123000 +$# patch 704 for pascal.xvi.o has 8 cards. reduce overheads in copying file +$: to reduce the compiler-s overheads. firstly, the algol code file +$: pascrun/disk is renamed pascal/prelude. originally, the compiler copied +$: the pascal/prelude file into the generated code file before starting to +$: translate the pascal program. this patch saves the 3 seconds or so required +$: for this by setting the "tape" option for the algol compiler and label +$: equating the tape file to pascal/prelude. the overhead to the algol compiler +$: is negligible. the advantage is even greater if the program fails to +$: compile syntax free. the file pascal/prelude is no longer referenced +$: directly in the pascal compiler. +$: see patch 711. this needs patch 705. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + errors (i5," errors detected ",20("#") /), 10188000 + alist ("$ set list "), 10189000 + merge ("$ set tape reset $" / 10190100 + "$ reset tape", t73,"99000000" ), 10190200 + termmess ("**** compilation terminated."); 10192000 +write(pascalgol,merge); % algol must compile prelude first 90022000 +$ set voidt 90023000 +$ pop voidt 90032000 +$: "; algol file tape= pascal/prelude serial; algol file card=", 90119000 +$# patch 705 for pascal.xvi.o contains 21 cards. generate a better zip +$: this patch tidies up the code that generates the zip to pass control to the +$: compatable algol compiler. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: +$ 90013000 + progname := if curlength < 7 90042000 + then " "&curname1[41:6|curlength-1:6|curlength] 90042010 + else curname2.[5:6]&curname1[41:35:36]; 90042020 +$: array ziparray[0:16]; 90092000 + define pprogname = 13 #, palgolname = 14 #, 90095000 + plibrary = 15 #, puser = 16 #, 90096000 + p(p1) = pointer(ziparray[p1])+1 for 7 #; 90097000 +$ set voidt 90098000 +$ pop voidt 90104000 +$ 90109000 + ziparray[pprogname]:=progname; ziparray[palgolname]:=algolname; 90112000 + ziparray[plibrary]:= if savefactor>0 then "library" else 90113000 + if savefactor<0 then " syntax" else " & run "; 90114000 + ziparray[puser]:=user; 90115000 + replace pointer(ziparray[*]) by "cc compile ", 90116000 + p(pprogname), "/", p(puser), 90117000 + " xalgol ", p(plibrary), 90118000 + "; algol file tape= pascal/prelude serial; algol file card=", 90119000 + p(palgolname), "/", p(puser), " serial; end."; 90120000 +$ set voidt 90121000 +$ pop voidt 90128000 +$# patch 708 for pascal.xvi.o contains 25 cards. line print file may be disk +$: to enable the compiler-s print file to be label equated to disk as for other +$: b5700 compilers. in particular, this patch changes the name to line to be +$: consistent with all the system compilers. the ability to label equated file +$: "line" to disk is necessary if the compiler is to be used from a terminal. +$: note that a blocked file should not have variable length records if it is +$: to be label equated to a printer. if less than a the max number of words per +$: record is written, the balance of the record remains unchanged from what was +$: last in the file buffer, so that on being printed "garbage" appears at the +$: end of such lines. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: +save file out line disk serial [20:1200] (1,17,90,save 1); % print file 10036000 + % avoid blocking records of variable length 10036001 +array icard, algolcard[0:9], lines, xline[0:16]; 10130000 + % avoid blocking variable length records 10130001 +array headtext, errline[0:16]; 10133000 + write( line[no], 17,xline[*]); 20042000 + write( line[no], 17,errline[*]); 20043000 + write( line[no], 17,xline[*]); 20045000 + write( line[no], 17,errline[*]); 20195000 + linepnt :=pointer(lines[1]); 20315000 + replace linepnt-8 by " " for 17 words; 20317000 + replace xlinepnt-8 by linepnt-8 for 17 words; 20318000 + replace pointer(errline[*]) by "**** ", linepnt for 16 words; 20319000 + replace algolpnt by linepnt for 9 words; 20321000 + replace pointer(headtext[*]) by linepnt for 10 words, "page 1 ", 20326000 + linepnt for 6 words; 20326100 + write(line, 17,xrefline[*]); 20549000 + lock( line, * ); % & crunch 20550000 + write(line, 17,xrefline[*]); linecnt:=linecnt+1; 20560000 + write(line, 17,xrefline[*]); linecnt:=linecnt+1; 20571000 + write(line, termmess); 90084000 + write(line, noerrors); 90111000 + write(line, errors,numerrs); 91110000 + write(line, errormess1[i]); 91112000 + write(line, errormess2[i-60]); 91114000 +$# PATCH 709 for pascal.xvi.o contains 17 cards. no print if no list & no errors +$: to open the print file only if the list option is set or if syntax errors +$: are detected. if the first card in the pascal source resets the list option +$: (*$l- *) and no syntax errors are detected, then the print file will not be +$: created (even for the heading) as for other compilers. in particular, this +$: implementation does not require a test prior to printing each line to +$: determine whether a heading has been printed. it only does this test when +$: the list option is set after the first card or explicitly thereafter, or +$: in the "printerrors" routine. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + if pagecnt=1 then write(line[no],17,headtext[*]) else 20029000 + write( line[page]); 20030000 + write( line[dbl],17,headtext[*]); 20031000 + if not listoption then 20194000 + begin if pagecnt=0 then heading; printline end; 20194100 + replace pointer(headtext[*])+45 by textpnt+3 for 2,"/", 20329000 + textpnt+1 for 2, "/", textpnt+3 for 2; 20330000 + newcard; listoption:=checkoption:=true; % default 20402100 + insymbol; % analysing first card may change default list optn 20402200 + if listoption and pagecnt=0 then heading; % on first page. 20402300 + if listoption then if pagecnt=0 then heading; % on first page30282100 +c := " "; % to initialize "insymbol" 90034000 +initialize; % compiler tables, newcard, insymbol 90035000 +$ 90036000 +if pagecnt > 0 % there has been some listing 90088000 +then begin write( line[dbl] ); write( line[dbl] ) end; 90089000 + if pagecnt>0 then % there has been listing 90110000 +$# patch 711 for pascal.xvi.o contains 10 cards. pasc001/usercode unique name +$: to generate a unique file name in the disk directory. this patch changes the +$: method for generating a unique file name for the algol source code output of +$: the compiler. formerly, this was done using the time function to obtain +$: some random digits. the method used in patch/merge is adopted here, namely +$: starting with the prefix (mfid) "pasc001", a search is preformed to determine +$: whether such a file name is already catalogued. if so, 1 is added and the +$: search repeated. in addition, the file is created with a save factor +$: (retention period) of zero days so that a halt-load will remove the file +$: automatically. +$: see patch 704. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: +procedure searchdiskdirectory( f, a ); file f; array a[0]; 20222100 + search( f, a[*] ); % end of searchdiskdirectory; 20222200 + 20222300 + charpnt := pointer(ch[0])+7; ch[0] := " "; 20322000 +ch[0] := "pasc000"; charpnt := pointer(ch[0])+5; 90016000 +pascalgol.fid := user := time(-1); 90017000 +do begin c:=c+1; replace charpnt by c for 3 digits; 90018000 + pascalgol.mfid := algolname := ch[0]; 90019000 + searchdiskdirectory( pascalgol, lines[*] ); 90020000 +end until lines[0]=-1; % file not on disk 90021000 +$# patch 712 for pascal.xvi.o contains 2 cards. mark procedure levels in margin +$: patch to mark the start and end of procedures and functions by annotating the +$: margin with the symbols "+p" & "-p" followed by the level number. +$: nils a otte, university of natal, durban. aug - nov 1977. +$: + margin("+p",curlevel); % mark procedure level 80420100 + margin("-p",curlevel); % mark end of procedure 80702100 +$# patch 713 for pascal.xvi.o contains 14 cards.corrects error message etc. +$: corrects the double "no erros" message and the output of headings +$: when l1 is set after l-. +$: also corrects the scanning problem when compiler options are incorrect. +$: david a cooper, heriot-watt univeristy ...... august 1978 +$: + error102mess(//"102 *** warning only, illegal compiler option.")10188750 + , % 10188751 + if errnum=100 or errnum=102 20181600 + then numerrs := numerrs - 1; %*error number 102 is only an illegal 20181610 +% * dollar option warning & 20181620 +% *error number 100 alone should not 20181650 + else listoption := c="+" else 30265000 + end 30280800 + else error(102); 30280810 + if err(102) then 90090710 + write(line,error102mess); 90090720 +$ 90110000 +$ 90111000 + ("102 ***warning only, illegal dollar option."), 91106900 +$# patch 800 for pascal.xvi.o.contains 10 cards. +$: to remove conflicts between heriot-watt & natal existing patches. +$: + maxsyms = 800#, %max number of symbols in one expression. 10052000 + maxpntrs = 25#; %max number of undeclared pointers(forwd). 10056000 +define err(err1) = boolean(0&errp[(err1).[6:2]][0:((err1).[4:5]):1])#; 10156108 +integer exprlevel, expinvarcnt; % 40018000 + integer index, ctype, numforwards, tx, i; % 80403000 +integer prognamelength; % 90013900 + if err(100) % 90090600 + "; algol file tape=pascrun/disk serial; algol file card=", 90119000 + p(palgolname),"/",p(puser)," serial;", % 90120000 + " xalgol stack = 2048; end."; % 90120500 +$# patch 998 for pascal.xvi.o contains 10 cards. insert page throws at desired +$: patch to insert page throws at desired pointes in the source to produce a +$: nicely laid out listing. +$: +$ page 19000000 +$ page 20290000 +$ page 29000000 +$ page 39000000 +$ page 49000000 +$ page 59000000 +$ page 69000000 +$ page 79000000 +$ page 89000000 +$ page 90070999 +$: nils a otte, university of natal, durban. aug - nov 1977. +$: +$# patch 999 for pascal.xvi.o contains 1 cards. verison number. +$: +define edition = "4.4"#;%august 1978...david a cooper... 10028000 + +?END diff --git a/PASCAL-Heriot-Watt/README.txt b/PASCAL-Heriot-Watt/README.txt new file mode 100644 index 0000000..e68408c --- /dev/null +++ b/PASCAL-Heriot-Watt/README.txt @@ -0,0 +1,37 @@ +PASCAL Compiler for the Burroughs B5500/B5700 + +A compiler and run-time system for Niklaus Wirth's Pascal language, +written by Dag F. Langmyhr at Heriot-Watt University in Edinburgh, +Scotland, ca. 1975. + +Rather than compiling Pascal source to B5500 object code, this compiler +translates the Pascal source to Burroughs Algol. The PASCRUN/DISK file +is Algol source that is inserted into the Algol generated from the +Pascal source to provide a run-time system -- actually it is more like a +shim between Pascal and standard Algol intrinsics and I/O. + +The compiler, run-time system, and patches were originally transcribed +by Rich Cornwell of North Carolina, US. Proofing and correction were +performed by Paul Kimpel of San Diego, California, US. + +PASCRUN.DISK.alg_m + Algol source for the run-time system inserted into the translated + Algol by the compiler. Transcribed from + http://bitsavers.org/pdf/burroughs/B5000_5500_5700/listing/ + B5700_Pascal_Apr78.pdf. + +PATCHES.PASCAL.card + Card deck containing patches to the Pascal compiler in PATCH/MERGE + format. Transcribed from + http://bitsavers.org/pdf/burroughs/B5000_5500_5700/listing/ + B5700_Pascal_Mar79.pdf. + +SYMBOL.PASCAL.alg_m + Source for the Pascal compiler/translator, written in Burroughs + Extended Algol for the B5500. Transcribed from + http://bitsavers.org/pdf/burroughs/B5000_5500_5700/listing/ + B5700_Pascal_Mar79.pdf. + + +Paul Kimpel +June 2016 diff --git a/PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m b/PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m new file mode 100644 index 0000000..d520272 --- /dev/null +++ b/PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m @@ -0,0 +1,3700 @@ +?execute object/reader +?common=3 +?file newtape = symbol/pascal serial +?data card +$ card list single seqxec xref 00001 +$ set card list single xref 00002 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00003 +% % 00004 +% % 00005 +% * * % 00006 +% * p a s c a l c o m p i l e r * % 00007 +% *********************************** % 00008 +% % 00009 +% % 00010 +% written 1975 by % 00011 +% dag f. langmyhr, % 00012 +% heriot-watt university, % 00013 +% edinburgh. % 00014 +% % 00015 +% % 00016 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00017 +% % 00018 +% % 00019 +% part 1: declarations. % 00020 +% ------------- % 00021 +% % 00022 +% % 00023 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00024 +% 00025 +% 00026 +begin% 00027 +define edition="2.3"#;% 00028 +integer numerrs, % @r+21: number of erros in program. 00029 + savefactor, % @r+22: savefactor for code file. 00030 + % >0 compile to library. 00031 + % =0 compile and run. 00032 + % <0 compile for syntax. 00033 + cardcnt; % @r+23: number of cards read. 00034 +file card "source" (2,10,150); % source code input file 00035 +file lines 1 (2,17); % print file. 00036 +file pascalgol disk serial [20:600] (2,10,150,save 0); % code file 00037 +define linesperpage=58#,% 00038 + maxint=549755813887#;% 00039 +% 00040 +%*** compiler constants *** 00041 +define maxtables =50#, %max number of name tables. 00042 + maxnames =997#, %max names in each table. 00043 + maxlevel =15#, %max depth of procedure declarations. 00044 + maxcases =211#, %max labels in a case-statement. 00045 + maxlabs =100#, %max number of labels. 00046 + maxparams =200#, %max number of parameters in whole program. 00047 + maxtypes =1022#, %max number of different types. 00048 + maxconsts =200#, %size of constant table. 00049 + maxtemps =5#, %number of extra vars in each procedure. 00050 + maxwithsyms=250#, %max number of symbols used by with-statms. 00051 + maxsyms =800#, %max number of symbols in one expression. 00052 + listlength =800#, %max length of var and param lists. 00053 + maxextfiles=20#, %max number of external files. 00054 + maxfiles =20#, %max number of files declared at one time. 00055 + maxpntrs =50#; %max number of undeclared pointers. 00056 +% 00057 +%*** name tables *** 00058 +array nametab1,nametab2,nametab3[0:maxtables,0:maxnames];% 00059 +define namelength =[41:6]#,% 00060 + type =[9:10]#,% 00061 + idclass =[12:3]#,% 00062 + var =0#,% 00063 + const=1#,% 00064 + func =2#,% 00065 + proc =3#,% 00066 + types=4#,% 00067 + info =[23:11]#,% 00068 + formal =[24:1]#,% 00069 + forwarddef =[25:1]#,% 00070 + externalfile=[26:1]#;% 00071 +% 00072 +%*** display vector *** 00073 +array display[0:maxlevel];% 00074 +define rectype =[9:10]#,% 00075 + firstwithsym =[19:10]#,% 00076 + lastwithsym =[29:10]#,% 00077 + numpntrsinwith=[35:6]#,% 00078 + bracketsinwith=[36:1]#,% 00079 + nametab =[46:7]#;% 00080 +% 00081 +%*** type tables *** 00082 +array typetab1,typetab2,typetab3[0:maxtypes];% 00083 +define form =[3:4]#,% 00084 + numeric =0#,% 00085 + symbolic=1#,% 00086 + subtype =2#,% 00087 + maintype=[33:10]#,% 00088 + char =3#,% 00089 + floating=4#,% 00090 + alfa =5#,% 00091 + set =6#,% 00092 + settype =[33:10]#,% 00093 + pointers=7#,% 00094 + pointtype=[33:10]#,% 00095 + arrays =8#,% 00096 + inxtype =[33:10]#,% 00097 + arrtype =[43:10]#,% 00098 + record =9#,% 00099 + rectab =[33:10]#,% 00100 + files =10#,% 00101 + filetype=[33:10]#,% 00102 + textfile=11#,% 00103 + size =[15:12]#,% 00104 + struct=[23:8]#;% 00105 +integer numtypes;% 00106 +% 00107 +%*** parameter table *** 00108 +array paramtab[0:maxparams];% 00109 +define paramname =[9:10]#,% 00110 + paramkind =[13:4]#,% 00111 + paramlevel=[23:10]#,% 00112 + paramtype =[33:10]#,% 00113 + paramfile =[34:1]#;% 00114 +integer numparams;% 00115 +% 00116 +%*** constant table *** 00117 +array consttab[0:maxconsts];% 00118 +integer numconsts;% 00119 +% 00120 +%*** label table *** 00121 +array labtab[0:maxlabs];% 00122 +define labval=[14:15]#,% 00123 + labdef=[15:1]#;% 00124 +integer numlabs,firstlab;% 00125 +% 00126 +%*** tables for i/o and character handling *** 00127 +array ch[0:0], text[0:1], string[0:11];% 00128 + pointer charpnt,textpnt,textpnt0,stringpnt;% 00129 +array icard[0:9], line[0:16], xline[0:10], algolcard[0:9];% 00130 + pointer cardpnt,linepnt,xlinepnt,algolpnt;% 00131 + integer charcnt,algolcnt,margincnt;% 00132 +array headtext[0:10], errline[0:16];% 00133 + integer linecnt,pagecnt,errinx;% 00134 +% 00135 +%*** xref file and table *** 00136 +file xreffile disk serial [20:3000] (2,3,15);% 00137 +array blocktab[0:maxtables], xrefline[0:16];% 00138 + integer numxref,numblocks; pointer xrefpnt;% 00139 +% 00140 +%*** other tables *** 00141 +integer array varlist[0:listlength]; % temporary list of variables. 00142 + integer varindex,firstvar;% 00143 +array symtab[0:maxsyms]; % used by "expression". 00144 + integer numsyms;% 00145 +array withtab[0:maxwithsyms]; % used by "withstat". 00146 + integer nwithsyms;% 00147 +integer array symbol[0:64]; % used by "insymbol". 00148 +integer array symkind[0:61]; % used in error recovery. 00149 +array pntrtab1,pntrtab2,pntrtab3[0:maxpntrs];% used for forward pointers 00150 + integer numpntrs;% 00151 +array extfiletab[0:maxextfiles]; % external files. 00152 + integer numextfiles;% 00153 +array filetab[0:maxfiles]; % files in use. 00154 + integer numfiles;% 00155 +boolean array err[0:119]; % records error messages. 00156 +% 00157 +%*** compile time options *** 00158 +boolean listoption,reswordoption,checkoption,dumpoption,xrefoption;% 00159 +integer cardlength;% 00160 +% 00161 +%*** intrinsic types *** 00162 +integer inttype,realtype,alfatype,chartype,booltype,niltype,texttype,% 00163 + inputfile,outputfile,emptyset;% 00164 +boolean inputdecl,outputdecl;% 00165 +% 00166 +%*** temporary variables *** 00167 +integer t1,t2,t3,t4,t5;% 00168 +% 00169 +%*** other variables *** 00170 +alpha user; % the user number found on the user card. 00171 +% 00172 +integer curlevel, % current procedure level. 00173 + toplevel, % top level in display vector. 00174 + numbegins, % number of "begin"s in the program. 00175 + numcases, % number of case-statements in program. 00176 + numreps, % number of repeat-statements in program. 00177 + numtemps, % number of temporary variables in use. 00178 + curfunc, % index of function currently compiled. 00179 + cursy, % last symbol read by scanner. 00180 + curtype, % type of entity last compiled. 00181 + curmode, % current expression mode. 00182 + lastrec; % last record table defined. 00183 +% 00184 +label endofinput;% 00185 +% 00186 +format noerrors ("no errors detected."),% 00187 + errors (i5," errors detected"/),% 00188 + alist ("$ set list single"),% 00189 + noalist ("$ reset list"),% 00190 + lastline ("; terminate: end of pascal program."),% 00191 + termmess ("**** end-of-input. compilation terminated.");% 00192 +monitor expovr:=realoverflow;% 00193 +% 00194 +%*** scanner symbols *** 00195 +define identifier=1#, intconst=2#, realconst=3#, alfaconst=4#,% 00196 + charconst=5#, notsy=6#, asterisk=7#, slash=8#,% 00197 + andsy=9#, divsy=10#, modsy=11#, plus=12#,% 00198 + minus=13#, orsy=14#, lsssy=15#, leqsy=16#,% 00199 + geqsy=17#, gtrsy=18#, neqsy=19#, eqlsy=20#,% 00200 + insy=21#, lpar=22#, rpar=23#, lbracket=24#,% 00201 + rbracket=25#, doubledot=26#, comma=27#, semicolon=28#,% 00202 + dot=29#, arrow=30#, colon=31#, assignsy=32#,% 00203 + beginsy=33#, endsy=34#, ifsy=35#, thensy=36#,% 00204 + elsesy=37#, casesy=38#, ofsy=39#, repeatsy=40#,% 00205 + untilsy=41#, whilesy=42#, dosy=43#, forsy=44#,% 00206 + tosy=45#, downtosy=46#, gotosy=47#, nilsy=48#,% 00207 + typesy=49#, arraysy=50#, recordsy=51#, filesy=52#,% 00208 + setsy=53#, constsy=54#, varsy=55#, labelsy=56#,% 00209 + funcsy=57#, procsy=58#, withsy=59#, programsy=60#,% 00210 + packedsy=61#;% 00211 +% 00212 +define initial=0#, middle=1#, terminal=2#;% 00213 +define number=0#, bitpattern=1#;% 00214 +$ page% 00215 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00216 +% % 00217 +% % 00218 +% % 00219 +% part 2: compiler utility routines. % 00220 +% -------------------------- % 00221 +% % 00222 +% % 00223 +% % 00224 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00225 +% 00226 +% 00227 +procedure insymbol; forward;% 00228 +procedure writealgol; forward;% 00229 +procedure newxref(name1,name2,table,decl);% 00230 +value name1, name2, table, decl;% 00231 +real name1, name2;% 00232 +integer table;% 00233 +boolean decl;% 00234 +forward;% 00235 +% 00236 +define ndigits(n)=% 00237 +if n{ 9 then 1 else% 00238 +if n{99 then 2 else 3 digits#;% 00239 +% 00240 +define heading=% 00241 +begin comment *** prints a heading on top of a new page. ;% 00242 + pagecnt:=pagecnt+1;% 00243 + replace pointer(headtext[*])+85 by pagecnt for ndigits(pagecnt);% 00244 + write(lines[page]);% 00245 + write(lines[dbl],11,headtext[*]);% 00246 + linecnt:=2;% 00247 +end of heading#;% 00248 +% 00249 +% 00250 +define printline= %*** prints a source code line. 00251 +begin% 00252 + replace linepnt-8 by cardcnt for 5 digits;% 00253 + if linecnt}linesperpage then heading;% 00254 + if reswordoption then% 00255 + begin% 00256 + write(lines[no],11,xline[*]);% 00257 + write(lines[no],11,xline[*]);% 00258 + end;% 00259 + write(lines,17,line[*]);% 00260 + linecnt:=linecnt+1;% 00261 +end of printline#;% 00262 +% 00263 +% 00264 +define newcard= %*** reads a new source code card. 00265 +begin% 00266 + if listoption then printline;% 00267 + if errinx>0 then printerrors;% 00268 + read(card,10,icard[*]) [endofinput];% 00269 + cardpnt:=pointer(icard[*]);% 00270 + replace linepnt by cardpnt for 10 words, " " for 6 words;% 00271 + replace xlinepnt by " " for 10 words;% 00272 + charcnt:=cardlength;% 00273 + margincnt:=85;% 00274 + cardcnt:=cardcnt+1;% 00275 +end#;% 00276 +% 00277 +% 00278 +define gen(t,n,start)= %*** generate a text "t", consisting of 00279 +begin %*** "n" letters, starting at "start". 00280 + if algolcnt 0 then% 00333 + begin% 00334 + while absx}1@7 do begin absx:=absx/10; power:=power+1; end;% 00335 + while absx<1@6 do begin absx:=absx/10; power:=power-1; end;% 00336 + v1:=entier(absx);% 00337 + v2:=entier((absx-v1)|1000000);% 00338 + replace algolpnt:algolpnt by v1 for 7 digits, ".",% 00339 + v2 for 6 digits, "@";% 00340 + algolcnt:=algolcnt-15;% 00341 + if power<0 then gen("-",1,7);% 00342 + power:=abs(power);% 00343 + replace algolpnt:algolpnt by power for 2 digits;% 00344 + algolcnt:=algolcnt-2;% 00345 + end else gen("0",1,7);% 00346 + if x<0 then gen(")",1,7);% 00347 + end;% 00348 +end of genreal;% 00349 +% 00350 +% 00351 +integer typeindex;% 00352 +% 00353 +define newtype=% 00354 +begin % 00355 + if numtypes}maxtypes then begin error(45);numtypes:=maxtypes-20 end; 00356 + typeindex:=numtypes:=numtypes+1;% 00357 +end #;% 00358 +% 00359 +% 00360 +procedure writealgol; %*** writes a completed xalgol card to 00361 +begin %*** the file. 00362 + replace pointer(algolcard[9]) by cardcnt for 8 digits;% 00363 + write(pascalgol,10,algolcard[*]);% 00364 + if dumpoption then write(lines,10,algolcard[*]);% 00365 + algolpnt:=pointer(algolcard[*]); algolcnt:=71;% 00366 + replace algolpnt by " " for 9 words;% 00367 +end of writealgol;% 00368 +% 00369 +define margin(letter,num)=% 00370 +begin comment *** places information in the margin. ;% 00371 + if margincnt{118 then% 00372 + begin text[0]:=letter;% 00373 + replace linepnt+margincnt by textpnt+5 for 2,% 00374 + num for ndigits(num);% 00375 + margincnt:=margincnt+6;% 00376 + end;% 00377 +end of margin#;% 00378 +% 00379 +% 00380 +procedure skip(symbol); %*** skip symbols to recover from error 00381 +value symbol; integer symbol; %*** condition. 00382 +begin% 00383 + while cursy!symbol and symkind[cursy]=middle do% 00384 + if cursy=recordsy then% 00385 + begin do begin insymbol;% 00386 + skip(99);% 00387 + end until cursy!semicolon and cursy!casesy;% 00388 + end else insymbol;% 00389 +end of skip;% 00390 +% 00391 +% 00392 +procedure error(errnum);% 00393 +value errnum; integer errnum;% 00394 +begin comment *** arrange error indicator. ;% 00395 + numerrs:=numerrs+1;% 00396 + err[errnum]:=true;% 00397 + errinx:=max(errinx,cardlength-2-charcnt);% 00398 + if errinx{115 then% 00399 + begin replace pointer(errline[1])+errinx by "|",% 00400 + errnum for ndigits(errnum);% 00401 + errinx:=errinx+(if errnum{ 9 then 2 else% 00402 + if errnum{99 then 3 else 4);% 00403 +end end of error;% 00404 +% 00405 +% 00406 +procedure printerrors;% 00407 +begin comment *** print error indicators. ;% 00408 + if not listoption then printline;% 00409 + write(lines,17,errline[*]);% 00410 + linecnt:=linecnt+1;% 00411 + replace pointer(errline[1]) by " " for 16 words;% 00412 + errinx:=0;% 00413 +end of print errors;% 00414 +% 00415 +% 00416 +define hash(n) = (n).[35:36] mod maxnames#;% 00417 +% 00418 +integer thislevel,thistab,thisindex;% 00419 +alpha thisid,tname;% 00420 +boolean found;% 00421 +% 00422 +define searchtab(tab)= %*** search name table "tab" for the 00423 +begin %*** identifier just read. 00424 + thisindex:=hash(curname1);% 00425 + tname:=nametab1[tab,thisindex];% 00426 + while (if tname=curname1 then nametab2[tab,thisindex]!curname2% 00427 + else tname!0) do% 00428 + begin% 00429 + thisindex:=if thisindex=0 then maxnames else thisindex-1;% 00430 + tname:=nametab1[tab,thisindex];% 00431 + end;% 00432 + found:=tname!0;% 00433 + if xrefoption then% 00434 + if found then newxref(curname1,curname2,tab,false);% 00435 +end of searchtab#;% 00436 +% 00437 +define search= %*** search all tables currently in use. 00438 +begin% 00439 + thislevel:=toplevel+1;% 00440 + do begin% 00441 + thislevel:=thislevel-1;% 00442 + thistab:=if thislevel{curlevel then thislevel% 00443 + else display[thislevel].nametab;% 00444 + searchtab(thistab);% 00445 + end until found or thislevel=0;% 00446 + thisid:=nametab3[thistab,thisindex];% 00447 +end of search #;% 00448 +% 00449 +% 00450 +define newname(name1,name2,tab) =% 00451 +begin %*** enter a new name into the name table "tab". 00452 + thisindex:=hash(name1);% 00453 + tname:=nametab1[tab,thisindex];% 00454 + while(if tname=name1 then nametab2[tab,thisindex]!name2% 00455 + else tname!0) do% 00456 + begin% 00457 + thisindex:=if thisindex=0 then maxnames else thisindex-1;% 00458 + tname:=nametab1[tab,thisindex];% 00459 + end;% 00460 + if tname!0 then error(2);% 00461 + nametab1[tab,thisindex]:=name1;% 00462 + nametab2[tab,thisindex]:=name2;% 00463 + if xrefoption then newxref(name1,name2,tab,true);% 00464 +end of newname #;% 00465 +% 00466 +% 00467 +procedure initialize; %*** initialization *** 00468 +begin %********************** 00469 + integer t1,t3;% 00470 +% 00471 + alpha a;% 00472 + fill symkind[*] with 28(middle),terminal,4(middle),initial,terminal, 00473 + initial,middle,terminal,initial,middle,initial,terminal,initial,% 00474 + middle,initial,2(middle),initial,middle,initial,4(middle),% 00475 + 7(initial),middle;% 00476 +% 00477 + fill symbol[*] with 10(0),0,arrow,0,colon,gtrsy,geqsy,plus,9(0),% 00478 + dot,lbracket,andsy,lpar,lsssy,arrow,0,9(0),0,asterisk,minus,% 00479 + rpar,semicolon,leqsy,0,slash,8(0),comma,0,neqsy,eqlsy,rbracket,% 00480 + 0,doubledot;% 00481 +% 00482 + linepnt :=pointer(line[1]);% 00483 + xlinepnt:=pointer(xline[1]);% 00484 + replace linepnt-8 by " => ", " " for 16 words;% 00485 + replace xlinepnt-8 by " " for 11 words;% 00486 + replace pointer(errline[*]) by "**** ", " " for 16 words;% 00487 + algolpnt:=pointer(algolcard[*]); algolcnt:=71;% 00488 + replace algolpnt by " " for 9 words;% 00489 + charpnt:=pointer(ch[*])+7;% 00490 + textpnt:=pointer(text[*])+1; textpnt0:=textpnt-1;% 00491 + replace textpnt by " " for 15;% 00492 + stringpnt:=pointer(string[*]);% 00493 + replace pointer(headtext[*]) by " " for 10 words, "page ";% 00494 + replace pointer(headtext[*]) by "pascal(", edition, ")/b-5700";% 00495 + text[0]:=time(5);% 00496 + replace pointer(headtext[*])+45 by textpnt+3 for 2, "/",% 00497 + textpnt+1 for 2, "/", textpnt+5 for 2;% 00498 + t1:=time(1)/3600;% 00499 + replace pointer(headtext[*])+57 by (t1 div 60) for 2 digits, ":",% 00500 + entier(t1 mod 60) for 2 digits;% 00501 + heading;% 00502 +% 00503 + %*** initialize intrinsic types, constants etc. *** 00504 +% 00505 + inttype:=t3:=1; %*** "integer" *** 00506 + t1:=numeric; t1.size:=1; t1.struct:=0;% 00507 + typetab1[1]:=t1; typetab2[1]:=-maxint; typetab3[1]:=maxint;% 00508 + newname("7intege", "r", 0); t3.idclass:=types;% 00509 + nametab3[0,thisindex]:=t3;% 00510 + realtype:=t3:=2; %*** "real" *** 00511 + t1.form:=floating; typetab1[2]:=t1;% 00512 + newname("400real", 0,0); t3.idclass:=types;% 00513 + nametab3[0,thisindex]:=t3;% 00514 + alfatype:=t3:=3; %*** "alfa" *** 00515 + t1.form:=alfa; typetab1[3]:=t1;% 00516 + newname("400alfa",0,0); t3.idclass:=types;% 00517 + nametab3[0,thisindex]:=t3;% 00518 + booltype:=t3:=4; %*** "boolean" *** 00519 + t1.form:=symbolic; typetab1[4]:=t1; typetab3[4]:=1;% 00520 + newname("7boolea", "n",0); t3.idclass:=types;% 00521 + nametab3[0,thisindex]:=t3;% 00522 + booltype:=t3:=5; %*** "char" *** 00523 + t1.form:=char; typetab1[5]:=t1; typetab3[5]:=63;% 00524 + newname("400char", 0,0); t3.idclass:=types;% 00525 + nametab3[0,thisindex]:=t3;% 00526 + t3:=booltype; t3.idclass:=const; %*** "false" *** 00527 + newname("50false",0,0); nametab3[0,thisindex]:=t3;% 00528 + t3.info:=1; %*** "true" *** 00529 + newname("400true",0,0); nametab3[0,thisindex]:=t3;% 00530 + numtypes:=5;% 00531 + niltype:=-1; %*** type of "nil" *** 00532 + emptyset:=-2; %*** type of [] *** 00533 + newname("6maxint",0,0); t3:=inttype; %*** "maxint" *** 00534 + t3.idclass:=const; t3.info:=1024;% 00535 + nametab3[0,thisindex]:=t3;% 00536 + numconsts:=1; consttab[1]:=maxint;% 00537 +% 00538 + t3:=0; t3.idclass:=proc; %*** procedures *** 00539 + for a:="3000get", "3000new", "400pack", "400page", "3000put",% 00540 + "400read", "6readln", "50reset", "6unpack", "50write" do% 00541 + begin% 00542 + newname(a,0,0); nametab3[0,thisindex]:=t3;% 00543 + end;% 00544 + newname("7dispos","e",0); nametab3[0,thisindex]:=t3;% 00545 + newname("7rewrit","e",0); nametab3[0,thisindex]:=t3;% 00546 + newname("7writel","n",0); nametab3[0,thisindex]:=t3;% 00547 +% 00548 + t3.idclass:=func; %*** functions *** 00549 + for a:="3000abs", "6arctan", "3000chr", "3000cos", "3000eof",% 00550 + "400eoln", "3000exp", "20000ln", "3000odd", "400pred",% 00551 + "400succ", "50round", "3000sin", "3000sqr", "400sqrt",% 00552 + "50trunc", "6concat", "400time", "400date", "6iotime",% 00553 + "400user", "3000ord"% 00554 + do begin% 00555 + newname(a,0,0); nametab3[0,thisindex]:=t3;% 00556 + end;% 00557 + newname("7elapse","d",0); nametab3[0,thisindex]:=t3;% 00558 + newname("7weekda","y",0); nametab3[0,thisindex]:=t3;% 00559 +% 00560 + texttype:=t3:=numtypes:=numtypes+1; %*** "text" *** 00561 + t1 := textfile; t1.struct := 1; typetab1[texttype] := t1;% 00562 + t3.idclass := types; % 00563 + newname("400text",0,0); nametab3[0,thisindex]:=t3;% 00564 + t3:=texttype; t3.idclass:=var; %*** "input" *** 00565 + t3.externalfile:=1;% 00566 + newname("50input",0,0); inputfile:=thisindex;% 00567 + nametab3[0,thisindex]:=t3;% 00568 + newname("6output",0,0); %*** "output" *** 00569 + nametab3[0,thisindex]:=t3; outputfile:=thisindex;% 00570 +end of intialized;% 00571 +% 00572 +% 00573 +% 00574 +%*** xref routines *** 00575 +%********************** 00576 +% 00577 +define xrefcard=[16:17]#,% 00578 + xrefblock=[26:10]#;% 00579 +real a0,b0,a1,b1,lasta0,lasta1;% 00580 +integer nl,lastblock,a2,ax;% 00581 +% 00582 +procedure newxref(name1,name2,table,decl);% 00583 +value name1,name2,table,decl;% 00584 +real name1,name2;% 00585 +integer table;% 00586 +boolean decl;% 00587 +begin% 00588 + nl:=name1.namelength;% 00589 + if nl<7 then name1:=0&name1[41:41:6]&name1[35:6|nl-1:6|nl]% 00590 + else name2:=0&name2[35:6|(nl-6)-1:6|(nl-6)];% 00591 + ax:=cardcnt; ax.xrefblock:=blocktab[table];% 00592 + if decl then ax:=ax-100000000000;% 00593 + write(xreffile,*,name1,name2,ax);% 00594 +end of newxref;% 00595 +% 00596 +procedure xrefmax(a);% 00597 +array a[0];% 00598 +begin % 00599 + a[0]:="azzzzzz"; a[1]:="zzzzzz"; a[2]:=9999999999;% 00600 +end of xrefmax;% 00601 +% 00602 +% 00603 +boolean procedure xrefcompare(a,b);% 00604 +array a,b[0];% 00605 +begin% 00606 + a0:=a[0]; b0:=b[0]; a1:=a[1]; b1:=b[1];% 00607 + xrefcompare:=% 00608 + if a0.[35:36]!b0.[35:36] then a0.[35:36]linesperpage then heading;% 00634 + xrefpnt:=pointer(xrefline[*]); numxref:=0;% 00635 + replace xrefpnt by " " for 17 words; xrefpnt:=xrefpnt+24;% 00636 + end;% 00637 + replace xrefpnt by a2.xrefcard for 5 digits;% 00638 + xrefpnt:=xrefpnt+7; numxref:=numxref+1;% 00639 + end else% 00640 + if a2<0 then% 00641 + begin% 00642 + a2:=a2+100000000000;% 00643 + write(lines,17,xrefline[*]); linecnt:=linecnt+1;% 00644 + if linecnt>linesperpage then heading;% 00645 + xrefpnt:=pointer(xrefline[*]); numxref:=0;% 00646 + replace xrefpnt by " " for 17 words;% 00647 + text[0]:=a0.[35:36]; lasta0:=a0;% 00648 + replace xrefpnt by textpnt+1 for a0.namelength;% 00649 + text[0]:=lasta1:=a1;% 00650 + if a0.namelength>6 then% 00651 + replace xrefpnt+6 by textpnt+1 for a0.namelength-6;% 00652 + replace xrefpnt+17 by a2.xrefcard for 5 digits;% 00653 + xrefpnt:=xrefpnt+24; lastblock:=a2.xrefblock;% 00654 + end;% 00655 + end;% 00656 +end of printxref;% 00657 +% 00658 +% 00659 +integer tt1,tt2,f1,f2,lt,rt;% 00660 +% 00661 +define checktypes(lefttype,righttype)=% 00662 +begin% 00663 + if lefttype>0 and righttype>0 then% 00664 + if lefttype!righttype then% 00665 + begin% 00666 + lt:=lefttype; rt:=righttype;% 00667 + tt1:=typetab1[lt]; tt2:=typetab1[rt];% 00668 + f1:=tt1.form; f2:=tt2.form;% 00669 + if lt!realtype or f2!numeric then% 00670 + if(f1!set and lt!emptyset)or(f2!set and rt!emptyset)then% 00671 + if(f1!pointers and lt!niltype)or(f2!pointers and rt!niltype)then% 00672 + begin% 00673 + if f1=set and f2=set then% 00674 + begin% 00675 + lt:=tt1.settype; rt:=tt2.settype;% 00676 + tt1:=typetab1[lt]; tt2:=typetab1[rt];% 00677 + f1:=tt1.form; f2:=tt2.form;% 00678 + end;% 00679 + if f1=pointers and f2=pointers then% 00680 + begin% 00681 + lt:=tt1.pointtype; rt:=tt2.pointtype;% 00682 + tt1:=typetab1[lt]; tt2:=typetab1[rt];% 00683 + f1:=tt1.form; f2:=tt2.form;% 00684 + end;% 00685 + while f1=subtype do% 00686 + begin lt:=tt1.maintype; tt1:=typetab1[lt]; f1:=tt1.form end;% 00687 + while f2=subtype do% 00688 + begin rt:=tt2.maintype; tt2:=typetab1[rt]; f2:=tt2.form end;% 00689 + if lt>0 and rt>0 then% 00690 + if lt!rt then% 00691 + if f1!numeric or f2!numeric then% 00692 + if f1!char or f2!char then error(17);% 00693 + end;% 00694 + end;% 00695 +end of checktypes#;% 00696 +% 00697 +% 00698 +integer filename;% 00699 +boolean lparfound;% 00700 +% 00701 +define fileparam(defaultfile)=%*** checks the first parameter to see 00702 +begin %*** if it is a file. 00703 + insymbol; filename:=curtype:=0;% 00704 + lparfound:=cursy=lpar;% 00705 + if lparfound then% 00706 + begin% 00707 + insymbol;% 00708 + if cursy=identifier then% 00709 + begin% 00710 + search;% 00711 + if found then% 00712 + begin% 00713 + if thisid.idclass=var then% 00714 + begin% 00715 + curtype:=thisid.type;% 00716 + if typetab1[curtype].form}files then% 00717 + begin% 00718 + filename:=1000|thislevel+thisindex;% 00719 + insymbol;% 00720 + end end end end;% 00721 + if symkind[cursy]=terminal then error(46);% 00722 + end;% 00723 + if filename=0 then filename:=defaultfile;% 00724 + if (filename=inputfile and not inputdecl) or% 00725 + (filename=outputfile and not outputdecl) then error(96);% 00726 +end of fileparam#;% 00727 +% 00728 +% 00729 +integer tform;% 00730 +boolean signed,negative;% 00731 +% 00732 +define constant(cval,ctype)= %*** *** 00733 +begin %****************** 00734 + if cursy=minus or cursy=plus then% 00735 + begin signed:=true; negative:=cursy=minus;% 00736 + insymbol;% 00737 + end else signed:=negative:=false;% 00738 + if cursy=intconst then% 00739 + begin ctype:=inttype;% 00740 + cval:=if negative then -curval else curval;% 00741 + end else% 00742 + if cursy=charconst then% 00743 + begin if signed then error(29);% 00744 + ctype:=chartype; cval:=curval;% 00745 + end else% 00746 + if cursy=realconst then% 00747 + begin ctype:=realtype;% 00748 + cval:=if negative then -curval else curval;% 00749 + end else% 00750 + if cursy=alfaconst then% 00751 + begin if signed then error(29);% 00752 + if curlength>7 then error(41);% 00753 + ctype:=alfatype; cval:=curval;% 00754 + end else% 00755 + if cursy=identifier then% 00756 + begin% 00757 + search;% 00758 + if found then% 00759 + begin% 00760 + if thisid.idclass=const and not boolean(thisid.formal) then% 00761 + begin% 00762 + if typetab1[thisid.type].form{alfa then% 00763 + begin% 00764 + cval:=thisid.info;% 00765 + if cval>1023 then cval:=consttab[cval-1023];% 00766 + ctype:=thisid.type;% 00767 + if signed then% 00768 + begin % 00769 + tform:=typetab1[thisid.type].form;% 00770 + if tform!numeric and tform!floating then error(29) else% 00771 + if negative then cval:=-cval;% 00772 + end;% 00773 + end else begin error(48); cval:=ctype:=0 end;% 00774 + end else begin error(32); cval:=ctype:=0 end;% 00775 + end else begin error(1); cval:=ctype:=0 end;% 00776 + end else begin error(32); cval:=ctype:=0 end;% 00777 + insymbol;% 00778 +end of constant#;% 00779 +$ page% 00780 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00781 +% % 00782 +% % 00783 +% % 00784 +% part 3: the scanner. % 00785 +% ------------ % 00786 +% % 00787 +% % 00788 +% % 00789 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00790 +% 00791 +% internal internal symbol 00792 +% symbol number name kind 00793 +% 00794 +% identifier 1 identifier middle 00795 +% 122 2 intconst middle 00796 +% 2.5 3 realconst middle 00797 +% "abcd" 4 alfaconst middle 00798 +% "c" 5 charconst middle 00799 +% not 6 notsy middle 00800 +% * 7 asterisk middle 00801 +% / 8 slash middle 00802 +% & and 9 andsy middle 00803 +% div 10 divsy middle 00804 +% mod 11 modsy middle 00805 +% + 12 plus middle 00806 +% - 13 minus middle 00807 +% or 14 orsy middle 00808 +% < lss 15 lsssy middle 00809 +% <= leq { 16 leqsy middle 00810 +% >= geq } 17 geqsy middle 00811 +% > gtr 18 gtrsy middle 00812 +% <> neq ! 19 neqsy middle 00813 +% = eql 20 eqlsy middle 00814 +% in 21 insy middle 00815 +% ( 22 lpar middle 00816 +% ) 23 rpar middle 00817 +% [ 24 lbracket middle 00818 +% ] 25 rbracket middle 00819 +% .. 26 doubledot middle 00820 +% , 27 comma middle 00821 +% ; 28 semicolon terminal 00822 +% . 29 dot middle 00823 +% ~ @ 30 arrow middle 00824 +% : 31 colon middle 00825 +% := 32 assignsy middle 00826 +% begin 33 beginsy initial 00827 +% end 34 endsy terminal 00828 +% if 35 ifsy initial 00829 +% then 36 thensy middle 00830 +% else 37 elsesy terminal 00831 +% case 38 casesy initial 00832 +% of 39 ofsy middle 00833 +% repeat 40 repeatsy initial 00834 +% until 41 untilsy terminal 00835 +% while 42 whilesy initial 00836 +% do 43 dosy middle 00837 +% for 44 forsy initial 00838 +% to 45 tosy middle 00839 +% downto 46 downtosy middle 00840 +% goto 47 gotosy initial 00841 +% nil 48 nilsy middle 00842 +% type 49 typesy initial 00843 +% array 50 arraysy middle 00844 +% record 51 recordsy middle 00845 +% file 52 filesy middle 00846 +% set 53 setsy middle 00847 +% const 54 constsy initial 00848 +% var 55 varsy initial 00849 +% label 56 labelsy initial 00850 +% function 57 funcsy initial 00851 +% procedure 58 procsy initial 00852 +% with 59 withsy initial 00853 +% program 60 programsy initial 00854 +% packed 61 packedsy middle 00855 +% 00856 +% 00857 +define blank=48#, equal=61#, quotes=63#, dollar=42#,% 00858 + letter(c)=(17{c and c{25)or(33{c and c{41)or(50{c and c{57)#,% 00859 + alfanum(c)=(letter(c) or c{9)#;% 00860 +% 00861 +real curval;% 00862 +alpha curname1,curname2,c,cx;% 00863 +integer curlength,lastcharpos;% 00864 +boolean finis;% 00865 +% 00866 +define nextchar=% 00867 +begin comment *** read next character. ***;% 00868 + if charcnt=0 then c:=blank else% 00869 + begin% 00870 + replace charpnt by cardpnt:cardpnt for 1;% 00871 + c:=ch[0]; charcnt:=charcnt-1;% 00872 +end end #;% 00873 +% 00874 +% 00875 +% 00876 +procedure insymbol;% 00877 +begin comment *** reads the next symbol. ***;% 00878 + integer scale,exp;% 00879 + boolean negexp;% 00880 + label start,overflow;% 00881 +% 00882 +start:% 00883 + if c=blank then% 00884 + begin scan cardpnt:cardpnt for charcnt:charcnt while =" ";% 00885 + if charcnt=0 then begin newcard; go to start end;% 00886 + nextchar;% 00887 + end;% 00888 + if letter(c) then% 00889 + begin% 00890 + curlength:=1; curname1:=c; curname2:=0;% 00891 + nextchar;% 00892 + while alfanum(c) and curlength<6 do% 00893 + begin curname1:=c&curname1[35:29:30];% 00894 + curlength:=curlength+1; nextchar;% 00895 + end;% 00896 + if curlength=6 then% 00897 + begin% 00898 + while alfanum(c) and curlength<12 do% 00899 + begin curname2:=c&curname2[35:29:30];% 00900 + curlength:=curlength+1; nextchar;% 00901 + end;% 00902 + while alfanum(c) do nextchar;% 00903 + end;% 00904 + curname1.namelength:=curlength;% 00905 + case curlength of% 00906 + begin ;% 00907 + cursy:=identifier;% 00908 + cursy:=if curname1="20000if" then ifsy else% 00909 + if curname1="20000do" then dosy else% 00910 + if curname1="20000to" then tosy else% 00911 + if curname1="20000or" then orsy else% 00912 + if curname1="20000of" then ofsy else% 00913 + if curname1="20000in" then insy else identifier;% 00914 + cursy:=if curname1="3000end" then endsy else% 00915 + if curname1="3000for" then forsy else% 00916 + if curname1="3000div" then divsy else% 00917 + if curname1="3000mod" then modsy else% 00918 + if curname1="3000nil" then nilsy else% 00919 + if curname1="3000and" then andsy else% 00920 + if curname1="3000not" then notsy else% 00921 + if curname1="3000var" then varsy else% 00922 + if curname1="3000set" then setsy else% 00923 + if curname1="3000lss" then lsssy else% 00924 + if curname1="3000leq" then leqsy else% 00925 + if curname1="3000geq" then geqsy else% 00926 + if curname1="3000gtr" then gtrsy else% 00927 + if curname1="3000neq" then neqsy else% 00928 + if curname1="3000eql" then eqlsy else identifier;% 00929 + cursy:=if curname1="400then" then thensy else% 00930 + if curname1="400else" then elsesy else% 00931 + if curname1="400with" then withsy else% 00932 + if curname1="400case" then casesy else% 00933 + if curname1="400goto" then gotosy else% 00934 + if curname1="400type" then typesy else% 00935 + if curname1="400file" then filesy else identifier;% 00936 + cursy:=if curname1="50begin" then beginsy else% 00937 + if curname1="50while" then whilesy else% 00938 + if curname1="50until" then untilsy else% 00939 + if curname1="50array" then arraysy else% 00940 + if curname1="50const" then constsy else% 00941 + if curname1="50label" then labelsy else identifier;% 00942 + cursy:=if curname1="6repeat" then repeatsy else% 00943 + if curname1="6downto" then downtosy else% 00944 + if curname1="6record" then recordsy else% 00945 + if curname1="6packed" then packedsy else identifier;% 00946 + cursy:=if curname1="7progra" and curname2="m" then programsy % 00947 + else identifier;% 00948 + cursy:=if curname1="8functi" and curname2="on" then funcsy % 00949 + else identifier;% 00950 + cursy:=if curname1="9proced" and curname2="ure" then procsy % 00951 + else identifier;% 00952 + cursy:=identifier; % 10 characters. 00953 + cursy:=identifier; % 11 characters. 00954 + cursy:=identifier; % 12 characters. 00955 + end of case;% 00956 + if reswordoption and cursy!identifier then% 00957 + begin t1:=cardlength-charcnt-curlength;% 00958 + if charcnt=0 then cardpnt:=cardpnt+1 else t1:=t1-1;% 00959 + replace xlinepnt+t1 by cardpnt-(curlength+1)% 00960 + for curlength;% 00961 + end;% 00962 + end of letter else% 00963 + if c{9 then% 00964 + begin% 00965 + curval:=c; cursy:=intconst;% 00966 + nextchar;% 00967 + while c{9 do begin curval:=10|curval+c; nextchar end;% 00968 + if c="." then% 00969 + begin% 00970 + nextchar;% 00971 + if c{9 then% 00972 + begin cursy:=realconst;% 00973 + do begin curval:=10|curval+c;% 00974 + scale:=scale-1; nextchar;% 00975 + end until c>9;% 00976 + end else if c="." then c:=64 % special mark for ".." 00977 + else error(4);% 00978 + end;% 00979 + if c="e" then% 00980 + begin% 00981 + cursy:=realconst; nextchar;% 00982 + if c="+" or c="-" then begin negexp:=c="-"; nextchar end;% 00983 + if c{9 then% 00984 + begin exp:=c; nextchar;% 00985 + while c{9 do begin exp:=10|exp+c; nextchar end;% 00986 + if negexp then exp:=-exp;% 00987 + end else error(4);% 00988 + scale:=scale+exp;% 00989 + end;% 00990 + if cursy=realconst then% 00991 + begin% 00992 + realoverflow:=overflow;% 00993 + curval:=curval|10*scale;% 00994 + realoverflow:=0;% 00995 + end else% 00996 + if curval>maxint then% 00997 + begin% 00998 +overflow: error(14); curval:=0; realoverflow:=0;% 00999 + end;% 01000 + end of digit else% 01001 + if c=quotes then% 01002 + begin% 01003 + cursy:=alfaconst; curlength:=0; nextchar;% 01004 + finis:=false;% 01005 + do begin% 01006 + if c=quotes then begin nextchar; finis:=c!quotes end else% 01007 + if charcnt=0 then begin error(6); finis:=true end;% 01008 + if not finis then% 01009 + begin% 01010 + replace stringpnt+curlength by charpnt for 1;% 01011 + curlength:=curlength+1;% 01012 + nextchar;% 01013 + end end until finis;% 01014 + if curlength=0 then error(4) else% 01015 + if curlength=1 then% 01016 + begin cursy:=charconst;% 01017 + replace charpnt by stringpnt for 1; curval:=ch[0];% 01018 + end else% 01019 + if curlength{7 then% 01020 + begin text[0]:=" ";% 01021 + replace textpnt by stringpnt for curlength;% 01022 + curval:=text[0];% 01023 + end;% 01024 + end of strings else% 01025 + begin% 01026 + cursy:=symbol[c]; nextchar;% 01027 + if cursy=colon and c=equal then% 01028 + begin cursy:=assignsy; nextchar end else% 01029 + if cursy=dot and c="." then% 01030 + begin cursy:=doubledot; nextchar end else% 01031 + if cursy=lsssy and c=equal then% 01032 + begin cursy:=leqsy; nextchar end else% 01033 + if cursy=lsssy and c=">" then% 01034 + begin cursy:=neqsy; nextchar end else% 01035 + if cursy=gtrsy and c=equal then% 01036 + begin cursy:=geqsy; nextchar end else% 01037 + if cursy=lpar and c="*" then% 01038 + begin % *** comment *** 01039 + nextchar;% 01040 + if c=dollar then % dollar indicates compiler options. 01041 + do begin% 01042 + nextchar; cx:=c; nextchar;% 01043 + if cx="l" then if c=1 then heading% 01044 + else listoption:=c="+" else% 01045 + if cx="r" then reswordoption:=c="+" else% 01046 + if cx="c" then checkoption:=c="+" else% 01047 + if cx="d" then dumpoption:=c="+" else% 01048 + if cx="x" then xrefoption:=c="+" else% 01049 + if cx="a" then% 01050 + if c="+" then write(pascalgol,alist)% 01051 + else write(pascalgol,noalist) else% 01052 + if cx="t" then% 01053 + begin lastcharpos := charcnt - cardlength;% 01054 + cardlength:=10|c;% 01055 + nextchar; cardlength:=cardlength+c;% 01056 + if cardlength{9 or cardlength>80 then% 01057 + begin error(14); cardlength:=72 end;% 01058 + charcnt:=max(0,lastcharpos+cardlength-1);% 01059 + end;% 01060 + nextchar;% 01061 + end until c!",";% 01062 + finis:=false;% 01063 + do begin% 01064 + if c!"*" then% 01065 + scan cardpnt:cardpnt for charcnt:charcnt until ="*";% 01066 + if charcnt=0 then newcard else% 01067 + begin nextchar;% 01068 + while c="*" do nextchar;% 01069 + finis:=c=")";% 01070 + end end until finis;% 01071 + nextchar;% 01072 + go to start;% 01073 + end of comment;% 01074 + end;% 01075 +end of insymbol;% 01076 +$ page% 01077 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 01078 +% % 01079 +% % 01080 +% % 01081 +% part 4: expression parser. % 01082 +% ------------------ % 01083 +% % 01084 +% % 01085 +% % 01086 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 01087 +% 01088 +% 01089 +procedure expression; forward;% 01090 +procedure concat; forward;% 01091 +% 01092 +alpha tempsym;% 01093 +real sx;% 01094 +integer exprlevel,tx;% 01095 +% 01096 +define puttext(t)=% 01097 +begin% 01098 + if numsyms=maxsyms then% 01099 + begin error(71);% 01100 + numsyms:=1;% 01101 + end else numsyms:=numsyms+1;% 01102 + symtab[numsyms]:=t;% 01103 +end of puttext #;% 01104 +% 01105 +define putsym(s)=% 01106 +begin% 01107 + tempsym:=(s)&1[41:5:6];% 01108 + puttext(tempsym);% 01109 +end of putsym #;% 01110 +% 01111 +define putconst(val)=% 01112 +begin% 01113 + puttext("2000000");% 01114 + puttext(val);% 01115 +end of putconst #;% 01116 +% 01117 +define putdummy=% 01118 +begin% 01119 + puttext("3000000");% 01120 +end of putdummy #;% 01121 +% 01122 +define putid(l,num,numdig)=% 01123 +begin% 01124 + text[0]:=" " & l [35:5:6];% 01125 + replace textpnt+2 by num for numdig digits;% 01126 + puttext(text[0]);% 01127 +end of putid#;% 01128 +% 01129 +define writeexpr=% 01130 +begin% 01131 + for t1:=1 step 1 until numsyms do% 01132 + begin% 01133 + sx:=symtab[t1]; tx:=sx.[41:6];% 01134 + if tx=0 then gen(sx,7,2) else% 01135 + if tx=3 then else% 01136 + if tx=1 then gen(sx,7,1) else% 01137 + begin% 01138 + t1:=t1+1; sx:=symtab[t1];% 01139 + if sx.[44:6]=0 then genint(sx) else genreal(sx);% 01140 + end end;% 01141 + numsyms:=0;% 01142 +end of writeexpr#;% 01143 +% 01144 +% 01145 +define checkexpr(llim,ulim)=% 01146 +begin% 01147 + puttext("check(");% 01148 + expression;% 01149 + putsym(","); putconst(llim);% 01150 + putsym(","); putconst(ulim);% 01151 + putsym(","); putconst(cardcnt);% 01152 + putsym(")");% 01153 +end of checkexpr#;% 01154 +% 01155 +% 01156 +boolean simplevariable,insidebrackets;% 01157 +integer numpointers;% 01158 + % 01159 +procedure variable;% 01160 +begin% 01161 + integer startsym,llim,ulim;% 01162 + real t;% 01163 + boolean inbracket,inrecord;% 01164 + label addaddr;% 01165 +% 01166 + startsym:=numsyms+1;% 01167 + if thislevel>curlevel then % variable in field list of 01168 + begin % record used in with-statement 01169 + t:=display[thislevel];% 01170 + t4:=t.firstwithsym; t5:=t.lastwithsym;% 01171 + for t3:=t4 step 1 until t5 do puttext(withtab[t3]);% 01172 + inrecord:=true;% 01173 + inbracket:=boolean(t.bracketsinwith);% 01174 + numpointers:=numpointers+t.numpntrsinwith;% 01175 + simplevariable:=false;% 01176 + curtype:=t.rectype; t:=typetab1[curtype];% 01177 + go to addaddr;% 01178 + end;% 01179 + if thislevel>1 and thislevel0 then begin putsym("-"); putconst( llim) end;% 01204 + putsym(")");% 01205 + if typetab1[curtype].size>1 then% 01206 + begin putsym("|"); putconst(typetab1[curtype].size) end;% 01207 + end else if typetab1[curtype].struct>0 then putsym(",");% 01208 + end until cursy!comma;% 01209 + if cursy!rbracket then% 01210 + begin error(59); skip(rbracket);% 01211 + if cursy=rbracket then insymbol;% 01212 + end else insymbol;% 01213 + end of brackets else% 01214 + if cursy=dot then% 01215 + begin% 01216 + if not(inbracket or inrecord) then% 01217 + begin putsym("["); inbracket:=true end;% 01218 + t:=typetab1[curtype];% 01219 + if t.form!record then error(12);% 01220 + insymbol;% 01221 + if cursy=identifier then% 01222 + begin% 01223 + searchtab(t.rectab);% 01224 + if found then% 01225 + begin% 01226 + thisid:=nametab3[t.rectab,thisindex];% 01227 + addaddr: putsym("+");% 01228 + putconst(thisid.info); curtype:=thisid.type;% 01229 + end else begin error(1); curtype:=0 end;% 01230 + end else begin error(9); curtype:=0 end;% 01231 + inrecord:=true;% 01232 + insymbol;% 01233 + end of dot else% 01234 + begin % cursy=arrow 01235 + t:=typetab1[curtype];% 01236 + if t.form=files then% 01237 + begin% 01238 + curtype:=t.filetype;% 01239 + if typetab1[curtype].struct=0 then puttext(" [0]");% 01240 + end else% 01241 + if t.form=textfile then% 01242 + begin% 01243 + symtab[numsyms]:=symtab[numsyms] & "i" [35:5:6];% 01244 + putsym("."); puttext("lastch");% 01245 + curtype:=chartype;% 01246 + end else% 01247 + if t.form=pointers then% 01248 + begin% 01249 + if inbracket then putsym("]");% 01250 + inbracket:=false;% 01251 + if numsyms+2{maxsyms then% 01252 + begin% 01253 + for t1:=numsyms step -1 until startsym do% 01254 + symtab[t1+2]:=symtab[t1];% 01255 + symtab[startsym]:=" mem[";% 01256 + symtab[startsym+1]:=" (t:=";% 01257 + numsyms:=numsyms+2; numpointers:=numpointers+1;% 01258 + inrecord:=true;% 01259 + end else error(63);% 01260 + curtype:=t.pointtype;% 01261 + end else begin error(12); curtype:=0 end;% 01262 + insymbol;% 01263 + end of arrow;% 01264 + end until cursy!lbracket and cursy!dot and cursy!arrow;% 01265 + if typetab1[curtype].struct=0 then% 01266 + begin% 01267 + if inbracket then putsym("]");% 01268 + while numpointers>0 do% 01269 + begin puttext("-1)div"); puttext(" 1022,");% 01270 + puttext(" t mod"); puttext(" 1022]");% 01271 + numpointers:=numpointers-1;% 01272 + end;% 01273 + end;% 01274 + end;% 01275 + insidebrackets:=inbracket;% 01276 + curmode:=number;% 01277 +end of variable;% 01278 +% 01279 +% 01280 +procedure passparams;% 01281 +begin% 01282 + integer npars,param,ptype,p,firstsym;% 01283 + boolean formalproc,check;% 01284 + label exit;% 01285 +% 01286 + putid("v",1000|thislevel+thisindex,5);% 01287 + p:=thisid.info;% 01288 + formalproc:=boolean(thisid.formal);% 01289 + npars:=paramtab[p]; p:=p+1;% 01290 + if formalproc then npars:=9999;% 01291 + insymbol;% 01292 + if cursy=lpar then% 01293 + begin% 01294 + putsym("(");% 01295 + do begin% 01296 + insymbol;% 01297 + if npars=0 then begin error(3); skip(rpar); go to exit end;% 01298 + param:=paramtab[p]; p:=p+1;% 01299 + ptype:=param.paramtype;% 01300 + if param.paramkind=const then% 01301 + begin% 01302 + check:=checkoption and typetab1[ptype].form leq char;% 01303 + if check then puttext("check(");% 01304 + putdummy; firstsym:=numsyms;% 01305 + exprlevel:=exprlevel+1;% 01306 + expression; exprlevel:=exprlevel-1;% 01307 + if curmode=bitpattern then% 01308 + begin symtab[firstsym]:=" real("; putsym(")"); end;% 01309 + if check then% 01310 + begin% 01311 + putsym(","); putconst(typetab2[ptype]);% 01312 + putsym(","); putconst(typetab3[ptype]);% 01313 + putsym(","); putconst(cardcnt); putsym(")");% 01314 + end;% 01315 + end else% 01316 + if param.paramkind=var then% 01317 + begin% 01318 + if cursy=identifier then% 01319 + begin% 01320 + search;% 01321 + if found then% 01322 + begin% 01323 + if thisid.idclass=var or% 01324 + thisid.idclass=const and boolean(thisid.formal) then% 01325 + begin% 01326 + if param.paramfile=1 then% 01327 + begin% 01328 + curtype:=thisid.type;% 01329 + putid("v",1000|thislevel+thisindex,5); putsym(",");% 01330 + putid("f",1000|thislevel+thisindex,5); putsym(",");% 01331 + putid("i",1000|thislevel+thisindex,5);% 01332 + insymbol;% 01333 + end else% 01334 + begin% 01335 + variable;% 01336 + if typetab1[curtype].struct>0 then% 01337 + if not simplevariable then error(92);% 01338 + end;% 01339 + end else begin error(8); curtype:=0 end;% 01340 + end else begin error(1); curtype:=0 end;% 01341 + end else begin error(9); curtype:=0 end;% 01342 + end else% 01343 + begin% 01344 + if cursy=identifier then% 01345 + begin% 01346 + search;% 01347 + if found then% 01348 + begin% 01349 + if thisid.idclass!param.paramkind then error(91);% 01350 + putid("v",1000|thislevel+thisindex,5);% 01351 + curtype:=if thisid.idclass=func then thisid.type else 0;% 01352 + insymbol;% 01353 + end else begin error(1); curtype:=0 end;% 01354 + end else begin error(9); curtype:=0 end;% 01355 + end;% 01356 + checktypes(ptype,curtype);% 01357 + npars:=npars-1;% 01358 + if cursy=comma then putsym(",");% 01359 + end until cursy!comma;% 01360 + if cursy!rpar then begin error(89); skip(rpar) end;% 01361 +exit: putsym(")");% 01362 + if cursy=rpar then insymbol;% 01363 + end;% 01364 + if npars>0 and not formalproc then error(3);% 01365 + curmode:=number;% 01366 +end of passparams;% 01367 +% 01368 +% 01369 +procedure factor; %*** factor *** 01370 +begin %************** 01371 + integer startsym,stype,t;% 01372 + boolean first;% 01373 + real val;% 01374 +% 01375 + define parameter= %*** check that the function has 1 param. 01376 + begin% 01377 + insymbol;% 01378 + if cursy=lpar then% 01379 + begin% 01380 + putsym("("); insymbol; expression;% 01381 + if typetab1[curtype].form=numeric then curtype:=inttype;% 01382 + if cursy!rpar then begin error(3); skip(rpar) end;% 01383 + putsym(")"); if cursy=rpar then insymbol;% 01384 + end else error(3);% 01385 + end of parameter#;% 01386 +% 01387 + curmode:=number;% 01388 + if cursy=identifier then% 01389 + begin% 01390 + search;% 01391 + if found then% 01392 + begin% 01393 + if thisid.idclass=var or% 01394 + thisid.idclass=const and boolean(thisid.formal)% 01395 + then variable else% 01396 + if thisid.idclass=const then% 01397 + begin% 01398 + if thisid.info{1023 then putconst(thisid.info)% 01399 + else putconst(consttab[thisid.info-1023]);% 01400 + curtype:=thisid.type; curmode:=number;% 01401 + insymbol;% 01402 + end else% 01403 + if thisid.idclass=func then% 01404 + begin% 01405 + if thistab=0 then %*** intrinsic function *** 01406 + begin% 01407 + integer dummy;% 01408 + if curname1="3000abs" then % "abs" 01409 + begin% 01410 + puttext(" abs"); parameter;% 01411 + if curtype!realtype and curtype!inttype then error(67);% 01412 + end else% 01413 + if curname1="3000chr" then % "chr" 01414 + begin% 01415 + insymbol;% 01416 + if cursy=lpar then% 01417 + begin insymbol; checkexpr(0,63);% 01418 + if typetab1[curtype].form!numeric then error(67);% 01419 + if cursy!rpar then begin error(46); skip(rpar) end;% 01420 + if cursy=rpar then insymbol;% 01421 + end else error(58);% 01422 + curtype:=chartype;% 01423 + end else% 01424 + if curname1="3000eof" or % "eof"/"eoln" 01425 + curname1="400eoln" then% 01426 + begin% 01427 + first:=curname1="3000eof";% 01428 + fileparam(inputfile);% 01429 + putid("i",filename,5);% 01430 + puttext(if first then " .eof" else " .eoln");% 01431 + if lparfound then% 01432 + begin% 01433 + if cursy!rpar then begin error(46); skip(rpar) end;% 01434 + if cursy=rpar then insymbol;% 01435 + end;% 01436 + curtype:=booltype;% 01437 + end else% 01438 + if curname1="3000odd" then % "odd" 01439 + begin% 01440 + puttext(" odd"); parameter;% 01441 + if curtype!inttype then error(67);% 01442 + curtype:=booltype; curmode:=bitpattern;% 01443 + end else% 01444 + if curname1="3000ord" then % "ord" 01445 + begin% 01446 + putsym("("); insymbol;% 01447 + if cursy=lpar then% 01448 + begin% 01449 + insymbol; expression;% 01450 + if typetab1[curtype].form>char then error(67);% 01451 + if cursy!rpar then begin error(46); skip(rpar) end;% 01452 + insymbol;% 01453 + end else error(58);% 01454 + curtype:=inttype; putsym(")");% 01455 + end else% 01456 + if curname1="400pred" or % "pred"/"succ" 01457 + curname1="400succ" then% 01458 + begin% 01459 + first:=curname1="400pred";% 01460 + puttext("check("); insymbol;% 01461 + if cursy=lpar then% 01462 + begin% 01463 + insymbol; expression;% 01464 + putsym(if first then "-" else "+"); putsym("1");% 01465 + if typetab1[curtype].form>char then error(67);% 01466 + putsym(","); putconst(typetab2[curtype]);% 01467 + putsym(","); putconst(typetab3[curtype]);% 01468 + putsym(","); putconst(cardcnt);% 01469 + putsym(")");% 01470 + if cursy!rpar then begin error(46); skip(rpar) end;% 01471 + if cursy=rpar then insymbol;% 01472 + end else begin error(58); curtype:=0 end;% 01473 + end else% 01474 + if curname1="50round" then % "round" 01475 + begin% 01476 + puttext(" round"); parameter;% 01477 + if curtype!realtype then error(67);% 01478 + numsyms:=numsyms-1; putsym(",");% 01479 + putconst(cardcnt); putsym(")");% 01480 + curtype:=inttype;% 01481 + end else% 01482 + if curname1="3000sqr" then % "sqr" 01483 + begin% 01484 + puttext(" sqr"); parameter;% 01485 + numsyms:=numsyms-1; putsym(",");% 01486 + putconst(cardcnt); putsym(")");% 01487 + if curtype!realtype and curtype!inttype then error(67);% 01488 + end else% 01489 + if curname1="50trunc" then % "trunc" 01490 + begin% 01491 + puttext(" trunc"); parameter;% 01492 + numsyms:=numsyms-1; putsym(",");% 01493 + putconst(cardcnt); putsym(")");% 01494 + if curtype!realtype then error(67);% 01495 + curtype:=inttype;% 01496 + end else% 01497 + if curname1="6concat" then % "concat" 01498 + concat else% 01499 + if curname1="400time" then % "time" 01500 + begin% 01501 + puttext("(time("); puttext("1)/60");% 01502 + curtype:=realtype; insymbol% 01503 + end else% 01504 + if curname1="400date" then % "date" 01505 + begin% 01506 + puttext("curdat");% 01507 + curtype:=alfatype; insymbol;% 01508 + end else% 01509 + if curname1="7elapse" and curname2="d" then % "elapsed" 01510 + begin% 01511 + puttext("(time("); puttext("2)/60)");% 01512 + curtype:=realtype; insymbol;% 01513 + end else% 01514 + if curname1="6iotime" then % "iotime" 01515 + begin% 01516 + puttext("(time("); puttext("3)/60)");% 01517 + curtype:=realtype; insymbol;% 01518 + end else% 01519 + if curname1="7weekda" and curname2="y" then % "weekday" 01520 + begin% 01521 + puttext("weekda");% 01522 + curtype:=alfatype; insymbol;% 01523 + end else if curname1="400user" then % "user" 01524 + begin% 01525 + puttext(" time"); puttext(" (-1)");% 01526 + curtype:=alfatype; insymbol;% 01527 + end else % "sin", "cos" etc. 01528 + begin% 01529 + puttext(if curname1="3000sin" then " sin" else% 01530 + if curname1="3000cos" then " cos" else% 01531 + if curname1="6arctan" then "arctan" else% 01532 + if curname1="400sqrt" then " sqrt" else% 01533 + if curname1="3000exp" then " exp" else% 01534 + " ln");% 01535 + parameter;% 01536 + if curtype!realtype and curtype!inttype then error(67);% 01537 + curtype:=realtype;% 01538 + end;% 01539 + end of intrinsic functions else% 01540 + begin % 01541 + t:=thisid.type;% 01542 + passparams;% 01543 + curtype:=t;% 01544 + end;% 01545 + end of functions else% 01546 + if thisid.idclass=proc then% 01547 + begin% 01548 + error(68); passparams;% 01549 + curtype:=0;% 01550 + end else begin error(69); curtype:=0; insymbol end;% 01551 + end else begin error(1); curtype:=0; insymbol end;% 01552 + end of identifier else% 01553 + if cursy{charconst then% 01554 + begin% 01555 + constant(val,curtype); putconst(val);% 01556 + end else% 01557 + if cursy=notsy then% 01558 + begin% 01559 + puttext(" not "); putdummy; startsym:=numsyms;% 01560 + insymbol; factor;% 01561 + if curtype>0 then% 01562 + if curtype!booltype then begin error(17); curtype:=0 end;% 01563 + if curmode=number then% 01564 + begin symtab[startsym]:=" b("; putsym(")");% 01565 + curmode:=bitpattern;% 01566 + end;% 01567 + end else% 01568 + if cursy=nilsy then% 01569 + begin% 01570 + putconst(0); curtype:=niltype;% 01571 + insymbol;% 01572 + end else% 01573 + if cursy=lpar then% 01574 + begin% 01575 + putsym("(");% 01576 + insymbol; expression;% 01577 + if cursy!rpar then begin error(46); skip(rpar) end;% 01578 + putsym(")");% 01579 + insymbol;% 01580 + end else% 01581 + if cursy=lbracket then %*** set constant *** 01582 + begin% 01583 + insymbol;% 01584 + if cursy=rbracket then% 01585 + begin% 01586 + putconst(0); curtype:=emptyset; curmode:=number;% 01587 + insymbol;% 01588 + end else% 01589 + begin% 01590 + first:=true;% 01591 + do begin% 01592 + if first then first:=false else insymbol;% 01593 + puttext(" bit("); startsym:=numsyms;% 01594 + expression;% 01595 + if stype=0 then% 01596 + begin stype:=curtype;% 01597 + if typetab1[curtype].form>char then error(72);% 01598 + end else checktypes(stype,curtype);% 01599 + if cursy=doubledot then% 01600 + begin% 01601 + putsym(","); symtab[startsym]:=" bits(";% 01602 + insymbol; expression;% 01603 + if stype=0 then% 01604 + begin stype:=curtype;% 01605 + if typetab1[curtype].form>char then error(72);% 01606 + end else checktypes(stype,curtype);% 01607 + end;% 01608 + putsym(","); putconst(cardcnt); putsym(")");% 01609 + if cursy=comma then puttext(" or");% 01610 + end until cursy!comma;% 01611 + if cursy!rbracket then% 01612 + begin error(59); skip(rbracket);% 01613 + if cursy=rbracket then insymbol;% 01614 + end else insymbol;% 01615 + newtype; t1:=set; t1.size:=1; t1.struct:=0;% 01616 + t1.settype:=stype; typetab1[typeindex]:=t1;% 01617 + curtype:=typeindex;% 01618 + curmode:=bitpattern;% 01619 + end;% 01620 + end of set constant else begin error(99); insymbol end;% 01621 +end of factor;% 01622 +% 01623 +% 01624 +procedure term; %*** term *** 01625 +begin %************ 01626 + integer startsym,mode,type1,muloptr,f;% 01627 + putdummy; startsym:=numsyms;% 01628 + factor;% 01629 + mode:=curmode;% 01630 + while cursy}asterisk and cursy{modsy do % "*","/","div","mod","and" 01631 + begin% 01632 + type1:=curtype; muloptr:=cursy;% 01633 + f:=typetab1[type1].form;% 01634 + if f=numeric or f=floating then% 01635 + begin% 01636 + mode:=number;% 01637 + if cursy=asterisk then putsym("|") else% 01638 + if cursy=slash then putsym("/") else% 01639 + if cursy=andsy then error(64) else% 01640 + begin % 01641 + if f=floating then error(64);% 01642 + if cursy=divsy then puttext(" div") else puttext(" mod");% 01643 + end end else% 01644 + if curtype=booltype or f=set then% 01645 + begin% 01646 + mode:=bitpattern;% 01647 + if curmode!mode then% 01648 + begin symtab[startsym]:=" b("; putsym(")") end;% 01649 + puttext(" and ");% 01650 + if cursy!(if f=set then asterisk else andsy) then error(64);% 01651 + end else error(64);% 01652 + putdummy; startsym:=numsyms;% 01653 + insymbol; factor;% 01654 + if curtype>0 and type1>0 then% 01655 + begin% 01656 + if curtype!type1 then% 01657 + begin% 01658 + if typetab1[type1].form!numeric or curtype!realtype then% 01659 + checktypes(type1,curtype);% 01660 + if type1=realtype then curtype:=realtype;% 01661 + end;% 01662 + if curtype=realtype and muloptr}divsy then error(65);% 01663 + end;% 01664 + if muloptr=slash then curtype:=realtype;% 01665 + if curtype=0 then curtype:=type1;% 01666 + end of while loop;% 01667 + if mode=bitpattern and curmode!mode then% 01668 + begin symtab[startsym]:=" b("; putsym(")") end;% 01669 + curmode:=mode;% 01670 +end of term;% 01671 +% 01672 +% 01673 +procedure simpleexpression; %*** simple expression *** 01674 +begin %************************* 01675 + integer startsym,mode,type1,f;% 01676 + boolean signed;% 01677 +% 01678 + putdummy; startsym:=numsyms;% 01679 + if cursy=plus or cursy=minus then% 01680 + begin signed:=true;% 01681 + putsym(if cursy=plus then"+" else "-");% 01682 + insymbol;% 01683 + end;% 01684 + term;% 01685 + mode:=curmode;% 01686 + if signed then% 01687 + begin f:=typetab1[curtype].form;% 01688 + if f!numeric and f!floating then error(29);% 01689 + end;% 01690 + while cursy}plus and cursy{orsy do % "+","-","or" 01691 + begin% 01692 + type1:=curtype; f:=typetab1[type1].form;% 01693 + if f=numeric or f=floating then% 01694 + begin mode:=number;% 01695 + if cursy=plus then putsym("+") else% 01696 + if cursy=minus then putsym("-") else error(64);% 01697 + end else% 01698 + if curtype=booltype then% 01699 + begin% 01700 + mode:=bitpattern;% 01701 + if curmode!mode then% 01702 + begin symtab[startsym]:=" b("; putsym(")") end;% 01703 + if cursy=orsy then puttext(" or") else error(64);% 01704 + end else% 01705 + if f=set then% 01706 + begin% 01707 + mode:=bitpattern;% 01708 + if curmode!mode then% 01709 + begin symtab[startsym]:=" b("; putsym(")"); end;% 01710 + if cursy=plus then puttext(" or") else% 01711 + if cursy=minus then begin puttext(" and");puttext(" not ")end 01712 + else error(64);% 01713 + end else error(64);% 01714 + insymbol;% 01715 + putdummy; startsym:=numsyms;% 01716 + term;% 01717 + if curtype>0 and type1>0 then% 01718 + begin% 01719 + if curtype!type1 then% 01720 + begin% 01721 + if typetab1[type1].form!numeric or curtype!realtype then% 01722 + checktypes(type1,curtype);% 01723 + if type1=realtype then curtype:=realtype;% 01724 + end end;% 01725 + if curtype=0 then curtype:=type1;% 01726 + end of while loop;% 01727 + if mode=bitpattern and curmode!bitpattern then% 01728 + begin symtab[startsym]:=" b("; putsym(")") end;% 01729 + curmode:=mode;% 01730 +end of simpleexpression;% 01731 +% 01732 +% 01733 +procedure expression; %*** expression *** 01734 +begin %****************** 01735 + integer startsym,firstsym,type1,reloptr,f;% 01736 + boolean callgen;% 01737 +% 01738 + exprlevel:=exprlevel+1;% 01739 + if exprlevel = 1 then% 01740 + begin% 01741 + putdummy;% 01742 + firstsym := numsyms;% 01743 + end;% 01744 + putdummy; startsym:=numsyms;% 01745 + putdummy;% 01746 + simpleexpression;% 01747 + if cursy}lsssy and cursy{insy then % "<","{","}",">","=","!","in" 01748 + begin% 01749 + type1:=curtype; f:=typetab1[type1].form;% 01750 + reloptr:=cursy;% 01751 + if f{alfa then% 01752 + begin% 01753 + if curmode=bitpattern then% 01754 + begin symtab[startsym]:=" real("; putsym(")") end;% 01755 + if cursy=lsssy then putsym("<") else% 01756 + if cursy=leqsy then putsym("{") else% 01757 + if cursy=geqsy then putsym("}") else% 01758 + if cursy=gtrsy then putsym(">") else% 01759 + if cursy=eqlsy then putsym("=") else% 01760 + if cursy=neqsy then putsym("!") else% 01761 + begin% 01762 + if f}floating then error(64);% 01763 + symtab[startsym]:="intst("; putsym(","); callgen:=true;% 01764 + end;% 01765 + end else% 01766 + if f=set then% 01767 + begin% 01768 + if curmode=bitpattern then% 01769 + begin symtab[startsym+1]:=" real("; putsym(")") end;% 01770 + if cursy=eqlsy or cursy=neqsy then% 01771 + begin putsym(if cursy=eqlsy then "=" else "!");% 01772 + end else% 01773 + begin% 01774 + if cursy=leqsy then symtab[startsym]:="incl1(" else% 01775 + if cursy=geqsy then symtab[startsym]:="incl2(" else error(64); 01776 + putsym(","); callgen:=true;% 01777 + end end else% 01778 + if f=pointers then% 01779 + begin% 01780 + if cursy=eqlsy then putsym("=") else% 01781 + if cursy=neqsy then putsym("!") else error(64);% 01782 + end else error(64);% 01783 + insymbol;% 01784 + putdummy; startsym:=numsyms;% 01785 + simpleexpression;% 01786 + if curtype>0 and type1>0 then% 01787 + if curtype!type1 then% 01788 + if reloptr!insy then% 01789 + begin % 01790 + if typetab1[type1].form!numeric or curtype!realtype then% 01791 + checktypes(type1,curtype);% 01792 + end else% 01793 + if typetab1[curtype].form!set then error(66)% 01794 + else checktypes(type1,typetab1[curtype].settype);% 01795 + if curmode=bitpattern then% 01796 + begin symtab[startsym]:=" real("; putsym(")") end;% 01797 + if callgen then putsym(")");% 01798 + curtype:=booltype; curmode:=bitpattern;% 01799 + end;% 01800 + exprlevel:=exprlevel-1;% 01801 + if exprlevel=0 then% 01802 + begin% 01803 + if curmode=bitpattern then% 01804 + begin% 01805 + symtab[firstsym] := " real(";% 01806 + putsym(")");% 01807 + end;% 01808 + writeexpr;% 01809 + end;% 01810 +end of expression;% 01811 +% 01812 +% 01813 +define boolexpr=% 01814 +begin % 01815 + putdummy; exprlevel:=1; expression;% 01816 + if curtype>0 then if curtype!booltype then error(17);% 01817 + if curmode!bitpattern then% 01818 + begin symtab[1]:=" b("; putsym(")") end;% 01819 + exprlevel:=0; writeexpr;% 01820 +end of boolean#;% 01821 +$ page% 01822 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 01823 +% % 01824 +% % 01825 +% % 01826 +% part 5: intrinsic routines. % 01827 +% ------------------- % 01828 +% % 01829 +% % 01830 +% % 01831 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 01832 +% 01833 +% 01834 +procedure concat; %*** "concat" *** 01835 +begin %**************** 01836 + define intexpr=% 01837 + begin insymbol; expression;% 01838 + if curtype>0 then % 01839 + if typetab1[curtype].form!numeric then error(17);% 01840 + end #;% 01841 +% 01842 + puttext("concat"); putsym("("); % 01843 + insymbol;% 01844 + if cursy=lpar then% 01845 + begin% 01846 + insymbol; expression;% 01847 + if curtype>0 then% 01848 + if typetab1[curtype].form>alfa then error(17);% 01849 + if cursy=comma then% 01850 + begin% 01851 + putsym(","); insymbol; expression;% 01852 + if curtype>0 then% 01853 + if typetab1[curtype].form>alfa then error(17);% 01854 + if cursy=comma then% 01855 + begin% 01856 + putsym(","); intexpr;% 01857 + if cursy=comma then% 01858 + begin% 01859 + putsym(","); intexpr;% 01860 + if cursy=comma then% 01861 + begin% 01862 + putsym(","); intexpr;% 01863 + putsym(","); putconst(cardcnt);% 01864 + putsym(")");% 01865 + if cursy!rpar then begin error(3); skip(rpar) end;% 01866 + end else begin error(3); skip(rpar) end;% 01867 + end else begin error(3); skip(rpar) end;% 01868 + end else begin error(3); skip(rpar) end;% 01869 + end else begin error(3); skip(rpar) end;% 01870 + end else begin error(3); skip(rpar) end;% 01871 + curtype:=realtype;% 01872 + if cursy=rpar then insymbol;% 01873 +end of concat;% 01874 +% 01875 +% 01876 +procedure pread(changeline);% 01877 +value changeline; boolean changeline;% 01878 +begin% 01879 + integer fileid,f;% 01880 + boolean check;% 01881 + gen(" begin",7,2);% 01882 + fileparam(inputfile); fileid:=filename;% 01883 + if typetab1[curtype].form=files then error(85);% 01884 + if symkind[cursy]!terminal then% 01885 + begin% 01886 + if cursy neq rpar then% 01887 + do begin% 01888 + while cursy=comma do insymbol;% 01889 + if cursy=identifier then% 01890 + begin% 01891 + search;% 01892 + if found then% 01893 + begin% 01894 + if thisid.idclass=var or% 01895 + thisid.idclass=const and boolean(thisid.formal) then% 01896 + begin% 01897 + variable; f:=typetab1[curtype].form;% 01898 + if f=numeric or f=floating or f=char then% 01899 + begin% 01900 + check:=checkoption and f!floating;% 01901 + writeexpr; gen(":=",2,6);% 01902 + if check then gen("check(",6,2);% 01903 + gen("pread(",6,2); genid("f",fileid,5); gen(",",1,7);% 01904 + genid("v",fileid,5); gen(",",1,7);% 01905 + genid("i",fileid,5); gen(",",1,7);% 01906 + if f=numeric then genint(2) else% 01907 + if f=floating then genint(3) else genint(1);% 01908 + gen(",",1,7); genint(cardcnt); gen(")",1,7);% 01909 + if check then% 01910 + begin% 01911 + gen(",",1,7); genint(typetab2[curtype]); gen(",",1,7); 01912 + genint(typetab3[curtype]); gen(",",1,7);% 01913 + genint(cardcnt); gen(")",1,7);% 01914 + end;% 01915 + end else begin error(82); insymbol end;% 01916 + end else begin error(8); insymbol end;% 01917 + end else begin error(1); insymbol end;% 01918 + end else error(9);% 01919 + gen(";",1,7);% 01920 + end until cursy!comma;% 01921 + if cursy!rpar then begin error(46); skip(rpar) end;% 01922 + if cursy=rpar then insymbol;% 01923 + end;% 01924 + if changeline then% 01925 + begin% 01926 + gen("rline(",6,2); genid("f",fileid,5); gen(",",1,7);% 01927 + genid("v",fileid,5); gen(",",1,7);% 01928 + genid("i",fileid,5); gen(")",1,7);% 01929 + end;% 01930 + gen("end",4,5);% 01931 + end of pread;% 01932 +% 01933 +% 01934 +procedure pwrite(linefeed);% 01935 +value linefeed; boolean linefeed;% 01936 +begin% 01937 + integer fileid,f,i,lastsy;% 01938 + pointer p;% 01939 + gen(" begin",7,2);% 01940 + fileparam(outputfile); fileid:=filename;% 01941 + if typetab1[curtype].form=files then error(85);% 01942 + if symkind[cursy]!terminal then% 01943 + begin% 01944 + if cursy neq rpar then% 01945 + do begin% 01946 + while cursy=comma do insymbol;% 01947 + if cursy=alfaconst and curlength>7 then% 01948 + begin% 01949 + gen("walfa(",6,2); genid("f",fileid,5); gen(",",1,7);% 01950 + genid("v",fileid,6); gen(",",1,7);% 01951 + genid("i",fileid,5); gen(",",1,7);% 01952 + p:=stringpnt;% 01953 + for i:=1 step 7 until 80 do% 01954 + if i{curlength then% 01955 + begin% 01956 + if algolcnt<10 then writealgol;% 01957 + replace algolpnt:algolpnt by """, p:p for 7, """, ",";% 01958 + algolcnt:=algolcnt-10;% 01959 + end else gen("0,",2,6);% 01960 + genint(curlength); gen(",",1,7);% 01961 + genint(cardcnt); gen(")",1,7);% 01962 + insymbol;% 01963 + end of alfaconst else% 01964 + begin% 01965 + gen("pwrite(",7,1); genid("f",fileid,5); gen(",",1,7);% 01966 + genid("v",fileid,5); gen(",",1,7);% 01967 + genid("i",fileid,5); gen(",",1,7);% 01968 + lastsy:=cursy;% 01969 + expression; f:=typetab1[curtype].form;% 01970 + gen(",",1,7);% 01971 + if f=numeric or f=floating or f=char or f=alfa or% 01972 + curtype=booltype then% 01973 + begin% 01974 + if f=numeric then genint(1) else% 01975 + if f=floating then genint(2) else% 01976 + if f=alfa then genint(5) else% 01977 + if f=char then genint(4) else genint(3);% 01978 + gen(",",1,7);% 01979 + if cursy=colon then% 01980 + begin% 01981 + insymbol; expression;% 01982 + if typetab1[curtype].form neq numeric then error(17);% 01983 + gen(",",1,7);% 01984 + if cursy=colon then% 01985 + begin% 01986 + if f!floating then error(4);% 01987 + insymbol; expression;% 01988 + if typetab1[curtype].form neq numeric then error(17);% 01989 + gen(",",1,7);% 01990 + end else gen("-1,",3,5);% 01991 + end else% 01992 + begin% 01993 + if f=floating then genint(16) else% 01994 + if f=alfa and lastsy=alfaconst then genint(curlength) else 01995 + if f=alfa then genint(7) else% 01996 + if f=char then genint(1) else genint(10);% 01997 + gen(",-1",4,4);% 01998 + end;% 01999 + end else error(17);% 02000 + genint(cardcnt); gen(")",1,7);% 02001 + end of expression;% 02002 + gen(";",1,7);% 02003 + end until cursy!comma;% 02004 + if cursy!rpar then begin error(46); skip(rpar) end;% 02005 + if cursy=rpar then insymbol;% 02006 + end;% 02007 + filename:=fileid;% 02008 + if linefeed then% 02009 + begin% 02010 + integer dummy;% 02011 + gen("wline(",6,2); genid("f",filename,5); gen(",",1,7);% 02012 + genid("v",filename,5); gen(",",1,7);% 02013 + genid("i",filename,5); gen(")",1,7);% 02014 + end;% 02015 + gen("end",4,5);% 02016 +end of pwrite;% 02017 +% 02018 +% 02019 +procedure filehandling(procnum); %*** file handling procedures: 02020 +value procnum; integer procnum; %*** 02021 +begin %*** 1) put 02022 + integer f; %*** 2) get 02023 + case procnum of %*** 3) reset 02024 + begin ; %*** 4) rewrite 02025 + gen("put",3,5); %*** 5) page 02026 + gen("get",3,5); % 02027 + gen("reset",5,3); % 02028 + gen("rewrite",7,1); % 02029 + gen("page",4,4); % 02030 + end; % 02031 + gen("(",1,7); fileparam(0);% 02032 + if filename=0 then error(78); % 02033 + f:=typetab1[curtype].form;% 02034 + if f=files and procnum=5 then error(80);% 02035 + genid("f",filename,5); gen(",",1,7);% 02036 + genid("v",filename,5); gen(",",1,7);% 02037 + genid("i",filename,5); gen(",",1,7);% 02038 + genint(cardcnt); gen(")",1,7);% 02039 + if cursy!rpar then begin error(46); skip(rpar) end;% 02040 + if cursy=rpar then insymbol;% 02041 +end of filehandling;% 02042 +% 02043 +% 02044 +procedure pack;% 02045 +begin% 02046 + integer it,t;% 02047 + gen("pack(",5,3);% 02048 + insymbol;% 02049 + if cursy=lpar then% 02050 + begin% 02051 + insymbol;% 02052 + if cursy=identifier then% 02053 + begin% 02054 + search;% 02055 + if found then% 02056 + begin% 02057 + if thisid.idclass=var then% 02058 + begin% 02059 + t:=typetab1[thisid.type];% 02060 + if t.form=arrays then% 02061 + begin% 02062 + it:=t.inxtype;% 02063 + if typetab1[t.arrtype].form!char then error(88);% 02064 + genid("v",1000|thislevel+thisindex,5);% 02065 + if thislevel>1 and thislevel!curlevel then error(5);% 02066 + gen(",",1,7); genint(typetab2[thisid.type]);% 02067 + gen(",",1,7); genint(typetab3[thisid.type]);% 02068 + end else error(88);% 02069 + end else error(88);% 02070 + end else error(1);% 02071 + end else error(9);% 02072 + insymbol;% 02073 + if cursy=comma then% 02074 + begin% 02075 + gen(",",1,7);% 02076 + insymbol; expression; checktypes(it,curtype);% 02077 + if cursy=comma then% 02078 + begin% 02079 + gen(",",1,7);% 02080 + insymbol;% 02081 + if cursy=identifier then% 02082 + begin% 02083 + search;% 02084 + if found then% 02085 + begin% 02086 + if thisid.idclass=var or% 02087 + thisid.idclass=const and boolean(thisid.formal) then% 02088 + begin% 02089 + variable; writeexpr;% 02090 + if curtype>0 then% 02091 + if typetab1[curtype].form!alfa then error(12);% 02092 + end else error(8);% 02093 + end else error(1);% 02094 + end else error(9);% 02095 + end else begin error(89); skip(rpar) end;% 02096 + end else begin error(89); skip(rpar) end;% 02097 + if cursy!rpar then begin error(46); skip(rpar) end;% 02098 + if cursy=rpar then insymbol;% 02099 + end else begin error(3); insymbol end;% 02100 + gen(",",1,7); genint(cardcnt); gen(")",1,7);% 02101 +end of pack; % 02102 +% 02103 +% 02104 +procedure unpack;% 02105 +begin% 02106 + integer it,t;% 02107 + gen("unpack(",7,1); insymbol;% 02108 + if cursy=lpar then% 02109 + begin% 02110 + insymbol; expression;% 02111 + if curtype>0 then if typetab1[curtype].form!alfa then error(17);% 02112 + if cursy=comma then% 02113 + begin% 02114 + gen(",",1,7); insymbol;% 02115 + if cursy=identifier then% 02116 + begin% 02117 + search;% 02118 + if found then% 02119 + begin% 02120 + if thisid.idclass=var then% 02121 + begin% 02122 + t:=typetab1[thisid.type];% 02123 + if t.form=arrays then% 02124 + begin% 02125 + it:=t.inxtype;% 02126 + if typetab1[t.arrtype].form!char then error(88);% 02127 + if thislevel>1 and thislevel!curlevel then error(5);% 02128 + genid("v",1000|thislevel+thisindex,5);% 02129 + gen(",",1,7); genint(typetab2[thisid.type]);% 02130 + gen(",",1,7); genint(typetab3[thisid.type]);% 02131 + end else error(88); % 02132 + end else error(88);% 02133 + end else error(1);% 02134 + end else error(9);% 02135 + insymbol; % 02136 + if cursy=comma then% 02137 + begin % 02138 + gen(",",1,7);% 02139 + insymbol; expression; checktypes(it,curtype);% 02140 + end else begin error(89); skip(rpar) end;% 02141 + end else begin error(89); skip(rpar) end;% 02142 + if cursy!rpar then begin error(89); skip(rpar) end;% 02143 + if cursy=rpar then insymbol;% 02144 + end else begin error(3); insymbol end;% 02145 + gen(",",1,7); genint(cardcnt); gen(")",1,7);% 02146 +end of unpack;% 02147 +% 02148 +% 02149 +procedure newdisp; %*** "new","dispose" 02150 +begin% 02151 + integer t1;% 02152 + if curname1="3000new" then gen("new(",4,4) else% 02153 + begin gen("dispose",7,1); gen("(",1,7) end;% 02154 + insymbol;% 02155 + if cursy=lpar then% 02156 + begin% 02157 + insymbol;% 02158 + if cursy=identifier then% 02159 + begin% 02160 + search;% 02161 + if found then% 02162 + begin% 02163 + variable;% 02164 + if curtype>0 then if typetab1[curtype].form=pointers then% 02165 + begin% 02166 + writeexpr; gen(",",1,7);% 02167 + t1:=typetab1[curtype].pointtype;% 02168 + t1:=typetab1[t1].size;% 02169 + if t1>1023 then error(86);% 02170 + genint(t1); gen(")",1,7);% 02171 + end else error(81);% 02172 + end else begin error(1); insymbol end;% 02173 + end else error(9);% 02174 + while cursy=comma do% 02175 + begin insymbol;% 02176 + if cursy neq identifier then error(9);% 02177 + if cursy neq rpar then insymbol;% 02178 + end;% 02179 + end else begin error(58); skip(rpar) end;% 02180 + if cursy!rpar then begin error(46); skip(rpar) end;% 02181 + if cursy=rpar then insymbol;% 02182 +end of newdisp;% 02183 +% 02184 + % 02185 +$ page% 02186 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02187 +% % 02188 +% % 02189 +% part 6: the statement parser. % 02190 +% --------------------- % 02191 +% % 02192 +% % 02193 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02194 +% 02195 +% 02196 +% 02197 +procedure statement; forward;% 02198 +% 02199 +procedure assignment;% 02200 +begin% 02201 + integer lefttype;% 02202 + label assign,exit;% 02203 + if found then% 02204 + begin% 02205 + if thisid.idclass=var or% 02206 + thisid.idclass=const and boolean(thisid.formal) then% 02207 + begin% 02208 + variable; lefttype:=curtype;% 02209 +assign: if cursy!assignsy then% 02210 + begin error(28); skip(assignsy);% 02211 + if symkind[cursy]=terminal then go to exit;% 02212 + end;% 02213 + insymbol;% 02214 + if typetab1[lefttype].struct>0 then% 02215 + begin% 02216 + error(95);% 02217 + end else% 02218 + begin% 02219 + writeexpr; gen(":=",2,6);% 02220 + if checkoption and typetab1[lefttype].form{char then% 02221 + checkexpr(typetab2[lefttype],typetab3[lefttype]) else% 02222 + expression;% 02223 + writeexpr;% 02224 + checktypes(lefttype,curtype);% 02225 + end;% 02226 + end else% 02227 + begin % function assignment. 02228 + if thislevel!curlevel-1 or thisindex!curfunc then error(5);% 02229 + genid("v",1000|thislevel+thisindex,5); lefttype:=thisid.type;% 02230 + insymbol; go to assign;% 02231 + end;% 02232 + end else% 02233 + begin% 02234 + skip(assignsy);% 02235 + if cursy=assignsy then go to assign;% 02236 + end;% 02237 +exit:% 02238 +end of assignment;% 02239 +% 02240 +% 02241 +procedure compstat;% 02242 +begin% 02243 + integer beginnum;% 02244 + label statm;% 02245 +% 02246 + beginnum:=numbegins:=numbegins+1; margin(" b",beginnum);% 02247 + gen("begin",6,3);% 02248 + do begin% 02249 + if cursy=semicolon or cursy=beginsy then insymbol;% 02250 +statm: statement;% 02251 + gen(";",1,7);% 02252 + if cursy=elsesy then begin error(20); insymbol; go statm end;% 02253 + if symkind[cursy]=initial then begin error(21); go statm end;% 02254 + end until cursy!semicolon;% 02255 + if cursy!endsy then% 02256 + begin error(24); skip(endsy);% 02257 + if cursy!endsy then begin insymbol; go to statm end;% 02258 + end;% 02259 + gen(" end",5,4); margin(" e",beginnum);% 02260 + insymbol;% 02261 +end of compstat;% 02262 +% 02263 +% 02264 +procedure ifstat;% 02265 +begin% 02266 + label exit;% 02267 + gen("if",3,6);% 02268 + insymbol; boolexpr;% 02269 + if cursy!thensy then% 02270 + begin if curtype>0 then error(27);% 02271 + skip(thensy);% 02272 + if cursy!thensy then% 02273 + begin if curtype=0 then error(27);% 02274 + if symkind[cursy]=terminal then go to exit;% 02275 + end; end;% 02276 + gen(" then",6,3);% 02277 + insymbol; statement;% 02278 + if cursy=elsesy then% 02279 + begin gen(" else",6,3); insymbol; statement end;% 02280 +exit:% 02281 +end of ifstat;% 02282 +% 02283 +% 02284 +procedure casestat;% 02285 +begin% 02286 + define casehash(n)=(n).[38:39] mod maxcases#;% 02287 + integer array casetab[0:maxcases];% 02288 + integer casenum,casetype,ncaselabs,tempvarnum,conval,contype,c,t;% 02289 + boolean zerolab,first;% 02290 +% 02291 + casenum:=numcases:=numcases+1; margin("cb",casenum);% 02292 + tempvarnum:=numtemps:=numtemps+1;% 02293 + if tempvarnum>maxtemps then error(16);% 02294 + gen("begin",6,3); genid("t",tempvarnum,2); gen(":=",2,6);% 02295 + insymbol; expression;% 02296 + gen(";",1,7); casetype:=curtype;% 02297 + if typetab1[casetype].form}floating then% 02298 + begin error(17); casetype:=0 end;% 02299 + if cursy!ofsy then% 02300 + begin if casetype>0 then error(18);% 02301 + skip(ofsy);% 02302 + if cursy=ofsy then insymbol else% 02303 + if casetype=0 then error(18);% 02304 + end else insymbol;% 02305 + do begin% 02306 + while cursy=semicolon do insymbol;% 02307 + first:=true;% 02308 + if cursy!endsy then% 02309 + begin% 02310 + gen("if",3,6);% 02311 + do begin% 02312 + if first then first:=false else insymbol;% 02313 + constant(conval,contype);% 02314 + if contype>0 then% 02315 + begin% 02316 + if casetype=0 then casetype:=contype else% 02317 + checktypes(casetype,contype);% 02318 + genid("t",tempvarnum,2); gen("=",1,7); genint(conval);% 02319 + ncaselabs:=ncaselabs+1;% 02320 + if ncaselabs0 then error(19);% 02357 + skip(dosy);% 02358 + if cursy!dosy then% 02359 + begin if curtype=0 then error(19);% 02360 + go to if symkind[cursy]=initial then statm else exit;% 02361 + end; end;% 02362 + gen(" do",4,5);% 02363 + insymbol;% 02364 +statm: statement;% 02365 +exit:% 02366 +end of whilestat;% 02367 +% 02368 +% 02369 +procedure repeatstat;% 02370 +begin% 02371 + integer repnum;% 02372 + label newtry;% 02373 +% 02374 + repnum:=numreps:=numreps+1;% 02375 + margin(" r",repnum);% 02376 + gen("do",3,6); gen("begin",6,3);% 02377 + do begin% 02378 + insymbol;% 02379 +newtry: statement;% 02380 + gen(";",1,7);% 02381 + if cursy=elsesy then begin error(20);insymbol; go newtry end;% 02382 + if symkind[cursy]=initial then begin error(21); go newtry end;% 02383 + end until cursy!semicolon;% 02384 + if cursy!untilsy then% 02385 + begin% 02386 + error(22);% 02387 + while cursy!untilsy and symkind[cursy]!initial do% 02388 + begin insymbol; skip(untilsy) end;% 02389 + if cursy!untilsy then go to newtry;% 02390 + end;% 02391 + gen(" end",5,4); gen("until",6,3); margin(" u",repnum);% 02392 + insymbol; boolexpr;% 02393 +end of repeatstat;% 02394 +% 02395 +% 02396 +procedure forstat;% 02397 +begin% 02398 + integer vartype,varnum,llim,ulim;% 02399 + boolean down;% 02400 + label statm;% 02401 +% 02402 + gen("begin",6,3);% 02403 + insymbol;% 02404 + if cursy=identifier then% 02405 + begin% 02406 + search;% 02407 + if found then% 02408 + begin% 02409 + varnum:=1000|thislevel+thisindex;% 02410 + if thisid.idclass=var or% 02411 + thisid.idclass=const and boolean(thisid.formal) then% 02412 + begin% 02413 + if thislevel>1 and thislevelcurlevel then error(83);% 02415 + vartype:=thisid.type;% 02416 + if typetab1[vartype].form{char then% 02417 + begin% 02418 + llim:=typetab2[vartype]; ulim:=typetab3[vartype];% 02419 + end else begin error(12); vartype:=0 end;% 02420 + end else error(8);% 02421 + end else error(1);% 02422 + end else error(9);% 02423 + insymbol;% 02424 + if cursy!assignsy then% 02425 + begin error(28);% 02426 + skip(assignsy);% 02427 + if cursy=assignsy then insymbol else% 02428 + if symkind[cursy]=initial then go to statm;% 02429 + end else insymbol;% 02430 + genid("v",varnum,5); gen("~",1,7);% 02431 + if checkoption then checkexpr(llim,ulim) else expression;% 02432 + writeexpr;% 02433 + gen(";",1,7);% 02434 + if vartype=0 then vartype:=curtype else checktypes(vartype,curtype); 02435 + numtemps:=numtemps+1; if numtemps>maxtemps then error(16);% 02436 + if cursy=tosy then insymbol else% 02437 + if cursy=downtosy then begin down:=true; insymbol end else% 02438 + begin if curtype>0 then error(23);% 02439 + skip(tosy);% 02440 + if cursy=tosy then insymbol else% 02441 + begin if curtype=0 then error(23);% 02442 + if symkind[cursy]=initial then go to statm;% 02443 + end; end;% 02444 + genid("t",numtemps,2); gen("~",1,7);% 02445 + if checkoption then checkexpr(llim,ulim) else expression;% 02446 + writeexpr;% 02447 + gen(";",1,7);% 02448 + if vartype=0 then vartype:=curtype else checktypes(vartype,curtype); 02449 + if cursy!dosy then% 02450 + begin if curtype>0 then error(19);% 02451 + skip(dosy);% 02452 + if cursy=dosy then insymbol else% 02453 + if curtype=0 then error(19);% 02454 + end else insymbol;% 02455 + gen("for",4,5); genid("v",varnum,5); gen("~",1,7);% 02456 + genid("v",varnum,5); gen(" ",1,7);% 02457 + if down then gen("downto",7,2) else gen("upto",5,4);% 02458 + genid("t",numtemps,2); gen(" do",4,5);% 02459 +statm: statement;% 02460 + gen(" end",5,4);% 02461 + numtemps:=numtemps-1;% 02462 +end of forstat;% 02463 +% 02464 +% 02465 +procedure gotostat;% 02466 +begin% 02467 + integer i;% 02468 + insymbol;% 02469 + if cursy=intconst then% 02470 + begin i:=numlabs;% 02471 + while i}1 and labtab[i].labval!curval do i:=i-1;% 02472 + if i=0 then error(15);% 02473 + gen("go",3,6); genid("l",curval,4);% 02474 + insymbol;% 02475 + end else error(10);% 02476 +end of gotostat;% 02477 +% 02478 +% 02479 +procedure withstat;% 02480 +begin% 02481 + integer startlevel,veryfirstwithsym,i;% 02482 + real d;% 02483 + startlevel:=toplevel; veryfirstwithsym:=nwithsyms;% 02484 + do begin% 02485 + insymbol;% 02486 + if cursy=identifier then% 02487 + begin% 02488 + search;% 02489 + if found then% 02490 + begin% 02491 + if thisid.idclass=var then% 02492 + begin% 02493 + variable;% 02494 + if curtype>0 then% 02495 + if typetab1[curtype].form!record then error(98);% 02496 + if simplevariable then% 02497 + begin putsym("["); insidebrackets:=true end;% 02498 + if toplevelmaxwithsyms then error(63) else% 02507 + for i:=1 step 1 until numsyms do% 02508 + begin% 02509 + withtab[nwithsyms]:=symtab[i];% 02510 + nwithsyms:=nwithsyms+1;% 02511 + end;% 02512 + d.lastwithsym:=nwithsyms-1;% 02513 + display[toplevel]:=d;% 02514 + end else error(84);% 02515 + end else begin error(8); insymbol end;% 02516 + end else begin error(1); insymbol end;% 02517 + end else begin error(9); insymbol end;% 02518 + numsyms:=0;% 02519 + numpointers := 0;% 02520 + end until cursy!comma;% 02521 + if cursy!dosy then% 02522 + begin error(19); skip(dosy);% 02523 + if cursy=dosy then insymbol;% 02524 + end else insymbol;% 02525 + statement;% 02526 + toplevel:=startlevel; nwithsyms:=veryfirstwithsym;% 02527 +end of withstat;% 02528 +% 02529 +% 02530 +procedure statement;% 02531 +begin% 02532 + integer i;% 02533 + label labfound;% 02534 +% 02535 + if cursy=intconst then % *** labeled statement *** 02536 + begin% 02537 + for i:=firstlab step 1 until numlabs do% 02538 + if labtab[i].labval=curval then% 02539 + begin if labtab[i].labdef=1 then error(31);% 02540 + labtab[i].labdef:=1;% 02541 + go to labfound;% 02542 + end;% 02543 + error(15);% 02544 +labfound: genid("l",curval,4); gen(":",1,7);% 02545 + insymbol;% 02546 + if cursy!colon then% 02547 + begin error(26);% 02548 + skip(colon); if cursy=colon then insymbol;% 02549 + end else insymbol;% 02550 + end;% 02551 +% 02552 + comment *** start of statement *** ;% 02553 +% 02554 + if cursy=identifier then% 02555 + begin% 02556 + search;% 02557 + if found then% 02558 + begin% 02559 + if thisid.idclass=var or% 02560 + thisid.idclass=const and boolean(thisid.formal) or% 02561 + thisid.idclass=func then assignment else% 02562 + if thisid.idclass=proc then% 02563 + begin% 02564 + if thislevel=0 then % *** intrinsic procedure *** 02565 + begin% 02566 + if curname1="50write" then pwrite(false) else% 02567 + if curname1="7writel" and% 02568 + curname2="000000n" then pwrite(true) else% 02569 + if curname1="400read" then pread(false) else% 02570 + if curname1="6readln" then pread(true) else% 02571 + if curname1="400page" then filehandling(5) else% 02572 + if curname1="3000get" then filehandling(2) else% 02573 + if curname1="3000put" then filehandling(1) else% 02574 + if curname1="50reset" then filehandling(3) else% 02575 + if curname1="7rewrit" and% 02576 + curname2="000000e" then filehandling(4) else% 02577 + if curname1="3000new" then newdisp else% 02578 + if curname1="7dispos" and% 02579 + curname2="000000e" then newdisp else% 02580 + if curname1="400pack" then pack else% 02581 + if curname1="6unpack" then unpack else error(0);% 02582 + end else passparams;% 02583 + writeexpr;% 02584 + end else begin error(13); skip(99) end;% 02585 + end else begin error(1); assignment end;% 02586 + end of identifier else% 02587 + if cursy=beginsy then compstat else% 02588 + if cursy=ifsy then ifstat else% 02589 + if cursy=casesy then casestat else% 02590 + if cursy=whilesy then whilestat else% 02591 + if cursy=repeatsy then repeatstat else% 02592 + if cursy=forsy then forstat else% 02593 + if cursy=withsy then withstat else% 02594 + if cursy=gotosy then gotostat else% 02595 + if symkind[cursy]!terminal then% 02596 + begin error(13); insymbol; skip(semicolon) end;% 02597 +end of statement;% 02598 +$ page% 02599 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02600 +% % 02601 +% % 02602 +% % 02603 +% part 7: type declarations. % 02604 +% ------------------ % 02605 +% % 02606 +% % 02607 +% % 02608 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02609 +% 02610 +% 02611 +real valx1,valx2;% 02612 +integer typex1,typex2;% 02613 +boolean packed;% 02614 +% 02615 +procedure fieldlist(rectab,firstaddr,lastaddr);% 02616 +value rectab,firstaddr;% 02617 +integer rectab,firstaddr,lastaddr;% 02618 +forward;% 02619 +% 02620 +define subrange= %*** subrange declaration*** 02621 +begin %*************************** 02622 + constant(valx1,typex1);% 02623 + if typetab1[typex1].form>char then error(11);% 02624 + if cursy!doubledot then error(53);% 02625 + insymbol;% 02626 + constant(valx2,typex2);% 02627 + if typex1>0 and typex2>0 then% 02628 + if typex1!typex2 then error(11) else% 02629 + if valx1>valx2 then error(54);% 02630 + t1:=typetab1[typex1].form; if t1=symbolic then t1:=subtype;% 02631 + newtype; ttype:=typeindex;% 02632 + t1.size:=tsize:=1; t1.struct:=0; t1.maintype:=typex1;% 02633 + typetab1[typeindex]:=t1;% 02634 + typetab2[typeindex]:=valx1; typetab3[typeindex]:=valx2;% 02635 +end of subrange#;% 02636 +% 02637 +% 02638 +procedure typedecl(ttype,tsize);% 02649 +integer ttype,tsize;% 02640 +begin% 02641 + procedure typerr(errnum,ttype,tsize);% 02642 + value errnum;% 02643 + integer errnum,ttype,tsize;% 02644 + begin error(errnum);% 02645 + ttype:=tsize:=0;% 02646 + end;% 02647 +% 02648 + integer recinx,arrstruct,tx,sx,t1,t2,t3,t,n;% 02649 + boolean first;% 02650 +% 02651 + packed:=false;% 02652 + if cursy=identifier then %*** simple type declaration *** 02653 + begin %******************************* 02654 + search;% 02655 + if found then% 02656 + begin% 02657 + if thisid.idclass=types then% 02658 + begin% 02659 + ttype:=thisid.type; tsize:=typetab1[ttype].size;% 02660 + insymbol;% 02661 + end else if thisid.idclass=const then subrange% 02662 + else typerr(7,ttype,tsize);% 02663 + end else begin typerr(1,ttype,tsize); insymbol end;% 02664 + end else% 02665 + if cursy{charconst or cursy=plus or cursy=minus then subrange else% 02666 + if cursy=lpar then% 02667 + begin% 02668 + n:=0;% 02669 + newtype; t3.idclass:=const; t3.type:=typeindex;% 02670 + do begin% 02671 + insymbol;% 02672 + if cursy=identifier then% 02673 + begin% 02674 + newname(curname1,curname2,curlevel);% 02675 + t3.info:=n; nametab3[curlevel,thisindex]:=t3;% 02676 + n:=n+1; insymbol;% 02677 + end else error(9);% 02678 + end until cursy!comma;% 02679 + if cursy!rpar then begin error(46); skip(rpar) end;% 02680 + t1:=symbolic; t1.struct:=0;% 02681 + t1.size:=tsize:=1; ttype:=typeindex;% 02682 + typetab1[typeindex]:=t1;% 02683 + typetab2[typeindex]:=0; typetab3[typeindex]:=n-1;% 02684 + if cursy=rpar then insymbol;% 02685 + end else% 02686 +% 02687 + if cursy=arrow then %*** pointer declaration *** 02688 + begin %*************************** 02689 + insymbol;% 02690 + if cursy=identifier then% 02691 + begin% 02692 + newtype; ttype:=typeindex; t1:=pointers;% 02693 + t1.size:=tsize:=1; t1.struct:=0;% 02694 + typetab1[typeindex]:=t1;% 02695 + search;% 02696 + if found then% 02697 + begin% 02698 + if thisid.idclass=types then% 02709 + typetab1[typeindex].pointtype:=thisid.type else% 02700 + typerr(7,ttype,tsize);% 02701 + end else% 02702 + begin% 02703 + if numpntrs0 then% 02722 + begin% 02723 + if typetab1[tx].form>char then error(48);% 02724 + t1:=arrays; t1.inxtype:=tx; t1.arrtype:=t;% 02725 + t2:=typetab2[tx]; t3:=typetab3[tx];% 02726 + if t3-t2>1022 then error(61);% 02727 + t1.size:=min(1023,t3-t2+1);% 02728 + newtype;% 02729 + typetab1[typeindex]:=t1;% 02730 + typetab2[typeindex]:=t2; typetab3[typeindex]:=t3;% 02731 + t:=typeindex;% 02732 + end;% 02733 + end until cursy!comma;% 02734 + if cursy!rbracket then error(59) else insymbol;% 02735 + if cursy!ofsy then begin error(18); skip(ofsy) end;% 02736 + insymbol;% 02737 + typedecl(tx,sx);% 02738 + if typetab1[tx].form}files then error(60);% 02739 + arrstruct:=typetab1[tx].struct;% 02740 + while t>0 do% 02741 + begin% 02742 + t1:=typetab1[t]; t3:=t1.arrtype;% 02743 + t1.arrtype:=tx; t1.struct:=arrstruct:=arrstruct+1;% 02744 + t1.size:=sx:=min(1024,sx|t1.size);% 02745 + typetab1[t]:=t1; tx:=t; t:=t3;% 02746 + end;% 02747 + ttype:=tx; tsize:=sx;% 02748 + end of array declaration else% 02749 +% 02750 + if cursy=filesy then %*** file declaration *** 02751 + begin %************************ 02752 + insymbol;% 02753 + if cursy!ofsy then% 02754 + begin error(18);% 02755 + if cursy!identifier then insymbol;% 02756 + end else insymbol;% 02757 + typedecl(tx,sx);% 02758 + if tx>0 then% 02759 + begin t:=typetab1[tx];% 02760 + if t.form}files then error(50) else% 02761 + if t.struct>1 then error(49)% 02762 + end;% 02763 + newtype; ttype:=typeindex;% 02764 + t1:=if t.form=char then textfile else files;% 02765 + t1.size:=tsize:=sx; t1.filetype:=tx;% 02766 + t1.struct:=1;% 02767 + typetab1[typeindex]:=t1;% 02768 + end of file declaration else% 02779 +% 02770 + if cursy=setsy then %*** set declaration *** 02771 + begin %*********************** 02772 + insymbol;% 02773 + if cursy!ofsy then% 02774 + begin error(18);% 02775 + if cursy>charconst then insymbol;% 02776 + end else insymbol;% 02777 + typedecl(tx,sx);% 02778 + if tx>0 then% 02779 + begin% 02780 + if typetab1[tx].form>char then error(48) else% 02781 + if typetab2[tx]<0 or typetab3[tx]>38 then error(51);% 02782 + end;% 02783 + newtype; ttype:=typeindex;% 02784 + t1:=set; t1.settype:=tx; t1.struct:=0;% 02785 + t1.size:=tsize:=1; typetab1[typeindex]:=t1;% 02786 + typetab2[typeindex]:=typetab2[tx];% 02787 + typetab3[typeindex]:=typetab3[tx];% 02788 + end of set declaration else% 02789 +% 02790 + if cursy=recordsy then %*** record declaration *** 02791 + begin %************************** 02792 + if lastrec-1>curlevel then lastrec:=lastrec-1 else error(55);% 02793 + recinx:=lastrec;% 02794 + blocktab[recinx]:=numblocks:=numblocks+1;% 02795 + insymbol;% 02796 + fieldlist(recinx,0,sx);% 02797 + if sx>1022 then begin error(56); sx:=1022 end;% 02798 + newtype; ttype:=typeindex;% 02799 + t1:=record; t1.rectab:=recinx; t1.struct:=1;% 02800 + t1.size:=tsize:=sx; typetab1[typeindex]:=t1;% 02801 + typetab2[typeindex]:=0; typetab3[typeindex]:=sx-1;% 02802 + if cursy!endsy then begin error(24); skip(endsy) end;% 02803 + if cursy=endsy then insymbol;% 02804 + end else begin error(4); skip(99) end;% 02805 + end;% 02806 +end of typedecl;% 02807 +% 02808 +% 02809 +procedure fieldlist(rectab,firstaddr,lastaddr);% 02810 +value rectab,firstaddr;% 02811 +integer rectab,firstaddr,lastaddr;% 02812 +begin% 02813 + integer array ilist[0:listlength];% 02814 + integer listinx;% 02815 + integer casetype,addr,maxaddr,index,ctype,tx,sx,t1,t3,llim,ulim,i;% 02816 + boolean first;% 02817 + real cval;% 02818 + label casetypeid,casepart,exit;% 02819 +% 02820 + addr:=firstaddr;% 02821 + do begin% 02822 + while cursy=semicolon do insymbol;% 02823 + if cursy=casesy then go to casepart;% 02824 + if cursy=identifier then% 02825 + begin% 02826 + listinx:=0; first:=true;% 02827 + do begin% 02828 + if first then first:=false else insymbol;% 02829 + if cursy=identifier then% 02830 + begin% 02831 + if listinx}listlength then begin error(37); listinx:=0 end;% 02832 + listinx:=listinx+1;% 02833 + newname(curname1,curname2,rectab);% 02834 + ilist[listinx]:=thisindex;% 02835 + insymbol;% 02836 + end else% 02837 + begin error(9);% 02838 + if cursy!comma then insymbol;% 02839 + end;% 02840 + end until cursy!comma;% 02841 + if cursy!colon then begin error(26); skip(colon) end;% 02842 + insymbol;% 02843 + typedecl(tx,sx);% 02844 + if tx>0 then if typetab1[tx].form}files then error(57);% 02845 + t3.idclass:=var; t3.type:=tx;% 02846 + for i:=1 step 1 until listinx do% 02847 + begin% 02848 + t3.info:=addr; addr:=min(addr+sx|1024);% 02849 + nametab3[rectab,ilist[i]]:=t3;% 02850 + end;% 02851 + end;% 02852 + end until cursy!semicolon;% 02853 + lastaddr:=addr;% 02854 + go to exit;% 02855 +% 02856 +casepart:% 02857 + listinx:=0; lastaddr:=addr; index:=-1;% 02858 + insymbol;% 02859 + if cursy=identifier then% 02860 + begin% 02861 + search;% 02862 + if found and thisid.idclass=types then go to casetypeid;% 02863 + newname(curname1,curname2,rectab); index:=thisindex;% 02864 + insymbol;% 02865 + if cursy!colon then error(26);% 02866 + insymbol;% 02867 + if cursy=identifier then% 02868 + begin% 02869 + search;% 02870 + if found then% 02871 + begin% 02872 + if thisid.idclass=types then% 02873 + begin% 02874 +casetypeid: casetype:=thisid.type; t1:=typetab1[casetype];% 02875 + llim:=typetab2[casetype]; ulim:=typetab3[casetype];% 02876 + if t1.form>char then error(48);% 02877 + if index}0 then% 02878 + begin% 02879 + t3.idclass:=var; t3.type:=casetype; t3.info:=addr;% 02880 + addr:=lastaddr:=addr+1; nametab3[rectab,index]:=t3;% 02881 + end;% 02882 + insymbol;% 02883 + end else begin error(7); skip(ofsy) end;% 02884 + end else begin error(1); skip(ofsy) end;% 02885 + end else begin error(9); skip(ofsy) end;% 02886 + end else begin error(9); skip(ofsy) end;% 02887 + if cursy!ofsy then begin error(18); skip(rpar) end;% 02888 + if cursy=ofsy then insymbol;% 02889 + if casetype=0 then begin llim:=-maxint; ulim:=maxint end;% 02890 + do begin% 02891 + while cursy=semicolon do insymbol;% 02892 + if cursy{charconst or cursy=plus or cursy=minus then% 02893 + begin% 02894 + first:=true;% 02895 + do begin% 02896 + if first then first:=false else insymbol;% 02897 + constant(cval,ctype);% 02898 + if ctype>0 then% 02899 + begin% 02900 + if casetype=0 then casetype:=ctype else% 02901 + if cvalulim then error(14) else% 02902 + checktypes(casetype,ctype);% 02903 + if listinx}listlength then begin error(30); listinx:=0 end;% 02904 + listinx:=listinx+1;% 02905 + ilist[listinx]:=cval; i:=1;% 02906 + while ilist[i]!cval do i:=i+1;% 02907 + if ilastaddr then lastaddr:=maxaddr;% 02916 + if cursy!rpar then begin error(46); skip(rpar) end;% 02917 + insymbol;% 02918 + end else error(58);% 02919 + end;% 02920 + end until cursy neq semicolon;% 02921 +exit:% 02922 +end of fieldlist;% 02923 +$ page% 02924 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02925 +% % 02926 +% % 02927 +% % 02928 +% part 8: the procedure block. % 02929 +% -------------------- % 02930 +% % 02931 +% % 02932 +% % 02933 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02934 +% 02935 +% 02936 +% 02937 +procedure declarevars(param,tab,first,last,level);% 02938 +value param,first,last,level;% 02939 +integer array tab[0];% 02940 +integer first,last,level;% 02941 +boolean param;% 02942 +begin% 02943 + integer level1000,typ,nam,namtab,t1,i,j,recsize;% 02944 + boolean realvar,arrayvar,firstdim,extfile;% 02945 + alpha fname;% 02946 + integer fnlength,fnstart;% 02947 +% 02948 + level1000:=level|1000;% 02949 + for i:=first step 1 until last do% 02950 + begin% 02951 + nam:=tab[i].[9:10]; namtab:=nametab3[level,nam];% 02952 + typ:=namtab.type; t1:=typetab1[typ];% 02953 + if namtab.idclass geq func then% 02954 + begin% 02955 + if realvar or arrayvar then% 02956 + begin% 02957 + gen(";",1,7);% 02958 + realvar:=arrayvar:=false;% 02959 + end;% 02960 + if namtab.idclass=func then gen("real",5,4);% 02961 + gen("procedu",8,1);% 02962 + genid("v",level1000+nam,5); gen(";",1,7);% 02963 + end else% 02964 + if t1.struct=0 then %*** simple type *** 02965 + begin% 02966 + if arrayvar then begin gen(";",1,7); arrayvar:=false end;% 02967 + if realvar then gen(",",1,7) else% 02968 + begin gen("real",5,4); realvar:=true end;% 02969 + genid("v",level1000+nam,5);% 02970 + end else% 02971 + begin% 02972 + if realvar then begin gen(";",1,7); realvar:=false end;% 02973 + if t1.form0 and curkind=const then error(94);% 03125 + end else if t.struct>0 then error(38);% 03126 + end else begin error(7); t3:=0 end;% 03127 + end else begin error(1); t3:=0 end;% 03128 + end else begin error(9); t3:=0 end;% 03129 + insymbol;% 03130 + end else% 03131 + begin% 03132 + if curkind!proc then error(7);% 03133 + t3:=0;% 03134 + end;% 03135 + t3.idclass:=curkind; t3.formal:=1;% 03136 + for i:=p1 step 1 until numparams do% 03137 + nametab3[curlevel+1,paramtab[i].paramname]:=t3;% 03138 + end until cursy!semicolon;% 03139 + if cursy!rpar then% 03140 + begin error(49); skip(rpar);% 03141 + if cursy=rpar then insymbol;% 03142 + end else insymbol% 03143 + end;% 03144 + paramtab[firstparam]:=numparams-firstparam;% 03145 +end of parameterlist;% 03146 +% 03147 +% 03148 +procedure block;% 03149 +begin% 03150 + integer index,ctype,numforwards,t,t3,tx,i;% 03151 + real cval;% 03152 + alpha c1,c2;% 03153 + boolean valueparams,fun;% 03154 + label start;% 03155 +% 03156 + integer labtabtop,consttabtop,typetabtop,paramtabtop,toprec,% 03157 + formerfirstlab,firstfile;% 03158 +% 03159 + formerfirstlab:=firstlab;% 03160 + labtabtop:=numlabs; firstlab:=labtabtop+1;% 03161 + consttabtop:=numconsts;% 03162 + typetabtop:=numtypes;% 03163 + paramtabtop:=numparams;% 03164 + toprec:=lastrec;% 03165 + firstfile:=numfiles+1;% 03166 +% 03167 + toplevel:=curlevel;% 03168 + if curlevel>1 then gen("begin",6,3);% 03169 +start:% 03170 + if cursy=labelsy then %*** label declaration *** 03171 + begin %************************* 03172 + gen("label",6,3);% 03173 + do begin% 03174 + insymbol;% 03175 + if cursy=intconst then% 03176 + begin% 03177 + genid("l",curval,4);% 03178 + if curval>9999 then error(33);% 03179 + for i:=firstlab step 1 until numlabs do% 03180 + if labtab[i].labval=curval then error(31);% 03181 + if numlabs}maxlabs then begin error(34); numlabs:=0 end;% 03182 + numlabs:=numlabs+1;% 03183 + labtab[numlabs]:=curval;% 03184 + insymbol;% 03185 + end else begin error(10); skip(comma) end;% 03186 + if cursy=comma then gen(",",1,7);% 03187 + end until cursy!comma;% 03188 + if cursy!semicolon then begin error(25); skip(semicolon) end;% 03189 + gen(";",1,7);% 03190 + if symkind[cursy]!initial then insymbol;% 03191 + end of label declaration;% 03192 +% 03193 + if cursy=constsy then %*** constant declaration *** 03194 + begin %**************************** 03195 + insymbol;% 03196 + do begin% 03197 + if cursy=identifier then% 03198 + begin% 03199 + newname(curname1,curname2,curlevel); index:=thisindex;% 03200 + insymbol;% 03201 + if cursy=eqlsy then% 03202 + begin% 03203 + insymbol; constant(cval,ctype);% 03204 + t3:=ctype; t3.idclass:=const;% 03205 + if cval.[46:8]!0 or cval>1023 then% 03206 + begin% 03207 + if numconsts}maxconsts then% 03208 + begin error(35); numconsts:=0 end;% 03209 + numconsts:=numconsts+1;% 03210 + consttab[numconsts]:=cval;% 03211 + t3.info:=1023+numconsts;% 03212 + end else t3.info:=cval;% 03213 + nametab3[curlevel,index]:=t3;% 03214 + end else begin error(36); skip(semicolon) end;% 03215 + end else begin error(9); skip(semicolon) end;% 03216 + if cursy!semicolon then begin error(25); skip(semicolon) end;% 03217 + if symkind[cursy]!initial then insymbol;% 03218 + end until cursy!identifier;% 03219 + end of constant declaration;% 03220 +% 03221 + if cursy=typesy then %*** type declaration **** 03222 + begin %************************* 03223 + insymbol;% 03224 + do begin% 03225 + if cursy=identifier then% 03226 + begin% 03227 + newname(curname1,curname2,curlevel); index:=thisindex;% 03228 + insymbol;% 03229 + if cursy=eqlsy then% 03230 + begin% 03231 + insymbol;% 03232 + typedecl(ctype,tx);% 03233 + t3:=ctype; t3.idclass:=types;% 03234 + nametab3[curlevel,index]:=t3;% 03235 + end else begin error(36); skip(semicolon) end;% 03236 + end else begin error(9); skip(semicolon) end;% 03237 + if cursy!semicolon then begin error(25); skip(semicolon) end;% 03238 + if symkind[cursy]!initial then insymbol;% 03239 + end until cursy!identifier;% 03240 + end of type declaration;% 03241 +% 03242 + if cursy=varsy then %*** variable declaration *** 03243 + begin %**************************** 03244 + varindex:=0;% 03245 + do begin% 03246 + firstvar:=varindex+1;% 03247 + do begin% 03248 + if cursy=varsy or cursy=comma then insymbol;% 03249 + if cursy=identifier then% 03250 + begin% 03251 + if varindex}listlength then% 03252 + begin error(37); varindex:=0 end;% 03253 + varindex:=varindex+1;% 03254 + newname(curname1,curname2,curlevel);% 03255 + varlist[varindex]:=thisindex;% 03256 + insymbol;% 03257 + end else begin error(9); skip(colon) end;% 03258 + end until cursy!comma;% 03259 + if cursy!colon then begin error(26); skip(colon) end;% 03260 + if cursy=colon then% 03261 + begin% 03262 + insymbol;% 03263 + typedecl(ctype,tx);% 03264 + t3:=ctype; t3.idclass:=var;% 03265 + for i:=firstvar step 1 until varindex do% 03266 + nametab3[curlevel,varlist[i]]:=t3;% 03267 + end else begin error(26); skip(semicolon) end;% 03268 + if cursy!semicolon then begin error(25); skip(semicolon) end;% 03269 + if symkind[cursy]!initial then insymbol;% 03270 + end until cursy!identifier;% 03271 + declarevars(false,varlist,1,varindex,curlevel);% 03272 + end of variable declarations;% 03273 +% 03274 + if numpntrs>0 then% 03275 + begin% 03276 + c1:=curname1; c2:=curname2;% 03277 + for i:=1 step 1 until numpntrs do% 03278 + begin% 03279 + curname1:=pntrtab1[i]; curname2:=pntrtab2[i];% 03280 + searchtab(curlevel);% 03281 + thisid:=nametab3[curlevel,thisindex];% 03282 + if found and thisid.idclass=types then% 03283 + typetab1[pntrtab3[i]].pointtype:=thisid.type else error(62);% 03284 + end;% 03285 + curname1:=c1; curname2:=c2; numpntrs:=0;% 03286 + end;% 03287 +% 03288 + while cursy=funcsy or cursy=procsy do %*** proc/func declaration *** 03289 + begin %***************************** 03290 + fun:=cursy=funcsy; insymbol;% 03291 + if cursy=identifier then% 03292 + begin% 03293 + searchtab(curlevel);% 03294 + thisid:=nametab3[curlevel,thisindex];% 03295 + if found and thisid.idclass}proc then% 03296 + begin% 03297 + index:=thisindex;% 03298 + if thisid.forwarddef=1 then% 03299 + begin% 03300 + nametab3[thislevel,thisindex].forwarddef:=0;% 03301 + numforwards:=numforwards-1;% 03302 + if(thisid.idclass=proc and fun)or% 03303 + (thisid.idclass=func and not fun) then error(43);% 03304 + insymbol;% 03305 + end else begin error(2); skip(semicolon) end;% 03306 + end else% 03307 + begin% 03308 + newname(curname1,curname2,curlevel); index:=thisindex;% 03309 + t3:=0; t3.info:=numparams+1;% 03310 + t3.idclass:=if fun then func else proc;% 03311 + nametab3[curlevel,index]:=t3;% 03312 + insymbol; parameterlist;% 03313 + if cursy=colon then% 03314 + begin% 03315 + if not fun then error(48);% 03316 + insymbol;% 03317 + if cursy=identifier then% 03318 + begin% 03319 + search;% 03320 + if found then% 03321 + begin% 03322 + if thisid.idclass=types then% 03323 + begin% 03324 + t:=typetab1[thisid.type];% 03325 + if t.form{alfa or t.form=pointers then% 03326 + begin% 03327 + nametab3[curlevel,index].type:=thisid.type;% 03328 + end else error(38);% 03329 + end else error(7);% 03330 + end else error(1);% 03331 + end else error(9);% 03332 + insymbol;% 03333 + end else if fun then% 03334 + begin error(26); skip(semicolon) end;% 03335 + end;% 03336 + end else begin error(9); skip(semicolon) end;% 03337 + if cursy!semicolon then begin error(25); skip(semicolon) end;% 03338 + if fun then gen("functn",7,2) else% 03339 + gen("procedu",8,1); genid("v",1000|curlevel+index,5);% 03340 + t:=nametab3[curlevel,index].info; tx:=t+paramtab[t];% 03341 + if tx>t then% 03342 + begin% 03343 + gen("(",1,7);% 03344 + for i:=t+1 step 1 until tx do% 03345 + begin genid("v",1000|(curlevel+1)+paramtab[i].paramname,5);% 03346 + if boolean(paramtab[i].paramfile) then% 03347 + begin% 03348 + gen(",",1,7);% 03349 + genid("f",1000|(curlevel+1)+paramtab[i].paramname,5);% 03350 + gen(",",1,7);% 03351 + genid("i",1000|(curlevel+1)+paramtab[i].paramname,5);% 03352 + end;% 03353 + if i lss tx then gen(",",1,7);% 03354 + end;% 03355 + gen(");",2,6);% 03356 + valueparams:=false;% 03357 + for i:=t+1 step 1 until tx do% 03358 + if paramtab[i].paramkind=const then% 03359 + begin% 03360 + if not valueparams then% 03361 + begin gen("value",6,3);% 03362 + valueparams:=true;% 03363 + end else gen(",",1,7);% 03364 + genid("v",1000|(curlevel+1)+paramtab[i].paramname,5);% 03365 + end;% 03366 + if valueparams then gen(";",1,7);% 03367 + declarevars(true,paramtab,t+1,tx,curlevel+1);% 03368 + end else gen(";",1,7);% 03369 +% 03370 + insymbol;% 03371 + if curname1="7forwar" and curname2="d" then% 03372 + begin% 03373 + nametab3[curlevel,index].forwarddef:=1;% 03374 + numforwards:=numforwards+1;% 03375 + gen("forward",8,1);% 03376 + insymbol;% 03377 + end else% 03378 + begin% 03379 + curlevel:=curlevel+1;% 03380 + if curlevel}lastrec then error(55);% 03381 + blocktab[curlevel]:=numblocks:=numblocks+1;% 03382 + t:=curfunc; curfunc:=if fun then index else -1;% 03383 + block; %*** compile procedure body *** 03384 + replace pointer(nametab1[curlevel,*]) by 0% 03385 + for maxnames+1 words;% 03386 + curlevel:=curlevel-1; curfunc:=t;% 03387 + toplevel:=curlevel;% 03388 + end;% 03389 + if cursy!semicolon then begin error(25); skip(semicolon) end;% 03390 + gen(";",1,7);% 03391 + if symkind[cursy]!initial then insymbol;% 03392 + end of procedure declaration;% 03393 +% 03394 +% 03395 + if numforwards>0 then error(44);% 03396 + gen("integer",8,1);% 03397 + for i:=1 step 1 until maxtemps do% 03398 + begin genid("t",i,2);% 03399 + if i1 then gen("end",4,5);% 03441 +end of block;% 03442 +$page 03443 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 03444 +% % 03445 +% % 03446 +% % 03447 +% part 9: the main program. % 03448 +% ----------------- % 03449 +% % 03450 +% % 03451 +% % 03452 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 03453 +% 03454 +% 03455 +integer prognamelength;% 03456 +alpha progname,algolname;% 03457 +% 03458 +algolname:="pasc000"&entier(time(4) mod 10)[17:5:6];% 03459 +algolname:=algolname&entier(time(4) div 7)[11:5:6];% 03460 +algolname:=algolname&entier(time(4) mod 9)[5:5:6];% 03461 +user:=time(-1);% 03462 +fill pascalgol with algolname,user;% 03463 +begin% 03464 + file pascrun disk serial "pascrun"/"disk" (2,10,150);% 03465 + array buf[0:9];% 03466 + label eof;% 03467 +% 03468 + while true do% 03469 + begin% 03470 + read(pascrun,9,buf[*]) [eof];% 03471 + write(pascalgol,10,buf[*]);% 03472 + end;% 03473 +eof:% 03474 +end of transfer of run time system;% 03475 +cardlength:=72;% 03476 +initialize; newcard;% 03477 +listoption:=checkoption:=true;% 03478 +c:=" "; insymbol;% 03479 +if cursy=programsy then% 03480 +begin% 03481 + insymbol;% 03482 + if cursy=identifier then% 03483 + begin% 03484 + progname:=curname1.[35:36]; prognamelength:=min(6,curlength);% 03485 + insymbol;% 03486 + if cursy=lpar then% 03487 + begin% 03488 + do begin% 03489 + insymbol;% 03490 + if cursy=identifier then% 03491 + begin% 03492 + if curname1="50input" then inputdecl:=true else% 03493 + if curname1="6output" then outputdecl:=true else% 03494 + begin% 03495 + if curlength>6 then error(77);% 03496 + numextfiles:=numextfiles+1;% 03497 + if numextfiles{maxextfiles then% 03498 + extfiletab[numextfiles]:=curname1 else% 03499 + if numextfiles=maxextfiles+1 then error(73);% 03500 + end;% 03501 + end else error(9);% 03502 + insymbol;% 03503 + end until cursy!comma;% 03504 + if cursy!rpar then begin error(46); skip(semicolon) end;% 03505 + if cursy=rpar then insymbol;% 03506 + if cursy!semicolon then begin error(25); skip(semicolon) end;% 03507 + end else begin error(58); skip(semicolon) end;% 03508 + end else begin error(9); skip(semicolon) end;% 03509 +end else begin error(75); skip(semicolon) end;% 03510 +insymbol;% 03511 +curlevel:=1;% 03512 +lastrec:=maxtables+1;% 03513 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 03514 +% % 03515 + block; % compile user program. % 03516 +% % 03517 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 03518 +if cursy!dot then% 03519 +begin% 03520 + error(76);% 03521 + do block until cursy=dot;% 03522 +end;% 03523 +if false then% 03524 +begin% 03525 +endofinput: error(87); charcnt:=-1;% 03526 + write(lines,termmess);% 03527 +end;% 03528 +if listoption and charcnt}0 then printline;% 03529 +if errinx>0 then printerrors;% 03530 +write(lines[dbl]);% 03531 +write(lines[dbl]);% 03532 +if numerrs=0 then% 03533 +begin% 03534 + array ziparray[0:19], z[0:0];% 03535 + pointer zippnt;% 03536 +% 03537 + define ziptext(text,l)=% 03538 + begin% 03539 + z[0]:=text;% 03540 + replace zippnt:zippnt by pointer(z[*])+(8-l) for l;% 03541 + end#;% 03542 +% 03543 + procedure zipnum(n); % transfers a number to the zip buffer. 03544 + value n; integer n;% 03545 + if n{9 then ziptext(n,1) else% 03546 + begin zipnum(n div 10); ziptext(entier(n mod 10),1) end;% 03547 +% 03548 + writealgol;% 03549 + write(pascalgol,lastline);% 03550 + lock(pascalgol,save);% 03551 + zippnt:=pointer(ziparray[*]);% 03552 + replace zippnt by " " for 20 words;% 03553 + write(lines,noerrors);% 03554 + ziptext("cc ",3); ziptext("compile",7);% 03555 + ziptext(" ",1); ziptext(progname,prognamelength);% 03556 + ziptext("/",1); ziptext(user,7);% 03557 + ziptext(" xalgol",7); ziptext(" ",1);% 03558 + if savefactor>0 then ziptext("library",7);% 03559 + if savefactor<0 then ziptext("syntax",6);% 03560 + ziptext(";",1);% 03561 + ziptext("xalgol",6); ziptext(" file",5);% 03562 + ziptext(" card=",6); ziptext(algolname,7);% 03563 + ziptext("/",1); ziptext(user,7);% 03564 + ziptext(" serial",7); ziptext(";",1);% 03565 + if savefactor>0 then% 03566 + begin% 03567 + ziptext("save=",5); zipnum(savefactor);% 03568 + ziptext(";",1);% 03569 + end;% 03570 + ziptext("end.",4);% 03571 + zip with ziparray[*];% 03572 +end of compiler zip else% 03573 +begin% 03574 + integer i;% 03575 + switch format errormess1 :=% 03576 + (" 0 *** compiler error *** contact the computer centre."),% 03577 + (" 1 identifier not defined."),% 03578 + (" 2 identifier already defined."),% 03579 + (" 3 wrong number of parameters."),% 03580 + (" 4 syntax error."),% 03581 + (" 5 variable not accessible (hardware restriction)."),% 03582 + (" 6 strings may not be continued from one card to another."),% 03583 + (" 7 a type expected."),% 03584 + (" 8 variable expected."),% 03585 + (" 9 identifier expected."),% 03586 + (" 10 integer constant expected."),% 03587 + (" 11 constant of other type than expected."),% 03588 + (" 12 variable of illegal type."),% 03589 + (" 13 unrecognizable statement."),% 03590 + (" 14 constant too big or to small."),% 03591 + (" 15 undefined label."),% 03592 + (" 16 for- and case-statements nested too deep."),% 03593 + (" 17 expression is of wrong type."),% 03594 + (" 18 """of""" expected."),% 03595 + (" 19 """do""" expected."),% 03596 + (" 20 """else""" without corresponding """then"""."),% 03597 + (" 21 illegal termination of statement."),% 03598 + (" 22 """until""" expected."),% 03599 + (" 23 """to""" expected."),% 03600 + (" 24 """end""" expected."),% 03601 + (" 25 """;""" expected."),% 03602 + (" 26 """:""" expected."),% 03603 + (" 27 """then""" expected."),% 03604 + (" 28 """:=""" expected."),% 03605 + (" 29 only numbers may be signed."),% 03606 + (" 30 too many cases."),% 03607 + (" 31 label used more than once."),% 03608 + (" 32 constant expected."),% 03609 + (" 33 label not in range 0..9999."),% 03610 + (" 34 too many labels declared."),% 03611 + (" 35 too many constants declared."),% 03612 + (" 36 """=""" expected."),% 03613 + (" 37 the list is too long."),% 03614 + (" 38 invalid type for a function."),% 03615 + (" 39 """begin""" expected."),% 03616 + (" 40 too many identifiers declared."),% 03617 + (" 41 alfa constants may not be longer than 7 characters."),% 03618 + (" 42 expression is not of type boolean."),% 03619 + (" 43 not proper forward declaration."),% 03620 + (" 44 unsatisfied forward declaration."),% 03621 + (" 45 too many different types declared."),% 03622 + (" 46 """)""" expected."),% 03623 + (" 47 """[""" expected."),% 03624 + (" 48 a simple type expected."),% 03625 + (" 49 """array of array""" and """array of record""" illegal",% 03626 + " as file type."),% 03627 + (" 50 """file of file""" is illegal."),% 03628 + (" 51 set boundry is too big or too small."),% 03629 + (" 52 too many undeclared pointers."),% 03630 + (" 53 """..""" expected."),% 03631 + (" 54 first value is greater than second value."),% 03632 + (" 55 too many records declared at one time."),% 03633 + (" 56 the record contains more then 1023 words."),% 03634 + (" 57 files not allowed in records."),% 03635 + (" 58 """(""" expected."),% 03636 + (" 59 """]""" expected.");% 03637 +% 03638 + switch format errormess2 :=% 03639 + (" 60 """array of file""" not allowed."),% 03640 + (" 61 range of index is greater than 1023."),% 03641 + (" 62 unsatisfied pointer declaration."),% 03642 + (" 63 expression is too long."),% 03643 + (" 64 illegal operator for this type of expression."),% 03644 + (" 65 integer expression expected."),% 03645 + (" 66 a set expected."),% 03646 + (" 67 parameter of illegal type."),% 03647 + (" 68 procedures not allowed in this context."),% 03648 + (" 69 illegal use of this type of identifier."),% 03649 + (" 70 too many parameters declared in the program."),% 03650 + (" 71 """array of char""" expected."),% 03651 + (" 72 wrong type of set expression."),% 03652 + (" 73 too many external files."),% 03653 + (" 74 illegal identifier for external file."),% 03654 + (" 75 """program""" expected."),% 03655 + (" 76 """.""" expected."),% 03656 + (" 77 external file identifier may not exceed 6 characters."),% 03657 + (" 78 illegal file parameter."),% 03658 + (" 79 illegal use of file handling procedure."),% 03659 + (" 80 text-file expected."),% 03660 + (" 81 pointer variable expected."),% 03661 + (" 82 only values of type real, integer or char may be read."),% 03662 + (" 83 variables in records illegal in this context."),% 03663 + (" 84 display overflow."),% 03664 + (" 85 read and write may only be used on text-files."),% 03665 + (" 86 referenced object is too big."),% 03666 + (" 87 end-of-input discovered."),% 03667 + (" 88 character array expected."),% 03668 + (" 89 """,""" expected."),% 03669 + (" 90 procedures may not have any type."),% 03670 + (" 91 parameters of wrong kind."),% 03671 + (" 92 only complete arrays and records may be transmitted."),% 03672 + (" 93 declared label not used."),% 03673 + (" 94 parameters of this type should not be value parameters."),% 03674 + (" 95 assignment of structured variables not implimented."),% 03675 + (" 96 input/ouput not declared."),% 03676 + (" 97 too many files in use."),% 03677 + (" 98 record identifier expected."),% 03678 + (" 99 unrecognized item."),% 03679 + ();% 03680 +% 03681 +% 03682 + write(lines,errors,numerrs);% 03683 + for i:=0 step 1 until 59 do if err[i] then% 03684 + write(lines,errormess1[i]);% 03685 + for i:=60 step 1 until 119 do if err[i] then% 03686 + write(lines,errormess2[i-60]);% 03687 +end of error messages;% 03688 +if xrefoption then% 03689 +begin % 03690 + replace pointer(xrefline[*]) by " " for 17 words;% 03691 + heading;% 03692 + sort(printxref,xreffile,0,xrefmax,xrefcompare,3,1000,6000);% 03693 +end;% 03694 +end of compiler.% 03695 +?end