diff --git a/PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m b/PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m index d520272..95391aa 100644 --- a/PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m +++ b/PASCAL-Heriot-Watt/SYMBOL.PASCAL.alg_m @@ -1,3700 +1,3699 @@ ?execute object/reader ?common=3 -?file newtape = symbol/pascal serial +?file newtape = symbol/pascal2 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 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 10003000 +% % 10004000 +% % 10005000 +% * * % 10006000 +% * p a s c a l c o m p i l e r * % 10007000 +% *********************************** % 10008000 +% % 10009000 +% % 10010000 +% written 1975 by % 10011000 +% dag f. langmyhr, % 10012000 +% heriot-watt university, % 10013000 +% edinburgh. % 10014000 +% % 10015000 +% % 10016000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 10017000 +% % 10018000 +% % 10019000 +% part 1: declarations. % 10020000 +% ------------- % 10021000 +% % 10022000 +% % 10023000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 10024000 + 10025000 + 10026000 +begin 10027000 +define edition="2.3"#; 10028000 +integer numerrs, % @r+21: number of erros in program. 10029000 + savefactor, % @r+22: savefactor for code file. 10030000 + % >0 compile to library. 10031000 + % =0 compile and run. 10032000 + % <0 compile for syntax. 10033000 + cardcnt; % @r+23: number of cards read. 10034000 +file card "source" (2,10,150); % source code input file 10035000 +file lines 1 (2,17); % print file. 10036000 +file pascalgol disk serial [20:610] (2,10,150,save 0); % code file 10037000 +define linesperpage=58#, 10038000 + maxint=549755813887#; 10039000 + 10040000 +%*** compiler constants *** 10041000 +define maxtables =50#, %max number of name tables. 10042000 + maxnames =997#, %max names in each table. 10043000 + maxlevel =15#, %max depth of procedure declarations. 10044000 + maxcases =211#, %max labels in a case-statement. 10045000 + maxlabs =110#, %max number of labels. 10046000 + maxparams =210#, %max number of parameters in whole program.10047000 + maxtypes =1022#, %max number of different types. 10048000 + maxconsts =210#, %size of constant table. 10049000 + maxtemps =5#, %number of extra vars in each procedure. 10050000 + maxwithsyms=250#, %max number of symbols used by with-statms.10051000 + maxsyms =810#, %max number of symbols in one expression. 10052000 + listlength =810#, %max length of var and param lists. 10053000 + maxextfiles=20#, %max number of external files. 10054000 + maxfiles =20#, %max number of files declared at one time. 10055000 + maxpntrs =50#; %max number of undeclared pointers. 10056000 + 10057000 +%*** name tables *** 10058000 +array nametab1,nametab2,nametab3[0:maxtables,0:maxnames]; 10059000 +define namelength =[41:6]#, 10060000 + type =[9:10]#, 10061000 + idclass =[12:3]#, 10062000 + var =0#, 10063000 + const=1#, 10064000 + func =2#, 10065000 + proc =3#, 10066000 + types=4#, 10067000 + info =[23:11]#, 10068000 + formal =[24:1]#, 10069000 + forwarddef =[25:1]#, 10070000 + externalfile=[26:1]#; 10071000 + 10072000 +%*** display vector *** 10073000 +array display[0:maxlevel]; 10074000 +define rectype =[9:10]#, 10075000 + firstwithsym =[19:10]#, 10076000 + lastwithsym =[29:10]#, 10077000 + numpntrsinwith=[35:6]#, 10078000 + bracketsinwith=[36:1]#, 10079000 + nametab =[46:7]#; 10080000 + 10081000 +%*** type tables *** 10082000 +array typetab1,typetab2,typetab3[0:maxtypes]; 10083000 +define form =[3:4]#, 10084000 + numeric =0#, 10085000 + symbolic=1#, 10086000 + subtype =2#, 10087000 + maintype=[33:10]#, 10088000 + char =3#, 10089000 + floating=4#, 10090000 + alfa =5#, 10091000 + set =6#, 10092000 + settype =[33:10]#, 10093000 + pointers=7#, 10094000 + pointtype=[33:10]#, 10095000 + arrays =8#, 10096000 + inxtype =[33:10]#, 10097000 + arrtype =[43:10]#, 10098000 + record =9#, 10099000 + rectab =[33:10]#, 10100000 + files =10#, 10101000 + filetype=[33:10]#, 10102000 + textfile=11#, 10103000 + size =[15:12]#, 10104000 + struct=[23:8]#; 10105000 +integer numtypes; 10106000 + 10107000 +%*** parameter table *** 10108000 +array paramtab[0:maxparams]; 10109000 +define paramname =[9:10]#, 10110000 + paramkind =[13:4]#, 10111000 + paramlevel=[23:10]#, 10112000 + paramtype =[33:10]#, 10113000 + paramfile =[34:1]#; 10114000 +integer numparams; 10115000 + 10116000 +%*** constant table *** 10117000 +array consttab[0:maxconsts]; 10118000 +integer numconsts; 10119000 + 10120000 +%*** label table *** 10121000 +array labtab[0:maxlabs]; 10122000 +define labval=[14:15]#, 10123000 + labdef=[15:1]#; 10124000 +integer numlabs,firstlab; 10125000 + 10126000 +%*** tables for i/o and character handling *** 10127000 +array ch[0:0], text[0:1], string[0:11]; 10128000 + pointer charpnt,textpnt,textpnt0,stringpnt; 10129000 +array icard[0:9], line[0:16], xline[0:10], algolcard[0:9]; 10130000 + pointer cardpnt,linepnt,xlinepnt,algolpnt; 10131000 + integer charcnt,algolcnt,margincnt; 10132000 +array headtext[0:10], errline[0:16]; 10133000 + integer linecnt,pagecnt,errinx; 10134000 + 10135000 +%*** xref file and table *** 10136000 +file xreffile disk serial [20:3100] (2,3,15); 10137000 +array blocktab[0:maxtables], xrefline[0:16]; 10138000 + integer numxref,numblocks; pointer xrefpnt; 10139000 + 10140000 +%*** other tables *** 10141000 +integer array varlist[0:listlength]; % temporary list of variables. 10142000 + integer varindex,firstvar; 10143000 +array symtab[0:maxsyms]; % used by "expression". 10144000 + integer numsyms; 10145000 +array withtab[0:maxwithsyms]; % used by "withstat". 10146000 + integer nwithsyms; 10147000 +integer array symbol[0:64]; % used by "insymbol". 10148000 +integer array symkind[0:61]; % used in error recovery. 10149000 +array pntrtab1,pntrtab2,pntrtab3[0:maxpntrs];% used for forward pointers10150000 + integer numpntrs; 10151000 +array extfiletab[0:maxextfiles]; % external files. 10152000 + integer numextfiles; 10153000 +array filetab[0:maxfiles]; % files in use. 10154000 + integer numfiles; 10155000 +boolean array err[0:119]; % records error messages. 10156000 + 10157000 +%*** compile time options *** 10158000 +boolean listoption,reswordoption,checkoption,dumpoption,xrefoption; 10159000 +integer cardlength; 10160000 + 10161000 +%*** intrinsic types *** 10162000 +integer inttype,realtype,alfatype,chartype,booltype,niltype,texttype, 10163000 + inputfile,outputfile,emptyset; 10164000 +boolean inputdecl,outputdecl; 10165000 + 10166000 +%*** temporary variables *** 10167000 +integer t1,t2,t3,t4,t5; 10168000 + 10169000 +%*** other variables *** 10170000 +alpha user; % the user number found on the user card.10171000 + 10172000 +integer curlevel, % current procedure level. 10173000 + toplevel, % top level in display vector. 10174000 + numbegins, % number of "begin"s in the program. 10175000 + numcases, % number of case-statements in program. 10176000 + numreps, % number of repeat-statements in program. 10177000 + numtemps, % number of temporary variables in use. 10178000 + curfunc, % index of function currently compiled. 10179000 + cursy, % last symbol read by scanner. 10180000 + curtype, % type of entity last compiled. 10181000 + curmode, % current expression mode. 10182000 + lastrec; % last record table defined. 10183000 + 10184000 +label endofinput; 10185000 + 10186000 +format noerrors ("no errors detected."), 10187000 + errors (i5," errors detected"/), 10188000 + alist ("$ set list single"), 10189000 + noalist ("$ reset list"), 10190000 + lastline ("; terminate: end of pascal program."), 10191000 + termmess ("**** end-of-input. compilation terminated."); 10192000 +monitor expovr:=realoverflow; 10193000 + 10194000 +%*** scanner symbols *** 10195000 +define identifier=1#, intconst=2#, realconst=3#, alfaconst=4#, 10196000 + charconst=5#, notsy=6#, asterisk=7#, slash=8#, 10197000 + andsy=9#, divsy=10#, modsy=11#, plus=12#, 10198000 + minus=13#, orsy=14#, lsssy=15#, leqsy=16#, 10199000 + geqsy=17#, gtrsy=18#, neqsy=19#, eqlsy=20#, 10200000 + insy=21#, lpar=22#, rpar=23#, lbracket=24#, 10201000 + rbracket=25#, doubledot=26#, comma=27#, semicolon=28#, 10202000 + dot=29#, arrow=30#, colon=31#, assignsy=32#, 10203000 + beginsy=33#, endsy=34#, ifsy=35#, thensy=36#, 10204000 + elsesy=37#, casesy=38#, ofsy=39#, repeatsy=40#, 10205000 + untilsy=41#, whilesy=42#, dosy=43#, forsy=44#, 10206000 + tosy=45#, downtosy=46#, gotosy=47#, nilsy=48#, 10207000 + typesy=49#, arraysy=50#, recordsy=51#, filesy=52#, 10208000 + setsy=53#, constsy=54#, varsy=55#, labelsy=56#, 10209000 + funcsy=57#, procsy=58#, withsy=59#, programsy=60#, 10210000 + packedsy=61#; 10211000 + 10212000 +define initial=0#, middle=1#, terminal=2#; 10213000 +define number=0#, bitpattern=1#; 10214000 +$ page 10215000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%20001000 +% %20002000 +% %20003000 +% %20004000 +% part 2: compiler utility routines. %20005000 +% -------------------------- %20006000 +% %20007000 +% %20008000 +% %20009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%20010000 + 20011000 + 20012000 +procedure insymbol; forward; 20013000 +procedure writealgol; forward; 20014000 +procedure newxref(name1,name2,table,decl); 20015000 +value name1, name2, table, decl; 20016000 +real name1, name2; 20017000 +integer table; 20018000 +boolean decl; 20019000 +forward; 20020000 + 20021000 +define ndigits(n)= 20022000 +if n{ 9 then 1 else 20023000 +if n{99 then 2 else 3 digits#; 20024000 + 20025000 +define heading= 20026000 +begin comment *** prints a heading on top of a new page. ; 20027000 + pagecnt:=pagecnt+1; 20028000 + replace pointer(headtext[*])+85 by pagecnt for ndigits(pagecnt); 20029000 + write(lines[page]); 20030000 + write(lines[dbl],11,headtext[*]); 20031000 + linecnt:=2; 20032000 +end of heading#; 20033000 + 20034000 + 20035000 +define printline= %*** prints a source code line. 20036000 +begin 20037000 + replace linepnt-8 by cardcnt for 5 digits; 20038000 + if linecnt}linesperpage then heading; 20039000 + if reswordoption then 20040000 + begin 20041000 + write(lines[no],11,xline[*]); 20042000 + write(lines[no],11,xline[*]); 20043000 + end; 20044000 + write(lines,17,line[*]); 20045000 + linecnt:=linecnt+1; 20046000 +end of printline#; 20047000 + 20048000 + 20049000 +define newcard= %*** reads a new source code card. 20050000 +begin 20051000 + if listoption then printline; 20052000 + if errinx>0 then printerrors; 20053000 + read(card,10,icard[*]) [endofinput]; 20054000 + cardpnt:=pointer(icard[*]); 20055000 + replace linepnt by cardpnt for 10 words, " " for 6 words; 20056000 + replace xlinepnt by " " for 10 words; 20057000 + charcnt:=cardlength; 20058000 + margincnt:=85; 20059000 + cardcnt:=cardcnt+1; 20060000 +end#; 20061000 + 20062000 + 20063000 +define gen(t,n,start)= %*** generate a text "t", consisting of 20064000 +begin %*** "n" letters, starting at "start". 20065000 + if algolcnt 0 then 20117000 + begin 20118000 + while absx}1@7 do begin absx:=absx/10; power:=power+1; end; 20119000 + while absx<1@6 do begin absx:=absx/10; power:=power-1; end; 20120000 + v1:=entier(absx); 20121000 + v2:=entier((absx-v1)|1000000); 20122000 + replace algolpnt:algolpnt by v1 for 7 digits, ".", 20123000 + v2 for 6 digits, "@"; 20124000 + algolcnt:=algolcnt-15; 20125000 + if power<0 then gen("-",1,7); 20126000 + power:=abs(power); 20127000 + replace algolpnt:algolpnt by power for 2 digits; 20128000 + algolcnt:=algolcnt-2; 20129000 + end else gen("0",1,7); 20130000 + if x<0 then gen(")",1,7); 20131000 + end; 20132000 +end of genreal; 20133000 + 20134000 + 20135000 +integer typeindex; 20136000 + 20137000 +define newtype= 20138000 +begin 20139000 + if numtypes}maxtypes then begin error(45);numtypes:=maxtypes-20 end;20140000 + typeindex:=numtypes:=numtypes+1; 20141000 +end #; 20142000 + 20143000 + 20144000 +procedure writealgol; %*** writes a completed xalgol card to 20145000 +begin %*** the file. 20146000 + replace pointer(algolcard[9]) by cardcnt for 8 digits; 20147000 + write(pascalgol,10,algolcard[*]); 20148000 + if dumpoption then write(lines,10,algolcard[*]); 20149000 + algolpnt:=pointer(algolcard[*]); algolcnt:=71; 20150000 + replace algolpnt by " " for 9 words; 20151000 +end of writealgol; 20152000 + 20153000 + 20154000 +define margin(letter,num)= 20155000 +begin comment *** places information in the margin. ; 20156000 + if margincnt{118 then 20157000 + begin text[0]:=letter; 20158000 + replace linepnt+margincnt by textpnt+5 for 2, 20159000 + num for ndigits(num); 20160000 + margincnt:=margincnt+6; 20161000 + end; 20162000 +end of margin#; 20163000 + 20164000 + 20165000 +procedure skip(symbol); %*** skip symbols to recover from error 20166000 +value symbol; integer symbol; %*** condition. 20167000 +begin 20168000 + while cursy!symbol and symkind[cursy]=middle do 20169000 + if cursy=recordsy then 20170000 + begin do begin insymbol; 20171000 + skip(99); 20172000 + end until cursy!semicolon and cursy!casesy; 20173000 + end else insymbol; 20174000 +end of skip; 20175000 + 20176000 + 20177000 +procedure error(errnum); 20178000 +value errnum; integer errnum; 20179000 +begin comment *** arrange error indicator. ; 20180000 + numerrs:=numerrs+1; 20181000 + err[errnum]:=true; 20182000 + errinx:=max(errinx,cardlength-2-charcnt); 20183000 + if errinx{115 then 20184000 + begin replace pointer(errline[1])+errinx by "|", 20185000 + errnum for ndigits(errnum); 20186000 + errinx:=errinx+(if errnum{ 9 then 2 else 20187000 + if errnum{99 then 3 else 4); 20188000 +end end of error; 20189000 + 20190000 + 20191000 +procedure printerrors; 20192000 +begin comment *** print error indicators. ; 20193000 + if not listoption then printline; 20194000 + write(lines,17,errline[*]); 20195000 + linecnt:=linecnt+1; 20196000 + replace pointer(errline[1]) by " " for 16 words; 20197000 + errinx:=0; 20198000 +end of print errors; 20199000 + 20200000 + 20201000 +define hash(n) = (n).[35:36] mod maxnames#; 20202000 + 20203000 +integer thislevel,thistab,thisindex; 20204000 +alpha thisid,tname; 20205000 +boolean found; 20206000 + 20207000 +define searchtab(tab)= %*** search name table "tab" for the 20208000 +begin %*** identifier just read. 20209000 + thisindex:=hash(curname1); 20210000 + tname:=nametab1[tab,thisindex]; 20211000 + while (if tname=curname1 then nametab2[tab,thisindex]!curname2 20212000 + else tname!0) do 20213000 + begin 20214000 + thisindex:=if thisindex=0 then maxnames else thisindex-1; 20215000 + tname:=nametab1[tab,thisindex]; 20216000 + end; 20217000 + found:=tname!0; 20218000 + if xrefoption then 20219000 + if found then newxref(curname1,curname2,tab,false); 20220000 +end of searchtab#; 20221000 + 20222000 +define search= %*** search all tables currently in use. 20223000 +begin 20224000 + thislevel:=toplevel+1; 20225000 + do begin 20226000 + thislevel:=thislevel-1; 20227000 + thistab:=if thislevel{curlevel then thislevel 20228000 + else display[thislevel].nametab; 20229000 + searchtab(thistab); 20230000 + end until found or thislevel=0; 20231000 + thisid:=nametab3[thistab,thisindex]; 20232000 +end of search #; 20233000 + 20234000 + 20235000 +define newname(name1,name2,tab) = 20236000 +begin %*** enter a new name into the name table "tab". 20237000 + thisindex:=hash(name1); 20238000 + tname:=nametab1[tab,thisindex]; 20239000 + while(if tname=name1 then nametab2[tab,thisindex]!name2 20240000 + else tname!0) do 20241000 + begin 20242000 + thisindex:=if thisindex=0 then maxnames else thisindex-1; 20243000 + tname:=nametab1[tab,thisindex]; 20244000 + end; 20245000 + if tname!0 then error(2); 20246000 + nametab1[tab,thisindex]:=name1; 20247000 + nametab2[tab,thisindex]:=name2; 20248000 + if xrefoption then newxref(name1,name2,tab,true); 20249000 +end of newname #; 20250000 + 20251000 + 20300000 +procedure initialize; %*** initialization *** 20301000 +begin %********************** 20302000 + integer t1,t3; 20303000 + alpha a; 20304000 + fill symkind[*] with 28(middle),terminal,4(middle),initial,terminal,20305000 + initial,middle,terminal,initial,middle,initial,terminal,initial, 20306000 + middle,initial,2(middle),initial,middle,initial,4(middle), 20307000 + 7(initial),middle; 20308000 + 20309000 + fill symbol[*] with 10(0),0,arrow,0,colon,gtrsy,geqsy,plus,9(0), 20310000 + dot,lbracket,andsy,lpar,lsssy,arrow,0,9(0),0,asterisk,minus, 20311000 + rpar,semicolon,leqsy,0,slash,8(0),comma,0,neqsy,eqlsy,rbracket, 20312000 + 0,doubledot; 20313000 + 20314000 + linepnt :=pointer(line[1]); 20315000 + xlinepnt:=pointer(xline[1]); 20316000 + replace linepnt-8 by " => ", " " for 16 words; 20317000 + replace xlinepnt-8 by " " for 11 words; 20318000 + replace pointer(errline[*]) by "**** ", " " for 16 words; 20319000 + algolpnt:=pointer(algolcard[*]); algolcnt:=71; 20320000 + replace algolpnt by " " for 9 words; 20321000 + charpnt:=pointer(ch[*])+7; 20322000 + textpnt:=pointer(text[*])+1; textpnt0:=textpnt-1; 20323000 + replace textpnt by " " for 15; 20324000 + stringpnt:=pointer(string[*]); 20325000 + replace pointer(headtext[*]) by " " for 10 words, "page "; 20326000 + replace pointer(headtext[*]) by "pascal(", edition, ")/b-5700"; 20327000 + text[0]:=time(5); 20328000 + replace pointer(headtext[*])+45 by textpnt+3 for 2, "/", 20329000 + textpnt+1 for 2, "/", textpnt+5 for 2; 20330000 + t1:=time(1)/3600; 20331000 + replace pointer(headtext[*])+57 by (t1 div 60) for 2 digits, ":", 20332000 + entier(t1 mod 60) for 2 digits; 20333000 + heading; 20334000 + 20335000 + %*** initialize intrinsic types, constants etc. *** 20336000 + 20337000 + inttype:=t3:=1; %*** "integer" *** 20338000 + t1:=numeric; t1.size:=1; t1.struct:=0; 20339000 + typetab1[1]:=t1; typetab2[1]:=-maxint; typetab3[1]:=maxint; 20340000 + newname("7intege", "r", 0); t3.idclass:=types; 20341000 + nametab3[0,thisindex]:=t3; 20342000 + realtype:=t3:=2; %*** "real" *** 20343000 + t1.form:=floating; typetab1[2]:=t1; 20344000 + newname("400real", 0,0); t3.idclass:=types; 20345000 + nametab3[0,thisindex]:=t3; 20346000 + alfatype:=t3:=3; %*** "alfa" *** 20347000 + t1.form:=alfa; typetab1[3]:=t1; 20348000 + newname("400alfa",0,0); t3.idclass:=types; 20349000 + nametab3[0,thisindex]:=t3; 20350000 + booltype:=t3:=4; %*** "boolean" *** 20351000 + t1.form:=symbolic; typetab1[4]:=t1; typetab3[4]:=1; 20352000 + newname("7boolea", "n",0); t3.idclass:=types; 20353000 + nametab3[0,thisindex]:=t3; 20354000 + booltype:=t3:=5; %*** "char" *** 20355000 + t1.form:=char; typetab1[5]:=t1; typetab3[5]:=63; 20356000 + newname("400char", 0,0); t3.idclass:=types; 20357000 + nametab3[0,thisindex]:=t3; 20358000 + t3:=booltype; t3.idclass:=const; %*** "false" *** 20359000 + newname("50false",0,0); nametab3[0,thisindex]:=t3; 20360000 + t3.info:=1; %*** "true" *** 20361000 + newname("400true",0,0); nametab3[0,thisindex]:=t3; 20362000 + numtypes:=5; 20363000 + niltype:=-1; %*** type of "nil" *** 20364000 + emptyset:=-2; %*** type of [] *** 20365000 + newname("6maxint",0,0); t3:=inttype; %*** "maxint" *** 20366000 + t3.idclass:=const; t3.info:=1024; 20367000 + nametab3[0,thisindex]:=t3; 20368000 + numconsts:=1; consttab[1]:=maxint; 20369000 + 20370000 + t3:=0; t3.idclass:=proc; %*** procedures *** 20371000 + for a:="3000get", "3000new", "400pack", "400page", "3000put", 20372000 + "400read", "6readln", "50reset", "6unpack", "50write" do 20373000 + begin 20374000 + newname(a,0,0); nametab3[0,thisindex]:=t3; 20375000 + end; 20376000 + newname("7dispos","e",0); nametab3[0,thisindex]:=t3; 20377000 + newname("7rewrit","e",0); nametab3[0,thisindex]:=t3; 20378000 + newname("7writel","n",0); nametab3[0,thisindex]:=t3; 20379000 + 20380000 + t3.idclass:=func; %*** functions *** 20381000 + for a:="3000abs", "6arctan", "3000chr", "3000cos", "3000eof", 20382000 + "400eoln", "3000exp", "20000ln", "3000odd", "400pred", 20383000 + "400succ", "50round", "3000sin", "3000sqr", "400sqrt", 20384000 + "50trunc", "6concat", "400time", "400date", "6iotime", 20385000 + "400user", "3000ord" 20386000 + do begin 20387000 + newname(a,0,0); nametab3[0,thisindex]:=t3; 20388000 + end; 20389000 + newname("7elapse","d",0); nametab3[0,thisindex]:=t3; 20390000 + newname("7weekda","y",0); nametab3[0,thisindex]:=t3; 20391000 + 20392000 + texttype:=t3:=numtypes:=numtypes+1; %*** "text" *** 20393000 + t1 := textfile; t1.struct := 1; typetab1[texttype] := t1; 20394000 + t3.idclass := types; 20395000 + newname("400text",0,0); nametab3[0,thisindex]:=t3; 20396000 + t3:=texttype; t3.idclass:=var; %*** "input" *** 20397000 + t3.externalfile:=1; 20398000 + newname("50input",0,0); inputfile:=thisindex; 20399000 + nametab3[0,thisindex]:=t3; 20400000 + newname("6output",0,0); %*** "output" *** 20401000 + nametab3[0,thisindex]:=t3; outputfile:=thisindex; 20402000 +end of intialized; 20403000 + 20404000 + 20500000 + 20501000 +%*** xref routines *** 20502000 +%********************** 20503000 + 20504000 +define xrefcard=[16:17]#, 20505000 + xrefblock=[26:10]#; 20506000 +real a0,b0,a1,b1,lasta0,lasta1; 20507000 +integer nl,lastblock,a2,ax; 20508000 + 20509000 +procedure newxref(name1,name2,table,decl); 20510000 +value name1,name2,table,decl; 20511000 +real name1,name2; 20512000 +integer table; 20513000 +boolean decl; 20514000 +begin 20515000 + nl:=name1.namelength; 20516000 + if nl<7 then name1:=0&name1[41:41:6]&name1[35:6|nl-1:6|nl] 20517000 + else name2:=0&name2[35:6|(nl-6)-1:6|(nl-6)]; 20518000 + ax:=cardcnt; ax.xrefblock:=blocktab[table]; 20519000 + if decl then ax:=ax-100000000000; 20520000 + write(xreffile,*,name1,name2,ax); 20521000 +end of newxref; 20522000 + 20523000 +procedure xrefmax(a); 20524000 +array a[0]; 20525000 +begin 20526000 + a[0]:="azzzzzz"; a[1]:="zzzzzz"; a[2]:=9999999999; 20527000 +end of xrefmax; 20528000 + 20529000 + 20530000 +boolean procedure xrefcompare(a,b); 20531000 +array a,b[0]; 20532000 +begin 20533000 + a0:=a[0]; b0:=b[0]; a1:=a[1]; b1:=b[1]; 20534000 + xrefcompare:= 20535000 + if a0.[35:36]!b0.[35:36] then a0.[35:36]linesperpage then heading; 20561000 + xrefpnt:=pointer(xrefline[*]); numxref:=0; 20562000 + replace xrefpnt by " " for 17 words; xrefpnt:=xrefpnt+24; 20563000 + end; 20564000 + replace xrefpnt by a2.xrefcard for 5 digits; 20565000 + xrefpnt:=xrefpnt+7; numxref:=numxref+1; 20566000 + end else 20567000 + if a2<0 then 20568000 + begin 20569000 + a2:=a2+100000000000; 20570000 + write(lines,17,xrefline[*]); linecnt:=linecnt+1; 20571000 + if linecnt>linesperpage then heading; 20572000 + xrefpnt:=pointer(xrefline[*]); numxref:=0; 20573000 + replace xrefpnt by " " for 17 words; 20574000 + text[0]:=a0.[35:36]; lasta0:=a0; 20575000 + replace xrefpnt by textpnt+1 for a0.namelength; 20576000 + text[0]:=lasta1:=a1; 20577000 + if a0.namelength>6 then 20578000 + replace xrefpnt+6 by textpnt+1 for a0.namelength-6; 20579000 + replace xrefpnt+17 by a2.xrefcard for 5 digits; 20580000 + xrefpnt:=xrefpnt+24; lastblock:=a2.xrefblock; 20581000 + end; 20582000 + end; 20583000 +end of printxref; 20584000 + 20585000 + 20800000 + 20801000 +integer tt1,tt2,f1,f2,lt,rt; 20802000 + 20803000 +define checktypes(lefttype,righttype)= 20804000 +begin 20805000 + if lefttype>0 and righttype>0 then 20806000 + if lefttype!righttype then 20807000 + begin 20808000 + lt:=lefttype; rt:=righttype; 20809000 + tt1:=typetab1[lt]; tt2:=typetab1[rt]; 20810000 + f1:=tt1.form; f2:=tt2.form; 20811000 + if lt!realtype or f2!numeric then 20812000 + if(f1!set and lt!emptyset)or(f2!set and rt!emptyset)then 20813000 + if(f1!pointers and lt!niltype)or(f2!pointers and rt!niltype)then 20814000 + begin 20815000 + if f1=set and f2=set then 20816000 + begin 20817000 + lt:=tt1.settype; rt:=tt2.settype; 20818000 + tt1:=typetab1[lt]; tt2:=typetab1[rt]; 20819000 + f1:=tt1.form; f2:=tt2.form; 20820000 + end; 20821000 + if f1=pointers and f2=pointers then 20822000 + begin 20823000 + lt:=tt1.pointtype; rt:=tt2.pointtype; 20824000 + tt1:=typetab1[lt]; tt2:=typetab1[rt]; 20825000 + f1:=tt1.form; f2:=tt2.form; 20826000 + end; 20827000 + while f1=subtype do 20828000 + begin lt:=tt1.maintype; tt1:=typetab1[lt]; f1:=tt1.form end; 20829000 + while f2=subtype do 20830000 + begin rt:=tt2.maintype; tt2:=typetab1[rt]; f2:=tt2.form end; 20831000 + if lt>0 and rt>0 then 20832000 + if lt!rt then 20833000 + if f1!numeric or f2!numeric then 20834000 + if f1!char or f2!char then error(17); 20835000 + end; 20836000 + end; 20837000 +end of checktypes#; 20838000 + 20839000 + 20840000 +integer filename; 20841000 +boolean lparfound; 20842000 + 20843000 +define fileparam(defaultfile)=%*** checks the first parameter to see 20844000 +begin %*** if it is a file. 20845000 + insymbol; filename:=curtype:=0; 20846000 + lparfound:=cursy=lpar; 20847000 + if lparfound then 20848000 + begin 20849000 + insymbol; 20850000 + if cursy=identifier then 20851000 + begin 20852000 + search; 20853000 + if found then 20854000 + begin 20855000 + if thisid.idclass=var then 20856000 + begin 20857000 + curtype:=thisid.type; 20858000 + if typetab1[curtype].form}files then 20859000 + begin 20860000 + filename:=1000|thislevel+thisindex; 20861000 + insymbol; 20862000 + end end end end; 20863000 + if symkind[cursy]=terminal then error(46); 20864000 + end; 20865000 + if filename=0 then filename:=defaultfile; 20866000 + if (filename=inputfile and not inputdecl) or 20867000 + (filename=outputfile and not outputdecl) then error(96); 20868000 +end of fileparam#; 20869000 + 20870000 + 20871000 +integer tform; 20872000 +boolean signed,negative; 20873000 + 20874000 +define constant(cval,ctype)= %*** *** 20875000 +begin %****************** 20876000 + if cursy=minus or cursy=plus then 20877000 + begin signed:=true; negative:=cursy=minus; 20878000 + insymbol; 20879000 + end else signed:=negative:=false; 20880000 + if cursy=intconst then 20881000 + begin ctype:=inttype; 20882000 + cval:=if negative then -curval else curval; 20883000 + end else 20884000 + if cursy=charconst then 20885000 + begin if signed then error(29); 20886000 + ctype:=chartype; cval:=curval; 20887000 + end else 20888000 + if cursy=realconst then 20889000 + begin ctype:=realtype; 20890000 + cval:=if negative then -curval else curval; 20891000 + end else 20892000 + if cursy=alfaconst then 20893000 + begin if signed then error(29); 20894000 + if curlength>7 then error(41); 20895000 + ctype:=alfatype; cval:=curval; 20896000 + end else 20897000 + if cursy=identifier then 20898000 + begin 20899000 + search; 20900000 + if found then 20901000 + begin 20902000 + if thisid.idclass=const and not boolean(thisid.formal) then 20903000 + begin 20904000 + if typetab1[thisid.type].form{alfa then 20905000 + begin 20906000 + cval:=thisid.info; 20907000 + if cval>1023 then cval:=consttab[cval-1023]; 20908000 + ctype:=thisid.type; 20909000 + if signed then 20910000 + begin 20911000 + tform:=typetab1[thisid.type].form; 20912000 + if tform!numeric and tform!floating then error(29) else%20913000 + if negative then cval:=-cval; 20914000 + end; 20915000 + end else begin error(48); cval:=ctype:=0 end; 20916000 + end else begin error(32); cval:=ctype:=0 end; 20917000 + end else begin error(1); cval:=ctype:=0 end; 20918000 + end else begin error(32); cval:=ctype:=0 end; 20919000 + insymbol; 20920000 +end of constant#; 20921000 +$ page 20922000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%30001000 +% %30002000 +% %30003000 +% %30004000 +% part 3: the scanner. %30005000 +% ------------ %30006000 +% %30007000 +% %30008000 +% %30009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%30010000 +% 30011000 +% internal internal symbol 30012000 +% symbol number name kind 30013000 +% 30014000 +% identifier 1 identifier middle 30015000 +% 122 2 intconst middle 30016000 +% 2.5 3 realconst middle 30017000 +% "abcd" 4 alfaconst middle 30018000 +% "c" 5 charconst middle 30019000 +% not 6 notsy middle 30020000 +% * 7 asterisk middle 30021000 +% / 8 slash middle 30022000 +% & and 9 andsy middle 30023000 +% div 10 divsy middle 30024000 +% mod 11 modsy middle 30025000 +% + 12 plus middle 30026000 +% - 13 minus middle 30027000 +% or 14 orsy middle 30028000 +% < lss 15 lsssy middle 30029000 +% <= leq { 16 leqsy middle 30030000 +% >= geq } 17 geqsy middle 30031000 +% > gtr 18 gtrsy middle 30032000 +% <> neq ! 19 neqsy middle 30033000 +% = eql 30 eqlsy middle 20034000 +% in 21 insy middle 30035000 +% ( 22 lpar middle 30036000 +% ) 23 rpar middle 30037000 +% [ 24 lbracket middle 30038000 +% ] 25 rbracket middle 30039000 +% .. 26 doubledot middle 30040000 +% , 27 comma middle 30041000 +% ; 28 semicolon terminal 30042000 +% . 29 dot middle 30043000 +% ~ @ 30 arrow middle 30044000 +% : 31 colon middle 30045000 +% := 32 assignsy middle 30046000 +% begin 33 beginsy initial 30047000 +% end 34 endsy terminal 30048000 +% if 35 ifsy initial 30049000 +% then 36 thensy middle 30050000 +% else 37 elsesy terminal 30051000 +% case 38 casesy initial 30052000 +% of 39 ofsy middle 30053000 +% repeat 40 repeatsy initial 30054000 +% until 41 untilsy terminal 30055000 +% while 42 whilesy initial 30056000 +% do 43 dosy middle 30057000 +% for 44 forsy initial 30058000 +% to 45 tosy middle 30059000 +% downto 46 downtosy middle 30060000 +% goto 47 gotosy initial 30061000 +% nil 48 nilsy middle 30062000 +% type 49 typesy initial 30063000 +% array 50 arraysy middle 30064000 +% record 51 recordsy middle 30065000 +% file 52 filesy middle 30066000 +% set 53 setsy middle 30067000 +% const 54 constsy initial 30068000 +% var 55 varsy initial 30069000 +% label 56 labelsy initial 30070000 +% function 57 funcsy initial 30071000 +% procedure 58 procsy initial 30072000 +% with 59 withsy initial 30073000 +% program 60 programsy initial 30074000 +% packed 61 packedsy middle 30075000 + 30076000 + 30077000 +define blank=48#, equal=61#, quotes=63#, dollar=42#, 30078000 + letter(c)=(17{c and c{25)or(33{c and c{41)or(50{c and c{57)#, 30079000 + alfanum(c)=(letter(c) or c{9)#; 30080000 + 30081000 +real curval; 30082000 +alpha curname1,curname2,c,cx; 30083000 +integer curlength,lastcharpos; 30084000 +boolean finis; 30085000 + 30086000 +define nextchar= 30087000 +begin comment *** read next character. ***; 30088000 + if charcnt=0 then c:=blank else 30089000 + begin 30090000 + replace charpnt by cardpnt:cardpnt for 1; 30091000 + c:=ch[0]; charcnt:=charcnt-1; 30092000 +end end #; 30093000 + 30094000 + 30095000 + 30096000 +procedure insymbol; 30097000 +begin comment *** reads the next symbol. ***; 30098000 + integer scale,exp; 30099000 + boolean negexp; 30100000 + label start,overflow; 30101000 + 30102000 +start: 30103000 + if c=blank then 30104000 + begin scan cardpnt:cardpnt for charcnt:charcnt while =" "; 30105000 + if charcnt=0 then begin newcard; go to start end; 30106000 + nextchar; 30107000 + end; 30108000 + if letter(c) then 30109000 + begin 30110000 + curlength:=1; curname1:=c; curname2:=0; 30111000 + nextchar; 30112000 + while alfanum(c) and curlength<6 do 30113000 + begin curname1:=c&curname1[35:29:30]; 30114000 + curlength:=curlength+1; nextchar; 30115000 + end; 30116000 + if curlength=6 then 30117000 + begin 30118000 + while alfanum(c) and curlength<12 do 30119000 + begin curname2:=c&curname2[35:29:30]; 30120000 + curlength:=curlength+1; nextchar; 30121000 + end; 30122000 + while alfanum(c) do nextchar; 30123000 + end; 30124000 + curname1.namelength:=curlength; 30125000 + case curlength of 30126000 + begin ; 30127000 + cursy:=identifier; 30128000 + cursy:=if curname1="20000if" then ifsy else 30129000 + if curname1="20000do" then dosy else 30130000 + if curname1="20000to" then tosy else 30131000 + if curname1="20000or" then orsy else 30132000 + if curname1="20000of" then ofsy else 30133000 + if curname1="20000in" then insy else identifier; 30134000 + cursy:=if curname1="3010end" then endsy else 30135000 + if curname1="3010for" then forsy else 30136000 + if curname1="3010div" then divsy else 30137000 + if curname1="3010mod" then modsy else 30138000 + if curname1="3010nil" then nilsy else 30139000 + if curname1="3010and" then andsy else 30140000 + if curname1="3010not" then notsy else 30141000 + if curname1="3010var" then varsy else 30142000 + if curname1="3010set" then setsy else 30143000 + if curname1="3010lss" then lsssy else 30144000 + if curname1="3010leq" then leqsy else 30145000 + if curname1="3010geq" then geqsy else 30146000 + if curname1="3010gtr" then gtrsy else 30147000 + if curname1="3010neq" then neqsy else 30148000 + if curname1="3010eql" then eqlsy else identifier; 30149000 + cursy:=if curname1="400then" then thensy else 30150000 + if curname1="400else" then elsesy else 30151000 + if curname1="400with" then withsy else 30152000 + if curname1="400case" then casesy else 30153000 + if curname1="400goto" then gotosy else 30154000 + if curname1="400type" then typesy else 30155000 + if curname1="400file" then filesy else identifier; 30156000 + cursy:=if curname1="50begin" then beginsy else 30157000 + if curname1="50while" then whilesy else 30158000 + if curname1="50until" then untilsy else 30159000 + if curname1="50array" then arraysy else 30160000 + if curname1="50const" then constsy else 30161000 + if curname1="50label" then labelsy else identifier; 30162000 + cursy:=if curname1="6repeat" then repeatsy else 30163000 + if curname1="6downto" then downtosy else 30164000 + if curname1="6record" then recordsy else 30165000 + if curname1="6packed" then packedsy else identifier; 30166000 + cursy:=if curname1="7progra" and curname2="m" then programsy %30167000 + else identifier; 30168000 + cursy:=if curname1="8functi" and curname2="on" then funcsy 30169000 + else identifier; 30170000 + cursy:=if curname1="9proced" and curname2="ure" then procsy 30171000 + else identifier; 30172000 + cursy:=identifier; % 10 characters. 30173000 + cursy:=identifier; % 11 characters. 30174000 + cursy:=identifier; % 12 characters. 30175000 + end of case; 30176000 + if reswordoption and cursy!identifier then 30177000 + begin t1:=cardlength-charcnt-curlength; 30178000 + if charcnt=0 then cardpnt:=cardpnt+1 else t1:=t1-1; 30179000 + replace xlinepnt+t1 by cardpnt-(curlength+1) 30180000 + for curlength; 30181000 + end; 30182000 + end of letter else 30183000 + if c{9 then 30184000 + begin 30185000 + curval:=c; cursy:=intconst; 30186000 + nextchar; 30187000 + while c{9 do begin curval:=10|curval+c; nextchar end; 30188000 + if c="." then 30189000 + begin 30190000 + nextchar; 30191000 + if c{9 then 30192000 + begin cursy:=realconst; 30193000 + do begin curval:=10|curval+c; 30194000 + scale:=scale-1; nextchar; 30195000 + end until c>9; 30196000 + end else if c="." then c:=64 % special mark for ".." 30197000 + else error(4); 30198000 + end; 30199000 + if c="e" then 30200000 + begin 30201000 + cursy:=realconst; nextchar; 30202000 + if c="+" or c="-" then begin negexp:=c="-"; nextchar end; 30203000 + if c{9 then 30204000 + begin exp:=c; nextchar; 30205000 + while c{9 do begin exp:=10|exp+c; nextchar end; 30206000 + if negexp then exp:=-exp; 30207000 + end else error(4); 30208000 + scale:=scale+exp; 30209000 + end; 30210000 + if cursy=realconst then 30211000 + begin 30212000 + realoverflow:=overflow; 30213000 + curval:=curval|10*scale; 30214000 + realoverflow:=0; 30215000 + end else 30216000 + if curval>maxint then 30217000 + begin 30218000 +overflow: error(14); curval:=0; realoverflow:=0; 30219000 + end; 30220000 + end of digit else 30221000 + if c=quotes then 30222000 + begin 30223000 + cursy:=alfaconst; curlength:=0; nextchar; 30224000 + finis:=false; 30225000 + do begin 30226000 + if c=quotes then begin nextchar; finis:=c!quotes end else 30227000 + if charcnt=0 then begin error(6); finis:=true end; 30228000 + if not finis then 30229000 + begin 30230000 + replace stringpnt+curlength by charpnt for 1; 30231000 + curlength:=curlength+1; 30232000 + nextchar; 30233000 + end end until finis; 30234000 + if curlength=0 then error(4) else 30235000 + if curlength=1 then 30236000 + begin cursy:=charconst; 30237000 + replace charpnt by stringpnt for 1; curval:=ch[0]; 30238000 + end else 30239000 + if curlength{7 then 30240000 + begin text[0]:=" "; 30241000 + replace textpnt by stringpnt for curlength; 30242000 + curval:=text[0]; 30243000 + end; 30244000 + end of strings else 30245000 + begin 30246000 + cursy:=symbol[c]; nextchar; 30247000 + if cursy=colon and c=equal then 30248000 + begin cursy:=assignsy; nextchar end else 30249000 + if cursy=dot and c="." then 30250000 + begin cursy:=doubledot; nextchar end else 30251000 + if cursy=lsssy and c=equal then 30252000 + begin cursy:=leqsy; nextchar end else 30253000 + if cursy=lsssy and c=">" then 30254000 + begin cursy:=neqsy; nextchar end else 30255000 + if cursy=gtrsy and c=equal then 30256000 + begin cursy:=geqsy; nextchar end else 30257000 + if cursy=lpar and c="*" then 30258000 + begin % *** comment *** 30259000 + nextchar; 30260000 + if c=dollar then % dollar indicates compiler options. 30261000 + do begin 30262000 + nextchar; cx:=c; nextchar; 30263000 + if cx="l" then if c=1 then heading 30264000 + else listoption:=c="+" else 30265000 + if cx="r" then reswordoption:=c="+" else 30266000 + if cx="c" then checkoption:=c="+" else 30267000 + if cx="d" then dumpoption:=c="+" else 30268000 + if cx="x" then xrefoption:=c="+" else 30269000 + if cx="a" then 30270000 + if c="+" then write(pascalgol,alist) 30271000 + else write(pascalgol,noalist) else 30272000 + if cx="t" then 30273000 + begin lastcharpos := charcnt - cardlength; 30274000 + cardlength:=10|c; 30275000 + nextchar; cardlength:=cardlength+c; 30276000 + if cardlength{9 or cardlength>80 then 30277000 + begin error(14); cardlength:=72 end; 30278000 + charcnt:=max(0,lastcharpos+cardlength-1); 30279000 + end; 30280000 + nextchar; 30281000 + end until c!","; 30282000 + finis:=false; 30283000 + do begin 30284000 + if c!"*" then 30285000 + scan cardpnt:cardpnt for charcnt:charcnt until ="*"; 30286000 + if charcnt=0 then newcard else 30287000 + begin nextchar; 30288000 + while c="*" do nextchar; 30289000 + finis:=c=")"; 30290000 + end end until finis; 30291000 + nextchar; 30292000 + go to start; 30293000 + end of comment; 30294000 + end; 30295000 +end of insymbol; 30296000 +$ page 30297000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%40001000 +% %40002000 +% %40003000 +% %40004000 +% part 4: expression parser. %40005000 +% ------------------ %40006000 +% %40007000 +% %40008000 +% %40009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%40010000 + 40011000 + 40012000 +procedure expression; forward; 40013000 +procedure concat; forward; 40014000 + 40015000 +alpha tempsym; 40016000 +real sx; 40017000 +integer exprlevel,tx; 40018000 + 40019000 +define puttext(t)= 40020000 +begin 40021000 + if numsyms=maxsyms then 40022000 + begin error(71); 40023000 + numsyms:=1; 40024000 + end else numsyms:=numsyms+1; 40025000 + symtab[numsyms]:=t; 40026000 +end of puttext #; 40027000 + 40028000 +define putsym(s)= 40029000 +begin 40030000 + tempsym:=(s)&1[41:5:6]; 40031000 + puttext(tempsym); 40032000 +end of putsym #; 40033000 + 40034000 +define putconst(val)= 40035000 +begin 40036000 + puttext("2000000"); 40037000 + puttext(val); 40038000 +end of putconst #; 40039000 + 40040000 +define putdummy= 40041000 +begin 40042000 + puttext("3000000"); 40043000 +end of putdummy #; 40044000 + 40045000 +define putid(l,num,numdig)= 40046000 +begin 40047000 + text[0]:=" " & l [35:5:6]; 40048000 + replace textpnt+2 by num for numdig digits; 40049000 + puttext(text[0]); 40050000 +end of putid#; 40051000 + 40052000 +define writeexpr= 40053000 +begin 40054000 + for t1:=1 step 1 until numsyms do 40055000 + begin 40056000 + sx:=symtab[t1]; tx:=sx.[41:6]; 40057000 + if tx=0 then gen(sx,7,2) else 40058000 + if tx=3 then else 40059000 + if tx=1 then gen(sx,7,1) else 40060000 + begin 40061000 + t1:=t1+1; sx:=symtab[t1]; 40062000 + if sx.[44:6]=0 then genint(sx) else genreal(sx); 40063000 + end end; 40064000 + numsyms:=0; 40065000 +end of writeexpr#; 40066000 + 40067000 + 40068000 +define checkexpr(llim,ulim)= 40069000 +begin 40070000 + puttext("check("); 40071000 + expression; 40072000 + putsym(","); putconst(llim); 40073000 + putsym(","); putconst(ulim); 40074000 + putsym(","); putconst(cardcnt); 40075000 + putsym(")"); 40076000 +end of checkexpr#; 40077000 + 40078000 + 40079000 +boolean simplevariable,insidebrackets; 40080000 +integer numpointers; 40081000 + 40082000 +procedure variable; 40083000 +begin 40084000 + integer startsym,llim,ulim; 40085000 + real t; 40086000 + boolean inbracket,inrecord; 40087000 + label addaddr; 40088000 + 40089000 + startsym:=numsyms+1; 40090000 + if thislevel>curlevel then % variable in field list of 40091000 + begin % record used in with-statement 40092000 + t:=display[thislevel]; 40093000 + t4:=t.firstwithsym; t5:=t.lastwithsym; 40094000 + for t3:=t4 step 1 until t5 do puttext(withtab[t3]); 40095000 + inrecord:=true; 40096000 + inbracket:=boolean(t.bracketsinwith); 40097000 + numpointers:=numpointers+t.numpntrsinwith; 40098000 + simplevariable:=false; 40099000 + curtype:=t.rectype; t:=typetab1[curtype]; 40100000 + go to addaddr; 40101000 + end; 40102000 + if thislevel>1 and thislevel0 then begin putsym("-"); putconst( llim) end; 40127000 + putsym(")"); 40128000 + if typetab1[curtype].size>1 then 40129000 + begin putsym("|"); putconst(typetab1[curtype].size) end; 40130000 + end else if typetab1[curtype].struct>0 then putsym(","); 40131000 + end until cursy!comma; 40132000 + if cursy!rbracket then 40133000 + begin error(59); skip(rbracket); 40134000 + if cursy=rbracket then insymbol; 40135000 + end else insymbol; 40136000 + end of brackets else 40137000 + if cursy=dot then 40138000 + begin 40139000 + if not(inbracket or inrecord) then 40140000 + begin putsym("["); inbracket:=true end; 40141000 + t:=typetab1[curtype]; 40142000 + if t.form!record then error(12); 40143000 + insymbol; 40144000 + if cursy=identifier then 40145000 + begin 40146000 + searchtab(t.rectab); 40147000 + if found then 40148000 + begin 40149000 + thisid:=nametab3[t.rectab,thisindex]; 40150000 + addaddr: putsym("+"); 40151000 + putconst(thisid.info); curtype:=thisid.type; 40152000 + end else begin error(1); curtype:=0 end; 40153000 + end else begin error(9); curtype:=0 end; 40154000 + inrecord:=true; 40155000 + insymbol; 40156000 + end of dot else 40157000 + begin % cursy=arrow 40158000 + t:=typetab1[curtype]; 40159000 + if t.form=files then 40160000 + begin 40161000 + curtype:=t.filetype; 40162000 + if typetab1[curtype].struct=0 then puttext(" [0]"); 40163000 + end else 40164000 + if t.form=textfile then 40165000 + begin 40166000 + symtab[numsyms]:=symtab[numsyms] & "i" [35:5:6]; 40167000 + putsym("."); puttext("lastch"); 40168000 + curtype:=chartype; 40169000 + end else 40170000 + if t.form=pointers then 40171000 + begin 40172000 + if inbracket then putsym("]"); 40173000 + inbracket:=false; 40174000 + if numsyms+2{maxsyms then 40175000 + begin 40176000 + for t1:=numsyms step -1 until startsym do 40177000 + symtab[t1+2]:=symtab[t1]; 40178000 + symtab[startsym]:=" mem["; 40179000 + symtab[startsym+1]:=" (t:="; 40180000 + numsyms:=numsyms+2; numpointers:=numpointers+1; 40181000 + inrecord:=true; 40182000 + end else error(63); 40183000 + curtype:=t.pointtype; 40184000 + end else begin error(12); curtype:=0 end; 40185000 + insymbol; 40186000 + end of arrow; 40187000 + end until cursy!lbracket and cursy!dot and cursy!arrow; 40188000 + if typetab1[curtype].struct=0 then 40189000 + begin 40190000 + if inbracket then putsym("]"); 40191000 + while numpointers>0 do 40192000 + begin puttext("-1)div"); puttext(" 1022,"); 40193000 + puttext(" t mod"); puttext(" 1022]"); 40194000 + numpointers:=numpointers-1; 40195000 + end; 40196000 + end; 40197000 + end; 40198000 + insidebrackets:=inbracket; 40199000 + curmode:=number; 40200000 +end of variable; 40201000 + 40202000 + 40203000 +procedure passparams; 40204000 +begin 40205000 + integer npars,param,ptype,p,firstsym; 40206000 + boolean formalproc,check; 40207000 + label exit; 40208000 + 40209000 + putid("v",1000|thislevel+thisindex,5); 40210000 + p:=thisid.info; 40211000 + formalproc:=boolean(thisid.formal); 40212000 + npars:=paramtab[p]; p:=p+1; 40213000 + if formalproc then npars:=9999; 40214000 + insymbol; 40215000 + if cursy=lpar then 40216000 + begin 40217000 + putsym("("); 40218000 + do begin 40219000 + insymbol; 40220000 + if npars=0 then begin error(3); skip(rpar); go to exit end; 40221000 + param:=paramtab[p]; p:=p+1; 40222000 + ptype:=param.paramtype; 40223000 + if param.paramkind=const then 40224000 + begin 40225000 + check:=checkoption and typetab1[ptype].form leq char; 40226000 + if check then puttext("check("); 40227000 + putdummy; firstsym:=numsyms; 40228000 + exprlevel:=exprlevel+1; 40229000 + expression; exprlevel:=exprlevel-1; 40230000 + if curmode=bitpattern then 40231000 + begin symtab[firstsym]:=" real("; putsym(")"); end; 40232000 + if check then 40233000 + begin 40234000 + putsym(","); putconst(typetab2[ptype]); 40235000 + putsym(","); putconst(typetab3[ptype]); 40236000 + putsym(","); putconst(cardcnt); putsym(")"); 40237000 + end; 40238000 + end else 40239000 + if param.paramkind=var then 40240000 + begin 40241000 + if cursy=identifier then 40242000 + begin 40243000 + search; 40244000 + if found then 40245000 + begin 40246000 + if thisid.idclass=var or 40247000 + thisid.idclass=const and boolean(thisid.formal) then 40248000 + begin 40249000 + if param.paramfile=1 then 40250000 + begin 40251000 + curtype:=thisid.type; 40252000 + putid("v",1000|thislevel+thisindex,5); putsym(","); 40253000 + putid("f",1000|thislevel+thisindex,5); putsym(","); 40254000 + putid("i",1000|thislevel+thisindex,5); 40255000 + insymbol; 40256000 + end else 40257000 + begin 40258000 + variable; 40259000 + if typetab1[curtype].struct>0 then 40260000 + if not simplevariable then error(92); 40261000 + end; 40262000 + end else begin error(8); curtype:=0 end; 40263000 + end else begin error(1); curtype:=0 end; 40264000 + end else begin error(9); curtype:=0 end; 40265000 + end else 40266000 + begin 40267000 + if cursy=identifier then 40268000 + begin 40269000 + search; 40270000 + if found then 40271000 + begin 40272000 + if thisid.idclass!param.paramkind then error(91); 40273000 + putid("v",1000|thislevel+thisindex,5); 40274000 + curtype:=if thisid.idclass=func then thisid.type else 0; 40275000 + insymbol; 40276000 + end else begin error(1); curtype:=0 end; 40277000 + end else begin error(9); curtype:=0 end; 40278000 + end; 40279000 + checktypes(ptype,curtype); 40280000 + npars:=npars-1; 40281000 + if cursy=comma then putsym(","); 40282000 + end until cursy!comma; 40283000 + if cursy!rpar then begin error(89); skip(rpar) end; 40284000 +exit: putsym(")"); 40285000 + if cursy=rpar then insymbol; 40286000 + end; 40287000 + if npars>0 and not formalproc then error(3); 40288000 + curmode:=number; 40289000 +end of passparams; 40290000 + 40291000 + 40292000 +procedure factor; %*** factor *** 40293000 +begin %************** 40294000 + integer startsym,stype,t; 40295000 + boolean first; 40296000 + real val; 40297000 + 40298000 + define parameter= %*** check that the function has 1 param. 40299000 + begin 40300000 + insymbol; 40301000 + if cursy=lpar then 40302000 + begin 40303000 + putsym("("); insymbol; expression; 40304000 + if typetab1[curtype].form=numeric then curtype:=inttype; 40305000 + if cursy!rpar then begin error(3); skip(rpar) end; 40306000 + putsym(")"); if cursy=rpar then insymbol; 40307000 + end else error(3); 40308000 + end of parameter#; 40309000 + 40310000 + curmode:=number; 40311000 + if cursy=identifier then 40312000 + begin 40313000 + search; 40314000 + if found then 40315000 + begin 40316000 + if thisid.idclass=var or 40317000 + thisid.idclass=const and boolean(thisid.formal) 40318000 + then variable else 40319000 + if thisid.idclass=const then 40320000 + begin 40321000 + if thisid.info{1023 then putconst(thisid.info) 40322000 + else putconst(consttab[thisid.info-1023]); 40323000 + curtype:=thisid.type; curmode:=number; 40324000 + insymbol; 40325000 + end else 40326000 + if thisid.idclass=func then 40327000 + begin 40328000 + if thistab=0 then %*** intrinsic function *** 40329000 + begin 40330000 + integer dummy; 40350000 + if curname1="3000abs" then % "abs" 40351000 + begin 40352000 + puttext(" abs"); parameter; 40353000 + if curtype!realtype and curtype!inttype then error(67); 40354000 + end else 40355000 + if curname1="3000chr" then % "chr" 40356000 + begin 40357000 + insymbol; 40358000 + if cursy=lpar then 40359000 + begin insymbol; checkexpr(0,63); 40360000 + if typetab1[curtype].form!numeric then error(67); 40361000 + if cursy!rpar then begin error(46); skip(rpar) end; 40362000 + if cursy=rpar then insymbol; 40363000 + end else error(58); 40364000 + curtype:=chartype; 40365000 + end else 40366000 + if curname1="3000eof" or % "eof"/"eoln" 40367000 + curname1="400eoln" then 40368000 + begin 40369000 + first:=curname1="3000eof"; 40370000 + fileparam(inputfile); 40371000 + putid("i",filename,5); 40372000 + puttext(if first then " .eof" else " .eoln"); 40373000 + if lparfound then 40374000 + begin 40375000 + if cursy!rpar then begin error(46); skip(rpar) end; 40376000 + if cursy=rpar then insymbol; 40377000 + end; 40378000 + curtype:=booltype; 40379000 + end else 40380000 + if curname1="3000odd" then % "odd" 40381000 + begin 40382000 + puttext(" odd"); parameter; 40383000 + if curtype!inttype then error(67); 40384000 + curtype:=booltype; curmode:=bitpattern; 40385000 + end else 40386000 + if curname1="3000ord" then % "ord" 40387000 + begin 40388000 + putsym("("); insymbol; 40389000 + if cursy=lpar then 40390000 + begin 40391000 + insymbol; expression; 40392000 + if typetab1[curtype].form>char then error(67); 40393000 + if cursy!rpar then begin error(46); skip(rpar) end; 40394000 + insymbol; 40395000 + end else error(58); 40396000 + curtype:=inttype; putsym(")"); 40397000 + end else 40398000 + if curname1="400pred" or % "pred"/"succ" 40399000 + curname1="400succ" then 40400000 + begin 40401000 + first:=curname1="400pred"; 40402000 + puttext("check("); insymbol; 40403000 + if cursy=lpar then 40404000 + begin 40405000 + insymbol; expression; 40406000 + putsym(if first then "-" else "+"); putsym("1"); 40407000 + if typetab1[curtype].form>char then error(67); 40408000 + putsym(","); putconst(typetab2[curtype]); 40409000 + putsym(","); putconst(typetab3[curtype]); 40410000 + putsym(","); putconst(cardcnt); 40411000 + putsym(")"); 40412000 + if cursy!rpar then begin error(46); skip(rpar) end; 40413000 + if cursy=rpar then insymbol; 40414000 + end else begin error(58); curtype:=0 end; 40415000 + end else 40416000 + if curname1="50round" then % "round" 40417000 + begin 40418000 + puttext(" round"); parameter; 40419000 + if curtype!realtype then error(67); 40420000 + numsyms:=numsyms-1; putsym(","); 40421000 + putconst(cardcnt); putsym(")"); 40422000 + curtype:=inttype; 40423000 + end else 40424000 + if curname1="3000sqr" then % "sqr" 40425000 + begin 40426000 + puttext(" sqr"); parameter; 40427000 + numsyms:=numsyms-1; putsym(","); 40428000 + putconst(cardcnt); putsym(")"); 40429000 + if curtype!realtype and curtype!inttype then error(67); 40430000 + end else 40431000 + if curname1="50trunc" then % "trunc" 40432000 + begin 40433000 + puttext(" trunc"); parameter; 40434000 + numsyms:=numsyms-1; putsym(","); 40434000 + putconst(cardcnt); putsym(")"); 40436000 + if curtype!realtype then error(67); 40437000 + curtype:=inttype; 40438000 + end else 40439000 + if curname1="6concat" then % "concat" 40440000 + concat else 40441000 + if curname1="400time" then % "time" 40442000 + begin 40443000 + puttext("(time("); puttext("1)/60"); 40444000 + curtype:=realtype; insymbol 40445000 + end else 40446000 + if curname1="400date" then % "date" 40447000 + begin 40448000 + puttext("curdat"); 40449000 + curtype:=alfatype; insymbol; 40450000 + end else 40451000 + if curname1="7elapse" and curname2="d" then % "elapsed" 40452000 + begin 40453000 + puttext("(time("); puttext("2)/60)"); 40454000 + curtype:=realtype; insymbol; 40455000 + end else 40456000 + if curname1="6iotime" then % "iotime" 40457000 + begin 40458000 + puttext("(time("); puttext("3)/60)"); 40459000 + curtype:=realtype; insymbol; 40460000 + end else 40461000 + if curname1="7weekda" and curname2="y" then % "weekday" 40462000 + begin 40463000 + puttext("weekda"); 40464000 + curtype:=alfatype; insymbol; 40465000 + end else if curname1="400user" then % "user" 40466000 + begin 40467000 + puttext(" time"); puttext(" (-1)"); 40468000 + curtype:=alfatype; insymbol; 40469000 + end else % "sin", "cos" etc. 40470000 + begin 40471000 + puttext(if curname1="3000sin" then " sin" else 40472000 + if curname1="3000cos" then " cos" else 40473000 + if curname1="6arctan" then "arctan" else 40474000 + if curname1="400sqrt" then " sqrt" else 40475000 + if curname1="3000exp" then " exp" else 40476000 + " ln"); 40477000 + parameter; 40478000 + if curtype!realtype and curtype!inttype then error(67); 40479000 + curtype:=realtype; 40480000 + end; 40481000 + end of intrinsic functions else 40482000 + begin 40483000 + t:=thisid.type; 40484000 + passparams; 40485000 + curtype:=t; 40486000 + end; 40487000 + end of functions else 40488000 + if thisid.idclass=proc then 40489000 + begin 40490000 + error(68); passparams; 40491000 + curtype:=0; 40492000 + end else begin error(69); curtype:=0; insymbol end; 40493000 + end else begin error(1); curtype:=0; insymbol end; 40494000 + end of identifier else 40495000 + if cursy{charconst then 40496000 + begin 40497000 + constant(val,curtype); putconst(val); 40498000 + end else 40499000 + if cursy=notsy then 40500000 + begin 40501000 + puttext(" not "); putdummy; startsym:=numsyms; 40502000 + insymbol; factor; 40503000 + if curtype>0 then 40504000 + if curtype!booltype then begin error(17); curtype:=0 end; 40505000 + if curmode=number then 40506000 + begin symtab[startsym]:=" b("; putsym(")"); 40507000 + curmode:=bitpattern; 40508000 + end; 40509000 + end else 40510000 + if cursy=nilsy then 40511000 + begin 40512000 + putconst(0); curtype:=niltype; 40513000 + insymbol; 40514000 + end else 40515000 + if cursy=lpar then 40516000 + begin 40517000 + putsym("("); 40518000 + insymbol; expression; 40519000 + if cursy!rpar then begin error(46); skip(rpar) end; 40520000 + putsym(")"); 40521000 + insymbol; 40522000 + end else 40523000 + if cursy=lbracket then %*** set constant *** 40524000 + begin 40525000 + insymbol; 40526000 + if cursy=rbracket then 40527000 + begin 40528000 + putconst(0); curtype:=emptyset; curmode:=number; 40529000 + insymbol; 40530000 + end else 40531000 + begin 40532000 + first:=true; 40533000 + do begin 40534000 + if first then first:=false else insymbol; 40535000 + puttext(" bit("); startsym:=numsyms; 40536000 + expression; 40537000 + if stype=0 then 40538000 + begin stype:=curtype; 40539000 + if typetab1[curtype].form>char then error(72); 40540000 + end else checktypes(stype,curtype); 40541000 + if cursy=doubledot then 40542000 + begin 40543000 + putsym(","); symtab[startsym]:=" bits("; 40544000 + insymbol; expression; 40545000 + if stype=0 then 40546000 + begin stype:=curtype; 40547000 + if typetab1[curtype].form>char then error(72); 40548000 + end else checktypes(stype,curtype); 40549000 + end; 40550000 + putsym(","); putconst(cardcnt); putsym(")"); 40551000 + if cursy=comma then puttext(" or"); 40552000 + end until cursy!comma; 40553000 + if cursy!rbracket then 40554000 + begin error(59); skip(rbracket); 40555000 + if cursy=rbracket then insymbol; 40556000 + end else insymbol; 40557000 + newtype; t1:=set; t1.size:=1; t1.struct:=0; 40558000 + t1.settype:=stype; typetab1[typeindex]:=t1; 40559000 + curtype:=typeindex; 40560000 + curmode:=bitpattern; 40561000 + end; 40562000 + end of set constant else begin error(99); insymbol end; 40563000 +end of factor; 40564000 + 40565000 + 40566000 +procedure term; %*** term *** 40567000 +begin %************ 40568000 + integer startsym,mode,type1,muloptr,f; 40569000 + putdummy; startsym:=numsyms; 40570000 + factor; 40571000 + mode:=curmode; 40572000 + while cursy}asterisk and cursy{modsy do % "*","/","div","mod","and"40573000 + begin 40574000 + type1:=curtype; muloptr:=cursy; 40575000 + f:=typetab1[type1].form; 40576000 + if f=numeric or f=floating then 40577000 + begin 40578000 + mode:=number; 40579000 + if cursy=asterisk then putsym("|") else 40580000 + if cursy=slash then putsym("/") else 40581000 + if cursy=andsy then error(64) else 40582000 + begin 40583000 + if f=floating then error(64); 40584000 + if cursy=divsy then puttext(" div") else puttext(" mod"); 40585000 + end end else 40586000 + if curtype=booltype or f=set then 40587000 + begin 40588000 + mode:=bitpattern; 40589000 + if curmode!mode then 40590000 + begin symtab[startsym]:=" b("; putsym(")") end; 40591000 + puttext(" and "); 40592000 + if cursy!(if f=set then asterisk else andsy) then error(64); 40593000 + end else error(64); 40594000 + putdummy; startsym:=numsyms; 40595000 + insymbol; factor; 40596000 + if curtype>0 and type1>0 then 40597000 + begin 40598000 + if curtype!type1 then 40599000 + begin 40600000 + if typetab1[type1].form!numeric or curtype!realtype then 40601000 + checktypes(type1,curtype); 40602000 + if type1=realtype then curtype:=realtype; 40603000 + end; 40604000 + if curtype=realtype and muloptr}divsy then error(65); 40605000 + end; 40606000 + if muloptr=slash then curtype:=realtype; 40607000 + if curtype=0 then curtype:=type1; 40608000 + end of while loop; 40609000 + if mode=bitpattern and curmode!mode then 40610000 + begin symtab[startsym]:=" b("; putsym(")") end; 40611000 + curmode:=mode; 40612000 +end of term; 40613000 + 40614000 + 40615000 +procedure simpleexpression; %*** simple expression *** 40616000 +begin %************************* 40617000 + integer startsym,mode,type1,f; 40618000 + boolean signed; 40619000 + 40620000 + putdummy; startsym:=numsyms; 40621000 + if cursy=plus or cursy=minus then 40622000 + begin signed:=true; 40623000 + putsym(if cursy=plus then"+" else "-"); 40624000 + insymbol; 40625000 + end; 40626000 + term; 40627000 + mode:=curmode; 40628000 + if signed then 40629000 + begin f:=typetab1[curtype].form; 40630000 + if f!numeric and f!floating then error(29); 40631000 + end; 40632000 + while cursy}plus and cursy{orsy do % "+","-","or" 40633000 + begin 40634000 + type1:=curtype; f:=typetab1[type1].form; 40635000 + if f=numeric or f=floating then 40636000 + begin mode:=number; 40637000 + if cursy=plus then putsym("+") else 40638000 + if cursy=minus then putsym("-") else error(64); 40639000 + end else 40640000 + if curtype=booltype then 40641000 + begin 40642000 + mode:=bitpattern; 40643000 + if curmode!mode then 40644000 + begin symtab[startsym]:=" b("; putsym(")") end; 40645000 + if cursy=orsy then puttext(" or") else error(64); 40646000 + end else 40647000 + if f=set then 40648000 + begin 40649000 + mode:=bitpattern; 40650000 + if curmode!mode then 40651000 + begin symtab[startsym]:=" b("; putsym(")"); end; 40652000 + if cursy=plus then puttext(" or") else 40653000 + if cursy=minus then begin puttext(" and");puttext(" not ")end40654000 + else error(64); 40655000 + end else error(64); 40656000 + insymbol; 40657000 + putdummy; startsym:=numsyms; 40658000 + term; 40659000 + if curtype>0 and type1>0 then 40660000 + begin 40661000 + if curtype!type1 then 40662000 + begin 40663000 + if typetab1[type1].form!numeric or curtype!realtype then 40664000 + checktypes(type1,curtype); 40665000 + if type1=realtype then curtype:=realtype; 40666000 + end end; 40667000 + if curtype=0 then curtype:=type1; 40668000 + end of while loop; 40669000 + if mode=bitpattern and curmode!bitpattern then 40670000 + begin symtab[startsym]:=" b("; putsym(")") end; 40671000 + curmode:=mode; 40672000 +end of simpleexpression; 40673000 + 40674000 + 40675000 +procedure expression; %*** expression *** 40676000 +begin %****************** 40677000 + integer startsym,firstsym,type1,reloptr,f; 40678000 + boolean callgen; 40679000 + 40680000 + exprlevel:=exprlevel+1; 40681000 + if exprlevel = 1 then 40682000 + begin 40683000 + putdummy; 40684000 + firstsym := numsyms; 40685000 + end; 40686000 + putdummy; startsym:=numsyms; 40687000 + putdummy; 40688000 + simpleexpression; 40689000 + if cursy}lsssy and cursy{insy then % "<","{","}",">","=","!","in" 40690000 + begin 40691000 + type1:=curtype; f:=typetab1[type1].form; 40692000 + reloptr:=cursy; 40693000 + if f{alfa then 40694000 + begin 40695000 + if curmode=bitpattern then 40696000 + begin symtab[startsym]:=" real("; putsym(")") end; 40697000 + if cursy=lsssy then putsym("<") else 40698000 + if cursy=leqsy then putsym("{") else 40699000 + if cursy=geqsy then putsym("}") else 40600000 + if cursy=gtrsy then putsym(">") else 40601000 + if cursy=eqlsy then putsym("=") else 40602000 + if cursy=neqsy then putsym("!") else 40703000 + begin 40704000 + if f}floating then error(64); 40705000 + symtab[startsym]:="intst("; putsym(","); callgen:=true; 40706000 + end; 40707000 + end else 40708000 + if f=set then 40709000 + begin 40710000 + if curmode=bitpattern then 40711000 + begin symtab[startsym+1]:=" real("; putsym(")") end; 40712000 + if cursy=eqlsy or cursy=neqsy then 40713000 + begin putsym(if cursy=eqlsy then "=" else "!"); 40714000 + end else 40715000 + begin 40716000 + if cursy=leqsy then symtab[startsym]:="incl1(" else 40717000 + if cursy=geqsy then symtab[startsym]:="incl2(" else error(64);40718000 + putsym(","); callgen:=true; 40719000 + end end else 40720000 + if f=pointers then 40721000 + begin 40722000 + if cursy=eqlsy then putsym("=") else 40723000 + if cursy=neqsy then putsym("!") else error(64); 40724000 + end else error(64); 40725000 + insymbol; 40726000 + putdummy; startsym:=numsyms; 40727000 + simpleexpression; 40728000 + if curtype>0 and type1>0 then 40729000 + if curtype!type1 then 40730000 + if reloptr!insy then 40731000 + begin 40732000 + if typetab1[type1].form!numeric or curtype!realtype then 40733000 + checktypes(type1,curtype); 40734000 + end else 40735000 + if typetab1[curtype].form!set then error(66) 40736000 + else checktypes(type1,typetab1[curtype].settype); 40737000 + if curmode=bitpattern then 40738000 + begin symtab[startsym]:=" real("; putsym(")") end; 40739000 + if callgen then putsym(")"); 40740000 + curtype:=booltype; curmode:=bitpattern; 40741000 + end; 40742000 + exprlevel:=exprlevel-1; 40743000 + if exprlevel=0 then 40744000 + begin 40745000 + if curmode=bitpattern then 40746000 + begin 40747000 + symtab[firstsym] := " real("; 40748000 + putsym(")"); 40749000 + end; 40750000 + writeexpr; 40751000 + end; 40752000 +end of expression; 40753000 + 40754000 + 40755000 +define boolexpr= 40756000 +begin 40757000 + putdummy; exprlevel:=1; expression; 40758000 + if curtype>0 then if curtype!booltype then error(17); 40759000 + if curmode!bitpattern then 40760000 + begin symtab[1]:=" b("; putsym(")") end; 40761000 + exprlevel:=0; writeexpr; 40762000 +end of boolean#; 40763000 +$ page 40764000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%50001000 +% %50002000 +% %50003000 +% %50004000 +% part 5: intrinsic routines. %50005000 +% ------------------- %50006000 +% %50007000 +% %50008000 +% %50009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%50010000 + 50011000 + 50012000 +procedure concat; %*** "concat" *** 50013000 +begin %**************** 50014000 + define intexpr= 50015000 + begin insymbol; expression; 50016000 + if curtype>0 then 50017000 + if typetab1[curtype].form!numeric then error(17); 50018000 + end #; 50019000 + 50020000 + puttext("concat"); putsym("("); 50021000 + insymbol; 50022000 + if cursy=lpar then 50023000 + begin 50024000 + insymbol; expression; 50025000 + if curtype>0 then 50026000 + if typetab1[curtype].form>alfa then error(17); 50027000 + if cursy=comma then 50028000 + begin 50029000 + putsym(","); insymbol; expression; 50030000 + if curtype>0 then 50031000 + if typetab1[curtype].form>alfa then error(17); 50032000 + if cursy=comma then 50033000 + begin 50034000 + putsym(","); intexpr; 50035000 + if cursy=comma then 50036000 + begin 50037000 + putsym(","); intexpr; 50038000 + if cursy=comma then 50039000 + begin 50040000 + putsym(","); intexpr; 50041000 + putsym(","); putconst(cardcnt); 50042000 + putsym(")"); 50043000 + if cursy!rpar then begin error(3); skip(rpar) end; 50044000 + end else begin error(3); skip(rpar) end; 50045000 + end else begin error(3); skip(rpar) end; 50046000 + end else begin error(3); skip(rpar) end; 50047000 + end else begin error(3); skip(rpar) end; 50048000 + end else begin error(3); skip(rpar) end; 50049000 + curtype:=realtype; 50050000 + if cursy=rpar then insymbol; 50051000 +end of concat; 50052000 + 50053000 + 50054000 +procedure pread(changeline); 50055000 +value changeline; boolean changeline; 50056000 +begin 50057000 + integer fileid,f; 50058000 + boolean check; 50059000 + gen(" begin",7,2); 50060000 + fileparam(inputfile); fileid:=filename; 50061000 + if typetab1[curtype].form=files then error(85); 50062000 + if symkind[cursy]!terminal then 50063000 + begin 50064000 + if cursy neq rpar then 50065000 + do begin 50066000 + while cursy=comma do insymbol; 50067000 + if cursy=identifier then 50068000 + begin 50069000 + search; 50070000 + if found then 50071000 + begin 50072000 + if thisid.idclass=var or 50073000 + thisid.idclass=const and boolean(thisid.formal) then 50074000 + begin 50075000 + variable; f:=typetab1[curtype].form; 50076000 + if f=numeric or f=floating or f=char then 50077000 + begin 50078000 + check:=checkoption and f!floating; 50079000 + writeexpr; gen(":=",2,6); 50080000 + if check then gen("check(",6,2); 50081000 + gen("pread(",6,2); genid("f",fileid,5); gen(",",1,7); 50082000 + genid("v",fileid,5); gen(",",1,7); 50083000 + genid("i",fileid,5); gen(",",1,7); 50084000 + if f=numeric then genint(2) else 50085000 + if f=floating then genint(3) else genint(1); 50086000 + gen(",",1,7); genint(cardcnt); gen(")",1,7); 50087000 + if check then 50088000 + begin 50089000 + gen(",",1,7); genint(typetab2[curtype]); gen(",",1,7);50090000 + genint(typetab3[curtype]); gen(",",1,7); 50091000 + genint(cardcnt); gen(")",1,7); 50092000 + end; 50093000 + end else begin error(82); insymbol end; 50094000 + end else begin error(8); insymbol end; 50095000 + end else begin error(1); insymbol end; 50096000 + end else error(9); 50097000 + gen(";",1,7); 50098000 + end until cursy!comma; 50099000 + if cursy!rpar then begin error(46); skip(rpar) end; 50100000 + if cursy=rpar then insymbol; 50101000 + end; 50102000 + if changeline then 50103000 + begin 50104000 + gen("rline(",6,2); genid("f",fileid,5); gen(",",1,7); 50105000 + genid("v",fileid,5); gen(",",1,7); 50106000 + genid("i",fileid,5); gen(")",1,7); 50107000 + end; 50108000 + gen("end",4,5); 50109000 + end of pread; 50110000 + 50111000 + 50112000 +procedure pwrite(linefeed); 50113000 +value linefeed; boolean linefeed; 50114000 +begin 50115000 + integer fileid,f,i,lastsy; 50116000 + pointer p; 50117000 + gen(" begin",7,2); 50118000 + fileparam(outputfile); fileid:=filename; 50119000 + if typetab1[curtype].form=files then error(85); 50120000 + if symkind[cursy]!terminal then 50121000 + begin 50122000 + if cursy neq rpar then 50123000 + do begin 50124000 + while cursy=comma do insymbol; 50125000 + if cursy=alfaconst and curlength>7 then 50126000 + begin 50127000 + gen("walfa(",6,2); genid("f",fileid,5); gen(",",1,7); 50128000 + genid("v",fileid,6); gen(",",1,7); 50129000 + genid("i",fileid,5); gen(",",1,7); 50130000 + p:=stringpnt; 50131000 + for i:=1 step 7 until 80 do 50132000 + if i{curlength then 50133000 + begin 50134000 + if algolcnt<10 then writealgol; 50135000 + replace algolpnt:algolpnt by """, p:p for 7, """, ","; 50136000 + algolcnt:=algolcnt-10; 50137000 + end else gen("0,",2,6); 50138000 + genint(curlength); gen(",",1,7); 50139000 + genint(cardcnt); gen(")",1,7); 50140000 + insymbol; 50141000 + end of alfaconst else 50142000 + begin 50143000 + gen("pwrite(",7,1); genid("f",fileid,5); gen(",",1,7); 50144000 + genid("v",fileid,5); gen(",",1,7); 50145000 + genid("i",fileid,5); gen(",",1,7); 50146000 + lastsy:=cursy; 50147000 + expression; f:=typetab1[curtype].form; 50148000 + gen(",",1,7); 50149000 + if f=numeric or f=floating or f=char or f=alfa or 50150000 + curtype=booltype then 50151000 + begin 50152000 + if f=numeric then genint(1) else 50153000 + if f=floating then genint(2) else 50154000 + if f=alfa then genint(5) else 50155000 + if f=char then genint(4) else genint(3); 50156000 + gen(",",1,7); 50157000 + if cursy=colon then 50158000 + begin 50159000 + insymbol; expression; 50160000 + if typetab1[curtype].form neq numeric then error(17); 50161000 + gen(",",1,7); 50162000 + if cursy=colon then 50163000 + begin 50164000 + if f!floating then error(4); 50165000 + insymbol; expression; 50166000 + if typetab1[curtype].form neq numeric then error(17); 50167000 + gen(",",1,7); 50168000 + end else gen("-1,",3,5); 50169000 + end else 50170000 + begin 50171000 + if f=floating then genint(16) else 50172000 + if f=alfa and lastsy=alfaconst then genint(curlength) else50173000 + if f=alfa then genint(7) else 50174000 + if f=char then genint(1) else genint(10); 50175000 + gen(",-1",4,4); 50176000 + end; 50177000 + end else error(17); 50178000 + genint(cardcnt); gen(")",1,7); 50179000 + end of expression; 50180000 + gen(";",1,7); 50181000 + end until cursy!comma; 50182000 + if cursy!rpar then begin error(46); skip(rpar) end; 50183000 + if cursy=rpar then insymbol; 50184000 + end; 50185000 + filename:=fileid; 50186000 + if linefeed then 50187000 + begin 50188000 + integer dummy; 50189000 + gen("wline(",6,2); genid("f",filename,5); gen(",",1,7); 50190000 + genid("v",filename,5); gen(",",1,7); 50191000 + genid("i",filename,5); gen(")",1,7); 50192000 + end; 50193000 + gen("end",4,5); 50194000 +end of pwrite; 50195000 + 50196000 + 50197000 +procedure filehandling(procnum); %*** file handling procedures: 50198000 +value procnum; integer procnum; %*** 50199000 +begin %*** 1) put 50200000 + integer f; %*** 2) get 50201000 + case procnum of %*** 3) reset 50202000 + begin ; %*** 4) rewrite 50203000 + gen("put",3,5); %*** 5) page 50204000 + gen("get",3,5); 50205000 + gen("reset",5,3); 50206000 + gen("rewrite",7,1); 50207000 + gen("page",4,4); 50208000 + end; 50209000 + gen("(",1,7); fileparam(0); 50210000 + if filename=0 then error(78); 50211000 + f:=typetab1[curtype].form; 50212000 + if f=files and procnum=5 then error(80); 50213000 + genid("f",filename,5); gen(",",1,7); 50214000 + genid("v",filename,5); gen(",",1,7); 50215000 + genid("i",filename,5); gen(",",1,7); 50216000 + genint(cardcnt); gen(")",1,7); 50217000 + if cursy!rpar then begin error(46); skip(rpar) end; 50218000 + if cursy=rpar then insymbol; 50219000 +end of filehandling; 50220000 + 50221000 + 50222000 +procedure pack; 50223000 +begin 50224000 + integer it,t; 50225000 + gen("pack(",5,3); 50226000 + insymbol; 50227000 + if cursy=lpar then 50228000 + begin 50229000 + insymbol; 50230000 + if cursy=identifier then 50231000 + begin 50232000 + search; 50233000 + if found then 50234000 + begin 50235000 + if thisid.idclass=var then 50236000 + begin 50237000 + t:=typetab1[thisid.type]; 50238000 + if t.form=arrays then 50239000 + begin 50240000 + it:=t.inxtype; 50241000 + if typetab1[t.arrtype].form!char then error(88); 50242000 + genid("v",1000|thislevel+thisindex,5); 50243000 + if thislevel>1 and thislevel!curlevel then error(5); 50244000 + gen(",",1,7); genint(typetab2[thisid.type]); 50245000 + gen(",",1,7); genint(typetab3[thisid.type]); 50246000 + end else error(88); 50247000 + end else error(88); 50248000 + end else error(1); 50249000 + end else error(9); 50250000 + insymbol; 50251000 + if cursy=comma then 50252000 + begin 50253000 + gen(",",1,7); 50254000 + insymbol; expression; checktypes(it,curtype); 50255000 + if cursy=comma then 50256000 + begin 50257000 + gen(",",1,7); 50258000 + insymbol; 50259000 + if cursy=identifier then 50260000 + begin 50261000 + search; 50262000 + if found then 50263000 + begin 50264000 + if thisid.idclass=var or 50265000 + thisid.idclass=const and boolean(thisid.formal) then 50266000 + begin 50267000 + variable; writeexpr; 50268000 + if curtype>0 then 50269000 + if typetab1[curtype].form!alfa then error(12); 50270000 + end else error(8); 50271000 + end else error(1); 50272000 + end else error(9); 50273000 + end else begin error(89); skip(rpar) end; 50274000 + end else begin error(89); skip(rpar) end; 50275000 + if cursy!rpar then begin error(46); skip(rpar) end; 50276000 + if cursy=rpar then insymbol; 50277000 + end else begin error(3); insymbol end; 50278000 + gen(",",1,7); genint(cardcnt); gen(")",1,7); 50279000 +end of pack; 50280000 + 50281000 + 50282000 +procedure unpack; 50283000 +begin 50284000 + integer it,t; 50285000 + gen("unpack(",7,1); insymbol; 50286000 + if cursy=lpar then 50287000 + begin 50288000 + insymbol; expression; 50289000 + if curtype>0 then if typetab1[curtype].form!alfa then error(17); 50290000 + if cursy=comma then 50291000 + begin 50292000 + gen(",",1,7); insymbol; 50293000 + if cursy=identifier then 50294000 + begin 50295000 + search; 50296000 + if found then 50297000 + begin 50298000 + if thisid.idclass=var then 50299000 + begin 50300000 + t:=typetab1[thisid.type]; 50301000 + if t.form=arrays then 50302000 + begin 50303000 + it:=t.inxtype; 50304000 + if typetab1[t.arrtype].form!char then error(88); 50305000 + if thislevel>1 and thislevel!curlevel then error(5); 50306000 + genid("v",1000|thislevel+thisindex,5); 50307000 + gen(",",1,7); genint(typetab2[thisid.type]); 50308000 + gen(",",1,7); genint(typetab3[thisid.type]); 50309000 + end else error(88); 50310000 + end else error(88); 50311000 + end else error(1); 50312000 + end else error(9); 50313000 + insymbol; 50314000 + if cursy=comma then 50315000 + begin 50316000 + gen(",",1,7); 50317000 + insymbol; expression; checktypes(it,curtype); 50318000 + end else begin error(89); skip(rpar) end; 50319000 + end else begin error(89); skip(rpar) end; 50320000 + if cursy!rpar then begin error(89); skip(rpar) end; 50321000 + if cursy=rpar then insymbol; 50322000 + end else begin error(3); insymbol end; 50323000 + gen(",",1,7); genint(cardcnt); gen(")",1,7); 50324000 +end of unpack; 50325000 + 50326000 + 50327000 +procedure newdisp; %*** "new","dispose" 50328000 +begin 50329000 + integer t1; 50330000 + if curname1="3000new" then gen("new(",4,4) else 50331000 + begin gen("dispose",7,1); gen("(",1,7) end; 50332000 + insymbol; 50333000 + if cursy=lpar then 50334000 + begin 50335000 + insymbol; 50336000 + if cursy=identifier then 50337000 + begin 50338000 + search; 50339000 + if found then 50340000 + begin 50341000 + variable; 50342000 + if curtype>0 then if typetab1[curtype].form=pointers then 50343000 + begin 50344000 + writeexpr; gen(",",1,7); 50345000 + t1:=typetab1[curtype].pointtype; 50346000 + t1:=typetab1[t1].size; 50347000 + if t1>1023 then error(86); 50348000 + genint(t1); gen(")",1,7); 50349000 + end else error(81); 50350000 + end else begin error(1); insymbol end; 50351000 + end else error(9); 50352000 + while cursy=comma do 50353000 + begin insymbol; 50354000 + if cursy neq identifier then error(9); 50355000 + if cursy neq rpar then insymbol; 50356000 + end; 50357000 + end else begin error(58); skip(rpar) end; 50358000 + if cursy!rpar then begin error(46); skip(rpar) end; 50359000 + if cursy=rpar then insymbol; 50360000 +end of newdisp; 50361000 +$ page 50362000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%60001000 +% %60002000 +% %60003000 +% %60004000 +% part 6: the statement parser. %60005000 +% --------------------- %60006000 +% %60007000 +% %60008000 +% %60009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%60010000 + 60011000 + 60012000 + 60013000 +procedure statement; forward; 60014000 + 60015000 +procedure assignment; 60016000 +begin 60017000 + integer lefttype; 60018000 + label assign,exit; 60019000 + if found then 60050000 + begin 60051000 + if thisid.idclass=var or 60052000 + thisid.idclass=const and boolean(thisid.formal) then 60053000 + begin 60054000 + variable; lefttype:=curtype; 60055000 +assign: if cursy!assignsy then 60056000 + begin error(28); skip(assignsy); 60057000 + if symkind[cursy]=terminal then go to exit; 60058000 + end; 60059000 + insymbol; 60060000 + if typetab1[lefttype].struct>0 then 60061000 + begin 60062000 + error(95); 60063000 + end else 60080000 + begin 60081000 + writeexpr; gen(":=",2,6); 60082000 + if checkoption and typetab1[lefttype].form{char then 60083000 + checkexpr(typetab2[lefttype],typetab3[lefttype]) else 60084000 + expression; 60085000 + writeexpr; 60086000 + checktypes(lefttype,curtype); 60087000 + end; 60088000 + end else 60089000 + begin % function assignment. 60090000 + if thislevel!curlevel-1 or thisindex!curfunc then error(5); 60091000 + genid("v",1000|thislevel+thisindex,5); lefttype:=thisid.type; 60092000 + insymbol; go to assign; 60093000 + end; 60094000 + end else 60095000 + begin 60096000 + skip(assignsy); 60097000 + if cursy=assignsy then go to assign; 60098000 + end; 60099000 +exit: 60100000 +end of assignment; 60101000 + 60102000 + 60103000 +procedure compstat; 60104000 +begin 60105000 + integer beginnum; 60106000 + label statm; 60107000 + 60108000 + beginnum:=numbegins:=numbegins+1; margin(" b",beginnum); 60109000 + gen("begin",6,3); 60110000 + do begin 60111000 + if cursy=semicolon or cursy=beginsy then insymbol; 60112000 +statm: statement; 60113000 + gen(";",1,7); 60114000 + if cursy=elsesy then begin error(20); insymbol; go statm end; 60115000 + if symkind[cursy]=initial then begin error(21); go statm end; 60116000 + end until cursy!semicolon; 60117000 + if cursy!endsy then 60118000 + begin error(24); skip(endsy); 60119000 + if cursy!endsy then begin insymbol; go to statm end; 60120000 + end; 60121000 + gen(" end",5,4); margin(" e",beginnum); 60122000 + insymbol; 60123000 +end of compstat; 60124000 + 60125000 + 60126000 +procedure ifstat; 60127000 +begin 60128000 + label exit; 60129000 + gen("if",3,6); 60130000 + insymbol; boolexpr; 60131000 + if cursy!thensy then 60132000 + begin if curtype>0 then error(27); 60133000 + skip(thensy); 60134000 + if cursy!thensy then 60135000 + begin if curtype=0 then error(27); 60136000 + if symkind[cursy]=terminal then go to exit; 60137000 + end; end; 60138000 + gen(" then",6,3); 60139000 + insymbol; statement; 60140000 + if cursy=elsesy then 60141000 + begin gen(" else",6,3); insymbol; statement end; 60142000 +exit: 60143000 +end of ifstat; 60144000 + 60145000 + 60146000 +procedure casestat; 60147000 +begin 60148000 + define casehash(n)=(n).[38:39] mod maxcases#; 60149000 + integer array casetab[0:maxcases]; 60150000 + integer casenum,casetype,ncaselabs,tempvarnum,conval,contype,c,t; 60151000 + boolean zerolab,first; 60152000 + 60153000 + casenum:=numcases:=numcases+1; margin("cb",casenum); 60154000 + tempvarnum:=numtemps:=numtemps+1; 60155000 + if tempvarnum>maxtemps then error(16); 60156000 + gen("begin",6,3); genid("t",tempvarnum,2); gen(":=",2,6); 60157000 + insymbol; expression; 60158000 + gen(";",1,7); casetype:=curtype; 60159000 + if typetab1[casetype].form}floating then 60160000 + begin error(17); casetype:=0 end; 60161000 + if cursy!ofsy then 60162000 + begin if casetype>0 then error(18); 60163000 + skip(ofsy); 60164000 + if cursy=ofsy then insymbol else 60165000 + if casetype=0 then error(18); 60166000 + end else insymbol; 60167000 + do begin 60168000 + while cursy=semicolon do insymbol; 60169000 + first:=true; 60170000 + if cursy!endsy then 60171000 + begin 60172000 + gen("if",3,6); 60173000 + do begin 60174000 + if first then first:=false else insymbol; 60175000 + constant(conval,contype); 60176000 + if contype>0 then 60177000 + begin 60178000 + if casetype=0 then casetype:=contype else 60179000 + checktypes(casetype,contype); 60180000 + genid("t",tempvarnum,2); gen("=",1,7); genint(conval); 60181000 + ncaselabs:=ncaselabs+1; 60182000 + if ncaselabs0 then error(19); 60219000 + skip(dosy); 60220000 + if cursy!dosy then 60221000 + begin if curtype=0 then error(19); 60222000 + go to if symkind[cursy]=initial then statm else exit; 60223000 + end; end; 60224000 + gen(" do",4,5); 60225000 + insymbol; 60226000 +statm: statement; 60227000 +exit: 60228000 +end of whilestat; 60229000 + 60230000 + 60231000 +procedure repeatstat; 60232000 +begin 60233000 + integer repnum; 60234000 + label newtry; 60235000 + 60236000 + repnum:=numreps:=numreps+1; 60237000 + margin(" r",repnum); 60238000 + gen("do",3,6); gen("begin",6,3); 60239000 + do begin 60240000 + insymbol; 60241000 +newtry: statement; 60242000 + gen(";",1,7); 60243000 + if cursy=elsesy then begin error(20);insymbol; go newtry end; 60244000 + if symkind[cursy]=initial then begin error(21); go newtry end; 60245000 + end until cursy!semicolon; 60246000 + if cursy!untilsy then 60247000 + begin 60248000 + error(22); 60249000 + while cursy!untilsy and symkind[cursy]!initial do 60250000 + begin insymbol; skip(untilsy) end; 60251000 + if cursy!untilsy then go to newtry; 60252000 + end; 60253000 + gen(" end",5,4); gen("until",6,3); margin(" u",repnum); 60254000 + insymbol; boolexpr; 60255000 +end of repeatstat; 60256000 + 60257000 + 60258000 +procedure forstat; 60259000 +begin 60260000 + integer vartype,varnum,llim,ulim; 60261000 + boolean down; 60262000 + label statm; 60263000 + 60264000 + gen("begin",6,3); 60265000 + insymbol; 60266000 + if cursy=identifier then 60267000 + begin 60268000 + search; 60269000 + if found then 60270000 + begin 60271000 + varnum:=1000|thislevel+thisindex; 60272000 + if thisid.idclass=var or 60273000 + thisid.idclass=const and boolean(thisid.formal) then 60274000 + begin 60275000 + if thislevel>1 and thislevelcurlevel then error(83); 60277000 + vartype:=thisid.type; 60278000 + if typetab1[vartype].form{char then 60279000 + begin 60280000 + llim:=typetab2[vartype]; ulim:=typetab3[vartype]; 60281000 + end else begin error(12); vartype:=0 end; 60282000 + end else error(8); 60283000 + end else error(1); 60284000 + end else error(9); 60285000 + insymbol; 60286000 + if cursy!assignsy then 60287000 + begin error(28); 60288000 + skip(assignsy); 60289000 + if cursy=assignsy then insymbol else 60290000 + if symkind[cursy]=initial then go to statm; 60291000 + end else insymbol; 60292000 + genid("v",varnum,5); gen("~",1,7); 60293000 + if checkoption then checkexpr(llim,ulim) else expression; 60294000 + writeexpr; 60295000 + gen(";",1,7); 60296000 + if vartype=0 then vartype:=curtype else checktypes(vartype,curtype);60297000 + numtemps:=numtemps+1; if numtemps>maxtemps then error(16); 60298000 + if cursy=tosy then insymbol else 60299000 + if cursy=downtosy then begin down:=true; insymbol end else 60300000 + begin if curtype>0 then error(23); 60301000 + skip(tosy); 60302000 + if cursy=tosy then insymbol else 60303000 + begin if curtype=0 then error(23); 60304000 + if symkind[cursy]=initial then go to statm; 60305000 + end; end; 60306000 + genid("t",numtemps,2); gen("~",1,7); 60307000 + if checkoption then checkexpr(llim,ulim) else expression; 60308000 + writeexpr; 60309000 + gen(";",1,7); 60310000 + if vartype=0 then vartype:=curtype else checktypes(vartype,curtype);60311000 + if cursy!dosy then 60312000 + begin if curtype>0 then error(19); 60313000 + skip(dosy); 60314000 + if cursy=dosy then insymbol else 60315000 + if curtype=0 then error(19); 60316000 + end else insymbol; 60317000 + gen("for",4,5); genid("v",varnum,5); gen("~",1,7); 60318000 + genid("v",varnum,5); gen(" ",1,7); 60319000 + if down then gen("downto",7,2) else gen("upto",5,4); 60320000 + genid("t",numtemps,2); gen(" do",4,5); 60321000 +statm: statement; 60322000 + gen(" end",5,4); 60323000 + numtemps:=numtemps-1; 60324000 +end of forstat; 60325000 + 60326000 + 60327000 +procedure gotostat; 60328000 +begin 60329000 + integer i; 60330000 + insymbol; 60331000 + if cursy=intconst then 60332000 + begin i:=numlabs; 60333000 + while i}1 and labtab[i].labval!curval do i:=i-1; 60334000 + if i=0 then error(15); 60335000 + gen("go",3,6); genid("l",curval,4); 60336000 + insymbol; 60337000 + end else error(10); 60338000 +end of gotostat; 60339000 + 60340000 + 60341000 +procedure withstat; 60342000 +begin 60343000 + integer startlevel,veryfirstwithsym,i; 60344000 + real d; 60345000 + startlevel:=toplevel; veryfirstwithsym:=nwithsyms; 60346000 + do begin 60347000 + insymbol; 60348000 + if cursy=identifier then 60349000 + begin 60350000 + search; 60351000 + if found then 60352000 + begin 60353000 + if thisid.idclass=var then 60354000 + begin 60355000 + variable; 60356000 + if curtype>0 then 60357000 + if typetab1[curtype].form!record then error(98); 60358000 + if simplevariable then 60359000 + begin putsym("["); insidebrackets:=true end; 60360000 + if toplevelmaxwithsyms then error(63) else 60369000 + for i:=1 step 1 until numsyms do 60370000 + begin 60371000 + withtab[nwithsyms]:=symtab[i]; 60372000 + nwithsyms:=nwithsyms+1; 60373000 + end; 60374000 + d.lastwithsym:=nwithsyms-1; 60375000 + display[toplevel]:=d; 60376000 + end else error(84); 60377000 + end else begin error(8); insymbol end; 60378000 + end else begin error(1); insymbol end; 60379000 + end else begin error(9); insymbol end; 60380000 + numsyms:=0; 60381000 + numpointers := 0; 60382000 + end until cursy!comma; 60383000 + if cursy!dosy then 60384000 + begin error(19); skip(dosy); 60385000 + if cursy=dosy then insymbol; 60386000 + end else insymbol; 60387000 + statement; 60388000 + toplevel:=startlevel; nwithsyms:=veryfirstwithsym; 60389000 +end of withstat; 60390000 + 60391000 + 60392000 +procedure statement; 60393000 +begin 60394000 + integer i; 60395000 + label labfound; 60396000 + 60397000 + if cursy=intconst then % *** labeled statement *** 60398000 + begin 60399000 + for i:=firstlab step 1 until numlabs do 60400000 + if labtab[i].labval=curval then 60401000 + begin if labtab[i].labdef=1 then error(31); 60402000 + labtab[i].labdef:=1; 60403000 + go to labfound; 60404000 + end; 60405000 + error(15); 60406000 +labfound: genid("l",curval,4); gen(":",1,7); 60407000 + insymbol; 60408000 + if cursy!colon then 60409000 + begin error(26); 60410000 + skip(colon); if cursy=colon then insymbol; 60411000 + end else insymbol; 60412000 + end; 60413000 + 60414000 + comment *** start of statement *** ; 60415000 + 60416000 + if cursy=identifier then 60417000 + begin 60418000 + search; 60419000 + if found then 60420000 + begin 60421000 + if thisid.idclass=var or 60422000 + thisid.idclass=const and boolean(thisid.formal) or 60423000 + thisid.idclass=func then assignment else 60424000 + if thisid.idclass=proc then 60425000 + begin 60426000 + if thislevel=0 then % *** intrinsic procedure *** 60427000 + begin 60428000 + if curname1="50write" then pwrite(false) else 60429000 + if curname1="7writel" and 60430000 + curname2="000000n" then pwrite(true) else 60431000 + if curname1="400read" then pread(false) else 60432000 + if curname1="6readln" then pread(true) else 60433000 + if curname1="400page" then filehandling(5) else 60434000 + if curname1="3000get" then filehandling(2) else 60435000 + if curname1="3000put" then filehandling(1) else 60436000 + if curname1="50reset" then filehandling(3) else 60437000 + if curname1="7rewrit" and 60438000 + curname2="000000e" then filehandling(4) else 60439000 + if curname1="3000new" then newdisp else 60440000 + if curname1="7dispos" and 60441000 + curname2="000000e" then newdisp else 60442000 + if curname1="400pack" then pack else 60443000 + if curname1="6unpack" then unpack else error(0); 60444000 + end else passparams; 60445000 + writeexpr; 60446000 + end else begin error(13); skip(99) end; 60447000 + end else begin error(1); assignment end; 60448000 + end of identifier else 60449000 + if cursy=beginsy then compstat else 60450000 + if cursy=ifsy then ifstat else 60451000 + if cursy=casesy then casestat else 60452000 + if cursy=whilesy then whilestat else 60453000 + if cursy=repeatsy then repeatstat else 60454000 + if cursy=forsy then forstat else 60455000 + if cursy=withsy then withstat else 60456000 + if cursy=gotosy then gotostat else 60457000 + if symkind[cursy]!terminal then 60458000 + begin error(13); insymbol; skip(semicolon) end; 60459000 +end of statement; 60460000 +$ page 60461000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%70001000 +% %70002000 +% %70003000 +% %70004000 +% part 7: type declarations. %70005000 +% ------------------ %70006000 +% %70007000 +% %70008000 +% %70009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%70010000 + 70011000 + 70012000 +real valx1,valx2; 70013000 +integer typex1,typex2; 70014000 +boolean packed; 70015000 + 70016000 +procedure fieldlist(rectab,firstaddr,lastaddr); 70017000 +value rectab,firstaddr; 70018000 +integer rectab,firstaddr,lastaddr; 70019000 +forward; 70020000 + 70021000 +define subrange= %*** subrange declaration*** 70022000 +begin %*************************** 70023000 + constant(valx1,typex1); 70024000 + if typetab1[typex1].form>char then error(11); 70025000 + if cursy!doubledot then error(53); 70026000 + insymbol; 70027000 + constant(valx2,typex2); 70028000 + if typex1>0 and typex2>0 then 70029000 + if typex1!typex2 then error(11) else 70030000 + if valx1>valx2 then error(54); 70031000 + t1:=typetab1[typex1].form; if t1=symbolic then t1:=subtype; 70032000 + newtype; ttype:=typeindex; 70033000 + t1.size:=tsize:=1; t1.struct:=0; t1.maintype:=typex1; 70034000 + typetab1[typeindex]:=t1; 70035000 + typetab2[typeindex]:=valx1; typetab3[typeindex]:=valx2; 70036000 +end of subrange#; 70037000 + 70038000 + 70039000 +procedure typedecl(ttype,tsize); 70040000 +integer ttype,tsize; 70041000 +begin 70042000 + procedure typerr(errnum,ttype,tsize); 70043000 + value errnum; 70044000 + integer errnum,ttype,tsize; 70045000 + begin error(errnum); 70046000 + ttype:=tsize:=0; 70047000 + end; 70048000 + 70049000 + integer recinx,arrstruct,tx,sx,t1,t2,t3,t,n; 70050000 + boolean first; 70051000 + 70052000 + packed:=false; 70080000 + if cursy=identifier then %*** simple type declaration *** 70081000 + begin %******************************* 70082000 + search; 70083000 + if found then 70084000 + begin 70085000 + if thisid.idclass=types then 70086000 + begin 70087000 + ttype:=thisid.type; tsize:=typetab1[ttype].size; 70088000 + insymbol; 70089000 + end else if thisid.idclass=const then subrange 70090000 + else typerr(7,ttype,tsize); 70091000 + end else begin typerr(1,ttype,tsize); insymbol end; 70092000 + end else 70093000 + if cursy{charconst or cursy=plus or cursy=minus then subrange else 70094000 + if cursy=lpar then 70095000 + begin 70096000 + n:=0; 70097000 + newtype; t3.idclass:=const; t3.type:=typeindex; 70098000 + do begin 70099000 + insymbol; 70100000 + if cursy=identifier then 70101000 + begin 70102000 + newname(curname1,curname2,curlevel); 70103000 + t3.info:=n; nametab3[curlevel,thisindex]:=t3; 70104000 + n:=n+1; insymbol; 70105000 + end else error(9); 70106000 + end until cursy!comma; 70107000 + if cursy!rpar then begin error(46); skip(rpar) end; 70108000 + t1:=symbolic; t1.struct:=0; 70109000 + t1.size:=tsize:=1; ttype:=typeindex; 70110000 + typetab1[typeindex]:=t1; 70111000 + typetab2[typeindex]:=0; typetab3[typeindex]:=n-1; 70112000 + if cursy=rpar then insymbol; 70113000 + end else 70114000 + 70115000 + if cursy=arrow then %*** pointer declaration *** 70116000 + begin %*************************** 70117000 + insymbol; 70118000 + if cursy=identifier then 70119000 + begin 70120000 + newtype; ttype:=typeindex; t1:=pointers; 70121000 + t1.size:=tsize:=1; t1.struct:=0; 70122000 + typetab1[typeindex]:=t1; 70123000 + search; 70124000 + if found then 70125000 + begin 70126000 + if thisid.idclass=types then 70127000 + typetab1[typeindex].pointtype:=thisid.type else 70128000 + typerr(7,ttype,tsize); 70129000 + end else 70130000 + begin 70131000 + if numpntrs0 then 70150000 + begin 70151000 + if typetab1[tx].form>char then error(48); 70152000 + t1:=arrays; t1.inxtype:=tx; t1.arrtype:=t; 70153000 + t2:=typetab2[tx]; t3:=typetab3[tx]; 70154000 + if t3-t2>1022 then error(61); 70155000 + t1.size:=min(1023,t3-t2+1); 70156000 + newtype; 70157000 + typetab1[typeindex]:=t1; 70158000 + typetab2[typeindex]:=t2; typetab3[typeindex]:=t3; 70159000 + t:=typeindex; 70160000 + end; 70161000 + end until cursy!comma; 70162000 + if cursy!rbracket then error(59) else insymbol; 70163000 + if cursy!ofsy then begin error(18); skip(ofsy) end; 70164000 + insymbol; 70165000 + typedecl(tx,sx); 70166000 + if typetab1[tx].form}files then error(60); 70167000 + arrstruct:=typetab1[tx].struct; 70168000 + while t>0 do 70169000 + begin 70170000 + t1:=typetab1[t]; t3:=t1.arrtype; 70171000 + t1.arrtype:=tx; t1.struct:=arrstruct:=arrstruct+1; 70172000 + t1.size:=sx:=min(1024,sx|t1.size); 70173000 + typetab1[t]:=t1; tx:=t; t:=t3; 70174000 + end; 70175000 + ttype:=tx; tsize:=sx; 70176000 + end of array declaration else 70177000 + 70178000 + if cursy=filesy then %*** file declaration *** 70179000 + begin %************************ 70180000 + insymbol; 70181000 + if cursy!ofsy then 70182000 + begin error(18); 70183000 + if cursy!identifier then insymbol; 70184000 + end else insymbol; 70185000 + typedecl(tx,sx); 70186000 + if tx>0 then 70187000 + begin t:=typetab1[tx]; 70188000 + if t.form}files then error(50) else 70189000 + if t.struct>1 then error(49) 70190000 + end; 70191000 + newtype; ttype:=typeindex; 70192000 + t1:=if t.form=char then textfile else files; 70193000 + t1.size:=tsize:=sx; t1.filetype:=tx; 70194000 + t1.struct:=1; 70195000 + typetab1[typeindex]:=t1; 70196000 + end of file declaration else 70197000 + 70198000 + if cursy=setsy then %*** set declaration *** 70199000 + begin %*********************** 70200000 + insymbol; 70201000 + if cursy!ofsy then 70202000 + begin error(18); 70203000 + if cursy>charconst then insymbol; 70204000 + end else insymbol; 70205000 + typedecl(tx,sx); 70206000 + if tx>0 then 70207000 + begin 70208000 + if typetab1[tx].form>char then error(48) else 70209000 + if typetab2[tx]<0 or typetab3[tx]>38 then error(51); 70210000 + end; 70211000 + newtype; ttype:=typeindex; 70212000 + t1:=set; t1.settype:=tx; t1.struct:=0; 70213000 + t1.size:=tsize:=1; typetab1[typeindex]:=t1; 70214000 + typetab2[typeindex]:=typetab2[tx]; 70215000 + typetab3[typeindex]:=typetab3[tx]; 70216000 + end of set declaration else 70217000 + 70218000 + if cursy=recordsy then %*** record declaration *** 70219000 + begin %************************** 70220000 + if lastrec-1>curlevel then lastrec:=lastrec-1 else error(55); 70221000 + recinx:=lastrec; 70222000 + blocktab[recinx]:=numblocks:=numblocks+1; 70223000 + insymbol; 70224000 + fieldlist(recinx,0,sx); 70225000 + if sx>1022 then begin error(56); sx:=1022 end; 70226000 + newtype; ttype:=typeindex; 70227000 + t1:=record; t1.rectab:=recinx; t1.struct:=1; 70228000 + t1.size:=tsize:=sx; typetab1[typeindex]:=t1; 70229000 + typetab2[typeindex]:=0; typetab3[typeindex]:=sx-1; 70230000 + if cursy!endsy then begin error(24); skip(endsy) end; 70231000 + if cursy=endsy then insymbol; 70232000 + end else begin error(4); skip(99) end; 70233000 + end; 70234000 +end of typedecl; 70235000 + 70236000 + 70237000 +procedure fieldlist(rectab,firstaddr,lastaddr); 70238000 +value rectab,firstaddr; 70239000 +integer rectab,firstaddr,lastaddr; 70240000 +begin 70241000 + integer array ilist[0:listlength]; 70242000 + integer listinx; 70243000 + integer casetype,addr,maxaddr,index,ctype,tx,sx,t1,t3,llim,ulim,i; 70244000 + boolean first; 70245000 + real cval; 70246000 + label casetypeid,casepart,exit; 70247000 + 70248000 + addr:=firstaddr; 70249000 + do begin 70250000 + while cursy=semicolon do insymbol; 70251000 + if cursy=casesy then go to casepart; 70252000 + if cursy=identifier then 70253000 + begin 70254000 + listinx:=0; first:=true; 70255000 + do begin 70256000 + if first then first:=false else insymbol; 70257000 + if cursy=identifier then 70258000 + begin 70259000 + if listinx}listlength then begin error(37); listinx:=0 end; 70260000 + listinx:=listinx+1; 70261000 + newname(curname1,curname2,rectab); 70262000 + ilist[listinx]:=thisindex; 70263000 + insymbol; 70264000 + end else 70265000 + begin error(9); 70266000 + if cursy!comma then insymbol; 70267000 + end; 70268000 + end until cursy!comma; 70269000 + if cursy!colon then begin error(26); skip(colon) end; 70270000 + insymbol; 70271000 + typedecl(tx,sx); 70272000 + if tx>0 then if typetab1[tx].form}files then error(57); 70273000 + t3.idclass:=var; t3.type:=tx; 70274000 + for i:=1 step 1 until listinx do 70275000 + begin 70276000 + t3.info:=addr; addr:=min(addr+sx|1024); 70277000 + nametab3[rectab,ilist[i]]:=t3; 70278000 + end; 70279000 + end; 70280000 + end until cursy!semicolon; 70281000 + lastaddr:=addr; 70282000 + go to exit; 70283000 + 70284000 +casepart: 70285000 + listinx:=0; lastaddr:=addr; index:=-1; 70286000 + insymbol; 70287000 + if cursy=identifier then 70288000 + begin 70289000 + search; 70290000 + if found and thisid.idclass=types then go to casetypeid; 70291000 + newname(curname1,curname2,rectab); index:=thisindex; 70292000 + insymbol; 70293000 + if cursy!colon then error(26); 70294000 + insymbol; 70295000 + if cursy=identifier then 70296000 + begin 70297000 + search; 70298000 + if found then 70299000 + begin 70300000 + if thisid.idclass=types then 70301000 + begin 70302000 +casetypeid: casetype:=thisid.type; t1:=typetab1[casetype]; 70303000 + llim:=typetab2[casetype]; ulim:=typetab3[casetype]; 70304000 + if t1.form>char then error(48); 70305000 + if index}0 then 70306000 + begin 70307000 + t3.idclass:=var; t3.type:=casetype; t3.info:=addr; 70308000 + addr:=lastaddr:=addr+1; nametab3[rectab,index]:=t3; 70309000 + end; 70310000 + insymbol; 70311000 + end else begin error(7); skip(ofsy) end; 70312000 + end else begin error(1); skip(ofsy) end; 70313000 + end else begin error(9); skip(ofsy) end; 70314000 + end else begin error(9); skip(ofsy) end; 70315000 + if cursy!ofsy then begin error(18); skip(rpar) end; 70316000 + if cursy=ofsy then insymbol; 70317000 + if casetype=0 then begin llim:=-maxint; ulim:=maxint end; 70318000 + do begin 70319000 + while cursy=semicolon do insymbol; 70320000 + if cursy{charconst or cursy=plus or cursy=minus then 70321000 + begin 70322000 + first:=true; 70323000 + do begin 70324000 + if first then first:=false else insymbol; 70325000 + constant(cval,ctype); 70326000 + if ctype>0 then 70327000 + begin 70328000 + if casetype=0 then casetype:=ctype else 70329000 + if cvalulim then error(14) else 70330000 + checktypes(casetype,ctype); 70331000 + if listinx}listlength then begin error(30); listinx:=0 end; 70332000 + listinx:=listinx+1; 70333000 + ilist[listinx]:=cval; i:=1; 70334000 + while ilist[i]!cval do i:=i+1; 70335000 + if ilastaddr then lastaddr:=maxaddr; 70344000 + if cursy!rpar then begin error(46); skip(rpar) end; 70345000 + insymbol; 70346000 + end else error(58); 70347000 + end; 70348000 + end until cursy neq semicolon; 70349000 +exit: 70350000 +end of fieldlist; 70351000 +$ page 70352000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%80001000 +% %80002000 +% %80003000 +% %80004000 +% part 8: the procedure block. %80005000 +% -------------------- %80006000 +% %80007000 +% %80008000 +% %80009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%80010000 + 80011000 + 80012000 + 80013000 +procedure declarevars(param,tab,first,last,level); 80014000 +value param,first,last,level; 80015000 +integer array tab[0]; 80016000 +integer first,last,level; 80017000 +boolean param; 80018000 +begin 80019000 + integer level1000,typ,nam,namtab,t1,i,j,recsize; 80020000 + boolean realvar,arrayvar,firstdim,extfile; 80021000 + alpha fname; 80022000 + integer fnlength,fnstart; 80023000 + 80024000 + level1000:=level|1000; 80025000 + for i:=first step 1 until last do 80026000 + begin 80027000 + nam:=tab[i].[9:10]; namtab:=nametab3[level,nam]; 80028000 + typ:=namtab.type; t1:=typetab1[typ]; 80029000 + if namtab.idclass geq func then 80030000 + begin 80031000 + if realvar or arrayvar then 80032000 + begin 80033000 + gen(";",1,7); 80034000 + realvar:=arrayvar:=false; 80035000 + end; 80036000 + if namtab.idclass=func then gen("real",5,4); 80037000 + gen("procedu",8,1); 80038000 + genid("v",level1000+nam,5); gen(";",1,7); 80039000 + end else 80040000 + if t1.struct=0 then %*** simple type *** 80041000 + begin 80042000 + if arrayvar then begin gen(";",1,7); arrayvar:=false end; 80043000 + if realvar then gen(",",1,7) else 80044000 + begin gen("real",5,4); realvar:=true end; 80045000 + genid("v",level1000+nam,5); 80046000 + end else 80047000 + begin 80048000 + if realvar then begin gen(";",1,7); realvar:=false end; 80049000 + if t1.form0 and curkind=const then error(94); 80201000 + end else if t.struct>0 then error(38); 80202000 + end else begin error(7); t3:=0 end; 80203000 + end else begin error(1); t3:=0 end; 80204000 + end else begin error(9); t3:=0 end; 80205000 + insymbol; 80206000 + end else 80207000 + begin 80208000 + if curkind!proc then error(7); 80209000 + t3:=0; 80210000 + end; 80211000 + t3.idclass:=curkind; t3.formal:=1; 80212000 + for i:=p1 step 1 until numparams do 80213000 + nametab3[curlevel+1,paramtab[i].paramname]:=t3; 80214000 + end until cursy!semicolon; 80215000 + if cursy!rpar then 80216000 + begin error(49); skip(rpar); 80217000 + if cursy=rpar then insymbol; 80218000 + end else insymbol 80119000 + end; 80220000 + paramtab[firstparam]:=numparams-firstparam; 80221000 +end of parameterlist; 80222000 + 80223000 + 80400000 +procedure block; 80401000 +begin 80402000 + integer index,ctype,numforwards,t,t3,tx,i; 80403000 + real cval; 80404000 + alpha c1,c2; 80405000 + boolean valueparams,fun; 80406000 + label start; 80407000 + 80408000 + integer labtabtop,consttabtop,typetabtop,paramtabtop,toprec, 80409000 + formerfirstlab,firstfile; 80410000 + 80411000 + formerfirstlab:=firstlab; 80412000 + labtabtop:=numlabs; firstlab:=labtabtop+1; 80413000 + consttabtop:=numconsts; 80414000 + typetabtop:=numtypes; 80415000 + paramtabtop:=numparams; 80416000 + toprec:=lastrec; 80417000 + firstfile:=numfiles+1; 80418000 + 80419000 + toplevel:=curlevel; 80420000 + if curlevel>1 then gen("begin",6,3); 80421000 +start: 80422000 + if cursy=labelsy then %*** label declaration *** 80423000 + begin %************************* 80424000 + gen("label",6,3); 80425000 + do begin 80426000 + insymbol; 80427000 + if cursy=intconst then 80428000 + begin 80429000 + genid("l",curval,4); 80430000 + if curval>9999 then error(33); 80431000 + for i:=firstlab step 1 until numlabs do 80432000 + if labtab[i].labval=curval then error(31); 80433000 + if numlabs}maxlabs then begin error(34); numlabs:=0 end; 80434000 + numlabs:=numlabs+1; 80435000 + labtab[numlabs]:=curval; 80436000 + insymbol; 80437000 + end else begin error(10); skip(comma) end; 80438000 + if cursy=comma then gen(",",1,7); 80439000 + end until cursy!comma; 80440000 + if cursy!semicolon then begin error(25); skip(semicolon) end; 80441000 + gen(";",1,7); 80442000 + if symkind[cursy]!initial then insymbol; 80443000 + end of label declaration; 80444000 + 80445000 + if cursy=constsy then %*** constant declaration *** 80446000 + begin %**************************** 80447000 + insymbol; 80448000 + do begin 80449000 + if cursy=identifier then 80450000 + begin 80451000 + newname(curname1,curname2,curlevel); index:=thisindex; 80452000 + insymbol; 80453000 + if cursy=eqlsy then 80454000 + begin 80455000 + insymbol; constant(cval,ctype); 80456000 + t3:=ctype; t3.idclass:=const; 80457000 + if cval.[46:8]!0 or cval>1023 then 80458000 + begin 80459000 + if numconsts}maxconsts then 80460000 + begin error(35); numconsts:=0 end; 80461000 + numconsts:=numconsts+1; 80462000 + consttab[numconsts]:=cval; 80463000 + t3.info:=1023+numconsts; 80464000 + end else t3.info:=cval; 80465000 + nametab3[curlevel,index]:=t3; 80466000 + end else begin error(36); skip(semicolon) end; 80467000 + end else begin error(9); skip(semicolon) end; 80468000 + if cursy!semicolon then begin error(25); skip(semicolon) end; 80469000 + if symkind[cursy]!initial then insymbol; 80470000 + end until cursy!identifier; 80471000 + end of constant declaration; 80472000 + 80473000 + if cursy=typesy then %*** type declaration **** 80474000 + begin %************************* 80475000 + insymbol; 80476000 + do begin 80477000 + if cursy=identifier then 80478000 + begin 80479000 + newname(curname1,curname2,curlevel); index:=thisindex; 80480000 + insymbol; 80481000 + if cursy=eqlsy then 80482000 + begin 80483000 + insymbol; 80484000 + typedecl(ctype,tx); 80485000 + t3:=ctype; t3.idclass:=types; 80486000 + nametab3[curlevel,index]:=t3; 80487000 + end else begin error(36); skip(semicolon) end; 80488000 + end else begin error(9); skip(semicolon) end; 80489000 + if cursy!semicolon then begin error(25); skip(semicolon) end; 80490000 + if symkind[cursy]!initial then insymbol; 80491000 + end until cursy!identifier; 80492000 + end of type declaration; 80493000 + 80494000 + if cursy=varsy then %*** variable declaration *** 80495000 + begin %**************************** 80496000 + varindex:=0; 80497000 + do begin 80498000 + firstvar:=varindex+1; 80499000 + do begin 80500000 + if cursy=varsy or cursy=comma then insymbol; 80501000 + if cursy=identifier then 80502000 + begin 80503000 + if varindex}listlength then 80504000 + begin error(37); varindex:=0 end; 80505000 + varindex:=varindex+1; 80506000 + newname(curname1,curname2,curlevel); 80507000 + varlist[varindex]:=thisindex; 80508000 + insymbol; 80509000 + end else begin error(9); skip(colon) end; 80510000 + end until cursy!comma; 80511000 + if cursy!colon then begin error(26); skip(colon) end; 80512000 + if cursy=colon then 80513000 + begin 80514000 + insymbol; 80515000 + typedecl(ctype,tx); 80516000 + t3:=ctype; t3.idclass:=var; 80517000 + for i:=firstvar step 1 until varindex do 80518000 + nametab3[curlevel,varlist[i]]:=t3; 80519000 + end else begin error(26); skip(semicolon) end; 80520000 + if cursy!semicolon then begin error(25); skip(semicolon) end; 80521000 + if symkind[cursy]!initial then insymbol; 80522000 + end until cursy!identifier; 80523000 + declarevars(false,varlist,1,varindex,curlevel); 80524000 + end of variable declarations; 80525000 + 80526000 + if numpntrs>0 then 80527000 + begin 80528000 + c1:=curname1; c2:=curname2; 80529000 + for i:=1 step 1 until numpntrs do 80530000 + begin 80531000 + curname1:=pntrtab1[i]; curname2:=pntrtab2[i]; 80532000 + searchtab(curlevel); 80533000 + thisid:=nametab3[curlevel,thisindex]; 80534000 + if found and thisid.idclass=types then 80535000 + typetab1[pntrtab3[i]].pointtype:=thisid.type else error(62); 80536000 + end; 80537000 + curname1:=c1; curname2:=c2; numpntrs:=0; 80538000 + end; 80539000 + 80540000 + while cursy=funcsy or cursy=procsy do %*** proc/func declaration ***80541000 + begin %*****************************80542000 + fun:=cursy=funcsy; insymbol; 80543000 + if cursy=identifier then 80544000 + begin 80545000 + searchtab(curlevel); 80546000 + thisid:=nametab3[curlevel,thisindex]; 80547000 + if found and thisid.idclass}proc then 80548000 + begin 80549000 + index:=thisindex; 80550000 + if thisid.forwarddef=1 then 80551000 + begin 80552000 + nametab3[thislevel,thisindex].forwarddef:=0; 80553000 + numforwards:=numforwards-1; 80554000 + if(thisid.idclass=proc and fun)or 80555000 + (thisid.idclass=func and not fun) then error(43); 80556000 + insymbol; 80567000 + end else begin error(2); skip(semicolon) end; 80568000 + end else 80569000 + begin 80570000 + newname(curname1,curname2,curlevel); index:=thisindex; 80571000 + t3:=0; t3.info:=numparams+1; 80572000 + t3.idclass:=if fun then func else proc; 80573000 + nametab3[curlevel,index]:=t3; 80574000 + insymbol; parameterlist; 80575000 + if cursy=colon then 80576000 + begin 80577000 + if not fun then error(48); 80578000 + insymbol; 80579000 + if cursy=identifier then 80580000 + begin 80581000 + search; 80582000 + if found then 80583000 + begin 80584000 + if thisid.idclass=types then 80585000 + begin 80586000 + t:=typetab1[thisid.type]; 80587000 + if t.form{alfa or t.form=pointers then 80588000 + begin 80589000 + nametab3[curlevel,index].type:=thisid.type; 80590000 + end else error(38); 80591000 + end else error(7); 80592000 + end else error(1); 80593000 + end else error(9); 80594000 + insymbol; 80595000 + end else if fun then 80596000 + begin error(26); skip(semicolon) end; 80597000 + end; 80598000 + end else begin error(9); skip(semicolon) end; 80599000 + if cursy!semicolon then begin error(25); skip(semicolon) end; 80600000 + if fun then gen("functn",7,2) else 80601000 + gen("procedu",8,1); genid("v",1000|curlevel+index,5); 80602000 + t:=nametab3[curlevel,index].info; tx:=t+paramtab[t]; 80603000 + if tx>t then 80604000 + begin 80605000 + gen("(",1,7); 80606000 + for i:=t+1 step 1 until tx do 80607000 + begin genid("v",1000|(curlevel+1)+paramtab[i].paramname,5); 80608000 + if boolean(paramtab[i].paramfile) then 80609000 + begin 80610000 + gen(",",1,7); 80611000 + genid("f",1000|(curlevel+1)+paramtab[i].paramname,5); 80612000 + gen(",",1,7); 80613000 + genid("i",1000|(curlevel+1)+paramtab[i].paramname,5); 80614000 + end; 80615000 + if i lss tx then gen(",",1,7); 80616000 + end; 80617000 + gen(");",2,6); 80618000 + valueparams:=false; 80619000 + for i:=t+1 step 1 until tx do 80620000 + if paramtab[i].paramkind=const then 80621000 + begin 80622000 + if not valueparams then 80623000 + begin gen("value",6,3); 80624000 + valueparams:=true; 80625000 + end else gen(",",1,7); 80626000 + genid("v",1000|(curlevel+1)+paramtab[i].paramname,5); 80627000 + end; 80628000 + if valueparams then gen(";",1,7); 80629000 + declarevars(true,paramtab,t+1,tx,curlevel+1); 80630000 + end else gen(";",1,7); 80631000 + 80632000 + insymbol; 80633000 + if curname1="7forwar" and curname2="d" then 80634000 + begin 80635000 + nametab3[curlevel,index].forwarddef:=1; 80636000 + numforwards:=numforwards+1; 80637000 + gen("forward",8,1); 80638000 + insymbol; 80639000 + end else 80640000 + begin 80641000 + curlevel:=curlevel+1; 80642000 + if curlevel}lastrec then error(55); 80643000 + blocktab[curlevel]:=numblocks:=numblocks+1; 80644000 + t:=curfunc; curfunc:=if fun then index else -1; 80645000 + block; %*** compile procedure body *** 80646000 + replace pointer(nametab1[curlevel,*]) by 0 80647000 + for maxnames+1 words; 80648000 + curlevel:=curlevel-1; curfunc:=t; 80649000 + toplevel:=curlevel; 80650000 + end; 80651000 + if cursy!semicolon then begin error(25); skip(semicolon) end; 80652000 + gen(";",1,7); 80653000 + if symkind[cursy]!initial then insymbol; 80654000 + end of procedure declaration; 80655000 + 80656000 + 80657000 + if numforwards>0 then error(44); 80658000 + gen("integer",8,1); 80659000 + for i:=1 step 1 until maxtemps do 80660000 + begin genid("t",i,2); 80661000 + if i1 then gen("end",4,5); 80703000 +end of block; 80704000 +$page 80705000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%90001000 +% %90002000 +% %90003000 +% %90004000 +% part 9: the main program. %90005000 +% ----------------- %90006000 +% %90007000 +% %90008000 +% %90009000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%90010000 + 90011000 + 90012000 +integer prognamelength; 90013000 +alpha progname,algolname; 90014000 + 90015000 +algolname:="pasc000"&entier(time(4) mod 10)[17:5:6]; 90016000 +algolname:=algolname&entier(time(4) div 7)[11:5:6]; 90017000 +algolname:=algolname&entier(time(4) mod 9)[5:5:6]; 90018000 +user:=time(-1); 90019000 +fill pascalgol with algolname,user; 90020000 +begin 90021000 + file pascrun disk serial "pascrun"/"disk" (2,10,150); 90022000 + array buf[0:9]; 90023000 + label eof; 90024000 + 90025000 + while true do 90026000 + begin 90027000 + read(pascrun,9,buf[*]) [eof]; 90028000 + write(pascalgol,10,buf[*]); 90029000 + end; 90030000 +eof: 90031000 +end of transfer of run time system; 90032000 +cardlength:=72; 90033000 +initialize; newcard; 90034000 +listoption:=checkoption:=true; 90035000 +c:=" "; insymbol; 90036000 +if cursy=programsy then 90037000 +begin 90038000 + insymbol; 90039000 + if cursy=identifier then 90040000 + begin 90041000 + progname:=curname1.[35:36]; prognamelength:=min(6,curlength); 90042000 + insymbol; 90043000 + if cursy=lpar then 90044000 + begin 90045000 + do begin 90046000 + insymbol; 90047000 + if cursy=identifier then 90048000 + begin 90049000 + if curname1="50input" then inputdecl:=true else 90050000 + if curname1="6output" then outputdecl:=true else 90051000 + begin 90052000 + if curlength>6 then error(77); 90053000 + numextfiles:=numextfiles+1; 90054000 + if numextfiles{maxextfiles then 90055000 + extfiletab[numextfiles]:=curname1 else 90056000 + if numextfiles=maxextfiles+1 then error(73); 90057000 + end; 90058000 + end else error(9); 90059000 + insymbol; 90060000 + end until cursy!comma; 90061000 + if cursy!rpar then begin error(46); skip(semicolon) end; 90062000 + if cursy=rpar then insymbol; 90063000 + if cursy!semicolon then begin error(25); skip(semicolon) end; 90064000 + end else begin error(58); skip(semicolon) end; 90065000 + end else begin error(9); skip(semicolon) end; 90066000 +end else begin error(75); skip(semicolon) end; 90067000 +insymbol; 90068000 +curlevel:=1; 90069000 +lastrec:=maxtables+1; 90070000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%90071000 +% %90072000 +% block; compile user program. %90073000 +% %90074000 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%90075000 +if cursy!dot then 90076000 +begin 90077000 + error(76); 90078000 + do block until cursy=dot; 90079000 +end; 90080000 +if false then 90081000 +begin 90082000 +endofinput: error(87); charcnt:=-1; 90083000 + write(lines,termmess); 90084000 +end; 90085000 +if listoption and charcnt}0 then printline; 90086000 +if errinx>0 then printerrors; 90087000 +write(lines[dbl]); 90088000 +write(lines[dbl]); 90089000 +if numerrs=0 then 90090000 +begin 90091000 + array ziparray[0:19], z[0:0]; 90092000 + pointer zippnt; 90093000 + 90094000 + define ziptext(text,l)= 90095000 + begin 90096000 + z[0]:=text; 90097000 + replace zippnt:zippnt by pointer(z[*])+(8-l) for l; 90098000 + end#; 90099000 + 90100000 + procedure zipnum(n); % transfers a number to the zip buffer. 90101000 + value n; integer n; 90102000 + if n{9 then ziptext(n,1) else 90103000 + begin zipnum(n div 10); ziptext(entier(n mod 10),1) end; 90104000 + 90105000 + writealgol; 90106000 + write(pascalgol,lastline); 90107000 + lock(pascalgol,save); 90108000 + zippnt:=pointer(ziparray[*]); 90109000 + replace zippnt by " " for 20 words; 90110000 + write(lines,noerrors); 90111000 + ziptext("cc ",3); ziptext("compile",7); 90112000 + ziptext(" ",1); ziptext(progname,prognamelength); 90113000 + ziptext("/",1); ziptext(user,7); 90114000 + ziptext(" xalgol",7); ziptext(" ",1); 90115000 + if savefactor>0 then ziptext("library",7); 90116000 + if savefactor<0 then ziptext("syntax",6); 90117000 + ziptext(";",1); 90118000 + ziptext("xalgol",6); ziptext(" file",5); 90119000 + ziptext(" card=",6); ziptext(algolname,7); 90120000 + ziptext("/",1); ziptext(user,7); 90121000 + ziptext(" serial",7); ziptext(";",1); 90122000 + if savefactor>0 then 90123000 + begin 90124000 + ziptext("save=",5); zipnum(savefactor); 90125000 + ziptext(";",1); 90126000 + end; 90127000 + ziptext("end.",4); 90128000 + zip with ziparray[*]; 90129000 +end of compiler zip else 90130000 +begin 91001000 + integer i; 91002000 + switch format errormess1 := 91003000 + (" 0 *** compiler error *** contact the computer centre."), 91004000 + (" 1 identifier not defined."), 91005000 + (" 2 identifier already defined."), 91006000 + (" 3 wrong number of parameters."), 91007000 + (" 4 syntax error."), 91008000 + (" 5 variable not accessible (hardware restriction)."), 91009000 + (" 6 strings may not be continued from one card to another."), 91010000 + (" 7 a type expected."), 91011000 + (" 8 variable expected."), 91012000 + (" 9 identifier expected."), 91013000 + (" 10 integer constant expected."), 91014000 + (" 11 constant of other type than expected."), 91015000 + (" 12 variable of illegal type."), 91016000 + (" 13 unrecognizable statement."), 91017000 + (" 14 constant too big or to small."), 91018000 + (" 15 undefined label."), 91019000 + (" 16 for- and case-statements nested too deep."), 91020000 + (" 17 expression is of wrong type."), 91021000 + (" 18 """of""" expected."), 91022000 + (" 19 """do""" expected."), 91023000 + (" 20 """else""" without corresponding """then"""."), 91024000 + (" 21 illegal termination of statement."), 91025000 + (" 22 """until""" expected."), 91026000 + (" 23 """to""" expected."), 91027000 + (" 24 """end""" expected."), 91028000 + (" 25 """;""" expected."), 91029000 + (" 26 """:""" expected."), 91030000 + (" 27 """then""" expected."), 91031000 + (" 28 """:=""" expected."), 91032000 + (" 29 only numbers may be signed."), 91033000 + (" 30 too many cases."), 91034000 + (" 31 label used more than once."), 91035000 + (" 32 constant expected."), 91036000 + (" 33 label not in range 0..9999."), 91037000 + (" 34 too many labels declared."), 91038000 + (" 35 too many constants declared."), 91039000 + (" 36 """=""" expected."), 91040000 + (" 37 the list is too long."), 91041000 + (" 38 invalid type for a function."), 91042000 + (" 39 """begin""" expected."), 91043000 + (" 40 too many identifiers declared."), 91044000 + (" 41 alfa constants may not be longer than 7 characters."), 91045000 + (" 42 expression is not of type boolean."), 91046000 + (" 43 not proper forward declaration."), 91047000 + (" 44 unsatisfied forward declaration."), 91048000 + (" 45 too many different types declared."), 91049000 + (" 46 """)""" expected."), 91050000 + (" 47 """[""" expected."), 91051000 + (" 48 a simple type expected."), 91052000 + (" 49 """array of array""" and """array of record""" illegal", 91053000 + " as file type."), 91054000 + (" 50 """file of file""" is illegal."), 91055000 + (" 51 set boundry is too big or too small."), 91056000 + (" 52 too many undeclared pointers."), 91057000 + (" 53 """..""" expected."), 91058000 + (" 54 first value is greater than second value."), 91059000 + (" 55 too many records declared at one time."), 91060000 + (" 56 the record contains more then 1023 words."), 91061000 + (" 57 files not allowed in records."), 91062000 + (" 58 """(""" expected."), 91063000 + (" 59 """]""" expected."); 91064000 + 91065000 + switch format errormess2 := 91066000 + (" 60 """array of file""" not allowed."), 91067000 + (" 61 range of index is greater than 1023."), 91068000 + (" 62 unsatisfied pointer declaration."), 91069000 + (" 63 expression is too long."), 91070000 + (" 64 illegal operator for this type of expression."), 91071000 + (" 65 integer expression expected."), 91072000 + (" 66 a set expected."), 91073000 + (" 67 parameter of illegal type."), 91074000 + (" 68 procedures not allowed in this context."), 91075000 + (" 69 illegal use of this type of identifier."), 91076000 + (" 70 too many parameters declared in the program."), 91077000 + (" 71 """array of char""" expected."), 91078000 + (" 72 wrong type of set expression."), 91079000 + (" 73 too many external files."), 91080000 + (" 74 illegal identifier for external file."), 91081000 + (" 75 """program""" expected."), 91082000 + (" 76 """.""" expected."), 91083000 + (" 77 external file identifier may not exceed 6 characters."), 91084000 + (" 78 illegal file parameter."), 91085000 + (" 79 illegal use of file handling procedure."), 91086000 + (" 80 text-file expected."), 91087000 + (" 81 pointer variable expected."), 91088000 + (" 82 only values of type real, integer or char may be read."), 91089000 + (" 83 variables in records illegal in this context."), 91090000 + (" 84 display overflow."), 91091000 + (" 85 read and write may only be used on text-files."), 91092000 + (" 86 referenced object is too big."), 91093000 + (" 87 end-of-input discovered."), 91094000 + (" 88 character array expected."), 91095000 + (" 89 """,""" expected."), 91096000 + (" 91 procedures may not have any type."), 91097000 + (" 91 parameters of wrong kind."), 91098000 + (" 92 only complete arrays and records may be transmitted."), 91099000 + (" 93 declared label not used."), 91100000 + (" 94 parameters of this type should not be value parameters."), 91101000 + (" 95 assignment of structured variables not implimented."), 91102000 + (" 96 input/ouput not declared."), 91103000 + (" 97 too many files in use."), 91104000 + (" 98 record identifier expected."), 91105000 + (" 99 unrecognized item."), 91106000 + (); 91107000 + 91108000 + 91109000 + write(lines,errors,numerrs); 91110000 + for i:=0 step 1 until 59 do if err[i] then 91111000 + write(lines,errormess1[i]); 91112000 + for i:=60 step 1 until 119 do if err[i] then 91113000 + write(lines,errormess2[i-60]); 91114000 +end of error messages; 91115000 +if xrefoption then 92001000 +begin 92002000 + replace pointer(xrefline[*]) by " " for 17 words; 92003000 + heading; 92004000 + sort(printxref,xreffile,0,xrefmax,xrefcompare,3,1000,6000); 92005000 +end; 92006000 +end of b5700 pascal compiler compiler.. ................................99001000 +END;END. last card image on source tape file 99999999 ?end