pem.p 97 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221
  1. #include <em_spec.h>
  2. #include <em_pseu.h>
  3. #include <em_mnem.h>
  4. #include <em_mes.h>
  5. #include <em_reg.h>
  6. #include <pc_size.h>
  7. {
  8. (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
  9. This product is part of the Amsterdam Compiler Kit.
  10. Permission to use, sell, duplicate or disclose this software must be
  11. obtained in writing. Requests for such permissions may be sent to
  12. Dr. Andrew S. Tanenbaum
  13. Wiskundig Seminarium
  14. Vrije Universiteit
  15. Postbox 7161
  16. 1007 MC Amsterdam
  17. The Netherlands
  18. }
  19. {if next line is included the compiler itself is written in standard pascal}
  20. {#define STANDARD 1}
  21. {Author: Johan Stevenson Version: 32}
  22. {$l- : no source line numbers}
  23. {$r- : no subrange checking}
  24. {$a- : no assertion checking}
  25. #ifdef STANDARD
  26. {$s+ : test conformancy to standard}
  27. #endif
  28. program pem(input,em,errors);
  29. {/*
  30. This Pascal compiler produces EM code as described in
  31. - A.S.Tanenbaum, J.W.Stevenson & H. van Staveren,
  32. "Description of a machine architecture for use with
  33. block structured languages" Informatika rapport 81.
  34. NOTE: this version is modified to produce the modified EM code of
  35. januari 1981. it is not possible, using this compiler, to
  36. generate code for machines with 1 byte wordsize.
  37. NOTE: this version is modified by Kees Visser in such a way that
  38. the compiler can now run on 2 and 4 byte machines. It is also
  39. able to generate em-code for a 2 bytes machine while running
  40. on a 4-bytes machine. Cross-compilation from a 2 bytes to a
  41. four bytes machine is also possible with the following
  42. exception: large integers that don't fit in an integer of
  43. the compiler are treated like longs and are thus not allowed
  44. in types.
  45. A description of Pascal is given in
  46. - K.Jensen & N.Wirth, "PASCAL user manual and report", Springer-Verlag.
  47. Several options may be given in the normal pascal way. Moreover,
  48. a positive number may be used instead of + and -. The options are:
  49. a: interpret assertions (+)
  50. c: C-type strings allowed (-)
  51. d: type long may be used (-)
  52. i: controls the number of elements in integer sets
  53. default: (wordsize in bits)
  54. l: insert code to keep track of source lines (+)
  55. o: optimize (+)
  56. r: check subranges (+)
  57. s: accept only standard pascal programs (-)
  58. t: trace procedure entry and exit (-)
  59. u: treat '_' as letter (-)
  60. */}
  61. {===================================================================}
  62. #ifdef STANDARD
  63. label 9999;
  64. #endif
  65. const
  66. {fundamental constants}
  67. MB1 = 7;
  68. NB1 = 8;
  69. MI2 = 32767;
  70. MU1 = 255;
  71. NU1 = 256;
  72. {string constants}
  73. imax = 10;
  74. max2bytes = '0000032767';
  75. max4bytes = '2147483647';
  76. #ifdef vax4
  77. MU2 = 65535;
  78. NU2 = 65536;
  79. {characteristics of the machine on which the compiler will run}
  80. {wordsize and integer size are 4}
  81. szcompint = 4;
  82. MI = 2147483647;
  83. maxcompintstring = max4bytes;
  84. #endif
  85. #ifdef vax2
  86. MU2 = 0; {not used}
  87. NU2 = 0; {not used}
  88. szcompint = 2;
  89. MI = MI2;
  90. maxcompintstring = max2bytes;
  91. #endif
  92. {maximal indices}
  93. idmax = 8;
  94. fnmax = 14;
  95. smax = 72;
  96. {opt values}
  97. off = 0;
  98. on = 1;
  99. {for push and pop: }
  100. global = false;
  101. local = true;
  102. {for sizeof and posaddr: }
  103. wordmult = false;
  104. wordpart = true;
  105. {ASCII characters}
  106. ascht = 9;
  107. ascnl = 10;
  108. ascvt = 11;
  109. ascff = 12;
  110. asccr = 13;
  111. {miscellaneous}
  112. maxcharord = 127; {maximal ordinal number of chars}
  113. maxargc = 13; {maximal index in argv}
  114. rwlim = 34; {number of reserved words}
  115. spaces = ' ';
  116. {-------------------------------------------------------------------}
  117. type
  118. {scalar types}
  119. symbol= (comma,semicolon,colon1,colon2,notsy,lbrack,ident,
  120. intcst,charcst,realcst,longcst,stringcst,nilcst,minsy,
  121. plussy,lparent,arrow,arraysy,recordsy,setsy,filesy,
  122. packedsy,progsy,labelsy,constsy,typesy,varsy,procsy,
  123. funcsy,beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,
  124. withsy,casesy,becomes,starsy,divsy,modsy,slashsy,
  125. andsy,orsy,eqsy,nesy,gtsy,gesy,ltsy,
  126. lesy,insy,endsy,elsesy,untilsy,ofsy,dosy,
  127. downtosy,tosy,thensy,rbrack,rparent,period
  128. ); {the order is important}
  129. chartype= (lower,upper,digit,layout,tabch,
  130. quotech,dquotech,colonch,periodch,lessch,
  131. greaterch,lparentch,lbracech,
  132. {different entries}
  133. rparentch,lbrackch,rbrackch,commach,semich,arrowch,
  134. plusch,minch,slash,star,equal,
  135. {also symbols}
  136. others
  137. );
  138. standpf= (pread,preadln,pwrite,pwriteln,pput,pget,
  139. preset,prewrite,pnew,pdispose,ppack,punpack,
  140. pmark,prelease,ppage,phalt,
  141. {all procedures}
  142. feof,feoln,fabs,fsqr,ford,fchr,fpred,fsucc,fodd,
  143. ftrunc,fround,fsin,fcos,fexp,fsqt,flog,fatn
  144. {all functions}
  145. ); {the order is important}
  146. libmnem= (ELN ,EFL ,CLS ,WDW , {input and output}
  147. OPN ,GETX,RDI ,RDC ,RDR ,RDL ,RLN ,
  148. {on inputfiles}
  149. CRE ,PUTX,WRI ,WSI ,WRC ,WSC ,WRS ,WSS ,WRB ,
  150. WSB ,WRR ,WSR ,WRL, WSL, WRF ,WRZ ,WSZ ,WLN ,PAG ,
  151. {on outputfiles, order important}
  152. ABR ,RND ,SINX,COSX,EXPX,SQT ,LOG ,ATN ,
  153. {floating point}
  154. ABI ,ABL ,BCP ,BTS ,NEWX,SAV ,RST ,INI ,HLT ,
  155. ASS ,GTO ,PAC ,UNP, DIS, ASZ, MDI, MDL
  156. {miscellaneous}
  157. );
  158. structform= (scalar,subrange,pointer,power,files,arrays,carray,
  159. records,variant,tag); {order important}
  160. structflag= (spack,withfile);
  161. identflag= (refer,used,assigned,noreg,loopvar,samesect);
  162. idclass= (types,konst,vars,field,carrbnd,proc,func);
  163. kindofpf= (standard,formal,actual,extern,varargs,forward);
  164. where= (blck,rec,wrec);
  165. attrkind= (cst,fixed,pfixed,loaded,ploaded,indexed);
  166. twostruct= (eq,subeq,ir,ri,il,li,lr,rl,es,se,noteq); {order important}
  167. {subrange types}
  168. rwrange= 0..rwlim;
  169. byte= 0..MU1;
  170. {pointer types}
  171. sp= ^structure;
  172. ip= ^identifier;
  173. lp= ^labl;
  174. bp= ^blockinfo;
  175. np= ^nameinfo;
  176. {set types}
  177. sos= set of symbol;
  178. setofids= set of idclass;
  179. formset= set of structform;
  180. sflagset= set of structflag;
  181. iflagset= set of identflag;
  182. {array types}
  183. idarr=packed array[1..idmax] of char;
  184. fnarr=packed array[1..fnmax] of char;
  185. {record types}
  186. position=record {the addr info of certain variable}
  187. ad:integer; {for locals it is the byte offset}
  188. lv:integer; {the level of the beast}
  189. end;
  190. {records of type attr are used to remember qualities of
  191. expression parts to delay the loading of them.
  192. Reasons to delay the loading of one word constants:
  193. - bound checking
  194. - set building.
  195. Reasons to delay the loading of direct accessible objects:
  196. - efficient handling of read/write
  197. - efficient handling of the with statement.
  198. }
  199. attr=record
  200. asp:sp; {type of expression}
  201. packbit:boolean; {true for part of packed structure}
  202. ak:attrkind; {access method}
  203. pos:position; {lv and ad}
  204. {If ak=cst then the value is stored in ad}
  205. end;
  206. nameinfo=record {one for each separate name space}
  207. nlink:np; {one deeper}
  208. fname:ip; {first name: root of tree}
  209. case occur:where of
  210. blck:();
  211. rec: ();
  212. wrec:(wa:attr) {name space opened by with statement}
  213. end;
  214. blockinfo=record {all info of the current procedure}
  215. nextbp:bp; {pointer to blockinfo of surrounding proc}
  216. reglb:integer; {data location counter (from begin of proc) }
  217. minlb:integer; {keeps track of minimum of reglb}
  218. ilbno:integer; {number of last local label}
  219. forwcount:integer; {number of not yet specified forward procs}
  220. lchain:lp; {first label: header of chain}
  221. end;
  222. structure=record
  223. size:integer; {size of structure in bytes}
  224. sflag:sflagset; {flag bits}
  225. case form:structform of
  226. scalar :(scalno:integer; {number of range descriptor}
  227. fconst:ip {names of constants}
  228. );
  229. subrange:(min,max:integer; {lower and upper bound}
  230. rangetype:sp; {type of bounds}
  231. subrno:integer {number of subr descriptor}
  232. );
  233. pointer :(eltype:sp); {type of pointed object}
  234. power :(elset:sp); {type of set elements}
  235. files :(filtype:sp); {type of file elements}
  236. arrays,carray:
  237. (aeltype:sp; {type of array elements}
  238. inxtype:sp; {type of array index}
  239. arpos:position {position of array descriptor}
  240. );
  241. records :(fstfld:ip; {points to first field}
  242. tagsp:sp {points to tag if present}
  243. );
  244. variant :(varval:integer; {tag value for this variant}
  245. nxtvar:sp; {next equilevel variant}
  246. subtsp:sp {points to tag for sub-case}
  247. );
  248. tag :(fstvar:sp; {first variant of case}
  249. tfldsp:sp {type of tag}
  250. )
  251. end;
  252. identifier=record
  253. idtype:sp; {type of identifier}
  254. name:idarr; {name of identifier}
  255. llink,rlink:ip; {see enterid,searchid}
  256. next:ip; {used to make several chains}
  257. iflag:iflagset; {several flag bits}
  258. case klass:idclass of
  259. types :();
  260. konst :(value:integer); {for integers the value is
  261. computed and stored in this field.
  262. For strings and reals an assembler constant is
  263. defined labeled '.1', '.2', ... This '.' number is then
  264. stored in value. For reals value may be negated to
  265. indicate that the opposite of the assembler constant
  266. is needed. }
  267. vars :(vpos:position); {position of var}
  268. field :(foffset:integer); {offset to begin of record}
  269. carrbnd :(); {idtype points to carray struct}
  270. proc,func:
  271. (case pfkind:kindofpf of
  272. standard:(key:standpf); {identification}
  273. formal,actual,forward,extern,varargs:
  274. (pfpos:position; {lv gives declaration level.
  275. ad is relevant for formal pf s and for
  276. functions (no conflict!!).
  277. for functions: ad is the result address.
  278. for formal pf s: ad is the address of the
  279. descriptor }
  280. pfno:integer; {unique pf number}
  281. maxlb:integer; {bytes of parameters}
  282. parhead:ip {head of parameter list}
  283. )
  284. )
  285. end;
  286. labl=record
  287. nextlp:lp; {chain of labels}
  288. seen:boolean;
  289. labval:integer; {label number given by the programmer}
  290. labname:integer; {label number given by the compiler}
  291. labdlb:integer {zero means only locally used,
  292. otherwise dlbno of label information}
  293. end;
  294. {-------------------------------------------------------------------}
  295. var {the most frequent used externals are declared first}
  296. sy:symbol; {last symbol}
  297. a:attr; {type,access method,position,value of expr}
  298. {returned by insym}
  299. ch:char; {last character}
  300. chsy:chartype; {type of ch, used by insym}
  301. val:integer; {if last symbol is an constant }
  302. ix:integer; {string length}
  303. eol:boolean; {true of current ch is a space, replacing a newline}
  304. zerostring:boolean; {true for strings in " "}
  305. id:idarr; {if last symbol is an identifier}
  306. {some counters}
  307. lino:integer; {line number on code file (1..n) }
  308. dlbno:integer; {number of last global number}
  309. holeb:integer; {size of hol-area}
  310. level:integer; {current static level}
  311. argc:integer; {index in argv}
  312. lastpfno:integer; {unique pf number counter}
  313. copt:integer; {C-type strings allowed if on}
  314. dopt:integer; {longs allowed if on}
  315. iopt:integer; {number of bits in sets with base integer}
  316. sopt:integer; {standard option}
  317. srcchno:integer; {column count for errors}
  318. srclino:integer; {source line number after preprocessing}
  319. srcorig:integer; {source line number before preprocessing}
  320. fildlb:integer; {label number of source string}
  321. {pointers pointing to standard types}
  322. realptr,intptr,textptr,nullset,boolptr:sp;
  323. charptr,nilptr,zeroptr,procptr,longptr:sp;
  324. {flags}
  325. giveline:boolean; {give source line number at next statement}
  326. including:boolean; {no LINs for included code}
  327. eofexpected:boolean; {quit without error if true (nextch) }
  328. main:boolean; {complete programme or a module}
  329. intypedec:boolean; {true if nested in typedefinition}
  330. fltused:boolean; {true if floating point instructions are used}
  331. seconddot:boolean; {indicates the second dot of '..'}
  332. {pointers}
  333. fwptr:ip; {head of chain of forward reference pointers}
  334. progp:ip; {program identifier}
  335. currproc:ip; {current procedure/function ip (see selector)}
  336. top:np; {pointer to the most recent name space}
  337. lastnp:np; {pointer to nameinfo of last searched ident }
  338. {records}
  339. b:blockinfo; {all info to be stacked at pfdeclaration}
  340. fa:attr; {attr for current file name}
  341. {arrays}
  342. sizes:array[0 .. sz_last] of integer;
  343. maxintstring,maxlongstring:packed array[1..imax] of char;
  344. strbuf:array[1..smax] of char;
  345. rw:array[rwrange] of idarr;
  346. {reserved words}
  347. frw:array[0..idmax] of integer;
  348. {indices in rw}
  349. rsy:array[rwrange] of symbol;
  350. {symbol for reserved words}
  351. cs:array[char] of chartype;
  352. {chartype of a character}
  353. csy:array[rparentch..equal] of symbol;
  354. {symbol for single character symbols}
  355. lmn:array[libmnem] of packed array[1..4] of char;
  356. {mnemonics of pascal library routines}
  357. opt:array['a'..'z'] of integer;
  358. forceopt:array['a'..'z'] of boolean;
  359. {26 different options}
  360. undefip:array[idclass] of ip;
  361. {used in searchid}
  362. iop:array[boolean] of ip;
  363. {false:standard input, true:standard output}
  364. argv:array[0..maxargc] of
  365. record name:idarr; ad:integer end;
  366. {save here the external heading names}
  367. {files}
  368. em:file of byte; {the EM code}
  369. errors:text; {the compilation errors}
  370. source:fnarr;
  371. {===================================================================}
  372. procedure initpos(var p:position);
  373. begin p.lv:=level; p.ad:=0; end;
  374. procedure inita(fsp:sp; fad:integer);
  375. begin with a do begin
  376. asp:=fsp; packbit:=false; ak:=fixed; pos.ad:=fad; pos.lv:=level;
  377. end end;
  378. function newip(kl:idclass; n:idarr; idt:sp; nxt:ip):ip;
  379. var p:ip; f:iflagset;
  380. begin f:=[];
  381. case kl of
  382. types,carrbnd: {similar structure}
  383. new(p,types);
  384. konst:
  385. begin new(p,konst); p^.value:=0 end;
  386. vars:
  387. begin new(p,vars); f:=[used,assigned]; initpos(p^.vpos) end;
  388. field:
  389. begin new(p,field); p^.foffset:=0 end;
  390. proc,func: {same structure}
  391. begin new(p,proc,actual); p^.pfkind:=actual;
  392. initpos(p^.pfpos); p^.pfno:=0; p^.maxlb:=0; p^.parhead:=nil;
  393. end
  394. end;
  395. p^.name:=n; p^.klass:=kl; p^.idtype:=idt; p^.next:=nxt;
  396. p^.llink:=nil; p^.rlink:=nil; p^.iflag:=f; newip:=p
  397. end;
  398. function newsp(sf:structform; sz:integer):sp;
  399. var p:sp; sflag:sflagset;
  400. begin sflag:=[];
  401. case sf of
  402. scalar:
  403. begin new(p,scalar); p^.scalno:=0; p^.fconst:=nil end;
  404. subrange:
  405. new(p,subrange);
  406. pointer:
  407. begin new(p,pointer); p^.eltype:=nil end;
  408. power:
  409. new(p,power);
  410. files:
  411. begin new(p,files); sflag:=[withfile] end;
  412. arrays,carray: {same structure}
  413. new(p,arrays);
  414. records:
  415. new(p,records);
  416. variant:
  417. new(p,variant);
  418. tag:
  419. new(p,tag);
  420. end;
  421. p^.form:=sf; p^.size:=sz; p^.sflag:=sflag; newsp:=p;
  422. end;
  423. function sizeof(fsp:sp; partword:boolean):integer;
  424. var s:integer;
  425. begin if fsp=nil then s:=0 else s:=fsp^.size;
  426. if s<>0 then
  427. if partword and (s<sz_word) then
  428. while sz_word mod s <> 0 do s:=s+1
  429. else
  430. while s mod sz_word <> 0 do s:=s+1;
  431. sizeof:=s
  432. end;
  433. function formof(fsp:sp; forms:formset):boolean;
  434. begin if fsp=nil then formof:=false else formof:=fsp^.form in forms end;
  435. {===================================================================}
  436. procedure put1(b:byte);
  437. begin write(em,b) end;
  438. procedure put2(i:integer);
  439. var i1,i2:byte;
  440. begin
  441. if i<0 then
  442. begin i:=-(i+1); i1:=MU1 - i mod NU1; i2:=MU1 - i div NU1 end
  443. else
  444. begin i1:=i mod NU1; i2:=i div NU1 end;
  445. put1(i1); put1(i2)
  446. end;
  447. procedure put4(i:integer);
  448. var i1,i2:integer;
  449. begin
  450. if i<0 then
  451. begin i:=-(i+1); i1:=MU2 - i mod NU2; i2:=MU2 - i div NU2 end
  452. else
  453. begin i1:=i mod NU2; i2:=i div NU2 end;
  454. put1(i1 mod NU1); put1(i1 div NU1);
  455. put1(i2 mod NU1); put1(i2 div NU1)
  456. end;
  457. procedure argend;
  458. begin put1(sp_cend) end;
  459. procedure argcst(i:integer);
  460. begin
  461. if (i >= -sp_zcst0) and (i < sp_ncst0-sp_zcst0) then
  462. put1(i + sp_zcst0 + sp_fcst0)
  463. else if (i >= -MI2-1) and (i <= MI2) then
  464. begin put1(sp_cst2); put2(i) end
  465. else begin put1(sp_cst4); put4(i) end
  466. end;
  467. procedure argnil;
  468. begin put1(sp_icon); argcst(sz_addr); argcst(1); put1(ord('0')) end;
  469. procedure argilb(i:integer);
  470. begin
  471. if i<=MU1 then
  472. begin put1(sp_ilb1); put1(i) end
  473. else
  474. begin put1(sp_ilb2); put2(i) end
  475. end;
  476. procedure argdlb(i:integer);
  477. begin
  478. if i<=MU1 then
  479. begin put1(sp_dlb1); put1(i) end
  480. else
  481. begin put1(sp_dlb2); put2(i) end
  482. end;
  483. procedure argident(var a:idarr);
  484. var i,j:integer;
  485. begin i:=idmax;
  486. while (a[i]=' ') and (i>1) do i:=i-1;
  487. put1(sp_pnam); argcst(i);
  488. for j:=1 to i do put1(ord(a[j]))
  489. end;
  490. procedure genop(b:byte);
  491. begin put1(b); lino:=lino+1 end;
  492. procedure gencst(b:byte; i:integer);
  493. begin genop(b); argcst(i) end;
  494. procedure gensp(m:libmnem; s:integer);
  495. var i:integer;
  496. begin genop(op_cal); put1(sp_pnam); argcst(4);
  497. for i:=1 to 4 do put1(ord(lmn[m][i]));
  498. gencst(op_asp,s)
  499. end;
  500. procedure genpnam(b:byte; fip:ip);
  501. var n:idarr; i,j:integer;
  502. begin
  503. if fip^.pfpos.lv<=1 then n:=fip^.name else
  504. begin n:='_ '; j:=1; i:=fip^.pfno;
  505. while i<>0 do
  506. begin j:=j+1; n[j]:=chr(i mod 10 + ord('0')); i:=i div 10 end;
  507. end;
  508. genop(b); argident(n)
  509. end;
  510. procedure genasp(m:byte);
  511. begin gencst(m,sizeof(a.asp,wordmult)) end;
  512. procedure genlin;
  513. begin giveline:=false;
  514. if opt['l']<>off then if main then gencst(op_lin,srcorig)
  515. end;
  516. procedure genreg(sz,ad,regval:integer);
  517. begin gencst(ps_mes,ms_reg);
  518. argcst(ad); argcst(sz); argcst(regval); argend
  519. end;
  520. procedure laedlb(d:integer);
  521. begin genop(op_lae); argdlb(d) end;
  522. procedure exchange(l1,l2:integer);
  523. var d1,d2:integer;
  524. begin d1:=l2-l1; d2:=lino-l2;
  525. if (d1<>0) and (d2<>0) then
  526. begin gencst(ps_exc,d1); argcst(d2) end
  527. end;
  528. procedure newilb(i:integer);
  529. begin lino:=lino+1;
  530. if i<sp_nilb0 then put1(i+sp_filb0) else argilb(i)
  531. end;
  532. function newdlb:integer;
  533. begin lino:=lino+1; dlbno:=dlbno+1; argdlb(dlbno); newdlb:=dlbno end;
  534. function romstr(typ:byte; siz:integer):integer;
  535. var i:integer;
  536. begin romstr:=newdlb; genop(ps_rom);
  537. put1(typ); if typ<>sp_scon then argcst(siz); argcst(ix);
  538. for i:=1 to ix do put1(ord(strbuf[i])); argend
  539. end;
  540. {===================================================================}
  541. procedure error(err:integer);
  542. {as you will notice, all error numbers are preceded by '+' and '0' to
  543. ease their renumbering in case of new errornumbers.
  544. }
  545. begin writeln(errors,err,srclino,srcchno);
  546. if err>0 then begin gencst(ps_mes,ms_err); argend end
  547. end;
  548. procedure errid(err:integer; var id:idarr);
  549. begin write(errors,'''',id); error(err) end;
  550. procedure errint(err:integer; i:integer);
  551. begin write(errors,i:1); error(err) end;
  552. procedure errasp(err:integer);
  553. begin if a.asp<>nil then begin error(err); a.asp:=nil end end;
  554. procedure teststandard;
  555. begin if sopt<>off then error(-(+01)) end;
  556. procedure enterid(fip: ip);
  557. {enter id pointed at by fip into the name-table,
  558. which on each declaration level is organised as
  559. an unbalanced binary tree}
  560. var nam:idarr; lip,lip1:ip; lleft,again:boolean;
  561. begin nam:=fip^.name; again:=false; assert nam[1]<>' ';
  562. lip:=top^.fname;
  563. if lip=nil then top^.fname:=fip else
  564. begin
  565. repeat lip1:=lip;
  566. if lip^.name>nam then
  567. begin lip:=lip^.llink; lleft:=true end
  568. else
  569. begin if lip^.name=nam then again:=true; {name conflict}
  570. lip:=lip^.rlink; lleft:=false;
  571. end;
  572. until lip=nil;
  573. if lleft then lip1^.llink:=fip else lip1^.rlink:=fip
  574. end;
  575. fip^.llink:=nil; fip^.rlink:=nil;
  576. if again then errid(+02,nam);
  577. end;
  578. {===================================================================}
  579. procedure trace(tname:idarr; fip:ip; var namdlb:integer);
  580. var i:integer;
  581. begin
  582. if opt['t']<>off then
  583. begin
  584. if namdlb=0 then
  585. begin namdlb:=newdlb; genop(ps_rom); put1(sp_scon); argcst(8);
  586. for i:=1 to 8 do put1(ord(fip^.name[i])); argend;
  587. end;
  588. laedlb(namdlb); genop(op_cal); argident(tname);
  589. gencst(op_asp,sz_addr);
  590. end;
  591. end;
  592. procedure expandnullset(fsp:sp);
  593. var s:integer;
  594. begin s:=sizeof(fsp,wordmult)-sz_word;
  595. if s<>0 then gencst(op_zer,s); a.asp:=fsp
  596. end;
  597. procedure push(local:boolean; ad:integer; sz:integer);
  598. begin assert sz mod sz_word = 0;
  599. if sz=sz_word then
  600. if local then gencst(op_lol,ad) else gencst(op_loe,ad)
  601. else if sz=2*sz_word then
  602. if local then gencst(op_ldl,ad) else gencst(op_lde,ad)
  603. else
  604. begin if local then gencst(op_lal,ad) else gencst(op_lae,ad);
  605. gencst(op_loi,sz)
  606. end
  607. end;
  608. procedure pop(local:boolean; ad:integer; sz:integer);
  609. begin assert sz mod sz_word = 0;
  610. if sz=sz_word then
  611. if local then gencst(op_stl,ad) else gencst(op_ste,ad)
  612. else if sz=2*sz_word then
  613. if local then gencst(op_sdl,ad) else gencst(op_sde,ad)
  614. else
  615. begin if local then gencst(op_lal,ad) else gencst(op_lae,ad);
  616. gencst(op_sti,sz)
  617. end
  618. end;
  619. procedure lexaddr(lv:integer; ad:integer);
  620. begin assert level>=lv;
  621. if ad>=0 then gencst(op_lxa,level-lv) else gencst(op_lxl,level-lv);
  622. gencst(op_adp,ad)
  623. end;
  624. procedure loadpos(var p:position; sz:integer);
  625. begin with p do
  626. if lv<=0 then push(global,ad,sz) else
  627. if lv=level then push(local,ad,sz) else
  628. begin lexaddr(lv,ad); gencst(op_loi,sz) end;
  629. end;
  630. procedure descraddr(var p:position);
  631. begin if p.lv=0 then laedlb(p.ad) else loadpos(p,sz_addr) end;
  632. procedure loadaddr;
  633. begin with a,pos do begin
  634. case ak of
  635. fixed:
  636. if lv<=0 then gencst(op_lae,ad) else
  637. if lv=level then gencst(op_lal,ad) else lexaddr(lv,ad);
  638. pfixed:
  639. loadpos(pos,sz_addr);
  640. ploaded:
  641. ;
  642. indexed:
  643. gencst(op_aar,sz_word);
  644. end; {case}
  645. ak:=ploaded;
  646. end end;
  647. procedure load;
  648. var sz:integer;
  649. begin with a do begin sz:=sizeof(asp,packbit);
  650. if asp<>nil then
  651. case ak of
  652. cst:
  653. gencst(op_loc,pos.ad); {only one-word scalars}
  654. fixed:
  655. loadpos(pos,sz);
  656. pfixed:
  657. begin loadpos(pos,sz_addr); gencst(op_loi,sz) end;
  658. loaded:
  659. ;
  660. ploaded:
  661. gencst(op_loi,sz);
  662. indexed:
  663. gencst(op_lar,sz_word);
  664. end; {case}
  665. ak:=loaded;
  666. end end;
  667. procedure store;
  668. var sz:integer;
  669. begin with a,pos do begin sz:=sizeof(asp,packbit);
  670. if asp<>nil then
  671. case ak of
  672. fixed:
  673. if lv<=0 then pop(global,ad,sz) else
  674. if level=lv then pop(local,ad,sz) else
  675. begin lexaddr(lv,ad); gencst(op_sti,sz) end;
  676. pfixed:
  677. begin loadpos(pos,sz_addr); gencst(op_sti,sz) end;
  678. ploaded:
  679. gencst(op_sti,sz);
  680. indexed:
  681. gencst(op_sar,sz_word);
  682. end; {case}
  683. end end;
  684. procedure fieldaddr(off:integer);
  685. begin with a do
  686. if (ak=fixed) and not packbit then pos.ad:=pos.ad+off else
  687. begin loadaddr; gencst(op_adp,off) end
  688. end;
  689. procedure loadcheap;
  690. begin if formof(a.asp,[arrays..records]) then loadaddr else load end;
  691. {===================================================================}
  692. procedure nextch;
  693. begin
  694. eol:=eoln(input); read(input,ch); chsy:=cs[ch];
  695. if chsy <> tabch then srcchno:=srcchno+1
  696. end;
  697. procedure nextln;
  698. begin
  699. if eof(input) then
  700. begin
  701. if not eofexpected then error(+03) else
  702. if fltused then begin gencst(ps_mes,ms_flt); argend end;
  703. #ifdef STANDARD
  704. goto 9999
  705. #else
  706. halt
  707. #endif
  708. end;
  709. srcchno:=0; srclino:=srclino+1;
  710. if not including then
  711. begin srcorig:=srcorig+1; giveline:=true end;
  712. end;
  713. procedure options(normal:boolean);
  714. var ci:char; i:integer;
  715. procedure getc;
  716. begin if normal then nextch else read(errors,ch) end;
  717. begin
  718. repeat getc;
  719. if (ch>='a') and (ch<='z') then
  720. begin ci:=ch; getc; i:=0;
  721. if ch='+' then begin i:=1; getc end else
  722. if ch='-' then getc else
  723. if cs[ch]=digit then
  724. repeat i:=i*10 + ord(ch) - ord('0'); getc;
  725. until cs[ch]<>digit
  726. else i:=-1;
  727. if i>=0 then
  728. if not normal then
  729. begin forceopt[ci]:=true; opt[ci]:=i end
  730. else
  731. if not forceopt[ci] then opt[ci]:=i;
  732. end;
  733. until ch<>',';
  734. end;
  735. procedure linedirective;
  736. var i:integer; fname:fnarr;
  737. begin
  738. repeat nextch until (ch='"') or eol;
  739. if eol then error(+04) else
  740. begin nextch; i:=0;
  741. while (ch<>'"') and not eol do
  742. begin
  743. if ch='/' then i:=0 else
  744. begin i:=i+1; if i<=fnmax then fname[i]:=ch end;
  745. nextch
  746. end;
  747. while i<fnmax do begin i:=i+1; fname[i]:=' ' end;
  748. including:=fname<>source; while not eol do nextch
  749. end;
  750. end;
  751. procedure putdig;
  752. begin ix:=ix+1; if ix<=smax then strbuf[ix]:=ch; nextch end;
  753. procedure inident;
  754. label 1;
  755. var i,k:integer;
  756. begin k:=0; id:=spaces;
  757. repeat
  758. if chsy=upper then ch:=chr(ord(ch)-ord('A')+ord('a'));
  759. if k<idmax then begin k:=k+1; id[k]:=ch end;
  760. nextch
  761. until chsy>digit;
  762. {lower=0,upper=1,digit=2. ugly but fast}
  763. for i:=frw[k-1] to frw[k] - 1 do
  764. if rw[i]=id then
  765. begin sy:=rsy[i]; goto 1 end;
  766. sy:=ident;
  767. 1:
  768. end;
  769. procedure innumber;
  770. label 1;
  771. var i,j:integer;
  772. is:packed array[1..imax] of char;
  773. begin ix:=0; sy:=intcst; val:=0;
  774. repeat putdig until chsy<>digit;
  775. if (ch='.') or (ch='e') or (ch='E') then
  776. begin
  777. if ch='.' then
  778. begin putdig;
  779. if ch='.' then
  780. begin seconddot:=true; ix:=ix-1; goto 1 end;
  781. if chsy<>digit then error(+05) else
  782. repeat putdig until chsy<>digit;
  783. end;
  784. if (ch='e') or (ch='E') then
  785. begin putdig;
  786. if (ch='+') or (ch='-') then putdig;
  787. if chsy<>digit then error(+06) else
  788. repeat putdig until chsy<>digit;
  789. end;
  790. if ix>smax then begin error(+07); ix:=smax end;
  791. sy:=realcst; fltused:=true; val:=romstr(sp_fcon,sz_real);
  792. end;
  793. 1:if (chsy=lower) or (chsy=upper) then teststandard;
  794. if sy=intcst then
  795. if ix>imax then error(+08) else
  796. begin is:='0000000000'; i:=ix; j:=imax;
  797. repeat is[j]:=strbuf[i]; j:=j-1; i:=i-1 until i=0;
  798. if (is<=maxintstring) and (is<=maxcompintstring) then
  799. repeat j:=j+1; val:=val*10 - ord('0') + ord(is[j]) until j=imax
  800. else if (is<=maxlongstring) and (dopt<>off) then
  801. begin sy:=longcst; val:=romstr(sp_icon,sz_long) end
  802. else error(+09)
  803. end
  804. end;
  805. procedure instring(qc:char);
  806. begin ix:=0; zerostring:=qc='"';
  807. repeat
  808. repeat nextch; ix:=ix+1; if ix<=smax then strbuf[ix]:=ch;
  809. until (ch=qc) or eol;
  810. if ch=qc then nextch else error(+010);
  811. until ch<>qc;
  812. if not zerostring then
  813. begin ix:=ix-1; if ix=0 then error(+011) end
  814. else
  815. begin strbuf[ix]:=chr(0); if copt=off then error(+012) end;
  816. if (ix=1) and not zerostring then
  817. begin sy:=charcst; val:=ord(strbuf[1]) end
  818. else
  819. begin if ix>smax then begin error(+013); ix:=smax end;
  820. sy:=stringcst; val:=romstr(sp_scon,0);
  821. end
  822. end;
  823. procedure incomment;
  824. var stopc:char;
  825. begin nextch; stopc:='}';
  826. if ch='$' then options(true);
  827. while (ch<>'}') and (ch<>stopc) do
  828. begin stopc:='}'; if ch='*' then stopc:=')';
  829. if eol then nextln; nextch
  830. end;
  831. if ch<>'}' then teststandard;
  832. nextch
  833. end;
  834. procedure insym;
  835. {read next basic symbol of source program and return its
  836. description in the global variables sy, op, id, val and ix}
  837. label 1;
  838. begin
  839. 1:case chsy of
  840. tabch:
  841. begin srcchno:=srcchno - srcchno mod 8 + 8; nextch; goto 1 end;
  842. layout:
  843. begin if eol then nextln; nextch; goto 1 end;
  844. lower,upper: inident;
  845. digit: innumber;
  846. quotech,dquotech:
  847. instring(ch);
  848. colonch:
  849. begin nextch;
  850. if ch='=' then begin sy:=becomes; nextch end else sy:=colon1
  851. end;
  852. periodch:
  853. begin nextch;
  854. if seconddot then begin seconddot:=false; sy:=colon2 end else
  855. if ch='.' then begin sy:=colon2; nextch end else sy:=period
  856. end;
  857. lessch:
  858. begin nextch;
  859. if ch='=' then begin sy:=lesy; nextch end else
  860. if ch='>' then begin sy:=nesy; nextch end else sy:=ltsy
  861. end;
  862. greaterch:
  863. begin nextch;
  864. if ch='=' then begin sy:=gesy; nextch end else sy:=gtsy
  865. end;
  866. lparentch:
  867. begin nextch;
  868. if ch<>'*' then sy:=lparent else
  869. begin teststandard; incomment; goto 1 end;
  870. end;
  871. lbracech:
  872. begin incomment; goto 1 end;
  873. rparentch,lbrackch,rbrackch,commach,semich,arrowch,
  874. plusch,minch,slash,star,equal:
  875. begin sy:=csy[chsy]; nextch end;
  876. others:
  877. begin
  878. if (ch='#') and (srcchno=1) then linedirective else
  879. begin error(+014); nextch end;
  880. goto 1
  881. end;
  882. end {case}
  883. end;
  884. procedure nextif(fsy:symbol; err:integer);
  885. begin if sy=fsy then insym else error(-err) end;
  886. function find1(sys1,sys2:sos; err:integer):boolean;
  887. {symbol of sys1 expected. return true if sy in sys1}
  888. begin
  889. if not (sy in sys1) then
  890. begin error(err); while not (sy in sys1+sys2) do insym end;
  891. find1:=sy in sys1
  892. end;
  893. function find2(sys1,sys2:sos; err:integer):boolean;
  894. {symbol of sys1+sys2 expected. return true if sy in sys1}
  895. begin
  896. if not (sy in sys1+sys2) then
  897. begin error(err); repeat insym until sy in sys1+sys2 end;
  898. find2:=sy in sys1
  899. end;
  900. function find3(sy1:symbol; sys2:sos; err:integer):boolean;
  901. {symbol sy1 or one of sys2 expected. return true if sy1 found and skip it}
  902. begin find3:=true;
  903. if not (sy in [sy1]+sys2) then
  904. begin error(err); repeat insym until sy in [sy1]+sys2 end;
  905. if sy=sy1 then insym else find3:=false
  906. end;
  907. function endofloop(sys1,sys2:sos; sy3:symbol; err:integer):boolean;
  908. begin endofloop:=false;
  909. if find2(sys2+[sy3],sys1,err) then nextif(sy3,err+1)
  910. else endofloop:=true;
  911. end;
  912. function lastsemicolon(sys1,sys2:sos; err:integer):boolean;
  913. begin lastsemicolon:=true;
  914. if not endofloop(sys1,sys2,semicolon,err) then
  915. if find2(sys2,sys1,err+2) then lastsemicolon:=false
  916. end;
  917. {===================================================================}
  918. function searchid(fidcls: setofids):ip;
  919. {search for current identifier symbol in the name table}
  920. label 1;
  921. var lip:ip; ic:idclass;
  922. begin lastnp:=top;
  923. while lastnp<>nil do
  924. begin lip:=lastnp^.fname;
  925. while lip<>nil do
  926. if lip^.name=id then
  927. if lip^.klass in fidcls then
  928. begin
  929. if lip^.klass=vars then if lip^.vpos.lv<>level then
  930. lip^.iflag:=lip^.iflag+[noreg];
  931. goto 1
  932. end
  933. else lip:=lip^.rlink
  934. else
  935. if lip^.name< id then lip:=lip^.rlink else lip:=lip^.llink;
  936. lastnp:=lastnp^.nlink;
  937. end;
  938. errid(+015,id);
  939. if types in fidcls then ic:=types else
  940. if vars in fidcls then ic:=vars else
  941. if konst in fidcls then ic:=konst else
  942. if proc in fidcls then ic:=proc else
  943. if func in fidcls then ic:=func else ic:=field;
  944. lip:=undefip[ic];
  945. 1:
  946. searchid:=lip
  947. end;
  948. function searchsection(fip: ip):ip;
  949. {to find record fields and forward declared procedure identifiers
  950. -->procedure pfdeclaration
  951. -->procedure selector}
  952. label 1;
  953. begin
  954. while fip<>nil do
  955. if fip^.name=id then goto 1 else
  956. if fip^.name< id then fip:=fip^.rlink else fip:=fip^.llink;
  957. 1: searchsection:=fip
  958. end;
  959. function searchlab(flp:lp; val:integer):lp;
  960. label 1;
  961. begin
  962. while flp<>nil do
  963. if flp^.labval=val then goto 1 else flp:=flp^.nextlp;
  964. 1:searchlab:=flp
  965. end;
  966. procedure opconvert(ts:twostruct);
  967. var op:integer;
  968. begin with a do begin genasp(op_loc);
  969. case ts of
  970. ir, lr: begin asp:=realptr; op:=op_cif; fltused:=true end;
  971. ri: begin asp:=intptr ; op:=op_cfi; fltused:=true end;
  972. rl: begin asp:=longptr; op:=op_cfi; fltused:=true end;
  973. li: begin asp:=intptr ; op:=op_cii end;
  974. il: begin asp:=longptr; op:=op_cii end;
  975. end;
  976. genasp(op_loc); genop(op)
  977. end end;
  978. procedure negate;
  979. begin if a.asp=realptr then genasp(op_ngf) else genasp(op_ngi) end;
  980. function desub(fsp:sp):sp;
  981. begin if formof(fsp,[subrange]) then fsp:=fsp^.rangetype; desub:=fsp end;
  982. function nicescalar(fsp:sp):boolean;
  983. begin
  984. if fsp=nil then nicescalar:=true else
  985. nicescalar:=(fsp^.form=scalar) and (fsp<>realptr) and (fsp<>longptr)
  986. end;
  987. function bounded(fsp:sp):boolean;
  988. begin bounded:=false;
  989. if fsp<>nil then
  990. if fsp^.form=subrange then bounded:=true else
  991. if fsp^.form=scalar then bounded:=fsp^.fconst<>nil
  992. end;
  993. procedure bounds(fsp:sp; var fmin,fmax:integer);
  994. begin
  995. if fsp=nil then
  996. begin fmin:=0; fmax:=0 end
  997. else
  998. case fsp^.form of
  999. subrange:
  1000. begin fmin:=fsp^.min; fmax:=fsp^.max end;
  1001. scalar:
  1002. begin fmin:=0; fmax:=fsp^.fconst^.value end
  1003. end
  1004. end;
  1005. procedure genrck(fsp:sp);
  1006. var min,max,sno:integer;
  1007. begin
  1008. if opt['r']<>off then if bounded(fsp) then
  1009. begin
  1010. if fsp^.form=scalar then sno:=fsp^.scalno else sno:=fsp^.subrno;
  1011. if sno=0 then
  1012. begin bounds(fsp,min,max); sno:=newdlb;
  1013. gencst(ps_rom,min); argcst(max); argend;
  1014. if fsp^.form=scalar then fsp^.scalno:=sno else fsp^.subrno:=sno
  1015. end;
  1016. laedlb(sno); gencst(op_rck,sz_word);
  1017. end
  1018. end;
  1019. procedure checkbnds(fsp:sp);
  1020. var min1,max1,min2,max2:integer;
  1021. begin
  1022. if bounded(fsp) then
  1023. if not bounded(a.asp) then genrck(fsp) else
  1024. begin bounds(fsp,min1,max1); bounds(a.asp,min2,max2);
  1025. if (min2<min1) or (max2>max1) then
  1026. genrck(fsp);
  1027. end;
  1028. a.asp:=fsp;
  1029. end;
  1030. function eqstruct(p,q:sp):boolean;
  1031. begin eqstruct:=(p=q) or (p=nil) or (q=nil) end;
  1032. function string(fsp:sp):boolean;
  1033. var lsp:sp;
  1034. begin string:=false;
  1035. if formof(fsp,[arrays]) then
  1036. if eqstruct(fsp^.aeltype,charptr) then
  1037. if spack in fsp^.sflag then
  1038. begin lsp:=fsp^.inxtype;
  1039. if lsp=nil then string:=true else
  1040. if lsp^.form=subrange then
  1041. if lsp^.rangetype=intptr then
  1042. if lsp^.min=1 then
  1043. string:=true
  1044. end
  1045. end;
  1046. function compat(p,q:sp):twostruct;
  1047. begin compat:=noteq;
  1048. if eqstruct(p,q) then compat:=eq else
  1049. begin p:=desub(p); q:=desub(q);
  1050. if eqstruct(p,q) then compat:=subeq else
  1051. if p^.form=q^.form then
  1052. case p^.form of
  1053. scalar:
  1054. if (p=intptr) and (q=realptr) then compat:=ir else
  1055. if (p=realptr) and (q=intptr) then compat:=ri else
  1056. if (p=intptr) and (q=longptr) then compat:=il else
  1057. if (p=longptr) and (q=intptr) then compat:=li else
  1058. if (p=longptr) and (q=realptr) then compat:=lr else
  1059. if (p=realptr) and (q=longptr) then compat:=rl else
  1060. ;
  1061. pointer:
  1062. if (p=nilptr) or (q=nilptr) then compat:=eq;
  1063. power:
  1064. if p=nullset then compat:=es else
  1065. if q=nullset then compat:=se else
  1066. if compat(p^.elset,q^.elset) <= subeq then
  1067. if p^.sflag=q^.sflag then compat:=eq;
  1068. arrays:
  1069. if string(p) and string(q) and (p^.size=q^.size) then compat:=eq;
  1070. files,carray,records: ;
  1071. end;
  1072. end
  1073. end;
  1074. procedure checkasp(fsp:sp; err:integer);
  1075. var ts:twostruct;
  1076. begin
  1077. ts:=compat(a.asp,fsp);
  1078. case ts of
  1079. eq:
  1080. if fsp<>nil then if withfile in fsp^.sflag then errasp(err);
  1081. subeq:
  1082. checkbnds(fsp);
  1083. li:
  1084. begin opconvert(ts); checkasp(fsp,err) end;
  1085. il,rl,lr,ir:
  1086. opconvert(ts);
  1087. es:
  1088. expandnullset(fsp);
  1089. noteq,ri,se:
  1090. errasp(err);
  1091. end
  1092. end;
  1093. procedure force(fsp:sp; err:integer);
  1094. begin load; checkasp(fsp,err) end;
  1095. function newident(kl:idclass; idt:sp; nxt:ip; err:integer):ip;
  1096. begin newident:=nil;
  1097. if sy<>ident then error(err) else
  1098. begin newident:=newip(kl,id,idt,nxt); insym end
  1099. end;
  1100. function stringstruct:sp;
  1101. var lsp:sp;
  1102. begin {only used when ix and zerostring are still valid}
  1103. if zerostring then lsp:=zeroptr else
  1104. begin lsp:=newsp(arrays,ix*sz_char); lsp^.sflag:=[spack];
  1105. lsp^.aeltype:=charptr; lsp^.inxtype:=nil;
  1106. end;
  1107. stringstruct:=lsp;
  1108. end;
  1109. function posaddr(var lb:integer; fsp:sp; partword:boolean):integer;
  1110. var sz:integer;
  1111. begin sz:=sizeof(fsp,partword);
  1112. if sz_int = 2 then
  1113. if lb >= MI2-sz-sz_word then begin error(+016); lb:=0 end;
  1114. if not partword or (sz>=sz_word) then
  1115. while lb mod sz_word <> 0 do lb:=lb+1;
  1116. posaddr:=lb;
  1117. lb:=lb+sz
  1118. end;
  1119. function negaddr(fsp:sp):integer;
  1120. var sz:integer;
  1121. begin with b do begin
  1122. sz:=sizeof(fsp,wordmult);
  1123. if sz_int = 2 then
  1124. if reglb <= -MI2+sz+sz_word then begin error(+017); reglb:=0 end;
  1125. reglb:=reglb-sz;
  1126. while reglb mod sz_word <> 0 do reglb:=reglb-1;
  1127. if reglb < minlb then minlb:=reglb;
  1128. negaddr:=reglb
  1129. end end;
  1130. procedure temporary(fsp:sp;r:integer);
  1131. begin inita(fsp,negaddr(fsp));
  1132. if r>=0 then genreg(sizeof(fsp,wordmult),a.pos.ad,r)
  1133. end;
  1134. procedure genhol;
  1135. begin gencst(ps_hol,posaddr(holeb,nil,false));
  1136. if sz_word = 4 then begin put1(sp_cst4); put1(0); put1(0); end
  1137. else put1(sp_cst2);
  1138. put1(0); put1(128); { 1000000000000000 pattern}
  1139. argcst(0); level:=1
  1140. end;
  1141. function arraysize(fsp:sp; pack:boolean):integer;
  1142. var sz,min,max,tot,n:integer;
  1143. begin sz:=sizeof(fsp^.aeltype,pack);
  1144. bounds(fsp^.inxtype,min,max);
  1145. fsp^.arpos.lv:=0; fsp^.arpos.ad:=newdlb;
  1146. gencst(ps_rom,min); argcst(max-min); argcst(sz); argend;
  1147. n:=max-min+1; tot:=sz*n;
  1148. if sz<>0 then if tot div sz <> n then begin error(+018); tot:=0 end;
  1149. arraysize:=tot
  1150. end;
  1151. procedure treewalk(fip:ip);
  1152. var lsp:sp; i,sz:integer;
  1153. begin
  1154. if fip<>nil then
  1155. begin treewalk(fip^.llink); treewalk(fip^.rlink);
  1156. if fip^.klass=vars then
  1157. begin if not (used in fip^.iflag) then errid(-(+019),fip^.name);
  1158. if not (assigned in fip^.iflag) then errid(-(+020),fip^.name);
  1159. lsp:=fip^.idtype;
  1160. if level<>1 then
  1161. if (refer in fip^.iflag) or not (noreg in fip^.iflag) then
  1162. if (refer in fip^.iflag) or formof(lsp,[pointer]) then
  1163. genreg(sz_addr,fip^.vpos.ad,reg_pointer)
  1164. else
  1165. begin sz:=sizeof(lsp,wordmult);
  1166. if loopvar in fip^.iflag then
  1167. genreg(sz,fip^.vpos.ad,reg_loop)
  1168. else if lsp=realptr then
  1169. genreg(sz,fip^.vpos.ad,reg_float)
  1170. else
  1171. genreg(sz,fip^.vpos.ad,reg_any);
  1172. end;
  1173. if lsp<>nil then if withfile in lsp^.sflag then
  1174. if lsp^.form=files then
  1175. if level=1 then
  1176. begin
  1177. for i:=2 to argc do with argv[i] do
  1178. if name=fip^.name then ad:=fip^.vpos.ad
  1179. end
  1180. else
  1181. begin
  1182. if not (refer in fip^.iflag) then
  1183. begin gencst(op_lal,fip^.vpos.ad); gensp(CLS,sz_addr)
  1184. end
  1185. end
  1186. else
  1187. if level<>1 then errid(-(+021),fip^.name)
  1188. end
  1189. end
  1190. end;
  1191. procedure constant(fsys:sos; var fsp:sp; var fval:integer);
  1192. var signed,min:boolean; lip:ip;
  1193. begin signed:=(sy=plussy) or (sy=minsy);
  1194. if signed then begin min:=sy=minsy; insym end else min:=false;
  1195. if find1([ident..stringcst],fsys,+022) then
  1196. begin fval:=val;
  1197. case sy of
  1198. stringcst: fsp:=stringstruct;
  1199. charcst: fsp:=charptr;
  1200. intcst: fsp:=intptr;
  1201. realcst: fsp:=realptr;
  1202. longcst: fsp:=longptr;
  1203. ident:
  1204. begin lip:=searchid([konst]);
  1205. fsp:=lip^.idtype; fval:=lip^.value;
  1206. end
  1207. end; {case}
  1208. if signed then
  1209. if (fsp<>intptr) and (fsp<>realptr) and (fsp<>longptr) then
  1210. error(+023)
  1211. else if min then fval:= -fval;
  1212. {note: negating the v-number for reals and longs}
  1213. insym;
  1214. end
  1215. else begin fsp:=nil; fval:=0 end;
  1216. end;
  1217. function cstinteger(fsys:sos; fsp:sp; err:integer):integer;
  1218. var lsp:sp; lval,min,max:integer;
  1219. begin constant(fsys,lsp,lval);
  1220. if fsp<>lsp then
  1221. if not eqstruct(desub(fsp),lsp) then
  1222. begin error(err); lval:=0 end
  1223. else if bounded(fsp) then
  1224. begin bounds(fsp,min,max);
  1225. if (lval<min) or (lval>max) then error(+024)
  1226. end;
  1227. cstinteger:=lval
  1228. end;
  1229. {===================================================================}
  1230. function typid(err:integer):sp;
  1231. var lip:ip; lsp:sp;
  1232. begin lsp:=nil;
  1233. if sy<>ident then error(err) else
  1234. begin lip:=searchid([types]); lsp:=lip^.idtype; insym end;
  1235. typid:=lsp
  1236. end;
  1237. function simpletyp(fsys:sos):sp;
  1238. var lsp,lsp1:sp; lip,hip:ip; min,max:integer; lnp:np;
  1239. newsubrange:boolean;
  1240. begin lsp:=nil;
  1241. if find1([ident..lparent],fsys,+025) then
  1242. if sy=lparent then
  1243. begin insym; lnp:=top; {decl. consts local to innermost block}
  1244. while top^.occur<>blck do top:=top^.nlink;
  1245. lsp:=newsp(scalar,sz_word); hip:=nil; max:=0;
  1246. repeat lip:=newident(konst,lsp,hip,+026);
  1247. if lip<>nil then
  1248. begin enterid(lip); hip:=lip; lip^.value:=max; max:=max+1 end;
  1249. until endofloop(fsys+[rparent],[ident],comma,+027); {+028}
  1250. if max<=MU1 then lsp^.size:=sz_byte;
  1251. lsp^.fconst:=hip; top:=lnp; nextif(rparent,+029);
  1252. end
  1253. else
  1254. begin newsubrange:=true;
  1255. if sy=ident then
  1256. begin lip:=searchid([types,konst]); insym;
  1257. if lip^.klass=types then
  1258. begin lsp:=lip^.idtype; newsubrange:=false end
  1259. else
  1260. begin lsp1:=lip^.idtype; min:=lip^.value end
  1261. end
  1262. else constant(fsys+[colon2,ident..plussy],lsp1,min);
  1263. if newsubrange then
  1264. begin lsp:=newsp(subrange,sz_word); lsp^.subrno:=0;
  1265. if not nicescalar(lsp1) then
  1266. begin error(+030); lsp1:=nil; min:=0 end;
  1267. lsp^.rangetype:=lsp1;
  1268. nextif(colon2,+031); max:=cstinteger(fsys,lsp1,+032);
  1269. if min>max then begin error(+033); max:=min end;
  1270. if (min>=0) and (max<=MU1) then lsp^.size:=sz_byte;
  1271. lsp^.min:=min; lsp^.max:=max
  1272. end
  1273. end;
  1274. simpletyp:=lsp
  1275. end;
  1276. function arraytyp(fsys:sos;
  1277. artyp:structform;
  1278. sflag:sflagset;
  1279. function element(fsys:sos):sp
  1280. ):sp;
  1281. var lsp,lsp1,hsp:sp; ok:boolean; sepsy:symbol; lip:ip;
  1282. oksys:sos;
  1283. begin insym; nextif(lbrack,+034); hsp:=nil;
  1284. repeat lsp:=newsp(artyp,0); initpos(lsp^.arpos);
  1285. lsp^.aeltype:=hsp; hsp:=lsp; {link reversed}
  1286. if artyp=carray then
  1287. begin sepsy:=semicolon; oksys:=[ident];
  1288. lip:=newident(carrbnd,lsp,nil,+035); if lip<>nil then enterid(lip);
  1289. nextif(colon2,+036);
  1290. lip:=newident(carrbnd,lsp,lip,+037); if lip<>nil then enterid(lip);
  1291. nextif(colon1,+038); lsp1:=typid(+039);
  1292. ok:=nicescalar(desub(lsp1));
  1293. end
  1294. else
  1295. begin sepsy:=comma; oksys:=[ident..lparent];
  1296. lsp1:=simpletyp(fsys+[comma,rbrack,ofsy,ident..packedsy]);
  1297. ok:=bounded(lsp1)
  1298. end;
  1299. if not ok then begin error(+040); lsp1:=nil end;
  1300. lsp^.inxtype:=lsp1
  1301. until endofloop(fsys+[rbrack,ofsy,ident..packedsy],oksys,
  1302. sepsy,+041); {+042}
  1303. nextif(rbrack,+043); nextif(ofsy,+044);
  1304. lsp:=element(fsys);
  1305. if lsp<>nil then sflag:=sflag + lsp^.sflag * [withfile];
  1306. repeat {reverse links and compute size}
  1307. lsp1:=hsp^.aeltype; hsp^.aeltype:=lsp; hsp^.sflag:=sflag;
  1308. if artyp=arrays then hsp^.size:=arraysize(hsp,spack in sflag);
  1309. lsp:=hsp; hsp:=lsp1
  1310. until hsp=nil; {lsp points to array with highest dimension}
  1311. arraytyp:=lsp
  1312. end;
  1313. function typ(fsys:sos):sp;
  1314. var lsp,lsp1:sp; off,sz,min,errno:integer;
  1315. sflag:sflagset; lnp:np;
  1316. function fldlist(fsys:sos):sp;
  1317. {level 2: << typ}
  1318. var fip,hip,lip:ip; lsp:sp;
  1319. function varpart(fsys:sos):sp;
  1320. {level 3: << fldlist << typ}
  1321. var tip,lip:ip; lsp,headsp,hsp,vsp,tsp,tsp1,tfsp:sp;
  1322. minoff,maxoff,int,nvar:integer; lid:idarr;
  1323. begin insym; tip:=nil; lip:=nil;
  1324. tsp:=newsp(tag,0);
  1325. if sy<>ident then error(+045) else
  1326. begin lid:=id; insym;
  1327. if sy=colon1 then
  1328. begin tip:=newip(field,lid,nil,nil); enterid(tip); insym;
  1329. if sy<>ident then error(+046) else
  1330. begin lid:=id; insym end;
  1331. end;
  1332. if sy=ofsy then {otherwise you may destroy id}
  1333. begin id:=lid; lip:=searchid([types]) end;
  1334. end;
  1335. if lip=nil then tfsp:=nil else tfsp:=lip^.idtype;
  1336. if bounded(tfsp) then
  1337. begin bounds(tfsp,int,nvar); nvar:=nvar-int+1 end
  1338. else
  1339. begin nvar:=0; if tfsp<>nil then begin error(+047); tfsp:=nil end end;
  1340. tsp^.tfldsp:=tfsp;
  1341. if tip<>nil then {explicit tag}
  1342. begin tip^.idtype:=tfsp;
  1343. tip^.foffset:=posaddr(off,tfsp,spack in sflag)
  1344. end;
  1345. nextif(ofsy,+048); minoff:=off; maxoff:=minoff; headsp:=nil;
  1346. repeat hsp:=nil; {for each caselabel list}
  1347. repeat nvar:=nvar-1;
  1348. int:=cstinteger(fsys+[ident..plussy,comma,colon1,lparent,
  1349. semicolon,casesy,rparent],tfsp,+049);
  1350. lsp:=headsp; {each label may occur only once}
  1351. while lsp<>nil do
  1352. begin if lsp^.varval=int then error(+050);
  1353. lsp:=lsp^.nxtvar
  1354. end;
  1355. vsp:=newsp(variant,0); vsp^.varval:=int;
  1356. vsp^.nxtvar:=headsp; headsp:=vsp; {chain of case labels}
  1357. vsp^.subtsp:=hsp; hsp:=vsp;
  1358. {use this field to link labels with same variant}
  1359. until endofloop(fsys+[colon1,lparent,semicolon,casesy,rparent],
  1360. [ident..plussy],comma,+051); {+052}
  1361. nextif(colon1,+053); nextif(lparent,+054);
  1362. tsp1:=fldlist(fsys+[rparent,semicolon,ident..plussy]);
  1363. if off>maxoff then maxoff:=off;
  1364. while vsp<>nil do
  1365. begin vsp^.size:=off; hsp:=vsp^.subtsp;
  1366. vsp^.subtsp:=tsp1; vsp:=hsp
  1367. end;
  1368. nextif(rparent,+055);
  1369. off:=minoff;
  1370. until lastsemicolon(fsys,[ident..plussy],+056); {+057 +058}
  1371. if nvar>0 then error(-(+059));
  1372. tsp^.fstvar:=headsp; tsp^.size:=minoff; off:=maxoff; varpart:=tsp;
  1373. end;
  1374. begin {fldlist}
  1375. if find2([ident],fsys+[casesy],+060) then
  1376. repeat lip:=nil; hip:=nil;
  1377. repeat fip:=newident(field,nil,nil,+061);
  1378. if fip<>nil then
  1379. begin enterid(fip);
  1380. if lip=nil then hip:=fip else lip^.next:=fip; lip:=fip;
  1381. end;
  1382. until endofloop(fsys+[colon1,ident..packedsy,semicolon,casesy],
  1383. [ident],comma,+062); {+063}
  1384. nextif(colon1,+064);
  1385. lsp:=typ(fsys+[casesy,semicolon]);
  1386. if lsp<>nil then if withfile in lsp^.sflag then
  1387. sflag:=sflag+[withfile];
  1388. while hip<>nil do
  1389. begin hip^.idtype:=lsp;
  1390. hip^.foffset:=posaddr(off,lsp,spack in sflag);
  1391. hip:=hip^.next
  1392. end;
  1393. until lastsemicolon(fsys+[casesy],[ident],+065); {+066 +067}
  1394. if sy=casesy then fldlist:=varpart(fsys) else fldlist:=nil;
  1395. end;
  1396. begin {typ}
  1397. sflag:=[]; lsp:=nil;
  1398. if sy=packedsy then begin sflag:=[spack]; insym end;
  1399. if find1([ident..filesy],fsys,+068) then
  1400. if sy in [ident..arrow] then
  1401. begin if spack in sflag then error(+069);
  1402. if sy=arrow then
  1403. begin lsp:=newsp(pointer,sz_addr); insym;
  1404. if not intypedec then lsp^.eltype:=typid(+070) else
  1405. if sy<>ident then error(+071) else
  1406. begin fwptr:=newip(types,id,lsp,fwptr); insym end
  1407. end
  1408. else lsp:=simpletyp(fsys);
  1409. end
  1410. else
  1411. case sy of
  1412. {<<<<<<<<<<<<}
  1413. arraysy:
  1414. lsp:=arraytyp(fsys,arrays,sflag,typ);
  1415. recordsy:
  1416. begin insym;
  1417. new(lnp,rec); lnp^.occur:=rec; lnp^.nlink:=top; lnp^.fname:=nil; top:=lnp;
  1418. off:=0; lsp1:=fldlist(fsys+[endsy]); {fldlist updates off}
  1419. lsp:=newsp(records,off); lsp^.tagsp:=lsp1;
  1420. lsp^.fstfld:=top^.fname; lsp^.sflag:=sflag;
  1421. top:=top^.nlink; nextif(endsy,+072)
  1422. end;
  1423. setsy:
  1424. begin insym; nextif(ofsy,+073);
  1425. lsp:=simpletyp(fsys); lsp1:=desub(lsp); errno:=0;
  1426. if bounded(lsp1) then
  1427. begin bounds(lsp1,min,sz);
  1428. if sz div NB1>=sz_mset then errno:=+074
  1429. end
  1430. else if bounded(lsp) then {subrange of integer}
  1431. begin bounds(lsp,min,sz);
  1432. if (min<0) or (sz>=iopt) then errno:=+075;
  1433. sz:=iopt-1
  1434. end
  1435. else if lsp=intptr then
  1436. begin sz:=iopt-1; errno:=-(+076) end
  1437. else
  1438. errno:=+077;
  1439. if errno<>0 then
  1440. begin error(errno); if errno>0 then begin lsp1:=nil; sz:=0 end end;
  1441. lsp:=newsp(power,sz div NB1 +1); lsp^.elset:=lsp1;
  1442. end;
  1443. filesy:
  1444. begin insym; nextif(ofsy,+078); lsp1:=typ(fsys);
  1445. if lsp1<>nil then if withfile in lsp1^.sflag then error(-(+079));
  1446. sz:=sizeof(lsp1,wordpart); if sz<sz_buff then sz:=sz_buff;
  1447. lsp:=newsp(files,sz+sz_head); lsp^.filtype:=lsp1;
  1448. end;
  1449. {>>>>>>>>>>>>}
  1450. end; {case}
  1451. typ:=lsp;
  1452. end;
  1453. function vpartyp(fsys:sos):sp;
  1454. begin
  1455. if find2([arraysy],fsys+[ident],+080) then
  1456. vpartyp:=arraytyp(fsys,carray,[],vpartyp)
  1457. else
  1458. vpartyp:=typid(+081)
  1459. end;
  1460. {===================================================================}
  1461. procedure block(fsys:sos; fip:ip); forward;
  1462. {pfdeclaration calls block. With a more obscure lexical
  1463. structure this forward declaration can be avoided}
  1464. procedure labeldeclaration(fsys:sos);
  1465. var llp:lp;
  1466. begin with b do begin
  1467. repeat
  1468. if sy<>intcst then error(+082) else
  1469. begin
  1470. if searchlab(lchain,val)<>nil then errint(+083,val) else
  1471. begin new(llp); llp^.labval:=val;
  1472. if val>9999 then teststandard;
  1473. ilbno:=ilbno+1; llp^.labname:=ilbno; llp^.labdlb:=0;
  1474. llp^.seen:=false; llp^.nextlp:=lchain; lchain:=llp;
  1475. end;
  1476. insym
  1477. end
  1478. until endofloop(fsys+[semicolon],[intcst],comma,+084); {+085}
  1479. nextif(semicolon,+086)
  1480. end end;
  1481. procedure constdefinition(fsys:sos);
  1482. var lip:ip;
  1483. begin
  1484. repeat lip:=newident(konst,nil,nil,+087);
  1485. if lip<>nil then
  1486. begin nextif(eqsy,+088);
  1487. constant(fsys+[semicolon,ident],lip^.idtype,lip^.value);
  1488. nextif(semicolon,+089); enterid(lip);
  1489. end;
  1490. until not find2([ident],fsys,+090);
  1491. end;
  1492. procedure typedefinition(fsys:sos);
  1493. var lip:ip;
  1494. begin fwptr:=nil; intypedec:=true;
  1495. repeat lip:=newident(types,nil,nil,+091);
  1496. if lip<>nil then
  1497. begin nextif(eqsy,+092);
  1498. lip^.idtype:=typ(fsys+[semicolon,ident]);
  1499. nextif(semicolon,+093); enterid(lip);
  1500. end;
  1501. until not find2([ident],fsys,+094);
  1502. assert sy<>ident;
  1503. while fwptr<>nil do
  1504. begin
  1505. id:=fwptr^.name; lip:=searchid([types]);
  1506. fwptr^.idtype^.eltype:=lip^.idtype; fwptr:=fwptr^.next
  1507. end;
  1508. intypedec:=false;
  1509. end;
  1510. procedure vardeclaration(fsys:sos);
  1511. var lip,hip,vip:ip; lsp:sp;
  1512. begin
  1513. repeat hip:=nil; lip:=nil;
  1514. repeat vip:=newident(vars,nil,nil,+095);
  1515. if vip<>nil then
  1516. begin enterid(vip); vip^.iflag:=[];
  1517. if lip=nil then hip:=vip else lip^.next:=vip; lip:=vip;
  1518. end;
  1519. until endofloop(fsys+[colon1,ident..packedsy],[ident],comma,+096); {+097}
  1520. nextif(colon1,+098);
  1521. lsp:=typ(fsys+[semicolon,ident]);
  1522. while hip<>nil do
  1523. begin hip^.idtype:=lsp;
  1524. if level<=1 then
  1525. hip^.vpos.ad:=posaddr(holeb,lsp,false)
  1526. else
  1527. hip^.vpos.ad:=negaddr(lsp);
  1528. hip:=hip^.next
  1529. end;
  1530. nextif(semicolon,+099);
  1531. until not find2([ident],fsys,+0100);
  1532. end;
  1533. procedure pfhead(fsys:sos;var fip:ip;var again:boolean;param:boolean);
  1534. forward;
  1535. procedure parlist(fsys:sos; slink:boolean; var tip:ip; var maxlb:integer);
  1536. var lastip,hip,lip,pip:ip; lsp,tsp:sp; iflag:iflagset; again:boolean;
  1537. begin tip:=nil; lastip:=nil;
  1538. maxlb:=0; if slink then maxlb:=sz_addr;
  1539. repeat {once for each formal-parameter-section}
  1540. if find1([ident,varsy,procsy,funcsy],fsys+[semicolon],+0101) then
  1541. begin
  1542. if (sy=procsy) or (sy=funcsy) then
  1543. begin
  1544. pfhead(fsys+[semicolon,ident,varsy,procsy,funcsy],hip,again,true);
  1545. hip^.pfpos.ad:=posaddr(maxlb,procptr,false);
  1546. hip^.pfkind:=formal; lip:=hip;
  1547. top:=top^.nlink; level:=level-1
  1548. end
  1549. else
  1550. begin hip:=nil; lip:=nil; iflag:=[assigned];
  1551. if sy=varsy then
  1552. begin iflag:=[refer,assigned,used]; insym end;
  1553. repeat pip:=newident(vars,nil,nil,+0102);
  1554. if pip<>nil then
  1555. begin enterid(pip); pip^.iflag:=iflag;
  1556. if lip=nil then hip:=pip else lip^.next:=pip; lip:=pip;
  1557. end;
  1558. iflag:=iflag+[samesect];
  1559. until endofloop(fsys+[semicolon,colon1],[ident],comma,+0103);
  1560. {+0104}
  1561. nextif(colon1,+0105);
  1562. if refer in iflag then
  1563. begin lsp:=vpartyp(fsys+[semicolon]); tsp:=lsp;
  1564. while formof(tsp,[carray]) do
  1565. begin tsp^.arpos.ad:=posaddr(maxlb,nilptr,false);
  1566. tsp:=tsp^.aeltype
  1567. end;
  1568. tsp:=nilptr;
  1569. end
  1570. else
  1571. begin lsp:=typid(+0106); tsp:=lsp end;
  1572. pip:=hip;
  1573. while pip<>nil do
  1574. begin pip^.vpos.ad:=posaddr(maxlb,tsp,false); pip^.idtype:=lsp;
  1575. pip:=pip^.next
  1576. end;
  1577. end;
  1578. if lastip=nil then tip:=hip else lastip^.next:=hip; lastip:=lip;
  1579. end;
  1580. until endofloop(fsys,[ident,varsy,procsy,funcsy],semicolon,+0107); {+0108}
  1581. end;
  1582. procedure pfhead; {forward declared}
  1583. var lip:ip; lsp:sp; lnp:np; kl:idclass;
  1584. begin lip:=nil; again:=false;
  1585. if sy=procsy then kl:=proc else
  1586. begin kl:=func; fsys:=fsys+[colon1,ident] end;
  1587. insym;
  1588. if sy<>ident then begin error(+0109); id:=spaces end;
  1589. if not param then lip:=searchsection(top^.fname);
  1590. if lip<>nil then
  1591. if (lip^.klass<>kl) or (lip^.pfkind<>forward) then errid(+0110,id) else
  1592. begin b.forwcount:=b.forwcount-1; again:=true end;
  1593. if again then insym else
  1594. begin lip:=newip(kl,id,nil,nil);
  1595. if sy=ident then begin enterid(lip); insym end;
  1596. lastpfno:=lastpfno+1; lip^.pfno:=lastpfno;
  1597. end;
  1598. level:=level+1;
  1599. new(lnp,blck); lnp^.occur:=blck; lnp^.nlink:=top; top:=lnp;
  1600. if again then lnp^.fname:=lip^.parhead else
  1601. begin lnp^.fname:=nil;
  1602. if find3(lparent,fsys,+0111) then
  1603. begin parlist(fsys+[rparent],lip^.pfpos.lv>1,lip^.parhead,lip^.maxlb);
  1604. nextif(rparent,+0112)
  1605. end;
  1606. end;
  1607. if (kl=func) and not again then
  1608. begin nextif(colon1,+0113); lsp:=typid(+0114);
  1609. if formof(lsp,[power..tag]) then
  1610. begin error(+0115); lsp:=nil end;
  1611. lip^.idtype:=lsp;
  1612. end;
  1613. fip:=lip;
  1614. end;
  1615. procedure pfdeclaration(fsys:sos);
  1616. var lip:ip; again,headonly:boolean; markp:^integer; lbp:bp; kind:kindofpf;
  1617. begin with b do begin
  1618. pfhead(fsys+[ident,semicolon,labelsy..beginsy],lip,again,false);
  1619. nextif(semicolon,+0116);
  1620. if find1([ident,labelsy..beginsy],fsys+[semicolon],+0117) then
  1621. begin headonly:=sy=ident;
  1622. if headonly then
  1623. begin kind:=standard;
  1624. if id='forward ' then kind:=forward else
  1625. if id='extern ' then kind:=extern else
  1626. if id='varargs ' then kind:=varargs else errid(+0118,id);
  1627. if kind<>standard then
  1628. begin insym; lip^.pfkind:=kind;
  1629. if kind=forward then
  1630. if again then errid(+0119,lip^.name) else
  1631. forwcount:=forwcount+1
  1632. else
  1633. begin lip^.pfpos.lv:=1; teststandard end
  1634. end;
  1635. end;
  1636. if not again then
  1637. if lip^.pfpos.lv<=1 then genpnam(ps_exp,lip) else genpnam(ps_inp,lip);
  1638. if not headonly then
  1639. begin lip^.pfkind:=actual;
  1640. #ifndef STANDARD
  1641. mark(markp);
  1642. #endif
  1643. new(lbp); lbp^:=b; nextbp:=lbp;
  1644. reglb:=0; minlb:=0; ilbno:=0; forwcount:=0; lchain:=nil;
  1645. block(fsys+[semicolon],lip);
  1646. b:=nextbp^;
  1647. #ifndef STANDARD
  1648. release(markp);
  1649. #endif
  1650. end;
  1651. end;
  1652. if not main then eofexpected:=forwcount=0;
  1653. nextif(semicolon,+0120);
  1654. level:=level-1; top:=top^.nlink;
  1655. end end;
  1656. {===================================================================}
  1657. procedure expression(fsys:sos); forward;
  1658. {this forward declaration cannot be avoided}
  1659. procedure selectarrayelement(fsys:sos);
  1660. var isp,lsp:sp;
  1661. begin
  1662. repeat loadaddr; isp:=nil;
  1663. if formof(a.asp,[arrays,carray]) then isp:=a.asp^.inxtype else
  1664. errasp(+0121);
  1665. lsp:=a.asp;
  1666. expression(fsys+[comma]); force(desub(isp),+0122);
  1667. {no range check}
  1668. if lsp<>nil then
  1669. begin a.packbit:=spack in lsp^.sflag;
  1670. descraddr(lsp^.arpos); lsp:=lsp^.aeltype
  1671. end;
  1672. a.asp:=lsp; a.ak:=indexed;
  1673. until endofloop(fsys,[notsy..lparent],comma,+0123); {+0124}
  1674. end;
  1675. procedure selector(fsys: sos; fip:ip; iflag:iflagset);
  1676. {selector computes the address of any kind of variable.
  1677. Four possibilities:
  1678. 1.for direct accessable variables (fixed), a contains offset and level,
  1679. 2.for indirect accessable variables (ploaded), the address is on the stack.
  1680. 3.for array elements, the top of stack gives the index (one word).
  1681. The address of the array is beneath it.
  1682. 4.for variables with address in direct accessible pointer variable (pfixed),
  1683. the offset and level of the pointer is stored in a.
  1684. If a.asp=nil then an error occurred else a.asp gives
  1685. the type of the variable.
  1686. }
  1687. var lip:ip;
  1688. begin inita(fip^.idtype,0);
  1689. case fip^.klass of
  1690. vars: with a do
  1691. begin pos:=fip^.vpos; if refer in fip^.iflag then ak:=pfixed end;
  1692. field:
  1693. begin a:=lastnp^.wa; fieldaddr(fip^.foffset); a.asp:=fip^.idtype end;
  1694. func: with a do
  1695. if fip^.pfkind=standard then errasp(+0125) else
  1696. if (fip^.pfpos.lv>=level-1) and (fip<>currproc) then error(+0126) else
  1697. if fip^.pfkind<>actual then error(+0127) else
  1698. begin pos:=fip^.pfpos; pos.lv:=pos.lv+1;
  1699. if sy=arrow then error(+0128);
  1700. end
  1701. end; {case}
  1702. if (sy=lbrack) or (sy=period) then iflag:=iflag+[noreg];
  1703. while find2([lbrack,period,arrow],fsys,+0129) do with a do
  1704. if sy=lbrack then
  1705. begin insym; selectarrayelement(fsys+[rbrack,lbrack,period,arrow]);
  1706. nextif(rbrack,+0130);
  1707. end else
  1708. if sy=period then
  1709. begin insym;
  1710. if sy<>ident then error(+0131) else
  1711. begin
  1712. if not formof(asp,[records]) then errasp(+0132) else
  1713. begin lip:=searchsection(asp^.fstfld);
  1714. if lip=nil then begin errid(+0133,id); asp:=nil end else
  1715. begin packbit:=spack in asp^.sflag;
  1716. fieldaddr(lip^.foffset); asp:=lip^.idtype
  1717. end
  1718. end;
  1719. insym
  1720. end
  1721. end
  1722. else
  1723. begin insym; iflag:=[used];
  1724. if asp<>nil then
  1725. if asp=zeroptr then errasp(+0134) else
  1726. if asp^.form=pointer then
  1727. begin
  1728. if ak=fixed then ak:=pfixed else
  1729. begin load; ak:=ploaded end;
  1730. asp:=asp^.eltype
  1731. end else
  1732. if asp^.form=files then
  1733. begin loadaddr; gensp(WDW,sz_addr); gencst(op_lfr,sz_addr);
  1734. asp:=asp^.filtype; ak:=ploaded; packbit:=true;
  1735. end
  1736. else errasp(+0135);
  1737. end;
  1738. fip^.iflag:=fip^.iflag+iflag;
  1739. end;
  1740. procedure variable(fsys:sos);
  1741. var lip: ip;
  1742. begin
  1743. if sy=ident then
  1744. begin lip:=searchid([vars,field]); insym;
  1745. selector(fsys,lip,[used,assigned,noreg])
  1746. end
  1747. else begin error(+0136); inita(nil,0) end;
  1748. end;
  1749. {===================================================================}
  1750. function plistequal(p1,p2:ip):boolean;
  1751. var ok:boolean; q1,q2:sp;
  1752. begin plistequal:=eqstruct(p1^.idtype,p2^.idtype);
  1753. p1:=p1^.parhead; p2:=p2^.parhead;
  1754. while (p1<>nil) and (p2<>nil) do
  1755. begin ok:=false;
  1756. if p1^.klass=p2^.klass then
  1757. if p1^.klass<>vars then ok:=plistequal(p1,p2) else
  1758. begin q1:=p1^.idtype; q2:=p2^.idtype; ok:=true;
  1759. while ok and formof(q1,[carray]) and formof(q2,[carray]) do
  1760. begin ok:=eqstruct(q1^.inxtype,q2^.inxtype);
  1761. q1:=q1^.aeltype; q2:=q2^.aeltype;
  1762. end;
  1763. if not (eqstruct(q1,q2) and
  1764. (p1^.iflag*[refer,samesect] = p2^.iflag*[refer,samesect]))
  1765. then ok:=false;
  1766. end;
  1767. if not ok then plistequal:=false;
  1768. p1:=p1^.next; p2:=p2^.next
  1769. end;
  1770. if (p1<>nil) or (p2<>nil) then plistequal:=false
  1771. end;
  1772. procedure callnonstandard(fsys:sos; moreargs:boolean; fip:ip);
  1773. var nxt,lip:ip; l0,l1,l2,l3,sz:integer; lsp,savasp:sp;
  1774. begin with a do begin
  1775. l0:=lino; l1:=l0; sz:=0; nxt:=fip^.parhead;
  1776. while moreargs do
  1777. begin
  1778. if nxt=nil then
  1779. begin if fip^.pfkind<>varargs then error(+0137);
  1780. expression(fsys); load; sz:=sz+sizeof(asp,wordmult)
  1781. end
  1782. else
  1783. begin lsp:=nxt^.idtype;
  1784. if nxt^.klass<>vars then {proc or func}
  1785. begin inita(procptr,0); sz:=sz+sz_proc;
  1786. if sy<>ident then error(+0138) else
  1787. begin lip:=searchid([nxt^.klass]); insym;
  1788. if lip^.pfkind=standard then error(+0139) else
  1789. if not plistequal(nxt,lip) then error(+0140)
  1790. else
  1791. begin pos:=lip^.pfpos;
  1792. if lip^.pfkind=formal then load else
  1793. begin
  1794. if lip^.pfpos.lv<=1 then gencst(op_zer,sz_addr) else
  1795. gencst(op_lxl,level-lip^.pfpos.lv);
  1796. genpnam(op_lpi,lip)
  1797. end
  1798. end
  1799. end
  1800. end
  1801. else if not (refer in nxt^.iflag) then {call by value}
  1802. begin expression(fsys); force(lsp,+0141);
  1803. sz:=sz+sizeof(asp,wordmult);
  1804. end
  1805. else {call by reference}
  1806. begin variable(fsys); loadaddr; sz:=sz+sz_addr;
  1807. if samesect in nxt^.iflag then lsp:=savasp else
  1808. begin savasp:=asp; l2:=lino;
  1809. while formof(lsp,[carray])
  1810. and formof(asp,[arrays,carray]) do
  1811. if (compat(lsp^.inxtype,asp^.inxtype) > subeq) or
  1812. (lsp^.sflag<>asp^.sflag) then errasp(+0142) else
  1813. begin l3:=lino; descraddr(asp^.arpos); exchange(l2,l3);
  1814. sz:=sz+sz_addr; asp:=asp^.aeltype; lsp:=lsp^.aeltype
  1815. end
  1816. end;
  1817. if not eqstruct(asp,lsp) then errasp(+0143);
  1818. if packbit then errasp(+0144);
  1819. end;
  1820. nxt:=nxt^.next
  1821. end;
  1822. exchange(l0,l1); l1:=lino; moreargs:=find3(comma,fsys,+0145)
  1823. end;
  1824. if nxt<>nil then error(+0146);
  1825. inita(procptr,0); pos:=fip^.pfpos;
  1826. if fip^.pfkind=formal then
  1827. with b do
  1828. begin load; ilbno:=ilbno+2;
  1829. gencst(op_exg,sz_addr);
  1830. gencst(op_dup,sz_addr);
  1831. gencst(op_zer,sz_addr);
  1832. genop(op_cmp);
  1833. gencst(op_zeq,ilbno-1);
  1834. gencst(op_exg,sz_addr);
  1835. genop(op_cai);
  1836. gencst(op_asp,sz_addr);
  1837. gencst(op_bra,ilbno);
  1838. newilb(ilbno-1);
  1839. gencst(op_asp,sz_addr);
  1840. genop(op_cai);
  1841. newilb(ilbno);
  1842. end
  1843. else
  1844. begin
  1845. if pos.lv>1 then
  1846. begin gencst(op_lxl,level-pos.lv); sz:=sz+sz_addr end;
  1847. genpnam(op_cal,fip)
  1848. end;
  1849. if sz<>0 then gencst(op_asp,sz);
  1850. asp:=fip^.idtype;
  1851. if asp<>nil then genasp(op_lfr)
  1852. end end;
  1853. procedure fileaddr;
  1854. var la:attr;
  1855. begin la:=a; a:=fa; loadaddr; a:=la end;
  1856. procedure callr(l1,l2:integer);
  1857. var la:attr; m:libmnem;
  1858. begin with a do begin
  1859. la:=a; asp:=desub(asp); fileaddr; m:=RDI;
  1860. if asp<>intptr then
  1861. if asp=charptr then m:=RDC else
  1862. if asp=realptr then m:=RDR else
  1863. if asp=longptr then m:=RDL else errasp(+0147);
  1864. gensp(m,sz_addr); genasp(op_lfr);
  1865. if asp<>la.asp then checkbnds(la.asp);
  1866. a:=la; exchange(l1,l2); store;
  1867. end end;
  1868. procedure callw(fsys:sos; l1,l2:integer);
  1869. var m:libmnem; s:integer;
  1870. begin with a do begin
  1871. fileaddr; exchange(l1,l2); loadcheap; asp:=desub(asp);
  1872. if string(asp) then
  1873. begin gencst(op_loc,asp^.size); m:=WRS; s:=sz_addr+sz_word end
  1874. else
  1875. begin m:=WRI; s:=sizeof(asp,wordmult);
  1876. if asp<>intptr then
  1877. if asp=charptr then m:=WRC else
  1878. if asp=realptr then m:=WRR else
  1879. if asp=boolptr then m:=WRB else
  1880. if asp=zeroptr then m:=WRZ else
  1881. if asp=longptr then m:=WRL else errasp(+0148);
  1882. end;
  1883. if find3(colon1,fsys,+0149) then
  1884. begin expression(fsys+[colon1]); force(intptr,+0150);
  1885. m:=succ(m); s:=s+sz_int
  1886. end;
  1887. if find3(colon1,fsys,+0151) then
  1888. begin expression(fsys); force(intptr,+0152); s:=s+sz_int;
  1889. if m<>WSR then error(+0153) else m:=WRF;
  1890. end;
  1891. gensp(m,s+sz_addr);
  1892. end end;
  1893. procedure callrw(fsys:sos; lpar,w,ln:boolean);
  1894. var l1,l2,errno:integer; ftype,lsp,fsp:sp; savlb:integer; m:libmnem;
  1895. begin with b do begin savlb:=reglb; ftype:=textptr;
  1896. inita(textptr,argv[ord(w)].ad); a.pos.lv:=0; fa:=a;
  1897. if lpar then
  1898. begin l1:=lino; if w then expression(fsys+[colon1]) else variable(fsys);
  1899. l2:=lino;
  1900. if formof(a.asp,[files]) then
  1901. begin ftype:=a.asp;
  1902. if (a.ak<>fixed) and (a.ak<>pfixed) then
  1903. begin loadaddr; temporary(nilptr,reg_pointer);
  1904. store; a.ak:=pfixed
  1905. end;
  1906. fa:=a; {store does not change a}
  1907. if (sy<>comma) and not ln then error(+0154);
  1908. end
  1909. else
  1910. begin if iop[w]=nil then error(+0155);
  1911. if w then callw(fsys,l1,l2) else callr(l1,l2)
  1912. end;
  1913. while find3(comma,fsys,+0156) do with a do
  1914. begin l1:=lino;
  1915. if w then expression(fsys+[colon1]) else variable(fsys);
  1916. l2:=lino;
  1917. if ftype=textptr then
  1918. if w then callw(fsys,l1,l2) else callr(l1,l2)
  1919. else
  1920. begin errno:=+0157; fsp:=ftype^.filtype;
  1921. if w then force(fsp,errno) else
  1922. begin store; lsp:=asp; l2:=lino end;
  1923. fileaddr; gensp(WDW,sz_addr); gencst(op_lfr,sz_addr);
  1924. ak:=ploaded; packbit:=true; asp:=fsp;
  1925. if w then store else
  1926. begin force(lsp,errno); exchange(l1,l2) end;
  1927. fileaddr; if w then m:=PUTX else m:=GETX; gensp(m,sz_addr)
  1928. end
  1929. end;
  1930. end
  1931. else
  1932. if not ln then error(+0158) else
  1933. if iop[w]=nil then error(+0159);
  1934. if ln then
  1935. begin if ftype<>textptr then error(+0160);
  1936. fileaddr; if w then m:=WLN else m:=RLN; gensp(m,sz_addr)
  1937. end;
  1938. reglb:=savlb
  1939. end end;
  1940. procedure callnd(fsys:sos);
  1941. label 1;
  1942. var lsp:sp; int:integer;
  1943. begin with a do begin
  1944. if asp=zeroptr then errasp(+0161) else asp:=asp^.eltype;
  1945. while find3(comma,fsys,+0162) do
  1946. begin
  1947. if asp<>nil then {asp of form record or variant}
  1948. if asp^.form=records then asp:=asp^.tagsp else
  1949. if asp^.form=variant then asp:=asp^.subtsp else errasp(+0163);
  1950. if asp=nil then constant(fsys,lsp,int) else
  1951. begin assert asp^.form=tag;
  1952. int:=cstinteger(fsys,asp^.tfldsp,+0164); lsp:=asp^.fstvar;
  1953. while lsp<>nil do
  1954. if lsp^.varval<>int then lsp:=lsp^.nxtvar else
  1955. begin asp:=lsp; goto 1 end;
  1956. end;
  1957. 1: end;
  1958. genasp(op_loc)
  1959. end end;
  1960. procedure call(fsys: sos; fip: ip);
  1961. var lkey: standpf; lpar:boolean; lsp,sp1,sp2:sp;
  1962. m:libmnem; s:integer; b:byte;
  1963. begin with a do begin fsys:=fsys+[comma];
  1964. lpar:=find3(lparent,fsys,+0165); if lpar then fsys:=fsys+[rparent];
  1965. if fip^.pfkind<>standard then callnonstandard(fsys,lpar,fip) else
  1966. begin lkey:=fip^.key; m:=CLS; lsp:=nil;
  1967. if not lpar then
  1968. if lkey in [pput..prelease,fabs..fatn] then error(+0166);
  1969. if lkey in [pput..ppage,feof,feoln] then
  1970. begin s:=sz_addr;
  1971. if lpar then
  1972. begin variable(fsys); loadaddr end
  1973. else
  1974. begin asp:=textptr;
  1975. if iop[lkey=ppage]=nil then errasp(+0167) else
  1976. gencst(op_lae,argv[ord(lkey=ppage)].ad)
  1977. end;
  1978. if lkey in [pput..prewrite,ppage,feof,feoln] then
  1979. if not formof(asp,[files]) then
  1980. begin error(+0168); asp:=textptr end;
  1981. if lkey in [pnew,pdispose,pmark,prelease] then
  1982. if not formof(asp,[pointer]) then
  1983. begin error(+0169); asp:=nilptr end;
  1984. end;
  1985. case lkey of
  1986. pread, preadln, pwrite, pwriteln: {0,1,2,3 resp}
  1987. callrw(fsys,lpar,lkey>=pwrite,odd(ord(lkey)));
  1988. pput: m:=PUTX;
  1989. pget: m:=GETX;
  1990. ppage: m:=PAG;
  1991. preset: m:=OPN;
  1992. prewrite: m:=CRE;
  1993. pnew: m:=NEWX;
  1994. pdispose: m:=DIS;
  1995. ppack:
  1996. begin sp2:=asp; nextif(comma,+0170); expression(fsys); load;
  1997. lsp:=asp; nextif(comma,+0171); variable(fsys); loadaddr;
  1998. sp1:=asp; asp:=lsp; m:=PAC
  1999. end;
  2000. punpack:
  2001. begin sp1:=asp; nextif(comma,+0172); variable(fsys); loadaddr;
  2002. sp2:=asp; nextif(comma,+0173); expression(fsys); load;
  2003. m:=UNP
  2004. end;
  2005. pmark: m:=SAV;
  2006. prelease: m:=RST;
  2007. phalt:
  2008. begin m:=HLT; teststandard;
  2009. if lpar then lsp:=intptr else gencst(op_loc,0);
  2010. end;
  2011. feof: m:=EFL;
  2012. feoln: m:=ELN;
  2013. fodd, fchr: lsp:=intptr;
  2014. fpred: b:=op_dec;
  2015. fsucc: b:=op_inc;
  2016. fround: m:=RND;
  2017. fsin, fcos, fexp, fsqt, flog, fatn: lsp:=realptr;
  2018. fabs, fsqr, ford, ftrunc: ;
  2019. end;
  2020. if lpar then if lkey in [phalt,fabs..fatn] then
  2021. begin expression(fsys);
  2022. force(lsp,+0174); s:=sizeof(asp,wordmult)
  2023. end;
  2024. if lkey in [ppack,punpack,fabs..fodd] then
  2025. asp:=desub(asp);
  2026. case lkey of
  2027. ppage, feoln:
  2028. begin if asp<>textptr then error(+0175); asp:=boolptr end;
  2029. preset, prewrite:
  2030. begin s:=sz_addr+sz_word;
  2031. if asp=textptr then gencst(op_loc,0) else
  2032. gencst(op_loc,sizeof(asp^.filtype,wordpart));
  2033. end;
  2034. pnew, pdispose:
  2035. begin callnd(fsys); s:=sz_addr+sz_word end;
  2036. ppack, punpack:
  2037. begin s:=2*sz_addr+sz_int;
  2038. if formof(sp1,[arrays,carray])
  2039. and formof(sp2,[arrays,carray]) then
  2040. if (spack in (sp1^.sflag - sp2^.sflag)) and
  2041. eqstruct(sp1^.aeltype,sp2^.aeltype) and
  2042. eqstruct(desub(sp1^.inxtype),asp) and
  2043. eqstruct(desub(sp2^.inxtype),asp) then
  2044. begin descraddr(sp1^.arpos); descraddr(sp2^.arpos) end
  2045. else error(+0176)
  2046. else error(+0177)
  2047. end;
  2048. pmark, prelease: teststandard;
  2049. feof: asp:=boolptr;
  2050. fabs:
  2051. if asp=intptr then m:=ABI else
  2052. if asp=longptr then m:=ABL else
  2053. if asp=realptr then m:=ABR else errasp(+0178);
  2054. fsqr:
  2055. begin
  2056. if (asp=intptr) or (asp=longptr) then b:=op_mli else
  2057. if asp=realptr then begin b:=op_mlf; fltused:=true end
  2058. else errasp(+0179);
  2059. genasp(op_dup); genasp(b)
  2060. end;
  2061. ford:
  2062. begin if not nicescalar(asp) then errasp(+0180); asp:=intptr end;
  2063. fchr: checkbnds(charptr);
  2064. fpred, fsucc:
  2065. begin genop(b);
  2066. if nicescalar(asp) then genrck(asp) else errasp(+0181)
  2067. end;
  2068. fodd:
  2069. begin gencst(op_loc,1); asp:=boolptr; genasp(op_and) end;
  2070. ftrunc, fround: if asp<>realptr then errasp(+0182);
  2071. fsin: m:=SINX;
  2072. fcos: m:=COSX;
  2073. fexp: m:=EXPX;
  2074. fsqt: m:=SQT;
  2075. flog: m:=LOG;
  2076. fatn: m:=ATN;
  2077. phalt:s:=0;
  2078. pread, preadln, pwrite, pwriteln, pput, pget: ;
  2079. end;
  2080. if m<>CLS then
  2081. begin gensp(m,s);
  2082. if lkey>=feof then genasp(op_lfr)
  2083. end;
  2084. if (lkey=fround) or (lkey=ftrunc) then
  2085. opconvert(ri);
  2086. end;
  2087. if lpar then nextif(rparent,+0183);
  2088. end end;
  2089. {===================================================================}
  2090. procedure convert(fsp:sp; l1:integer);
  2091. {Convert tries to make the operands of some operator of the same type.
  2092. The operand types are given by fsp and a.asp. The resulting type
  2093. is put in a.asp.
  2094. l1 gives the lino of the first instruction of the right operand.
  2095. }
  2096. var l2:integer; ts:twostruct; lsp:sp;
  2097. begin with a do begin asp:=desub(asp);
  2098. ts:=compat(asp,fsp);
  2099. case ts of
  2100. eq,subeq:
  2101. ;
  2102. il,ir,lr:
  2103. opconvert(ts);
  2104. es:
  2105. expandnullset(fsp);
  2106. li,ri,rl,se:
  2107. begin l2:=lino; lsp:=asp; asp:=fsp;
  2108. convert(lsp,l1); exchange(l1,l2); asp:=lsp
  2109. end;
  2110. noteq:
  2111. errasp(+0184);
  2112. end;
  2113. if asp=realptr then fltused:=true
  2114. end end;
  2115. procedure buildset(fsys:sos);
  2116. {This is a bad construct in pascal. Two objections:
  2117. - expr..expr very difficult to implement on most machines
  2118. - this construct makes it hard to implement sets of different size
  2119. }
  2120. const ncsb = 32; {tunable}
  2121. type byteset = set of 0..MB1;
  2122. var i,j,val1,val2,ncst,l1,l2,sz:integer;
  2123. cst1,cst2,cst12,varpart:boolean;
  2124. cstpart:array[1..ncsb] of byteset;
  2125. procedure genconstset(sz:integer);
  2126. {level 2: << buildset}
  2127. var i,j:integer;
  2128. function setcode(s:byteset):byte;
  2129. {level 3: << buildset}
  2130. var b,i,w:byte;
  2131. begin i:=0; w:=0; b:=1;
  2132. for i:=0 to MB1 do
  2133. begin if i in s then w:=w+b; b:=b+b end;
  2134. setcode := w;
  2135. end;
  2136. begin
  2137. i:=sz;
  2138. repeat
  2139. genop(op_loc); j:=i; i:=i-sz_word;
  2140. {the bytes of the next word to be loaded on the stack}
  2141. {are in cstpart[i+1] .. cstpart[j]}
  2142. while (cstpart[j] = []) and (j > i+1) do j:=j-1;
  2143. if j = i+1 then argcst(setcode(cstpart[j]))
  2144. else
  2145. begin
  2146. if j = i+2 then put1(sp_cst2)
  2147. else begin j:=i+4; put1(sp_cst4) end;
  2148. for j:=i+1 to j do put1(setcode(cstpart[j]))
  2149. end;
  2150. until i = 0;
  2151. end;
  2152. procedure setexpr(fsys:sos; var c:boolean; var v:integer);
  2153. {level 2: << buildset}
  2154. var min:integer; lsp:sp;
  2155. begin with a do begin c:=false; v:=0; lsp:=asp;
  2156. expression(fsys); asp:=desub(asp);
  2157. if not eqstruct(asp,lsp^.elset) then
  2158. begin error(+0185); lsp:=nullset end;
  2159. if lsp=nullset then
  2160. begin
  2161. if bounded(asp) then bounds(asp,min,sz) else
  2162. if asp=intptr then sz:=iopt-1 else begin errasp(+0186); sz:=0 end;
  2163. sz:=sz div NB1 + 1; while sz mod sz_word <> 0 do sz:=sz+1;
  2164. if sz>sz_mset then errasp(+0187);
  2165. lsp:=newsp(power,sz); lsp^.elset:=asp
  2166. end;
  2167. if asp<>nil then if ak=cst then
  2168. if (pos.ad<0) or (pos.ad div NB1>=sizeof(lsp,wordmult)) then
  2169. error(+0188)
  2170. else if sz<=ncsb*sz_byte then
  2171. begin c:=true; v:=pos.ad end;
  2172. if not c then load; asp:=lsp
  2173. end end;
  2174. begin with a do begin {buildset}
  2175. varpart:=false; ncst:=0; asp:=nullset;
  2176. for i:=1 to ncsb do cstpart[i]:=[];
  2177. if find2([notsy..lparent],fsys,+0189) then
  2178. repeat l1:=lino;
  2179. setexpr(fsys+[colon2,comma],cst1,val1); cst12:=cst1;
  2180. if find3(colon2,fsys+[comma,notsy..lparent],+0190) then
  2181. begin setexpr(fsys+[comma,notsy..lparent],cst2,val2);
  2182. cst12:=cst12 and cst2;
  2183. if not cst12 then
  2184. begin
  2185. if cst2 then gencst(op_loc,val2);
  2186. if cst1 then
  2187. begin l2:=lino; gencst(op_loc,val1); exchange(l1,l2) end;
  2188. l2:=lino; genasp(op_zer); exchange(l1,l2);
  2189. genasp(op_loc); gensp(BTS,3*sz_word)
  2190. end;
  2191. end
  2192. else
  2193. if cst12 then val2:=val1 else genasp(op_set);
  2194. if cst12 then
  2195. for i:=val1 to val2 do
  2196. begin j:=i div NB1 + 1; ncst:=ncst+1;
  2197. cstpart[j]:=cstpart[j] + [i mod NB1]
  2198. end
  2199. else
  2200. if varpart then genasp(op_ior) else varpart:=true;
  2201. until endofloop(fsys,[notsy..lparent],comma,+0191); {+0192}
  2202. ak:=loaded;
  2203. if ncst>0 then
  2204. begin
  2205. genconstset(sizeof(asp,wordmult));
  2206. if varpart then genasp(op_ior);
  2207. end
  2208. else
  2209. if not varpart then genasp(op_zer); {empty set}
  2210. end end;
  2211. procedure factor(fsys: sos);
  2212. var lip:ip; lsp:sp;
  2213. begin with a do begin
  2214. asp:=nil; packbit:=false; ak:=loaded;
  2215. if find1([notsy..nilcst,lparent],fsys,+0193) then
  2216. case sy of
  2217. ident:
  2218. begin lip:=searchid([konst,vars,field,func,carrbnd]); insym;
  2219. case lip^.klass of
  2220. func: {call moves result to top stack}
  2221. begin call(fsys,lip); ak:=loaded; packbit:=false end;
  2222. konst:
  2223. begin asp:=lip^.idtype;
  2224. if nicescalar(asp) then {including asp=nil}
  2225. begin ak:=cst; pos.ad:=lip^.value end
  2226. else
  2227. begin ak:=ploaded; laedlb(abs(lip^.value));
  2228. if asp^.form=scalar then
  2229. begin load; if lip^.value<0 then negate end
  2230. else
  2231. if asp=zeroptr then ak:=loaded
  2232. end
  2233. end;
  2234. field,vars:
  2235. selector(fsys,lip,[used]);
  2236. carrbnd:
  2237. begin lsp:=lip^.idtype; assert formof(lsp,[carray]);
  2238. descraddr(lsp^.arpos); lsp:=lsp^.inxtype; asp:=desub(lsp);
  2239. if lip^.next=nil then ak:=ploaded {low bound} else
  2240. begin gencst(op_loi,2*sz_int); genasp(op_adi) end;
  2241. load; checkbnds(lsp);
  2242. end;
  2243. end {case}
  2244. end;
  2245. intcst:
  2246. begin asp:=intptr; ak:=cst; pos.ad:=val; insym end;
  2247. realcst:
  2248. begin asp:=realptr; ak:=ploaded; laedlb(val); insym end;
  2249. longcst:
  2250. begin asp:=longptr; ak:=ploaded; laedlb(val); insym end;
  2251. charcst:
  2252. begin asp:=charptr; ak:=cst; pos.ad:=val; insym end;
  2253. stringcst:
  2254. begin asp:=stringstruct; laedlb(val); insym;
  2255. if asp<>zeroptr then ak:=ploaded;
  2256. end;
  2257. nilcst:
  2258. begin insym; asp:=nilptr; genasp(op_zer); end;
  2259. lparent:
  2260. begin insym; expression(fsys+[rparent]); nextif(rparent,+0194) end;
  2261. notsy:
  2262. begin insym; factor(fsys); load; genop(op_teq); asp:=desub(asp);
  2263. if asp<>boolptr then errasp(+0195)
  2264. end;
  2265. lbrack:
  2266. begin insym; buildset(fsys+[rbrack]); nextif(rbrack,+0196) end;
  2267. end
  2268. end end;
  2269. procedure term(fsys:sos);
  2270. var lsy:symbol; lsp:sp; l1:integer; first:boolean;
  2271. begin with a,b do begin first:=true; l1:=lino;
  2272. factor(fsys+[starsy..andsy]);
  2273. while find2([starsy..andsy],fsys,+0197) do
  2274. begin if first then begin load; first:=false end;
  2275. lsy:=sy; insym; l1:=lino; lsp:=asp;
  2276. factor(fsys+[starsy..andsy]); load; convert(lsp,l1);
  2277. if asp<>nil then
  2278. case lsy of
  2279. starsy:
  2280. if (asp=intptr) or (asp=longptr) then genasp(op_mli) else
  2281. if asp=realptr then genasp(op_mlf) else
  2282. if asp^.form=power then genasp(op_and) else errasp(+0198);
  2283. slashsy:
  2284. begin
  2285. if (asp=intptr) or (asp=longptr) then
  2286. begin lsp:=asp;
  2287. convert(realptr,l1); {make real of right operand}
  2288. convert(lsp,l1); {make real of left operand}
  2289. end;
  2290. if asp=realptr then genasp(op_dvf) else errasp(+0199);
  2291. end;
  2292. divsy:
  2293. if (asp=intptr) or (asp=longptr) then genasp(op_dvi) else
  2294. errasp(+0200);
  2295. modsy:
  2296. begin
  2297. if asp=intptr then gensp(MDI,2*sz_int) else
  2298. if asp=longptr then gensp(MDL,2*sz_long) else errasp(+0201);
  2299. genasp(op_lfr);
  2300. end;
  2301. andsy:
  2302. if asp=boolptr then genasp(op_and) else errasp(+0202);
  2303. end {case}
  2304. end {while}
  2305. end end;
  2306. procedure simpleexpression(fsys:sos);
  2307. var lsy:symbol; lsp:sp; l1:integer; signed,min,first:boolean;
  2308. begin with a do begin l1:=lino; first:=true;
  2309. signed:=(sy=plussy) or (sy=minsy);
  2310. if signed then begin min:=sy=minsy; insym end else min:=false;
  2311. term(fsys + [minsy,plussy,orsy]); lsp:=desub(asp);
  2312. if signed then
  2313. if (lsp<>intptr) and (lsp<>realptr) and (lsp<>longptr) then
  2314. errasp(+0203)
  2315. else if min then
  2316. begin load; first:=false; asp:=lsp; negate end;
  2317. while find2([plussy,minsy,orsy],fsys,+0204) do
  2318. begin if first then begin load; first:=false end;
  2319. lsy:=sy; insym; l1:=lino; lsp:=asp;
  2320. term(fsys+[minsy,plussy,orsy]); load; convert(lsp,l1);
  2321. if asp<>nil then
  2322. case lsy of
  2323. plussy:
  2324. if (asp=intptr) or (asp=longptr) then genasp(op_adi) else
  2325. if asp=realptr then genasp(op_adf) else
  2326. if asp^.form=power then genasp(op_ior) else errasp(+0205);
  2327. minsy:
  2328. if (asp=intptr) or (asp=longptr) then genasp(op_sbi) else
  2329. if asp=realptr then genasp(op_sbf) else
  2330. if asp^.form=power then begin genasp(op_com); genasp(op_and) end
  2331. else errasp(+0206);
  2332. orsy:
  2333. if asp=boolptr then genasp(op_ior) else errasp(+0207);
  2334. end {case}
  2335. end {while}
  2336. end end;
  2337. procedure expression; { fsys:sos }
  2338. var lsy:symbol; lsp:sp; l1,l2:integer;
  2339. begin with a do begin l1:=lino;
  2340. simpleexpression(fsys+[eqsy..insy]);
  2341. if find2([eqsy..insy],fsys,+0208) then
  2342. begin lsy:=sy; insym; lsp:=asp; loadcheap; l2:=lino;
  2343. simpleexpression(fsys); loadcheap;
  2344. if lsy=insy then
  2345. begin
  2346. if not formof(asp,[power]) then errasp(+0209) else
  2347. if asp=nullset then genasp(op_and) else
  2348. {this effectively replaces the word on top of the
  2349. stack by the result of the 'in' operator: false }
  2350. if not (compat(lsp,asp^.elset) <= subeq) then errasp(+0210) else
  2351. begin exchange(l1,l2); genasp(op_inn) end
  2352. end
  2353. else
  2354. begin convert(lsp,l2);
  2355. if asp<>nil then
  2356. case asp^.form of
  2357. scalar:
  2358. if asp=realptr then genasp(op_cmf) else genasp(op_cmi);
  2359. pointer:
  2360. if (lsy=eqsy) or (lsy=nesy) then genop(op_cmp) else
  2361. errasp(+0211);
  2362. power:
  2363. case lsy of
  2364. eqsy,nesy: genasp(op_cms);
  2365. ltsy,gtsy: errasp(+0212);
  2366. lesy: {'a<=b' equivalent to 'a-b=[]'}
  2367. begin genasp(op_com); genasp(op_and); genasp(op_zer);
  2368. genasp(op_cms); lsy:=eqsy
  2369. end;
  2370. gesy: {'a>=b' equivalent to 'a=a+b'}
  2371. begin gencst(op_dup,2*sizeof(asp,wordmult));
  2372. genasp(op_asp); genasp(op_ior);
  2373. genasp(op_cms); lsy:=eqsy
  2374. end
  2375. end; {case}
  2376. arrays:
  2377. if string(asp) then
  2378. begin gencst(op_loc,asp^.size);
  2379. gensp(BCP,2*sz_addr+sz_word);
  2380. gencst(op_lfr,sz_word)
  2381. end
  2382. else errasp(+0213);
  2383. records: errasp(+0214);
  2384. files: errasp(+0215)
  2385. end; { case }
  2386. case lsy of
  2387. ltsy: genop(op_tlt);
  2388. lesy: genop(op_tle);
  2389. gtsy: genop(op_tgt);
  2390. gesy: genop(op_tge);
  2391. nesy: genop(op_tne);
  2392. eqsy: genop(op_teq)
  2393. end
  2394. end;
  2395. asp:=boolptr; ak:=loaded
  2396. end;
  2397. end end;
  2398. {===================================================================}
  2399. procedure statement(fsys:sos); forward;
  2400. {this forward declaration can be avoided}
  2401. procedure assignment(fsys:sos; fip:ip);
  2402. var la:attr; l1,l2:integer;
  2403. begin
  2404. l1:=lino; selector(fsys+[becomes],fip,[assigned]); l2:=lino;
  2405. la:=a; nextif(becomes,+0216);
  2406. expression(fsys); loadcheap; checkasp(la.asp,+0217);
  2407. exchange(l1,l2); a:=la;
  2408. if not formof(la.asp,[arrays..records]) then store else
  2409. begin loadaddr;
  2410. if la.asp^.form<>carray then genasp(op_blm) else
  2411. begin descraddr(la.asp^.arpos); gensp(ASZ,sz_addr);
  2412. gencst(op_lfr,sz_word); gencst(op_bls,sz_word)
  2413. end;
  2414. end;
  2415. end;
  2416. procedure gotostatement;
  2417. {jumps into structured statements can give strange results. }
  2418. label 1;
  2419. var llp:lp; lbp:bp; diff:integer;
  2420. begin
  2421. if sy<>intcst then error(+0218) else
  2422. begin llp:=searchlab(b.lchain,val);
  2423. if llp<>nil then gencst(op_bra,llp^.labname) else
  2424. begin lbp:=b.nextbp; diff:=1;
  2425. while lbp<>nil do
  2426. begin llp:=searchlab(lbp^.lchain,val);
  2427. if llp<>nil then goto 1;
  2428. lbp:=lbp^.nextbp; diff:=diff+1;
  2429. end;
  2430. 1: if llp=nil then errint(+0219,val) else
  2431. begin
  2432. if llp^.labdlb=0 then
  2433. begin dlbno:=dlbno+1; llp^.labdlb:=dlbno;
  2434. genop(ps_ina); argdlb(dlbno); {forward data reference}
  2435. end;
  2436. laedlb(llp^.labdlb);
  2437. if diff=level-1 then gencst(op_zer,sz_addr) else
  2438. gencst(op_lxl,diff);
  2439. gensp(GTO,2*sz_addr);
  2440. end;
  2441. end;
  2442. insym;
  2443. end
  2444. end;
  2445. procedure compoundstatement(fsys:sos; err:integer);
  2446. begin
  2447. repeat statement(fsys+[semicolon])
  2448. until endofloop(fsys,[beginsy..casesy],semicolon,err)
  2449. end;
  2450. procedure ifstatement(fsys:sos);
  2451. var lb1,lb2:integer;
  2452. begin with b do begin
  2453. expression(fsys+[thensy,elsesy]);
  2454. force(boolptr,+0220); ilbno:=ilbno+1; lb1:=ilbno; gencst(op_zeq,lb1);
  2455. nextif(thensy,+0221); statement(fsys+[elsesy]);
  2456. if find3(elsesy,fsys,+0222) then
  2457. begin ilbno:=ilbno+1; lb2:=ilbno; gencst(op_bra,lb2);
  2458. newilb(lb1); statement(fsys); newilb(lb2)
  2459. end
  2460. else newilb(lb1);
  2461. end end;
  2462. procedure casestatement(fsys:sos);
  2463. label 1;
  2464. type cip=^caseinfo;
  2465. caseinfo=record
  2466. next: cip;
  2467. csstart: integer;
  2468. cslab: integer
  2469. end;
  2470. var lsp:sp; head,p,q,r:cip; l0,l1:integer;
  2471. ilb1,ilb2,dlb,i,n,m,min,max:integer;
  2472. begin with b do begin
  2473. expression(fsys+[ofsy,semicolon,ident..plussy]); lsp:=a.asp; load;
  2474. if not nicescalar(desub(lsp)) then begin error(+0223); lsp:=nil end;
  2475. l0:=lino; ilbno:=ilbno+1; ilb1:=ilbno;
  2476. nextif(ofsy,+0224); head:=nil; max:=-MI; min:=MI; n:=0;
  2477. repeat ilbno:=ilbno+1; ilb2:=ilbno; {label of current case}
  2478. repeat i:=cstinteger(fsys+[comma,colon1,semicolon],lsp,+0225);
  2479. if i>max then max:=i; if i<min then min:=i; n:=n+1;
  2480. q:=head; r:=nil; new(p);
  2481. while q<>nil do
  2482. begin {chain all cases in ascending order}
  2483. if q^.cslab>=i then
  2484. begin if q^.cslab=i then error(+0226); goto 1 end;
  2485. r:=q; q:=q^.next
  2486. end;
  2487. 1: p^.next:=q; p^.cslab:=i; p^.csstart:=ilb2;
  2488. if r=nil then head:=p else r^.next:=p;
  2489. until endofloop(fsys+[colon1,semicolon],[ident..plussy],comma,+0227);
  2490. {+0228}
  2491. nextif(colon1,+0229); newilb(ilb2); statement(fsys+[semicolon]);
  2492. gencst(op_bra,ilb1);
  2493. until lastsemicolon(fsys,[ident..plussy],+0230); {+0231 +0232}
  2494. assert n<>0; newilb(ilb1); l1:=lino;
  2495. dlb:=newdlb; genop(ps_rom); argnil;
  2496. if (max div 3) - (min div 3) < n then
  2497. begin argcst(min); argcst(max-min);
  2498. m:=op_csa;
  2499. while head<>nil do
  2500. begin
  2501. while head^.cslab>min do
  2502. begin argnil; min:=min+1 end;
  2503. argilb(head^.csstart); min:=min+1; head:=head^.next
  2504. end;
  2505. end
  2506. else
  2507. begin argcst(n); m:=op_csb;
  2508. while head<>nil do
  2509. begin argcst(head^.cslab);argilb(head^.csstart);head:=head^.next end;
  2510. end;
  2511. argend; laedlb(dlb); gencst(m,sz_word); exchange(l0,l1)
  2512. end end;
  2513. procedure repeatstatement(fsys:sos);
  2514. var lb1: integer;
  2515. begin with b do begin
  2516. ilbno:=ilbno+1; lb1:=ilbno; newilb(lb1);
  2517. compoundstatement(fsys+[untilsy],+0233); {+0234}
  2518. nextif(untilsy,+0235); genlin;
  2519. expression(fsys); force(boolptr,+0236); gencst(op_zeq,lb1);
  2520. end end;
  2521. procedure whilestatement(fsys:sos);
  2522. var lb1,lb2: integer;
  2523. begin with b do begin
  2524. ilbno:=ilbno+1; lb1:=ilbno; newilb(lb1);
  2525. ilbno:=ilbno+1; lb2:=ilbno;
  2526. genlin; expression(fsys+[dosy]);
  2527. force(boolptr,+0237); gencst(op_zeq,lb2);
  2528. nextif(dosy,+0238); statement(fsys);
  2529. gencst(op_bra,lb1); newilb(lb2)
  2530. end end;
  2531. procedure forstatement(fsys:sos);
  2532. var lip:ip; tosym:boolean; endlab,looplab,savlb:integer;
  2533. av,at1,at2:attr; lsp:sp;
  2534. procedure forbound(fsys:sos; var fa:attr; fsp:sp);
  2535. begin
  2536. expression(fsys); fa:=a; force(fsp,+0239);
  2537. if fa.ak<>cst then
  2538. begin temporary(fsp,reg_any);
  2539. genasp(op_dup); fa:=a; store
  2540. end
  2541. end;
  2542. begin with b do begin savlb:=reglb; tosym:=false;
  2543. ilbno:=ilbno+1; looplab:=ilbno; ilbno:=ilbno+1; endlab:=ilbno;
  2544. inita(nil,0);
  2545. if sy<>ident then error(+0240) else
  2546. begin lip:=searchid([vars]); insym;
  2547. a.asp:=lip^.idtype; a.pos:=lip^.vpos;
  2548. lip^.iflag:=lip^.iflag+[used,assigned,loopvar];
  2549. if level>1 then
  2550. if (a.pos.ad>=0) or (a.pos.lv<>level) then
  2551. error(+0241);
  2552. end;
  2553. lsp:=desub(a.asp);
  2554. if not nicescalar(lsp) then begin errasp(+0242); lsp:=nil end;
  2555. av:=a; nextif(becomes,+0243);
  2556. forbound(fsys+[tosy,downtosy,notsy..lparent,dosy],at1,lsp);
  2557. if find1([tosy,downtosy],fsys+[notsy..lparent,dosy],+0244) then
  2558. begin tosym:=sy=tosy; insym end;
  2559. forbound(fsys+[dosy],at2,lsp);
  2560. if tosym then gencst(op_bgt,endlab) else gencst(op_blt,endlab);
  2561. a:=at1; force(av.asp,+0245); a:=av; store; newilb(looplab);
  2562. nextif(dosy,+0246); statement(fsys);
  2563. a:=av; load; a:=at2; load; gencst(op_beq,endlab);
  2564. a:=av; load; if tosym then genop(op_inc) else genop(op_dec);
  2565. a.asp:=lsp; checkbnds(av.asp); a:=av; store;
  2566. gencst(op_bra,looplab); newilb(endlab);
  2567. reglb:=savlb
  2568. end end;
  2569. procedure withstatement(fsys:sos);
  2570. var lnp,savtop:np; savlb:integer; pbit:boolean;
  2571. begin with b do begin
  2572. savlb:=reglb; savtop:=top;
  2573. repeat variable(fsys+[comma,dosy]);
  2574. if not formof(a.asp,[records]) then errasp(+0247) else
  2575. begin pbit:=spack in a.asp^.sflag;
  2576. new(lnp,wrec); lnp^.occur:=wrec; lnp^.fname:=a.asp^.fstfld;
  2577. if a.ak<>fixed then
  2578. begin loadaddr; temporary(nilptr,reg_pointer); store;
  2579. a.ak:=pfixed;
  2580. end;
  2581. a.packbit:=pbit; lnp^.wa:=a; lnp^.nlink:=top; top:=lnp;
  2582. end;
  2583. until endofloop(fsys+[dosy],[ident],comma,+0248); {+0249}
  2584. nextif(dosy,+0250); statement(fsys);
  2585. top:=savtop; reglb:=savlb;
  2586. end end;
  2587. procedure assertion(fsys:sos);
  2588. begin teststandard;
  2589. if opt['a']=off then
  2590. while not (sy in fsys) do insym
  2591. else
  2592. begin expression(fsys); force(boolptr,+0251);
  2593. gencst(op_loc,srcorig); gensp(ASS,2*sz_word);
  2594. end
  2595. end;
  2596. procedure statement; {fsys: sos}
  2597. var lip:ip; llp:lp; lsy:symbol;
  2598. begin
  2599. assert [labelsy..casesy,endsy] <= fsys;
  2600. assert [ident,intcst] * fsys = [];
  2601. if find2([intcst],fsys+[ident],+0252) then
  2602. begin llp:=searchlab(b.lchain,val);
  2603. if llp=nil then errint(+0253,val) else
  2604. begin if llp^.seen then errint(+0254,val) else llp^.seen:=true;
  2605. newilb(llp^.labname)
  2606. end;
  2607. insym; nextif(colon1,+0255);
  2608. end;
  2609. if find2([ident,beginsy..casesy],fsys,+0256) then
  2610. begin if giveline then if sy<>whilesy then genlin;
  2611. if sy=ident then
  2612. if id='assert ' then
  2613. begin insym; assertion(fsys) end
  2614. else
  2615. begin lip:=searchid([vars,field,func,proc]); insym;
  2616. if lip^.klass=proc then call(fsys,lip) else assignment(fsys,lip)
  2617. end
  2618. else
  2619. begin lsy:=sy; insym;
  2620. case lsy of
  2621. beginsy:
  2622. begin compoundstatement(fsys,+0257); {+0258}
  2623. nextif(endsy,+0259)
  2624. end;
  2625. gotosy:
  2626. gotostatement;
  2627. ifsy:
  2628. ifstatement(fsys);
  2629. casesy:
  2630. begin casestatement(fsys); nextif(endsy,+0260) end;
  2631. whilesy:
  2632. whilestatement(fsys);
  2633. repeatsy:
  2634. repeatstatement(fsys);
  2635. forsy:
  2636. forstatement(fsys);
  2637. withsy:
  2638. withstatement(fsys);
  2639. end
  2640. end;
  2641. end
  2642. end;
  2643. {===================================================================}
  2644. procedure body(fsys:sos; fip:ip);
  2645. var i,dlb,l0,l1,ssp:integer; llp:lp; spset:boolean;
  2646. begin with b do begin
  2647. {produce PRO}
  2648. genpnam(ps_pro,fip); argend;
  2649. gencst(ps_mes,ms_par);argcst(fip^.maxlb); argend;
  2650. l0:=lino; dlb:=0; trace('procentr',fip,dlb);
  2651. {global labels}
  2652. llp:=lchain; spset:=false;
  2653. while llp<>nil do
  2654. begin
  2655. if llp^.labdlb<>0 then
  2656. begin
  2657. if not spset then
  2658. begin spset:=true;
  2659. gencst(ps_mes,ms_gto); argend;
  2660. temporary(nilptr,-1); ssp:=a.pos.ad;
  2661. gencst(op_lor,1); store
  2662. end;
  2663. argdlb(llp^.labdlb); lino:=lino+1; genop(ps_rom);
  2664. argilb(llp^.labname); argcst(ssp); argend;
  2665. end;
  2666. llp:=llp^.nextlp
  2667. end;
  2668. {the body itself}
  2669. currproc:=fip;
  2670. compoundstatement(fsys,+0261); {+0262}
  2671. trace('procexit',fip,dlb);
  2672. {undefined labels}
  2673. llp:=lchain;
  2674. while llp<>nil do
  2675. begin if not llp^.seen then errint(+0263,llp^.labval);
  2676. llp:=llp^.nextlp
  2677. end;
  2678. {finish and close files}
  2679. treewalk(top^.fname);
  2680. if level=1 then
  2681. begin l1:=lino;
  2682. genop(op_fil); argdlb(fildlb); {temporarily}
  2683. dlb:=newdlb; gencst(ps_con,argc+1);
  2684. for i:=0 to argc do with argv[i] do
  2685. begin argcst(ad);
  2686. if (ad=-1) and (i>1) then errid(+0264,name)
  2687. end;
  2688. argend; gencst(op_lxl,0); laedlb(dlb); gencst(op_lae,0);
  2689. gencst(op_lxa,0); gensp(INI,4*sz_addr);
  2690. exchange(l0,l1); gencst(op_loc,0); gensp(HLT,0)
  2691. end
  2692. else
  2693. begin inita(fip^.idtype,fip^.pfpos.ad);
  2694. if fip^.klass=func then
  2695. begin load;
  2696. if not (assigned in fip^.iflag) then
  2697. errid(-(+0265),fip^.name);
  2698. end;
  2699. genasp(op_ret);
  2700. end;
  2701. gencst(ps_end,-minlb);
  2702. end end;
  2703. {===================================================================}
  2704. procedure block; {forward declared}
  2705. begin with b do begin
  2706. assert [labelsy..withsy] <= fsys;
  2707. assert [ident,intcst,casesy,endsy,period] * fsys = [];
  2708. if find3(labelsy,fsys,+0266) then labeldeclaration(fsys);
  2709. if find3(constsy,fsys,+0267) then constdefinition(fsys);
  2710. if find3(typesy,fsys,+0268) then typedefinition(fsys);
  2711. if find3(varsy,fsys,+0269) then vardeclaration(fsys);
  2712. if fip=progp then
  2713. begin
  2714. if iop[true]<>nil then
  2715. begin argv[1].ad:=posaddr(holeb,textptr,false);
  2716. iop[true]^.vpos.ad:=argv[1].ad
  2717. end;
  2718. if iop[false]<>nil then
  2719. begin argv[0].ad:=posaddr(holeb,textptr,false);
  2720. iop[false]^.vpos.ad:=argv[0].ad
  2721. end;
  2722. genhol; genpnam(ps_exp,fip);
  2723. end; {externals are also extern for the main body}
  2724. fip^.pfpos.ad:=negaddr(fip^.idtype); {function result area}
  2725. while find2([procsy,funcsy],fsys,+0270) do pfdeclaration(fsys);
  2726. if forwcount<>0 then error(+0271); {forw proc not specified}
  2727. nextif(beginsy,+0272);
  2728. body(fsys+[casesy,endsy],fip);
  2729. nextif(endsy,+0273);
  2730. end end;
  2731. {===================================================================}
  2732. procedure programme(fsys:sos);
  2733. var stdin,stdout:boolean; p:ip;
  2734. begin
  2735. nextif(progsy,+0274); nextif(ident,+0275);
  2736. if find3(lparent,fsys+[semicolon],+0276) then
  2737. begin
  2738. repeat
  2739. if sy<>ident then error(+0277) else
  2740. begin stdin:=id='input '; stdout:=id='output ';
  2741. if stdin or stdout then
  2742. begin p:=newip(vars,id,textptr,nil);
  2743. enterid(p); iop[stdout]:=p;
  2744. end
  2745. else
  2746. if argc<maxargc then
  2747. begin
  2748. argc:=argc+1; argv[argc].name:=id; argv[argc].ad:=-1
  2749. end;
  2750. insym
  2751. end
  2752. until endofloop(fsys+[rparent,semicolon],[ident],comma,+0278); {+0279}
  2753. if argc>maxargc then
  2754. begin error(+0280); argc:=maxargc end;
  2755. nextif(rparent,+0281);
  2756. end;
  2757. nextif(semicolon,+0282);
  2758. block(fsys,progp);
  2759. if opt['l']<>off then
  2760. begin gencst(ps_mes,ms_src); argcst(srcorig); argend end;
  2761. eofexpected:=true; nextif(period,+0283);
  2762. end;
  2763. procedure compile;
  2764. var lsys:sos;
  2765. begin lsys:=[progsy,labelsy..withsy];
  2766. repeat eofexpected:=false;
  2767. main:=find2([progsy,labelsy,beginsy..withsy],lsys,+0284);
  2768. if main then programme(lsys) else
  2769. begin
  2770. if find3(constsy,lsys,+0285) then constdefinition(lsys);
  2771. if find3(typesy,lsys,+0286) then typedefinition(lsys);
  2772. if find3(varsy,lsys,+0287) then vardeclaration(lsys);
  2773. genhol;
  2774. while find2([procsy,funcsy],lsys,+0288) do pfdeclaration(lsys);
  2775. end;
  2776. error(+0289);
  2777. until false; { the only way out is the halt in nextln on eof }
  2778. end;
  2779. {===================================================================}
  2780. procedure init1;
  2781. var c:char;
  2782. begin
  2783. {reserved words}
  2784. rw[ 0]:='if '; rw[ 1]:='do '; rw[ 2]:='of ';
  2785. rw[ 3]:='to '; rw[ 4]:='in '; rw[ 5]:='or ';
  2786. rw[ 6]:='end '; rw[ 7]:='for '; rw[ 8]:='nil ';
  2787. rw[ 9]:='var '; rw[10]:='div '; rw[11]:='mod ';
  2788. rw[12]:='set '; rw[13]:='and '; rw[14]:='not ';
  2789. rw[15]:='then '; rw[16]:='else '; rw[17]:='with ';
  2790. rw[18]:='case '; rw[19]:='type '; rw[20]:='goto ';
  2791. rw[21]:='file '; rw[22]:='begin '; rw[23]:='until ';
  2792. rw[24]:='while '; rw[25]:='array '; rw[26]:='const ';
  2793. rw[27]:='label '; rw[28]:='repeat '; rw[29]:='record ';
  2794. rw[30]:='downto '; rw[31]:='packed '; rw[32]:='program ';
  2795. rw[33]:='function'; rw[34]:='procedur';
  2796. {corresponding symbols}
  2797. rsy[ 0]:=ifsy; rsy[ 1]:=dosy; rsy[ 2]:=ofsy;
  2798. rsy[ 3]:=tosy; rsy[ 4]:=insy; rsy[ 5]:=orsy;
  2799. rsy[ 6]:=endsy; rsy[ 7]:=forsy; rsy[ 8]:=nilcst;
  2800. rsy[ 9]:=varsy; rsy[10]:=divsy; rsy[11]:=modsy;
  2801. rsy[12]:=setsy; rsy[13]:=andsy; rsy[14]:=notsy;
  2802. rsy[15]:=thensy; rsy[16]:=elsesy; rsy[17]:=withsy;
  2803. rsy[18]:=casesy; rsy[19]:=typesy; rsy[20]:=gotosy;
  2804. rsy[21]:=filesy; rsy[22]:=beginsy; rsy[23]:=untilsy;
  2805. rsy[24]:=whilesy; rsy[25]:=arraysy; rsy[26]:=constsy;
  2806. rsy[27]:=labelsy; rsy[28]:=repeatsy; rsy[29]:=recordsy;
  2807. rsy[30]:=downtosy; rsy[31]:=packedsy; rsy[32]:=progsy;
  2808. rsy[33]:=funcsy; rsy[34]:=procsy;
  2809. {indices into rw to find reserved words fast}
  2810. frw[0]:= 0; frw[1]:= 0; frw[2]:= 6; frw[3]:=15; frw[4]:=22;
  2811. frw[5]:=28; frw[6]:=32; frw[7]:=33; frw[8]:=35;
  2812. {char types}
  2813. for c:=chr(0) to chr(maxcharord) do cs[c]:=others;
  2814. for c:='0' to '9' do cs[c]:=digit;
  2815. for c:='A' to 'Z' do cs[c]:=upper;
  2816. for c:='a' to 'z' do cs[c]:=lower;
  2817. cs[chr(ascnl)]:=layout;
  2818. cs[chr(ascvt)]:=layout;
  2819. cs[chr(ascff)]:=layout;
  2820. cs[chr(asccr)]:=layout;
  2821. {characters with corresponding chartype in ASCII order}
  2822. cs[chr(ascht)]:=tabch;
  2823. cs[' ']:=layout; cs['"']:=dquotech; cs['''']:=quotech;
  2824. cs['(']:=lparentch; cs[')']:=rparentch; cs['*']:=star;
  2825. cs['+']:=plusch; cs[',']:=commach; cs['-']:=minch;
  2826. cs['.']:=periodch; cs['/']:=slash; cs[':']:=colonch;
  2827. cs[';']:=semich; cs['<']:=lessch; cs['=']:=equal;
  2828. cs['>']:=greaterch; cs['[']:=lbrackch; cs[']']:=rbrackch;
  2829. cs['^']:=arrowch; cs['{']:=lbracech;
  2830. {single character symbols in chartype order}
  2831. csy[rparentch]:=rparent; csy[lbrackch]:=lbrack;
  2832. csy[rbrackch]:=rbrack; csy[commach]:=comma;
  2833. csy[semich]:=semicolon; csy[arrowch]:=arrow;
  2834. csy[plusch]:=plussy; csy[minch]:=minsy;
  2835. csy[slash]:=slashsy; csy[star]:=starsy;
  2836. csy[equal]:=eqsy;
  2837. {pascal library mnemonics}
  2838. lmn[ELN ]:='_eln'; lmn[EFL ]:='_efl'; lmn[CLS ]:='_cls';
  2839. lmn[WDW ]:='_wdw';
  2840. lmn[OPN ]:='_opn'; lmn[GETX]:='_get'; lmn[RDI ]:='_rdi';
  2841. lmn[RDC ]:='_rdc'; lmn[RDR ]:='_rdr'; lmn[RDL ]:='_rdl';
  2842. lmn[RLN ]:='_rln';
  2843. lmn[CRE ]:='_cre'; lmn[PUTX]:='_put'; lmn[WRI ]:='_wri';
  2844. lmn[WSI ]:='_wsi'; lmn[WRC ]:='_wrc'; lmn[WSC ]:='_wsc';
  2845. lmn[WRS ]:='_wrs'; lmn[WSS ]:='_wss'; lmn[WRB ]:='_wrb';
  2846. lmn[WSB ]:='_wsb'; lmn[WRR ]:='_wrr'; lmn[WSR ]:='_wsr';
  2847. lmn[WRL ]:='_wrl'; lmn[WSL ]:='_wsl';
  2848. lmn[WRF ]:='_wrf'; lmn[WRZ ]:='_wrz'; lmn[WSZ ]:='_wsz';
  2849. lmn[WLN ]:='_wln'; lmn[PAG ]:='_pag';
  2850. lmn[ABR ]:='_abr'; lmn[RND ]:='_rnd'; lmn[SINX]:='_sin';
  2851. lmn[COSX]:='_cos'; lmn[EXPX]:='_exp'; lmn[SQT ]:='_sqt';
  2852. lmn[LOG ]:='_log'; lmn[ATN ]:='_atn'; lmn[ABI ]:='_abi';
  2853. lmn[ABL ]:='_abl';
  2854. lmn[BCP ]:='_bcp'; lmn[BTS ]:='_bts'; lmn[NEWX]:='_new';
  2855. lmn[SAV ]:='_sav'; lmn[RST ]:='_rst'; lmn[INI ]:='_ini';
  2856. lmn[HLT ]:='_hlt'; lmn[ASS ]:='_ass'; lmn[GTO ]:='_gto';
  2857. lmn[PAC ]:='_pac'; lmn[UNP ]:='_unp'; lmn[DIS ]:='_dis';
  2858. lmn[ASZ ]:='_asz'; lmn[MDI ]:='_mdi'; lmn[MDL ]:='_mdl';
  2859. {scalar variables}
  2860. b.nextbp:=nil;
  2861. b.reglb:=0;
  2862. b.minlb:=0;
  2863. b.ilbno:=0;
  2864. b.forwcount:=0;
  2865. b.lchain:=nil;
  2866. srcchno:=0;
  2867. srclino:=1;
  2868. srcorig:=1;
  2869. lino:=0;
  2870. dlbno:=0;
  2871. holeb:=0;
  2872. argc:=1;
  2873. lastpfno:=0;
  2874. giveline:=true;
  2875. including:=false;
  2876. eofexpected:=false;
  2877. intypedec:=false;
  2878. fltused:=false;
  2879. seconddot:=false;
  2880. iop[false]:=nil;
  2881. iop[true]:=nil;
  2882. argv[0].ad:=-1;
  2883. argv[1].ad:=-1;
  2884. end;
  2885. procedure init2;
  2886. var p:ip; k:idclass; j:standpf;
  2887. pfn:array[standpf] of idarr;
  2888. begin
  2889. {initialize the first name space}
  2890. new(top,blck); top^.occur:=blck; top^.nlink:=nil; top^.fname:=nil;
  2891. level:=0;
  2892. {undefined identifier pointers used by searchid}
  2893. for k:=types to func do
  2894. undefip[k]:=newip(k,spaces,nil,nil);
  2895. {names of standard procedures/functions}
  2896. pfn[pread ]:='read '; pfn[preadln ]:='readln ';
  2897. pfn[pwrite ]:='write '; pfn[pwriteln ]:='writeln ';
  2898. pfn[pput ]:='put '; pfn[pget ]:='get ';
  2899. pfn[ppage ]:='page '; pfn[preset ]:='reset ';
  2900. pfn[prewrite ]:='rewrite '; pfn[pnew ]:='new ';
  2901. pfn[pdispose ]:='dispose '; pfn[ppack ]:='pack ';
  2902. pfn[punpack ]:='unpack '; pfn[pmark ]:='mark ';
  2903. pfn[prelease ]:='release '; pfn[phalt ]:='halt ';
  2904. pfn[feof ]:='eof '; pfn[feoln ]:='eoln ';
  2905. pfn[fabs ]:='abs '; pfn[fsqr ]:='sqr ';
  2906. pfn[ford ]:='ord '; pfn[fchr ]:='chr ';
  2907. pfn[fpred ]:='pred '; pfn[fsucc ]:='succ ';
  2908. pfn[fodd ]:='odd '; pfn[ftrunc ]:='trunc ';
  2909. pfn[fround ]:='round '; pfn[fsin ]:='sin ';
  2910. pfn[fcos ]:='cos '; pfn[fexp ]:='exp ';
  2911. pfn[fsqt ]:='sqrt '; pfn[flog ]:='ln ';
  2912. pfn[fatn ]:='arctan ';
  2913. {standard procedure/function identifiers}
  2914. for j:=pread to phalt do
  2915. begin new(p,proc,standard); p^.klass:=proc;
  2916. p^.name:=pfn[j]; p^.pfkind:=standard; p^.key:=j; enterid(p);
  2917. end;
  2918. for j:=feof to fatn do
  2919. begin new(p,func,standard); p^.klass:=func; p^.idtype:=nil;
  2920. p^.name:=pfn[j]; p^.pfkind:=standard; p^.key:=j; enterid(p);
  2921. end;
  2922. {program identifier}
  2923. progp:=newip(proc,'m_a_i_n ',nil,nil);
  2924. end;
  2925. procedure init3;
  2926. var n:np; p,q:ip; i:integer; c:char;
  2927. is:packed array[1..imax] of char;
  2928. begin
  2929. for i:=0 to sz_last do readln(errors,sizes[i]);
  2930. if sz_int = 2 then maxintstring := max2bytes
  2931. else maxintstring := max4bytes;
  2932. if sz_long = 2 then maxlongstring := max2bytes
  2933. else maxlongstring := max4bytes;
  2934. gencst(ps_mes,ms_emx); argcst(sz_word); argcst(sz_addr); argend;
  2935. ix:=1;
  2936. while not eoln(errors) do
  2937. begin read(errors,c);
  2938. if ix<smax then begin strbuf[ix]:=c; ix:=ix+1 end
  2939. end;
  2940. readln(errors); strbuf[ix]:=chr(0);
  2941. for i:=1 to fnmax do
  2942. if i<ix then source[i]:=strbuf[i] else source[i]:=' ';
  2943. fildlb:=romstr(sp_scon,0);
  2944. {standard type pointers}
  2945. intptr :=newsp(scalar,sz_int);
  2946. realptr:=newsp(scalar,sz_real);
  2947. longptr:=newsp(scalar,sz_long);
  2948. charptr:=newsp(scalar,sz_char);
  2949. boolptr:=newsp(scalar,sz_bool);
  2950. nilptr :=newsp(pointer,sz_addr);
  2951. zeroptr:=newsp(pointer,sz_addr);
  2952. procptr:=newsp(records,sz_proc);
  2953. nullset:=newsp(power,sz_word); nullset^.elset:=nil;
  2954. textptr:=newsp(files,sz_head+sz_buff); textptr^.filtype:=charptr;
  2955. {standard type names}
  2956. enterid(newip(types,'integer ',intptr,nil));
  2957. enterid(newip(types,'real ',realptr,nil));
  2958. enterid(newip(types,'char ',charptr,nil));
  2959. enterid(newip(types,'boolean ',boolptr,nil));
  2960. enterid(newip(types,'text ',textptr,nil));
  2961. {standard constant names}
  2962. q:=nil; p:=newip(konst,'false ',boolptr,q); enterid(p);
  2963. q:=p; p:=newip(konst,'true ',boolptr,q); p^.value:=1; enterid(p);
  2964. boolptr^.fconst:=p;
  2965. {maxint of the target machine}
  2966. p:=newip(konst,'maxint ',intptr,nil);
  2967. if sz_int = 2 then p^.value:=MI2
  2968. else if szcompint = 4 then p^.value := MI
  2969. else {szcompint = 2, sz_int = 4}
  2970. begin p^.idtype:=longptr; ix:=imax; is:=max4bytes;
  2971. for i:=1 to ix do strbuf[i]:=is[i];
  2972. p^.value:=romstr(sp_icon,sz_int);
  2973. end;
  2974. enterid(p);
  2975. p:=newip(konst,spaces,charptr,nil); p^.value:=maxcharord;
  2976. charptr^.fconst:=p;
  2977. {new name space for user externals}
  2978. new(n,blck); n^.occur:=blck; n^.nlink:=top; n^.fname:=nil; top:=n;
  2979. {options}
  2980. for c:='a' to 'z' do begin opt[c]:=0; forceopt[c]:=false end;
  2981. opt['a']:=on;
  2982. opt['i']:=NB1*sz_iset;
  2983. opt['l']:=on;
  2984. opt['o']:=on;
  2985. opt['r']:=on;
  2986. sopt:=off;
  2987. end;
  2988. procedure init4;
  2989. begin
  2990. copt:=opt['c'];
  2991. dopt:=opt['d']; if szcompint < sz_int then dopt:=on;
  2992. iopt:=opt['i'];
  2993. sopt:=opt['s'];
  2994. if sopt<>off then begin copt:=off; dopt:=off end
  2995. else if opt['u']<>off then cs['_']:=lower;
  2996. if copt<>off then enterid(newip(types,'string ',zeroptr,nil));
  2997. if dopt<>off then enterid(newip(types,'long ',longptr,nil));
  2998. if opt['o']=off then begin gencst(ps_mes,ms_opt); argend end;
  2999. if dopt<>off then fltused:=true; {temporary kludge}
  3000. end;
  3001. begin {main body of pcompiler}
  3002. init1; {initialize tables and scalars}
  3003. init2; {initialize heap objects}
  3004. rewrite(em); put2(sp_magic); reset(errors);
  3005. init3; {size dependent initialization}
  3006. while not eof(errors) do
  3007. begin options(false); readln(errors) end;
  3008. rewrite(errors);
  3009. if not eof(input) then
  3010. begin nextch; insym;
  3011. init4; {option dependent initialization}
  3012. compile
  3013. end;
  3014. #ifdef STANDARD
  3015. 9999: ;
  3016. #endif
  3017. end. {pcompiler}