1
2
30
31 program pascalcompiler(input,output,prr);
32
33 const displimit = 20; maxlevel = 10;
34 intsize = 1;
35 intal = 1;
36 realsize = 1;
37 realal = 1;
38 charsize = 1;
39 charal = 1;
40 charmax = 1;
41 boolsize = 1;
42 boolal = 1;
43 ptrsize = 1;
44 adral = 1;
45 setsize = 1;
46 setal = 1;
47 stackal = 1;
48 stackelsize = 1;
49 strglgth = 16;
50 sethigh = 47;
51 setlow = 0;
52 ordmaxchar = 63;
53 ordminchar = 0;
54 maxint = 32767;
55 lcaftermarkstack = 5;
56 fileal = charal;
57
64 maxstack = 1;
65 parmal = stackal;
66 parmsize = stackelsize;
67 recal = stackal;
68 filebuffer = 4;
69 maxaddr = maxint;
70
71
72
73 type
74
75
76 marktype= ^integer;
77
78
79
80 symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
81 lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
82 colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy,
83 procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
84 beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
85 gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
86 thensy,othersy);
87 operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
88 neop,eqop,inop,noop);
89 setofsys = set of symbol;
90 chtp = (letter,number,special,illegal,
91 chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace);
92
93
94
95 setty = set of setlow..sethigh;
96 cstclass = (reel,pset,strg);
97 csp = ^ constant;
98 constant = record case cclass: cstclass of
99 reel: (rval: packed array [1..strglgth] of char);
100 pset: (pval: setty);
101 strg: (slgth: 0..strglgth;
102 sval: packed array [1..strglgth] of char)
103 end;
104
105 valu = record case intval: boolean of
106 true: (ival: integer);
107 false: (valp: csp)
108 end;
109
110
111
112 levrange = 0..maxlevel; addrrange = 0..maxaddr;
113 structform = (scalar,subrange,pointer,power,arrays,records,files,
114 tagfld,variant);
115 declkind = (standard,declared);
116 stp = ^ structure; ctp = ^ identifier;
117
118 structure = packed record
119 marked: boolean;
120 size: addrrange;
121 case form: structform of
122 scalar: (case scalkind: declkind of
123 declared: (fconst: ctp); standard: ());
124 subrange: (rangetype: stp; min,max: valu);
125 pointer: (eltype: stp);
126 power: (elset: stp);
127 arrays: (aeltype,inxtype: stp);
128 records: (fstfld: ctp; recvar: stp);
129 files: (filtype: stp);
130 tagfld: (tagfieldp: ctp; fstvar: stp);
131 variant: (nxtvar,subvar: stp; varval: valu)
132 end;
133
134
135
136
137 idclass = (types,konst,vars,field,proc,func);
138 setofids = set of idclass;
139 idkind = (actual,formal);
140 alpha = packed array [1..8] of char;
141
142 identifier = packed record
143 name: alpha; llink, rlink: ctp;
144 idtype: stp; next: ctp;
145 case klass: idclass of
146 types: ();
147 konst: (values: valu);
148 vars: (vkind: idkind; vlev: levrange; vaddr: addrrange);
149 field: (fldaddr: addrrange);
150 proc, func: (case pfdeckind: declkind of
151 standard: (key: 1..15);
152 declared: (pflev: levrange; pfname: integer;
153 case pfkind: idkind of
154 actual: (forwdecl, externl: boolean);
155 formal: ()))
156 end;
157
158
159 disprange = 0..displimit;
160 where = (blck,crec,vrec,rec);
161
162
163
164 attrkind = (cst,varbl,expr);
165 vaccess = (drct,indrct,inxd);
166
167 attr = record typtr: stp;
168 case kind: attrkind of
169 cst: (cval: valu);
170 varbl: (case access: vaccess of
171 drct: (vlevel: levrange; dplmt: addrrange);
172 indrct: (idplmt: addrrange))
173 end;
174
175 testp = ^ testpointer;
176 testpointer = packed record
177 elt1,elt2 : stp;
178 lasttestp : testp
179 end;
180
181
182
183 lbp = ^ labl;
184 labl = record nextlab: lbp; defined: boolean;
185 labval, labname: integer
186 end;
187
188 extfilep = ^filerec;
189 filerec = record filename:alpha; nextfile:extfilep end;
190
191
192
193 var
194 prr: text;
195
198
199 sy: symbol;
200 op: operator;
201 val: valu;
202 lgth: integer;
203 id: alpha;
204 kk: 1..8;
205 ch: char;
206 eol: boolean;
207
208
209
210
211
212 chcnt: integer;
213 lc,ic: addrrange;
214 linecount: integer;
215
216
217
218
219
220 dp,
221 prterr,
223 list,prcode,prtables: boolean;
228 debug: boolean;
229
230
231
232
233 parmptr,
234 intptr,realptr,charptr,
235 boolptr,nilptr,textptr: stp;
236 utypptr,ucstptr,uvarptr,
237 ufldptr,uprcptr,ufctptr,
238 fwptr: ctp;
239 fextfilep: extfilep;
240 globtestp: testp;
241
242
243
244
245
246 level: levrange;
247 disx,
248 top: disprange;
249
250 display:
251 array [disprange] of
252 packed record
253 fname: ctp; flabel: lbp;
254 case occur: where of
255 crec: (clev: levrange;
256 cdspl: addrrange);
257 vrec: (vdspl: addrrange)
258 end;
259
260
261
262
263
264 errinx: 0..10;
265 errlist:
266 array [1..10] of
267 packed record pos: integer;
268 nmr: 1..400
269 end;
270
271
272
273
274
275
276 gattr: attr;
277
278
279
280
281
282 constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
283 statbegsys,typedels: setofsys;
284 chartp : array[char] of chtp;
285 rw: array [1..35] of alpha;
286 frw: array [1..9] of 1..36;
287 rsy: array [1..35] of symbol;
288 ssy: array [char] of symbol;
289 rop: array [1..35] of operator;
290 sop: array [char] of operator;
291 na: array [1..35] of alpha;
292 mn: array [0..60] of packed array [1..4] of char;
293 sna: array [1..23] of packed array [1..4] of char;
294 cdx: array [0..60] of -4..+4;
295 pdx: array [1..23] of -7..+7;
296 ordint: array [char] of integer;
297
298 intlabel,mxint10,digmax: integer;
299
300 procedure mark(var p: marktype); begin end;
301 procedure release(p: marktype); begin end;
302
303 procedure endofline;
304 var lastpos,freepos,currpos,currnmr,f,k: integer;
305 begin
306 if errinx > 0 then
307 begin write(output,linecount:6,' **** ':9);
308 lastpos := 0; freepos := 1;
309 for k := 1 to errinx do
310 begin
311 with errlist[k] do
312 begin currpos := pos; currnmr := nmr end;
313 if currpos = lastpos then write(output,',')
314 else
315 begin
316 while freepos < currpos do
317 begin write(output,' '); freepos := freepos + 1 end;
318 write(output,'^');
319 lastpos := currpos
320 end;
321 if currnmr < 10 then f := 1
322 else if currnmr < 100 then f := 2
323 else f := 3;
324 write(output,currnmr:f);
325 freepos := freepos + f + 1
326 end;
327 writeln(output); errinx := 0
328 end;
329 linecount := linecount + 1;
330 if list and (not eof(input)) then
331 begin write(output,linecount:6,' ':2);
332 if dp then write(output,lc:7) else write(output,ic:7);
333 write(output,' ')
334 end;
335 chcnt := 0
336 end ;
337
338 procedure error(ferrnr: integer);
339 begin
340 if errinx >= 9 then
341 begin errlist[10].nmr := 255; errinx := 10 end
342 else
343 begin errinx := errinx + 1;
344 errlist[errinx].nmr := ferrnr
345 end;
346 errlist[errinx].pos := chcnt
347 end ;
348
349 procedure insymbol;
350
352 label 1,2,3;
353 var i,k: integer;
354 digit: packed array [1..strglgth] of char;
355 string: packed array [1..strglgth] of char;
356 lvp: csp; test: boolean;
357
358 procedure nextch;
359 begin if eol then
360 begin if list then writeln(output); endofline
361 end;
362 if not eof(input) then
363 begin eol := eoln(input); read(input,ch);
364 if list then write(output,ch);
365 chcnt := chcnt + 1
366 end
367 else
368 begin writeln(output,' *** eof ','encountered');
369 test := false
370 end
371 end;
372
373 procedure options;
374 begin
375 repeat nextch;
376 if ch <> '*' then
377 begin
378 if ch = 't' then
379 begin nextch; prtables := ch = '+' end
380 else
381 if ch = 'l' then
382 begin nextch; list := ch = '+';
383 if not list then writeln(output)
384 end
385 else
386 if ch = 'd' then
387 begin nextch; debug := ch = '+' end
388 else
389 if ch = 'c' then
390 begin nextch; prcode := ch = '+' end;
391 nextch
392 end
393 until ch <> ','
394 end ;
395
396 begin
397 1:
398 repeat while ((ch = ' ') or (ch = ' ' (*tab*))) and not eol do nextch;
399 test := eol;
400 if test then nextch
401 until not test;
402 if chartp[ch] = illegal then
403 begin sy := othersy; op := noop;
404 error(399); nextch
405 end
406 else
407 case chartp[ch] of
408 letter:
409 begin k := 0;
410 repeat
411 if k < 8 then
412 begin k := k + 1; id[k] := ch end ;
413 nextch
414 until chartp[ch] in [special,illegal,chstrquo,chcolon,
415 chperiod,chlt,chgt,chlparen,chspace];
416 if k >= kk then kk := k
417 else
418 repeat id[kk] := ' '; kk := kk - 1
419 until kk = k;
420 for i := frw[k] to frw[k+1] - 1 do
421 if rw[i] = id then
422 begin sy := rsy[i]; op := rop[i]; goto 2 end;
423 sy := ident; op := noop;
424 2: end;
425 number:
426 begin op := noop; i := 0;
427 repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
428 until chartp[ch] <> number;
429 if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then
430 begin
431 k := i;
432 if ch = '.' then
433 begin k := k+1; if k <= digmax then digit[k] := ch;
434 nextch;
435 if chartp[ch] <> number then error(201)
436 else
437 repeat k := k + 1;
438 if k <= digmax then digit[k] := ch; nextch
439 until chartp[ch] <> number
440 end;
441 if ch = 'e' then
442 begin k := k+1; if k <= digmax then digit[k] := ch;
443 nextch;
444 if (ch = '+') or (ch ='-') then
445 begin k := k+1; if k <= digmax then digit[k] := ch;
446 nextch
447 end;
448 if chartp[ch] <> number then error(201)
449 else
450 repeat k := k+1;
451 if k <= digmax then digit[k] := ch; nextch
452 until chartp[ch] <> number
453 end;
454 new(lvp,reel); sy:= realconst; lvp^.cclass := reel;
455 with lvp^ do
456 begin for i := 1 to strglgth do rval[i] := ' ';
457 if k <= digmax then
458 for i := 2 to k + 1 do rval[i] := digit[i-1]
459 else begin error(203); rval[2] := '0';
460 rval[3] := '.'; rval[4] := '0'
461 end
462 end;
463 val.valp := lvp
464 end
465 else
466 3: begin
467 if i > digmax then begin error(203); val.ival := 0 end
468 else
469 with val do
470 begin ival := 0;
471 for k := 1 to i do
472 begin
473 if ival <= mxint10 then
474 ival := ival*10+ordint[digit[k]]
475 else begin error(203); ival := 0 end
476 end;
477 sy := intconst
478 end
479 end
480 end;
481 chstrquo:
482 begin lgth := 0; sy := stringconst; op := noop;
483 repeat
484 repeat nextch; lgth := lgth + 1;
485 if lgth <= strglgth then string[lgth] := ch
486 until (eol) or (ch = '''');
487 if eol then error(202) else nextch
488 until ch <> '''';
489 lgth := lgth - 1;
490 if lgth = 0 then error(205) else
491 if lgth = 1 then val.ival := ord(string[1])
492 else
493 begin new(lvp,strg); lvp^.cclass:=strg;
494 if lgth > strglgth then
495 begin error(399); lgth := strglgth end;
496 with lvp^ do
497 begin slgth := lgth;
498 for i := 1 to lgth do sval[i] := string[i]
499 end;
500 val.valp := lvp
501 end
502 end;
503 chcolon:
504 begin op := noop; nextch;
505 if ch = '=' then
506 begin sy := becomes; nextch end
507 else sy := colon
508 end;
509 chperiod:
510 begin op := noop; nextch;
511 if ch = '.' then
512 begin sy := colon; nextch end
513 else sy := period
514 end;
515 chlt:
516 begin nextch; sy := relop;
517 if ch = '=' then
518 begin op := leop; nextch end
519 else
520 if ch = '>' then
521 begin op := neop; nextch end
522 else op := ltop
523 end;
524 chgt:
525 begin nextch; sy := relop;
526 if ch = '=' then
527 begin op := geop; nextch end
528 else op := gtop
529 end;
530 chlparen:
531 begin nextch;
532 if ch = '*' then
533 begin nextch;
534 if ch = '$' then options;
535 repeat
536 while (ch <> '*') and not eof(input) do nextch;
537 nextch
538 until (ch = ')') or eof(input);
539 nextch; goto 1
540 end;
541 sy := lparent; op := noop
542 end;
543 special:
544 begin sy := ssy[ch]; op := sop[ch];
545 nextch
546 end;
547 chspace: sy := othersy
548 end
549 end ;
550
551 procedure enterid(fcp: ctp);
552
555 var nam: alpha; lcp, lcp1: ctp; lleft: boolean;
556 begin nam := fcp^.name;
557 lcp := display[top].fname;
558 if lcp = nil then
559 display[top].fname := fcp
560 else
561 begin
562 repeat lcp1 := lcp;
563 if lcp^.name = nam then
564 begin error(101); lcp := lcp^.rlink; lleft := false end
565 else
566 if lcp^.name < nam then
567 begin lcp := lcp^.rlink; lleft := false end
568 else begin lcp := lcp^.llink; lleft := true end
569 until lcp = nil;
570 if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
571 end;
572 fcp^.llink := nil; fcp^.rlink := nil
573 end ;
574
575 procedure searchsection(fcp: ctp; var fcp1: ctp);
576
579 label 1;
580 begin
581 while fcp <> nil do
582 if fcp^.name = id then goto 1
583 else if fcp^.name < id then fcp := fcp^.rlink
584 else fcp := fcp^.llink;
585 1: fcp1 := fcp
586 end ;
587
588 procedure searchid(fidcls: setofids; var fcp: ctp);
589 label 1;
590 var lcp: ctp;
591 begin
592 for disx := top downto 0 do
593 begin lcp := display[disx].fname;
594 while lcp <> nil do
595 if lcp^.name = id then
596 if lcp^.klass in fidcls then goto 1
597 else
598 begin if prterr then error(103);
599 lcp := lcp^.rlink
600 end
601 else
602 if lcp^.name < id then
603 lcp := lcp^.rlink
604 else lcp := lcp^.llink
605 end;
606
609 if prterr then
610 begin error(104);
611
614 if types in fidcls then lcp := utypptr
615 else
616 if vars in fidcls then lcp := uvarptr
617 else
618 if field in fidcls then lcp := ufldptr
619 else
620 if konst in fidcls then lcp := ucstptr
621 else
622 if proc in fidcls then lcp := uprcptr
623 else lcp := ufctptr;
624 end;
625 1: fcp := lcp
626 end ;
627
628 procedure getbounds(fsp: stp; var fmin,fmax: integer);
629
630
631 begin
632 fmin := 0; fmax := 0;
633 if fsp <> nil then
634 with fsp^ do
635 if form = subrange then
636 begin fmin := min.ival; fmax := max.ival end
637 else
638 if fsp = charptr then
639 begin fmin := ordminchar; fmax := ordmaxchar
640 end
641 else
642 if fconst <> nil then
643 fmax := fconst^.values.ival
644 end ;
645
646 function alignquot(fsp: stp): integer;
647 begin
648 alignquot := 1;
649 if fsp <> nil then
650 with fsp^ do
651 case form of
652 scalar: if fsp=intptr then alignquot := intal
653 else if fsp=boolptr then alignquot := boolal
654 else if scalkind=declared then alignquot := intal
655 else if fsp=charptr then alignquot := charal
656 else if fsp=realptr then alignquot := realal
657 else alignquot := parmal;
658 subrange: alignquot := alignquot(rangetype);
659 pointer: alignquot := adral;
660 power: alignquot := setal;
661 files: alignquot := fileal;
662 arrays: alignquot := alignquot(aeltype);
663 records: alignquot := recal;
664 variant,tagfld: error(501)
665 end
666 end ;
667
668 procedure align(fsp: stp; var flc: addrrange);
669 var k,l: integer;
670 begin
671 k := alignquot(fsp);
672 l := flc-1;
673 flc := l + k - (k+l) mod k
674 end ;
675
676 procedure printtables(fb: boolean);
677
678 var i, lim: disprange;
679
680 procedure marker;
681
682 var i: integer;
683
684 procedure markctp(fp: ctp); forward;
685
686 procedure markstp(fp: stp);
687
688 begin
689 if fp <> nil then
690 with fp^ do
691 begin marked := true;
692 case form of
693 scalar: ;
694 subrange: markstp(rangetype);
695 pointer: ;
697 power: markstp(elset) ;
698 arrays: begin markstp(aeltype); markstp(inxtype) end;
699 records: begin markctp(fstfld); markstp(recvar) end;
700 files: markstp(filtype);
701 tagfld: markstp(fstvar);
702 variant: begin markstp(nxtvar); markstp(subvar) end
703 end
704 end
705 end ;
706
707 procedure markctp;
708 begin
709 if fp <> nil then
710 with fp^ do
711 begin markctp(llink); markctp(rlink);
712 markstp(idtype)
713 end
714 end ;
715
716 begin
717 for i := top downto lim do
718 markctp(display[i].fname)
719 end ;
720
721 procedure followctp(fp: ctp); forward;
722
723 procedure followstp(fp: stp);
724 begin
725 if fp <> nil then
726 with fp^ do
727 if marked then
728 begin marked := false; write(output,' ':4,ord(fp):6,size:10);
729 case form of
730 scalar: begin write(output,'scalar':10);
731 if scalkind = standard then
732 write(output,'standard':10)
733 else write(output,'declared':10,' ':4,ord(fconst):6);
734 writeln(output)
735 end;
736 subrange: begin
737 write(output,'subrange':10,' ':4,ord(rangetype):6);
738 if rangetype <> realptr then
739 write(output,min.ival,max.ival)
740 else
741 if (min.valp <> nil) and (max.valp <> nil) then
742 write(output,' ',min.valp^.rval:9,
743 ' ',max.valp^.rval:9);
744 writeln(output); followstp(rangetype);
745 end;
746 pointer: writeln(output,'pointer':10,' ':4,ord(eltype):6);
747 power: begin writeln(output,'set':10,' ':4,ord(elset):6);
748 followstp(elset)
749 end;
750 arrays: begin
751 writeln(output,'array':10,' ':4,ord(aeltype):6,' ':4,
752 ord(inxtype):6);
753 followstp(aeltype); followstp(inxtype)
754 end;
755 records: begin
756 writeln(output,'record':10,' ':4,ord(fstfld):6,' ':4,
757 ord(recvar):6); followctp(fstfld);
758 followstp(recvar)
759 end;
760 files: begin write(output,'file':10,' ':4,ord(filtype):6);
761 followstp(filtype)
762 end;
763 tagfld: begin writeln(output,'tagfld':10,' ':4,ord(tagfieldp):6,
764 ' ':4,ord(fstvar):6);
765 followstp(fstvar)
766 end;
767 variant: begin writeln(output,'variant':10,' ':4,ord(nxtvar):6,
768 ' ':4,ord(subvar):6,varval.ival);
769 followstp(nxtvar); followstp(subvar)
770 end
771 end
772 end
773 end ;
774
775 procedure followctp;
776 var i: integer;
777 begin
778 if fp <> nil then
779 with fp^ do
780 begin write(output,' ':4,ord(fp):6,' ',name:9,' ':4,ord(llink):6,
781 ' ':4,ord(rlink):6,' ':4,ord(idtype):6);
782 case klass of
783 types: write(output,'type':10);
784 konst: begin write(output,'constant':10,' ':4,ord(next):6);
785 if idtype <> nil then
786 if idtype = realptr then
787 begin
788 if values.valp <> nil then
789 write(output,' ',values.valp^.rval:9)
790 end
791 else
792 if idtype^.form = arrays then
793 begin
794 if values.valp <> nil then
795 begin write(output,' ');
796 with values.valp^ do
797 for i := 1 to slgth do
798 write(output,sval[i])
799 end
800 end
801 else write(output,values.ival)
802 end;
803 vars: begin write(output,'variable':10);
804 if vkind = actual then write(output,'actual':10)
805 else write(output,'formal':10);
806 write(output,' ':4,ord(next):6,vlev,' ':4,vaddr:6 );
807 end;
808 field: write(output,'field':10,' ':4,ord(next):6,' ':4,fldaddr:6);
809 proc,
810 func: begin
811 if klass = proc then write(output,'procedure':10)
812 else write(output,'function':10);
813 if pfdeckind = standard then
814 write(output,'standard':10, key:10)
815 else
816 begin write(output,'declared':10,' ':4,ord(next):6);
817 write(output,pflev,' ':4,pfname:6);
818 if pfkind = actual then
819 begin write(output,'actual':10);
820 if forwdecl then write(output,'forward':10)
821 else write(output,'notforward':10);
822 if externl then write(output,'extern':10)
823 else write(output,'not extern':10);
824 end
825 else write(output,'formal':10)
826 end
827 end
828 end ;
829 writeln(output);
830 followctp(llink); followctp(rlink);
831 followstp(idtype)
832 end
833 end ;
834
835 begin
836 writeln(output); writeln(output); writeln(output);
837 if fb then lim := 0
838 else begin lim := top; write(output,' local') end;
839 writeln(output,' tables '); writeln(output);
840 marker;
841 for i := top downto lim do
842 followctp(display[i].fname);
843 writeln(output);
844 if not eol then write(output,' ':chcnt+16)
845 end ;
846
847 procedure genlabel(var nxtlab: integer);
848 begin intlabel := intlabel + 1;
849 nxtlab := intlabel
850 end ;
851
852 procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
853 var lsy: symbol; test: boolean;
854
855 procedure skip(fsys: setofsys);
856
857 begin
858 if not eof(input) then
859 begin while not(sy in fsys) and (not eof(input)) do insymbol;
860 if not (sy in fsys) then insymbol
861 end
862 end ;
863
864 procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu);
865 var lsp: stp; lcp: ctp; sign: (none,pos,neg);
866 lvp: csp; i: 2..strglgth;
867 begin lsp := nil; fvalu.ival := 0;
868 if not(sy in constbegsys) then
869 begin error(50); skip(fsys+constbegsys) end;
870 if sy in constbegsys then
871 begin
872 if sy = stringconst then
873 begin
874 if lgth = 1 then lsp := charptr
875 else
876 begin
877 new(lsp,arrays);
878 with lsp^ do
879 begin aeltype := charptr; inxtype := nil;
880 size := lgth*charsize; form := arrays
881 end
882 end;
883 fvalu := val; insymbol
884 end
885 else
886 begin
887 sign := none;
888 if (sy = addop) and (op in [plus,minus]) then
889 begin if op = plus then sign := pos else sign := neg;
890 insymbol
891 end;
892 if sy = ident then
893 begin searchid([konst],lcp);
894 with lcp^ do
895 begin lsp := idtype; fvalu := values end;
896 if sign <> none then
897 if lsp = intptr then
898 begin if sign = neg then fvalu.ival := -fvalu.ival end
899 else
900 if lsp = realptr then
901 begin
902 if sign = neg then
903 begin new(lvp,reel);
904 if fvalu.valp^.rval[1] = '-' then
905 lvp^.rval[1] := '+'
906 else lvp^.rval[1] := '-';
907 for i := 2 to strglgth do
908 lvp^.rval[i] := fvalu.valp^.rval[i];
909 fvalu.valp := lvp;
910 end
911 end
912 else error(105);
913 insymbol;
914 end
915 else
916 if sy = intconst then
917 begin if sign = neg then val.ival := -val.ival;
918 lsp := intptr; fvalu := val; insymbol
919 end
920 else
921 if sy = realconst then
922 begin if sign = neg then val.valp^.rval[1] := '-';
923 lsp := realptr; fvalu := val; insymbol
924 end
925 else
926 begin error(106); skip(fsys) end
927 end;
928 if not (sy in fsys) then
929 begin error(6); skip(fsys) end
930 end;
931 fsp := lsp
932 end ;
933
934 function equalbounds(fsp1,fsp2: stp): boolean;
935 var lmin1,lmin2,lmax1,lmax2: integer;
936 begin
937 if (fsp1=nil) or (fsp2=nil) then equalbounds := true
938 else
939 begin
940 getbounds(fsp1,lmin1,lmax1);
941 getbounds(fsp2,lmin2,lmax2);
942 equalbounds := (lmin1=lmin2) and (lmax1=lmax2)
943 end
944 end ;
945
946 function comptypes(fsp1,fsp2: stp) : boolean;
947
948 var nxt1,nxt2: ctp; comp: boolean;
949 ltestp1,ltestp2 : testp;
950 begin
951 if fsp1 = fsp2 then comptypes := true
952 else
953 if (fsp1 <> nil) and (fsp2 <> nil) then
954 if fsp1^.form = fsp2^.form then
955 case fsp1^.form of
956 scalar:
957 comptypes := false;
958
960 subrange:
961 comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
962 pointer:
963 begin
964 comp := false; ltestp1 := globtestp;
965 ltestp2 := globtestp;
966 while ltestp1 <> nil do
967 with ltestp1^ do
968 begin
969 if (elt1 = fsp1^.eltype) and
970 (elt2 = fsp2^.eltype) then comp := true;
971 ltestp1 := lasttestp
972 end;
973 if not comp then
974 begin new(ltestp1);
975 with ltestp1^ do
976 begin elt1 := fsp1^.eltype;
977 elt2 := fsp2^.eltype;
978 lasttestp := globtestp
979 end;
980 globtestp := ltestp1;
981 comp := comptypes(fsp1^.eltype,fsp2^.eltype)
982 end;
983 comptypes := comp; globtestp := ltestp2
984 end;
985 power:
986 comptypes := comptypes(fsp1^.elset,fsp2^.elset);
987 arrays:
988 begin
989 comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
990 and comptypes(fsp1^.inxtype,fsp2^.inxtype);
991 comptypes := comp and (fsp1^.size = fsp2^.size) and
992 equalbounds(fsp1^.inxtype,fsp2^.inxtype)
993 end;
994 records:
995 begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
996 while (nxt1 <> nil) and (nxt2 <> nil) do
997 begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
998 nxt1 := nxt1^.next; nxt2 := nxt2^.next
999 end;
1000 comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
1001 and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
1002 end;
1003
1005 files:
1006 comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
1007 end
1008 else
1009 if fsp1^.form = subrange then
1010 comptypes := comptypes(fsp1^.rangetype,fsp2)
1011 else
1012 if fsp2^.form = subrange then
1013 comptypes := comptypes(fsp1,fsp2^.rangetype)
1014 else comptypes := false
1015 else comptypes := true
1016 end ;
1017
1018 function string(fsp: stp) : boolean;
1019 begin string := false;
1020 if fsp <> nil then
1021 if fsp^.form = arrays then
1022 if comptypes(fsp^.aeltype,charptr) then string := true
1023 end ;
1024
1025 procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange);
1026 var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
1027 lsize,displ: addrrange; lmin,lmax: integer;
1028
1029 procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange);
1030 var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
1031 lcnt: integer; lvalu: valu;
1032 begin fsize := 1;
1033 if not (sy in simptypebegsys) then
1034 begin error(1); skip(fsys + simptypebegsys) end;
1035 if sy in simptypebegsys then
1036 begin
1037 if sy = lparent then
1038 begin ttop := top;
1039 while display[top].occur <> blck do top := top - 1;
1040 new(lsp,scalar,declared);
1041 with lsp^ do
1042 begin size := intsize; form := scalar;
1043 scalkind := declared
1044 end;
1045 lcp1 := nil; lcnt := 0;
1046 repeat insymbol;
1047 if sy = ident then
1048 begin new(lcp,konst);
1049 with lcp^ do
1050 begin name := id; idtype := lsp; next := lcp1;
1051 values.ival := lcnt; klass := konst
1052 end;
1053 enterid(lcp);
1054 lcnt := lcnt + 1;
1055 lcp1 := lcp; insymbol
1056 end
1057 else error(2);
1058 if not (sy in fsys + [comma,rparent]) then
1059 begin error(6); skip(fsys + [comma,rparent]) end
1060 until sy <> comma;
1061 lsp^.fconst := lcp1; top := ttop;
1062 if sy = rparent then insymbol else error(4)
1063 end
1064 else
1065 begin
1066 if sy = ident then
1067 begin searchid([types,konst],lcp);
1068 insymbol;
1069 if lcp^.klass = konst then
1070 begin new(lsp,subrange);
1071 with lsp^, lcp^ do
1072 begin rangetype := idtype; form := subrange;
1073 if string(rangetype) then
1074 begin error(148); rangetype := nil end;
1075 min := values; size := intsize
1076 end;
1077 if sy = colon then insymbol else error(5);
1078 constant(fsys,lsp1,lvalu);
1079 lsp^.max := lvalu;
1080 if lsp^.rangetype <> lsp1 then error(107)
1081 end
1082 else
1083 begin lsp := lcp^.idtype;
1084 if lsp <> nil then fsize := lsp^.size
1085 end
1086 end
1087 else
1088 begin new(lsp,subrange); lsp^.form := subrange;
1089 constant(fsys + [colon],lsp1,lvalu);
1090 if string(lsp1) then
1091 begin error(148); lsp1 := nil end;
1092 with lsp^ do
1093 begin rangetype:=lsp1; min:=lvalu; size:=intsize end;
1094 if sy = colon then insymbol else error(5);
1095 constant(fsys,lsp1,lvalu);
1096 lsp^.max := lvalu;
1097 if lsp^.rangetype <> lsp1 then error(107)
1098 end;
1099 if lsp <> nil then
1100 with lsp^ do
1101 if form = subrange then
1102 if rangetype <> nil then
1103 if rangetype = realptr then error(399)
1104 else
1105 if min.ival > max.ival then error(102)
1106 end;
1107 fsp := lsp;
1108 if not (sy in fsys) then
1109 begin error(6); skip(fsys) end
1110 end
1111 else fsp := nil
1112 end ;
1113
1114 procedure fieldlist(fsys: setofsys; var frecvar: stp);
1115 var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
1116 minsize,maxsize,lsize: addrrange; lvalu: valu;
1117 begin nxt1 := nil; lsp := nil;
1118 if not (sy in (fsys+[ident,casesy])) then
1119 begin error(19); skip(fsys + [ident,casesy]) end;
1120 while sy = ident do
1121 begin nxt := nxt1;
1122 repeat
1123 if sy = ident then
1124 begin new(lcp,field);
1125 with lcp^ do
1126 begin name := id; idtype := nil; next := nxt;
1127 klass := field
1128 end;
1129 nxt := lcp;
1130 enterid(lcp);
1131 insymbol
1132 end
1133 else error(2);
1134 if not (sy in [comma,colon]) then
1135 begin error(6); skip(fsys + [comma,colon,semicolon,casesy])
1136 end;
1137 test := sy <> comma;
1138 if not test then insymbol
1139 until test;
1140 if sy = colon then insymbol else error(5);
1141 typ(fsys + [casesy,semicolon],lsp,lsize);
1142 while nxt <> nxt1 do
1143 with nxt^ do
1144 begin align(lsp,displ);
1145 idtype := lsp; fldaddr := displ;
1146 nxt := next; displ := displ + lsize
1147 end;
1148 nxt1 := lcp;
1149 while sy = semicolon do
1150 begin insymbol;
1151 if not (sy in fsys + [ident,casesy,semicolon]) then
1152 begin error(19); skip(fsys + [ident,casesy]) end
1153 end
1154 end ;
1155 nxt := nil;
1156 while nxt1 <> nil do
1157 with nxt1^ do
1158 begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;
1159 if sy = casesy then
1160 begin new(lsp,tagfld);
1161 with lsp^ do
1162 begin tagfieldp := nil; fstvar := nil; form:=tagfld end;
1163 frecvar := lsp;
1164 insymbol;
1165 if sy = ident then
1166 begin new(lcp,field);
1167 with lcp^ do
1168 begin name := id; idtype := nil; klass:=field;
1169 next := nil; fldaddr := displ
1170 end;
1171 enterid(lcp);
1172 insymbol;
1173 if sy = colon then insymbol else error(5);
1174 if sy = ident then
1175 begin searchid([types],lcp1);
1176 lsp1 := lcp1^.idtype;
1177 if lsp1 <> nil then
1178 begin align(lsp1,displ);
1179 lcp^.fldaddr := displ;
1180 displ := displ+lsp1^.size;
1181 if (lsp1^.form <= subrange) or string(lsp1) then
1182 begin if comptypes(realptr,lsp1) then error(109)
1183 else if string(lsp1) then error(399);
1184 lcp^.idtype := lsp1; lsp^.tagfieldp := lcp;
1185 end
1186 else error(110);
1187 end;
1188 insymbol;
1189 end
1190 else begin error(2); skip(fsys + [ofsy,lparent]) end
1191 end
1192 else begin error(2); skip(fsys + [ofsy,lparent]) end;
1193 lsp^.size := displ;
1194 if sy = ofsy then insymbol else error(8);
1195 lsp1 := nil; minsize := displ; maxsize := displ;
1196 repeat lsp2 := nil;
1197 if not (sy in fsys + [semicolon]) then
1198 begin
1199 repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu);
1200 if lsp^.tagfieldp <> nil then
1201 if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111);
1202 new(lsp3,variant);
1203 with lsp3^ do
1204 begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
1205 form := variant
1206 end;
1207 lsp4 := lsp1;
1208 while lsp4 <> nil do
1209 with lsp4^ do
1210 begin
1211 if varval.ival = lvalu.ival then error(178);
1212 lsp4 := nxtvar
1213 end;
1214 lsp1 := lsp3; lsp2 := lsp3;
1215 test := sy <> comma;
1216 if not test then insymbol
1217 until test;
1218 if sy = colon then insymbol else error(5);
1219 if sy = lparent then insymbol else error(9);
1220 fieldlist(fsys + [rparent,semicolon],lsp2);
1221 if displ > maxsize then maxsize := displ;
1222 while lsp3 <> nil do
1223 begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2;
1224 lsp3^.size := displ;
1225 lsp3 := lsp4
1226 end;
1227 if sy = rparent then
1228 begin insymbol;
1229 if not (sy in fsys + [semicolon]) then
1230 begin error(6); skip(fsys + [semicolon]) end
1231 end
1232 else error(4);
1233 end;
1234 test := sy <> semicolon;
1235 if not test then
1236 begin displ := minsize;
1237 insymbol
1238 end
1239 until test;
1240 displ := maxsize;
1241 lsp^.fstvar := lsp1;
1242 end
1243 else frecvar := nil
1244 end ;
1245
1246 begin
1247 if not (sy in typebegsys) then
1248 begin error(10); skip(fsys + typebegsys) end;
1249 if sy in typebegsys then
1250 begin
1251 if sy in simptypebegsys then simpletype(fsys,fsp,fsize)
1252 else
1253 if sy = arrow then
1254 begin new(lsp,pointer); fsp := lsp;
1255 with lsp^ do
1256 begin eltype := nil; size := ptrsize; form:=pointer end;
1257 insymbol;
1258 if sy = ident then
1259 begin prterr := false;
1260 searchid([types],lcp); prterr := true;
1261 if lcp = nil then
1262 begin new(lcp,types);
1263 with lcp^ do
1264 begin name := id; idtype := lsp;
1265 next := fwptr; klass := types
1266 end;
1267 fwptr := lcp
1268 end
1269 else
1270 begin
1271 if lcp^.idtype <> nil then
1272 if lcp^.idtype^.form = files then error(108)
1273 else lsp^.eltype := lcp^.idtype
1274 end;
1275 insymbol;
1276 end
1277 else error(2);
1278 end
1279 else
1280 begin
1281 if sy = packedsy then
1282 begin insymbol;
1283 if not (sy in typedels) then
1284 begin
1285 error(10); skip(fsys + typedels)
1286 end
1287 end;
1288 if sy = arraysy then
1289 begin insymbol;
1290 if sy = lbrack then insymbol else error(11);
1291 lsp1 := nil;
1292 repeat new(lsp,arrays);
1293 with lsp^ do
1294 begin aeltype := lsp1; inxtype := nil; form:=arrays end;
1295 lsp1 := lsp;
1296 simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize);
1297 lsp1^.size := lsize;
1298 if lsp2 <> nil then
1299 if lsp2^.form <= subrange then
1300 begin
1301 if lsp2 = realptr then
1302 begin error(109); lsp2 := nil end
1303 else
1304 if lsp2 = intptr then
1305 begin error(149); lsp2 := nil end;
1306 lsp^.inxtype := lsp2
1307 end
1308 else begin error(113); lsp2 := nil end;
1309 test := sy <> comma;
1310 if not test then insymbol
1311 until test;
1312 if sy = rbrack then insymbol else error(12);
1313 if sy = ofsy then insymbol else error(8);
1314 typ(fsys,lsp,lsize);
1315 repeat
1316 with lsp1^ do
1317 begin lsp2 := aeltype; aeltype := lsp;
1318 if inxtype <> nil then
1319 begin getbounds(inxtype,lmin,lmax);
1320 align(lsp,lsize);
1321 lsize := lsize*(lmax - lmin + 1);
1322 size := lsize
1323 end
1324 end;
1325 lsp := lsp1; lsp1 := lsp2
1326 until lsp1 = nil
1327 end
1328 else
1329 if sy = recordsy then
1330 begin insymbol;
1331 oldtop := top;
1332 if top < displimit then
1333 begin top := top + 1;
1334 with display[top] do
1335 begin fname := nil;
1336 flabel := nil;
1337 occur := rec
1338 end
1339 end
1340 else error(250);
1341 displ := 0;
1342 fieldlist(fsys-[semicolon]+[endsy],lsp1);
1343 new(lsp,records);
1344 with lsp^ do
1345 begin fstfld := display[top].fname;
1346 recvar := lsp1; size := displ; form := records
1347 end;
1348 top := oldtop;
1349 if sy = endsy then insymbol else error(13)
1350 end
1351 else
1352 if sy = setsy then
1353 begin insymbol;
1354 if sy = ofsy then insymbol else error(8);
1355 simpletype(fsys,lsp1,lsize);
1356 if lsp1 <> nil then
1357 if lsp1^.form > subrange then
1358 begin error(115); lsp1 := nil end
1359 else
1360 if lsp1 = realptr then
1361 begin error(114); lsp1 := nil end
1362 else if lsp1 = intptr then
1363 begin error(169); lsp1 := nil end
1364 else
1365 begin getbounds(lsp1,lmin,lmax);
1366 if (lmin < setlow) or (lmax > sethigh)
1367 then error(169);
1368 end;
1369 new(lsp,power);
1370 with lsp^ do
1371 begin elset:=lsp1; size:=setsize; form:=power end;
1372 end
1373 else
1374 if sy = filesy then
1375 begin insymbol;
1376 error(399); skip(fsys); lsp := nil
1377 end;
1378 fsp := lsp
1379 end;
1380 if not (sy in fsys) then
1381 begin error(6); skip(fsys) end
1382 end
1383 else fsp := nil;
1384 if fsp = nil then fsize := 1 else fsize := fsp^.size
1385 end ;
1386
1387 procedure labeldeclaration;
1388 var llp: lbp; redef: boolean; lbname: integer;
1389 begin
1390 repeat
1391 if sy = intconst then
1392 with display[top] do
1393 begin llp := flabel; redef := false;
1394 while (llp <> nil) and not redef do
1395 if llp^.labval <> val.ival then
1396 llp := llp^.nextlab
1397 else begin redef := true; error(166) end;
1398 if not redef then
1399 begin new(llp);
1400 with llp^ do
1401 begin labval := val.ival; genlabel(lbname);
1402 defined := false; nextlab := flabel; labname := lbname
1403 end;
1404 flabel := llp
1405 end;
1406 insymbol
1407 end
1408 else error(15);
1409 if not ( sy in fsys + [comma, semicolon] ) then
1410 begin error(6); skip(fsys+[comma,semicolon]) end;
1411 test := sy <> comma;
1412 if not test then insymbol
1413 until test;
1414 if sy = semicolon then insymbol else error(14)
1415 end ;
1416
1417 procedure constdeclaration;
1418 var lcp: ctp; lsp: stp; lvalu: valu;
1419 begin
1420 if sy <> ident then
1421 begin error(2); skip(fsys + [ident]) end;
1422 while sy = ident do
1423 begin new(lcp,konst);
1424 with lcp^ do
1425 begin name := id; idtype := nil; next := nil; klass:=konst end;
1426 insymbol;
1427 if (sy = relop) and (op = eqop) then insymbol else error(16);
1428 constant(fsys + [semicolon],lsp,lvalu);
1429 enterid(lcp);
1430 lcp^.idtype := lsp; lcp^.values := lvalu;
1431 if sy = semicolon then
1432 begin insymbol;
1433 if not (sy in fsys + [ident]) then
1434 begin error(6); skip(fsys + [ident]) end
1435 end
1436 else error(14)
1437 end
1438 end ;
1439
1440 procedure typedeclaration;
1441 var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
1442 begin
1443 if sy <> ident then
1444 begin error(2); skip(fsys + [ident]) end;
1445 while sy = ident do
1446 begin new(lcp,types);
1447 with lcp^ do
1448 begin name := id; idtype := nil; klass := types end;
1449 insymbol;
1450 if (sy = relop) and (op = eqop) then insymbol else error(16);
1451 typ(fsys + [semicolon],lsp,lsize);
1452 enterid(lcp);
1453 lcp^.idtype := lsp;
1454
1455 lcp1 := fwptr;
1456 while lcp1 <> nil do
1457 begin
1458 if lcp1^.name = lcp^.name then
1459 begin lcp1^.idtype^.eltype := lcp^.idtype;
1460 if lcp1 <> fwptr then
1461 lcp2^.next := lcp1^.next
1462 else fwptr := lcp1^.next;
1463 end
1464 else lcp2 := lcp1;
1465 lcp1 := lcp1^.next
1466 end;
1467 if sy = semicolon then
1468 begin insymbol;
1469 if not (sy in fsys + [ident]) then
1470 begin error(6); skip(fsys + [ident]) end
1471 end
1472 else error(14)
1473 end;
1474 if fwptr <> nil then
1475 begin error(117); writeln(output);
1476 repeat writeln(output,' type-id ',fwptr^.name);
1477 fwptr := fwptr^.next
1478 until fwptr = nil;
1479 if not eol then write(output,' ': chcnt+16)
1480 end
1481 end ;
1482
1483 procedure vardeclaration;
1484 var lcp,nxt: ctp; lsp: stp; lsize: addrrange;
1485 begin nxt := nil;
1486 repeat
1487 repeat
1488 if sy = ident then
1489 begin new(lcp,vars);
1490 with lcp^ do
1491 begin name := id; next := nxt; klass := vars;
1492 idtype := nil; vkind := actual; vlev := level
1493 end;
1494 enterid(lcp);
1495 nxt := lcp;
1496 insymbol;
1497 end
1498 else error(2);
1499 if not (sy in fsys + [comma,colon] + typedels) then
1500 begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end;
1501 test := sy <> comma;
1502 if not test then insymbol
1503 until test;
1504 if sy = colon then insymbol else error(5);
1505 typ(fsys + [semicolon] + typedels,lsp,lsize);
1506 while nxt <> nil do
1507 with nxt^ do
1508 begin align(lsp,lc);
1509 idtype := lsp; vaddr := lc;
1510 lc := lc + lsize; nxt := next
1511 end;
1512 if sy = semicolon then
1513 begin insymbol;
1514 if not (sy in fsys + [ident]) then
1515 begin error(6); skip(fsys + [ident]) end
1516 end
1517 else error(14)
1518 until (sy <> ident) and not (sy in typedels);
1519 if fwptr <> nil then
1520 begin error(117); writeln(output);
1521 repeat writeln(output,' type-id ',fwptr^.name);
1522 fwptr := fwptr^.next
1523 until fwptr = nil;
1524 if not eol then write(output,' ': chcnt+16)
1525 end
1526 end ;
1527
1528 procedure procdeclaration(fsy: symbol);
1529 var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
1530 forw: boolean; oldtop: disprange;
1531 llc,lcm: addrrange; lbname: integer; markp: marktype;
1532
1533 procedure parameterlist(fsy: setofsys; var fpar: ctp);
1534 var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind;
1535 llc,lsize: addrrange; count: integer;
1536 begin lcp1 := nil;
1537 if not (sy in fsy + [lparent]) then
1538 begin error(7); skip(fsys + fsy + [lparent]) end;
1539 if sy = lparent then
1540 begin if forw then error(119);
1541 insymbol;
1542 if not (sy in [ident,varsy,procsy,funcsy]) then
1543 begin error(7); skip(fsys + [ident,rparent]) end;
1544 while sy in [ident,varsy,procsy,funcsy] do
1545 begin
1546 if sy = procsy then
1547 begin error(399);
1548 repeat insymbol;
1549 if sy = ident then
1550 begin new(lcp,proc,declared,formal);
1551 with lcp^ do
1552 begin name := id; idtype := nil; next := lcp1;
1553 pflev := level ;
1554 klass:=proc;pfdeckind:=declared;pfkind:=formal
1555 end;
1556 enterid(lcp);
1557 lcp1 := lcp;
1558 align(parmptr,lc);
1559
1560 insymbol
1561 end
1562 else error(2);
1563 if not (sy in fsys + [comma,semicolon,rparent]) then
1564 begin error(7);skip(fsys+[comma,semicolon,rparent])end
1565 until sy <> comma
1566 end
1567 else
1568 begin
1569 if sy = funcsy then
1570 begin error(399); lcp2 := nil;
1571 repeat insymbol;
1572 if sy = ident then
1573 begin new(lcp,func,declared,formal);
1574 with lcp^ do
1575 begin name := id; idtype := nil; next := lcp2;
1576 pflev := level ;
1577 klass:=func;pfdeckind:=declared;
1578 pfkind:=formal
1579 end;
1580 enterid(lcp);
1581 lcp2 := lcp;
1582 align(parmptr,lc);
1583
1584 insymbol;
1585 end;
1586 if not (sy in [comma,colon] + fsys) then
1587 begin error(7);skip(fsys+[comma,semicolon,rparent])
1588 end
1589 until sy <> comma;
1590 if sy = colon then
1591 begin insymbol;
1592 if sy = ident then
1593 begin searchid([types],lcp);
1594 lsp := lcp^.idtype;
1595 if lsp <> nil then
1596 if not(lsp^.form in[scalar,subrange,pointer])
1597 then begin error(120); lsp := nil end;
1598 lcp3 := lcp2;
1599 while lcp2 <> nil do
1600 begin lcp2^.idtype := lsp; lcp := lcp2;
1601 lcp2 := lcp2^.next
1602 end;
1603 lcp^.next := lcp1; lcp1 := lcp3;
1604 insymbol
1605 end
1606 else error(2);
1607 if not (sy in fsys + [semicolon,rparent]) then
1608 begin error(7);skip(fsys+[semicolon,rparent])end
1609 end
1610 else error(5)
1611 end
1612 else
1613 begin
1614 if sy = varsy then
1615 begin lkind := formal; insymbol end
1616 else lkind := actual;
1617 lcp2 := nil;
1618 count := 0;
1619 repeat
1620 if sy = ident then
1621 begin new(lcp,vars);
1622 with lcp^ do
1623 begin name:=id; idtype:=nil; klass:=vars;
1624 vkind := lkind; next := lcp2; vlev := level;
1625 end;
1626 enterid(lcp);
1627 lcp2 := lcp; count := count+1;
1628 insymbol;
1629 end;
1630 if not (sy in [comma,colon] + fsys) then
1631 begin error(7);skip(fsys+[comma,semicolon,rparent])
1632 end;
1633 test := sy <> comma;
1634 if not test then insymbol
1635 until test;
1636 if sy = colon then
1637 begin insymbol;
1638 if sy = ident then
1639 begin searchid([types],lcp);
1640 lsp := lcp^.idtype;
1641 lsize := ptrsize;
1642 if lsp <> nil then
1643 if lkind=actual then
1644 if lsp^.form<=power then lsize := lsp^.size
1645 else if lsp^.form=files then error(121);
1646 align(parmptr,lsize);
1647 lcp3 := lcp2;
1648 align(parmptr,lc);
1649 lc := lc+count*lsize;
1650 llc := lc;
1651 while lcp2 <> nil do
1652 begin lcp := lcp2;
1653 with lcp2^ do
1654 begin idtype := lsp;
1655 llc := llc-lsize;
1656 vaddr := llc;
1657 end;
1658 lcp2 := lcp2^.next
1659 end;
1660 lcp^.next := lcp1; lcp1 := lcp3;
1661 insymbol
1662 end
1663 else error(2);
1664 if not (sy in fsys + [semicolon,rparent]) then
1665 begin error(7);skip(fsys+[semicolon,rparent])end
1666 end
1667 else error(5);
1668 end;
1669 end;
1670 if sy = semicolon then
1671 begin insymbol;
1672 if not (sy in fsys + [ident,varsy,procsy,funcsy]) then
1673 begin error(7); skip(fsys + [ident,rparent]) end
1674 end
1675 end ;
1676 if sy = rparent then
1677 begin insymbol;
1678 if not (sy in fsy + fsys) then
1679 begin error(6); skip(fsy + fsys) end
1680 end
1681 else error(4);
1682 lcp3 := nil;
1683
1685 while lcp1 <> nil do
1686 with lcp1^ do
1687 begin lcp2 := next; next := lcp3;
1688 if klass = vars then
1689 if idtype <> nil then
1690 if (vkind=actual)and(idtype^.form>power) then
1691 begin align(idtype,lc);
1692 vaddr := lc;
1693 lc := lc+idtype^.size;
1694 end;
1695 lcp3 := lcp1; lcp1 := lcp2
1696 end;
1697 fpar := lcp3
1698 end
1699 else fpar := nil
1700 end ;
1701
1702 begin
1703 llc := lc; lc := lcaftermarkstack; forw := false;
1704 if sy = ident then
1705 begin searchsection(display[top].fname,lcp);
1706 if lcp <> nil then
1707 begin
1708 if lcp^.klass = proc then
1709 forw := lcp^.forwdecl and(fsy=procsy)and(lcp^.pfkind=actual)
1710 else
1711 if lcp^.klass = func then
1712 forw:=lcp^.forwdecl and(fsy=funcsy)and(lcp^.pfkind=actual)
1713 else forw := false;
1714 if not forw then error(160)
1715 end;
1716 if not forw then
1717 begin
1718 if fsy = procsy then new(lcp,proc,declared,actual)
1719 else new(lcp,func,declared,actual);
1720 with lcp^ do
1721 begin name := id; idtype := nil;
1722 externl := false; pflev := level; genlabel(lbname);
1723 pfdeckind := declared; pfkind := actual; pfname := lbname;
1724 if fsy = procsy then klass := proc
1725 else klass := func
1726 end;
1727 enterid(lcp)
1728 end
1729 else
1730 begin lcp1 := lcp^.next;
1731 while lcp1 <> nil do
1732 begin
1733 with lcp1^ do
1734 if klass = vars then
1735 if idtype <> nil then
1736 begin lcm := vaddr + idtype^.size;
1737 if lcm > lc then lc := lcm
1738 end;
1739 lcp1 := lcp1^.next
1740 end
1741 end;
1742 insymbol
1743 end
1744 else
1745 begin error(2); lcp := ufctptr end;
1746 oldlev := level; oldtop := top;
1747 if level < maxlevel then level := level + 1 else error(251);
1748 if top < displimit then
1749 begin top := top + 1;
1750 with display[top] do
1751 begin
1752 if forw then fname := lcp^.next
1753 else fname := nil;
1754 flabel := nil;
1755 occur := blck
1756 end
1757 end
1758 else error(250);
1759 if fsy = procsy then
1760 begin parameterlist([semicolon],lcp1);
1761 if not forw then lcp^.next := lcp1
1762 end
1763 else
1764 begin parameterlist([semicolon,colon],lcp1);
1765 if not forw then lcp^.next := lcp1;
1766 if sy = colon then
1767 begin insymbol;
1768 if sy = ident then
1769 begin if forw then error(122);
1770 searchid([types],lcp1);
1771 lsp := lcp1^.idtype;
1772 lcp^.idtype := lsp;
1773 if lsp <> nil then
1774 if not (lsp^.form in [scalar,subrange,pointer]) then
1775 begin error(120); lcp^.idtype := nil end;
1776 insymbol
1777 end
1778 else begin error(2); skip(fsys + [semicolon]) end
1779 end
1780 else
1781 if not forw then error(123)
1782 end;
1783 if sy = semicolon then insymbol else error(14);
1784 if sy = forwardsy then
1785 begin
1786 if forw then error(161)
1787 else lcp^.forwdecl := true;
1788 insymbol;
1789 if sy = semicolon then insymbol else error(14);
1790 if not (sy in fsys) then
1791 begin error(6); skip(fsys) end
1792 end
1793 else
1794 begin lcp^.forwdecl := false; mark(markp);
1795 repeat block(fsys,semicolon,lcp);
1796 if sy = semicolon then
1797 begin if prtables then printtables(false); insymbol;
1798 if not (sy in [beginsy,procsy,funcsy]) then
1799 begin error(6); skip(fsys) end
1800 end
1801 else error(14)
1802 until (sy in [beginsy,procsy,funcsy]) or eof(input);
1803 release(markp);
1804 end;
1805 level := oldlev; top := oldtop; lc := llc;
1806 end ;
1807
1808 procedure body(fsys: setofsys);
1809 const cstoccmax=65; cixmax=1000;
1810 type oprange = 0..63;
1811 var
1812 llcp:ctp; saveid:alpha;
1813 cstptr: array [1..cstoccmax] of csp;
1814 cstptrix: 0..cstoccmax;
1815
1819 entname, segsize: integer;
1820 stacktop, topnew, topmax: integer;
1821 lcmax,llc1: addrrange; lcp: ctp;
1822 llp: lbp;
1823
1824
1825 procedure mes(i: integer);
1826 begin topnew := topnew + cdx[i]*maxstack;
1827 if topnew > topmax then topmax := topnew
1828 end;
1829
1830 procedure putic;
1831 begin if ic mod 10 = 0 then writeln(prr,'i',ic:5) end;
1832
1833 procedure gen0(fop: oprange);
1834 begin
1835 if prcode then begin putic; writeln(prr,mn[fop]:4) end;
1836 ic := ic + 1; mes(fop)
1837 end ;
1838
1839 procedure gen1(fop: oprange; fp2: integer);
1840 var k: integer;
1841 begin
1842 if prcode then
1843 begin putic; write(prr,mn[fop]:4);
1844 if fop = 30 then
1845 begin writeln(prr,sna[fp2]:12);
1846 topnew := topnew + pdx[fp2]*maxstack;
1847 if topnew > topmax then topmax := topnew
1848 end
1849 else
1850 begin
1851 if fop = 38 then
1852 begin write(prr,'''');
1853 with cstptr[fp2]^ do
1854 begin
1855 for k := 1 to slgth do write(prr,sval[k]:1);
1856 for k := slgth+1 to strglgth do write(prr,' ');
1857 end;
1858 writeln(prr,'''')
1859 end
1860 else if fop = 42 then writeln(prr,chr(fp2))
1861 else writeln(prr,fp2:12);
1862 mes(fop)
1863 end
1864 end;
1865 ic := ic + 1
1866 end ;
1867
1868 procedure gen2(fop: oprange; fp1,fp2: integer);
1869 var k : integer;
1870 begin
1871 if prcode then
1872 begin putic; write(prr,mn[fop]:4);
1873 case fop of
1874 45,50,54,56:
1875 writeln(prr,' ',fp1:3,fp2:8);
1876 47,48,49,52,53,55:
1877 begin write(prr,chr(fp1));
1878 if chr(fp1) = 'm' then write(prr,fp2:11);
1879 writeln(prr)
1880 end;
1881 51:
1882 case fp1 of
1883 1: writeln(prr,'i ',fp2);
1884 2: begin write(prr,'r ');
1885 with cstptr[fp2]^ do
1886 for k := 1 to strglgth do write(prr,rval[k]);
1887 writeln(prr)
1888 end;
1889 3: writeln(prr,'b ',fp2);
1890 4: writeln(prr,'n');
1891 6: writeln(prr,'c ''':3,chr(fp2),'''');
1892 5: begin write(prr,'(');
1893 with cstptr[fp2]^ do
1894 for k := setlow to sethigh do
1895 if k in pval then write(prr,k:3);
1896 writeln(prr,')')
1897 end
1898 end
1899 end;
1900 end;
1901 ic := ic + 1; mes(fop)
1902 end ;
1903
1904 procedure gentypindicator(fsp: stp);
1905 begin
1906 if fsp<>nil then
1907 with fsp^ do
1908 case form of
1909 scalar: if fsp=intptr then write(prr,'i')
1910 else
1911 if fsp=boolptr then write(prr,'b')
1912 else
1913 if fsp=charptr then write(prr,'c')
1914 else
1915 if scalkind = declared then write(prr,'i')
1916 else write(prr,'r');
1917 subrange: gentypindicator(rangetype);
1918 pointer: write(prr,'a');
1919 power: write(prr,'s');
1920 records,arrays: write(prr,'m');
1921 files,tagfld,variant: error(500)
1922 end
1923 end ;
1924
1925 procedure gen0t(fop: oprange; fsp: stp);
1926 begin
1927 if prcode then
1928 begin putic;
1929 write(prr,mn[fop]:4);
1930 gentypindicator(fsp);
1931 writeln(prr);
1932 end;
1933 ic := ic + 1; mes(fop)
1934 end ;
1935
1936 procedure gen1t(fop: oprange; fp2: integer; fsp: stp);
1937 begin
1938 if prcode then
1939 begin putic;
1940 write(prr,mn[fop]:4);
1941 gentypindicator(fsp);
1942 writeln(prr,fp2:11)
1943 end;
1944 ic := ic + 1; mes(fop)
1945 end ;
1946
1947 procedure gen2t(fop: oprange; fp1,fp2: integer; fsp: stp);
1948 begin
1949 if prcode then
1950 begin putic;
1951 write(prr,mn[fop]: 4);
1952 gentypindicator(fsp);
1953 writeln(prr,fp1:3+5*ord(abs(fp1)>99),fp2:8);
1954 end;
1955 ic := ic + 1; mes(fop)
1956 end ;
1957
1958 procedure load;
1959 begin
1960 with gattr do
1961 if typtr <> nil then
1962 begin
1963 case kind of
1964 cst: if (typtr^.form = scalar) and (typtr <> realptr) then
1965 if typtr = boolptr then gen2(51,3,cval.ival)
1966 else
1967 if typtr=charptr then
1968 gen2(51,6,cval.ival)
1969 else gen2(51,1,cval.ival)
1970 else
1971 if typtr = nilptr then gen2(51,4,0)
1972 else
1973 if cstptrix >= cstoccmax then error(254)
1974 else
1975 begin cstptrix := cstptrix + 1;
1976 cstptr[cstptrix] := cval.valp;
1977 if typtr = realptr then
1978 gen2(51,2,cstptrix)
1979 else
1980 gen2(51,5,cstptrix)
1981 end;
1982 varbl: case access of
1983 drct: if vlevel<=1 then
1984 gen1t(39,dplmt,typtr)
1985 else gen2t(54,level-vlevel,dplmt,typtr);
1986 indrct: gen1t(35,idplmt,typtr);
1987 inxd: error(400)
1988 end;
1989 expr:
1990 end;
1991 kind := expr
1992 end
1993 end ;
1994
1995 procedure store(var fattr: attr);
1996 begin
1997 with fattr do
1998 if typtr <> nil then
1999 case access of
2000 drct: if vlevel <= 1 then gen1t(43,dplmt,typtr)
2001 else gen2t(56,level-vlevel,dplmt,typtr);
2002 indrct: if idplmt <> 0 then error(400)
2003 else gen0t(26,typtr);
2004 inxd: error(400)
2005 end
2006 end ;
2007
2008 procedure loadaddress;
2009 begin
2010 with gattr do
2011 if typtr <> nil then
2012 begin
2013 case kind of
2014 cst: if string(typtr) then
2015 if cstptrix >= cstoccmax then error(254)
2016 else
2017 begin cstptrix := cstptrix + 1;
2018 cstptr[cstptrix] := cval.valp;
2019 gen1(38,cstptrix)
2020 end
2021 else error(400);
2022 varbl: case access of
2023 drct: if vlevel <= 1 then gen1(37,dplmt)
2024 else gen2(50,level-vlevel,dplmt);
2025 indrct: if idplmt <> 0 then
2026 gen1t(34,idplmt,nilptr);
2027 inxd: error(400)
2028 end;
2029 expr: error(400)
2030 end;
2031 kind := varbl; access := indrct; idplmt := 0
2032 end
2033 end ;
2034
2035
2036 procedure genfjp(faddr: integer);
2037 begin load;
2038 if gattr.typtr <> nil then
2039 if gattr.typtr <> boolptr then error(144);
2040 if prcode then begin putic; writeln(prr,mn[33]:4,' l':8,faddr:4) end;
2041 ic := ic + 1; mes(33)
2042 end ;
2043
2044 procedure genujpxjp(fop: oprange; fp2: integer);
2045 begin
2046 if prcode then
2047 begin putic; writeln(prr, mn[fop]:4, ' l':8,fp2:4) end;
2048 ic := ic + 1; mes(fop)
2049 end ;
2050
2051
2052 procedure gencupent(fop: oprange; fp1,fp2: integer);
2053 begin
2054 if prcode then
2055 begin putic;
2056 writeln(prr,mn[fop]:4,fp1:4,'l':4,fp2:4)
2057 end;
2058 ic := ic + 1; mes(fop)
2059 end;
2060
2061
2062 procedure checkbnds(fsp: stp);
2063 var lmin,lmax: integer;
2064 begin
2065 if fsp <> nil then
2066 if fsp <> intptr then
2067 if fsp <> realptr then
2068 if fsp^.form <= subrange then
2069 begin
2070 getbounds(fsp,lmin,lmax);
2071 gen2t(45,lmin,lmax,fsp)
2072 end
2073 end ;
2074
2075
2076 procedure putlabel(labname: integer);
2077 begin if prcode then writeln(prr, 'l', labname:4)
2078 end ;
2079
2080 procedure statement(fsys: setofsys);
2081 label 1;
2082 var lcp: ctp; llp: lbp;
2083
2084 procedure expression(fsys: setofsys); forward;
2085
2086 procedure selector(fsys: setofsys; fcp: ctp);
2087 var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer;
2088 begin
2089 with fcp^, gattr do
2090 begin typtr := idtype; kind := varbl;
2091 case klass of
2092 vars:
2093 if vkind = actual then
2094 begin access := drct; vlevel := vlev;
2095 dplmt := vaddr
2096 end
2097 else
2098 begin gen2t(54,level-vlev,vaddr,nilptr);
2099 access := indrct; idplmt := 0
2100 end;
2101 field:
2102 with display[disx] do
2103 if occur = crec then
2104 begin access := drct; vlevel := clev;
2105 dplmt := cdspl + fldaddr
2106 end
2107 else
2108 begin
2109 if level = 1 then gen1t(39,vdspl,nilptr)
2110 else gen2t(54,0,vdspl,nilptr);
2111 access := indrct; idplmt := fldaddr
2112 end;
2113 func:
2114 if pfdeckind = standard then
2115 begin error(150); typtr := nil end
2116 else
2117 begin
2118 if pfkind = formal then error(151)
2119 else
2120 if (pflev+1<>level)or(fprocp<>fcp) then error(177);
2121 begin access := drct; vlevel := pflev + 1;
2122 dplmt := 0
2123 end
2124 end
2125 end
2126 end ;
2127 if not (sy in selectsys + fsys) then
2128 begin error(59); skip(selectsys + fsys) end;
2129 while sy in selectsys do
2130 begin
2131 if sy = lbrack then
2132 begin
2133 repeat lattr := gattr;
2134 with lattr do
2135 if typtr <> nil then
2136 if typtr^.form <> arrays then
2137 begin error(138); typtr := nil end;
2138 loadaddress;
2139 insymbol; expression(fsys + [comma,rbrack]);
2140 load;
2141 if gattr.typtr <> nil then
2142 if gattr.typtr^.form<>scalar then error(113)
2143 else if not comptypes(gattr.typtr,intptr) then
2144 gen0t(58,gattr.typtr);
2145 if lattr.typtr <> nil then
2146 with lattr.typtr^ do
2147 begin
2148 if comptypes(inxtype,gattr.typtr) then
2149 begin
2150 if inxtype <> nil then
2151 begin getbounds(inxtype,lmin,lmax);
2152 if debug then
2153 gen2t(45,lmin,lmax,intptr);
2154 if lmin>0 then gen1t(31,lmin,intptr)
2155 else if lmin<0 then
2156 gen1t(34,-lmin,intptr);
2157
2158 end
2159 end
2160 else error(139);
2161 with gattr do
2162 begin typtr := aeltype; kind := varbl;
2163 access := indrct; idplmt := 0
2164 end;
2165 if gattr.typtr <> nil then
2166 begin
2167 lsize := gattr.typtr^.size;
2168 align(gattr.typtr,lsize);
2169 gen1(36,lsize)
2170 end
2171 end
2172 until sy <> comma;
2173 if sy = rbrack then insymbol else error(12)
2174 end
2175 else
2176 if sy = period then
2177 begin
2178 with gattr do
2179 begin
2180 if typtr <> nil then
2181 if typtr^.form <> records then
2182 begin error(140); typtr := nil end;
2183 insymbol;
2184 if sy = ident then
2185 begin
2186 if typtr <> nil then
2187 begin searchsection(typtr^.fstfld,lcp);
2188 if lcp = nil then
2189 begin error(152); typtr := nil end
2190 else
2191 with lcp^ do
2192 begin typtr := idtype;
2193 case access of
2194 drct: dplmt := dplmt + fldaddr;
2195 indrct: idplmt := idplmt + fldaddr;
2196 inxd: error(400)
2197 end
2198 end
2199 end;
2200 insymbol
2201 end
2202 else error(2)
2203 end
2204 end
2205 else
2206 begin
2207 if gattr.typtr <> nil then
2208 with gattr,typtr^ do
2209 if form = pointer then
2210 begin load; typtr := eltype;
2211 if debug then gen2t(45,1,maxaddr,nilptr);
2212 with gattr do
2213 begin kind := varbl; access := indrct;
2214 idplmt := 0
2215 end
2216 end
2217 else
2218 if form = files then typtr := filtype
2219 else error(141);
2220 insymbol
2221 end;
2222 if not (sy in fsys + selectsys) then
2223 begin error(6); skip(fsys + selectsys) end
2224 end
2225 end ;
2226
2227 procedure call(fsys: setofsys; fcp: ctp);
2228 var lkey: 1..15;
2229
2230 procedure variable(fsys: setofsys);
2231 var lcp: ctp;
2232 begin
2233 if sy = ident then
2234 begin searchid([vars,field],lcp); insymbol end
2235 else begin error(2); lcp := uvarptr end;
2236 selector(fsys,lcp)
2237 end ;
2238
2239 procedure getputresetrewrite;
2240 begin variable(fsys + [rparent]); loadaddress;
2241 if gattr.typtr <> nil then
2242 if gattr.typtr^.form <> files then error(116);
2243 if lkey <= 2 then gen1(30,lkey)
2244 else error(399)
2245 end ;
2246
2247 procedure read;
2248 var llev:levrange; laddr:addrrange;
2249 lsp : stp;
2250 begin
2251 llev := 1; laddr := lcaftermarkstack;
2252 if sy = lparent then
2253 begin insymbol;
2254 variable(fsys + [comma,rparent]);
2255 lsp := gattr.typtr; test := false;
2256 if lsp <> nil then
2257 if lsp^.form = files then
2258 with gattr, lsp^ do
2259 begin
2260 if filtype = charptr then
2261 begin llev := vlevel; laddr := dplmt end
2262 else error(399);
2263 if sy = rparent then
2264 begin if lkey = 5 then error(116);
2265 test := true
2266 end
2267 else
2268 if sy <> comma then
2269 begin error(116); skip(fsys + [comma,rparent]) end;
2270 if sy = comma then
2271 begin insymbol; variable(fsys + [comma,rparent])
2272 end
2273 else test := true
2274 end;
2275 if not test then
2276 repeat loadaddress;
2277 gen2(50,level-llev,laddr);
2278 if gattr.typtr <> nil then
2279 if gattr.typtr^.form <= subrange then
2280 if comptypes(intptr,gattr.typtr) then
2281 gen1(30,3)
2282 else
2283 if comptypes(realptr,gattr.typtr) then
2284 gen1(30,4)
2285 else
2286 if comptypes(charptr,gattr.typtr) then
2287 gen1(30,5)
2288 else error(399)
2289 else error(116);
2290 test := sy <> comma;
2291 if not test then
2292 begin insymbol; variable(fsys + [comma,rparent])
2293 end
2294 until test;
2295 if sy = rparent then insymbol else error(4)
2296 end
2297 else if lkey = 5 then error(116);
2298 if lkey = 11 then
2299 begin gen2(50,level-llev,laddr);
2300 gen1(30,21)
2301 end
2302 end ;
2303
2304 procedure write;
2305 var lsp: stp; default : boolean; llkey: 1..15;
2306 llev:levrange; laddr,len:addrrange;
2307 begin llkey := lkey;
2308 llev := 1; laddr := lcaftermarkstack + charmax;
2309 if sy = lparent then
2310 begin insymbol;
2311 expression(fsys + [comma,colon,rparent]);
2312 lsp := gattr.typtr; test := false;
2313 if lsp <> nil then
2314 if lsp^.form = files then
2315 with gattr, lsp^ do
2316 begin
2317 if filtype = charptr then
2318 begin llev := vlevel; laddr := dplmt end
2319 else error(399);
2320 if sy = rparent then
2321 begin if llkey = 6 then error(116);
2322 test := true
2323 end
2324 else
2325 if sy <> comma then
2326 begin error(116); skip(fsys+[comma,rparent]) end;
2327 if sy = comma then
2328 begin insymbol; expression(fsys+[comma,colon,rparent])
2329 end
2330 else test := true
2331 end;
2332 if not test then
2333 repeat
2334 lsp := gattr.typtr;
2335 if lsp <> nil then
2336 if lsp^.form <= subrange then load else loadaddress;
2337 if sy = colon then
2338 begin insymbol; expression(fsys + [comma,colon,rparent]);
2339 if gattr.typtr <> nil then
2340 if gattr.typtr <> intptr then error(116);
2341 load; default := false
2342 end
2343 else default := true;
2344 if sy = colon then
2345 begin insymbol; expression(fsys + [comma,rparent]);
2346 if gattr.typtr <> nil then
2347 if gattr.typtr <> intptr then error(116);
2348 if lsp <> realptr then error(124);
2349 load; error(399);
2350 end
2351 else
2352 if lsp = intptr then
2353 begin if default then gen2(51,1,10);
2354 gen2(50,level-llev,laddr);
2355 gen1(30,6)
2356 end
2357 else
2358 if lsp = realptr then
2359 begin if default then gen2(51,1,20);
2360 gen2(50,level-llev,laddr);
2361 gen1(30,8)
2362 end
2363 else
2364 if lsp = charptr then
2365 begin if default then gen2(51,1,1);
2366 gen2(50,level-llev,laddr);
2367 gen1(30,9)
2368 end
2369 else
2370 if lsp <> nil then
2371 begin
2372 if lsp^.form = scalar then error(399)
2373 else
2374 if string(lsp) then
2375 begin len := lsp^.size div charmax;
2376 if default then
2377 gen2(51,1,len);
2378 gen2(51,1,len);
2379 gen2(50,level-llev,laddr);
2380 gen1(30,10)
2381 end
2382 else error(116)
2383 end;
2384 test := sy <> comma;
2385 if not test then
2386 begin insymbol; expression(fsys + [comma,colon,rparent])
2387 end
2388 until test;
2389 if sy = rparent then insymbol else error(4)
2390 end
2391 else if lkey = 6 then error(116);
2392 if llkey = 12 then
2393 begin gen2(50,level-llev,laddr);
2394 gen1(30,22)
2395 end
2396 end ;
2397
2398 procedure pack;
2399 var lsp,lsp1: stp;
2400 begin error(399); variable(fsys + [comma,rparent]);
2401 lsp := nil; lsp1 := nil;
2402 if gattr.typtr <> nil then
2403 with gattr.typtr^ do
2404 if form = arrays then
2405 begin lsp := inxtype; lsp1 := aeltype end
2406 else error(116);
2407 if sy = comma then insymbol else error(20);
2408 expression(fsys + [comma,rparent]);
2409 if gattr.typtr <> nil then
2410 if gattr.typtr^.form <> scalar then error(116)
2411 else
2412 if not comptypes(lsp,gattr.typtr) then error(116);
2413 if sy = comma then insymbol else error(20);
2414 variable(fsys + [rparent]);
2415 if gattr.typtr <> nil then
2416 with gattr.typtr^ do
2417 if form = arrays then
2418 begin
2419 if not comptypes(aeltype,lsp1)
2420 or not comptypes(inxtype,lsp) then
2421 error(116)
2422 end
2423 else error(116)
2424 end ;
2425
2426 procedure unpack;
2427 var lsp,lsp1: stp;
2428 begin error(399); variable(fsys + [comma,rparent]);
2429 lsp := nil; lsp1 := nil;
2430 if gattr.typtr <> nil then
2431 with gattr.typtr^ do
2432 if form = arrays then
2433 begin lsp := inxtype; lsp1 := aeltype end
2434 else error(116);
2435 if sy = comma then insymbol else error(20);
2436 variable(fsys + [comma,rparent]);
2437 if gattr.typtr <> nil then
2438 with gattr.typtr^ do
2439 if form = arrays then
2440 begin
2441 if not comptypes(aeltype,lsp1)
2442 or not comptypes(inxtype,lsp) then
2443 error(116)
2444 end
2445 else error(116);
2446 if sy = comma then insymbol else error(20);
2447 expression(fsys + [rparent]);
2448 if gattr.typtr <> nil then
2449 if gattr.typtr^.form <> scalar then error(116)
2450 else
2451 if not comptypes(lsp,gattr.typtr) then error(116);
2452 end ;
2453
2454 procedure new;
2455 label 1;
2456 var lsp,lsp1: stp; varts: integer;
2457 lsize: addrrange; lval: valu;
2458 begin variable(fsys + [comma,rparent]); loadaddress;
2459 lsp := nil; varts := 0; lsize := 0;
2460 if gattr.typtr <> nil then
2461 with gattr.typtr^ do
2462 if form = pointer then
2463 begin
2464 if eltype <> nil then
2465 begin lsize := eltype^.size;
2466 if eltype^.form = records then lsp := eltype^.recvar
2467 end
2468 end
2469 else error(116);
2470 while sy = comma do
2471 begin insymbol;constant(fsys + [comma,rparent],lsp1,lval);
2472 varts := varts + 1;
2473
2474 if lsp = nil then error(158)
2475 else
2476 if lsp^.form <> tagfld then error(162)
2477 else
2478 if lsp^.tagfieldp <> nil then
2479 if string(lsp1) or (lsp1 = realptr) then error(159)
2480 else
2481 if comptypes(lsp^.tagfieldp^.idtype,lsp1) then
2482 begin
2483 lsp1 := lsp^.fstvar;
2484 while lsp1 <> nil do
2485 with lsp1^ do
2486 if varval.ival = lval.ival then
2487 begin lsize := size; lsp := subvar;
2488 goto 1
2489 end
2490 else lsp1 := nxtvar;
2491 lsize := lsp^.size; lsp := nil;
2492 end
2493 else error(116);
2494 1: end ;
2495 gen2(51,1,lsize);
2496 gen1(30,12);
2497 end ;
2498
2499 procedure mark;
2500 begin variable(fsys+[rparent]);
2501 if gattr.typtr <> nil then
2502 if gattr.typtr^.form = pointer then
2503 begin loadaddress; gen1(30,23) end
2504 else error(116)
2505 end;
2506
2507 procedure release;
2508 begin variable(fsys+[rparent]);
2509 if gattr.typtr <> nil then
2510 if gattr.typtr^.form = pointer then
2511 begin load; gen1(30,13) end
2512 else error(116)
2513 end ;
2514
2515
2516
2517 procedure abs;
2518 begin
2519 if gattr.typtr <> nil then
2520 if gattr.typtr = intptr then gen0(0)
2521 else
2522 if gattr.typtr = realptr then gen0(1)
2523 else begin error(125); gattr.typtr := intptr end
2524 end ;
2525
2526 procedure sqr;
2527 begin
2528 if gattr.typtr <> nil then
2529 if gattr.typtr = intptr then gen0(24)
2530 else
2531 if gattr.typtr = realptr then gen0(25)
2532 else begin error(125); gattr.typtr := intptr end
2533 end ;
2534
2535 procedure trunc;
2536 begin
2537 if gattr.typtr <> nil then
2538 if gattr.typtr <> realptr then error(125);
2539 gen0(27);
2540 gattr.typtr := intptr
2541 end ;
2542
2543 procedure odd;
2544 begin
2545 if gattr.typtr <> nil then
2546 if gattr.typtr <> intptr then error(125);
2547 gen0(20);
2548 gattr.typtr := boolptr
2549 end ;
2550
2551 procedure ord;
2552 begin
2553 if gattr.typtr <> nil then
2554 if gattr.typtr^.form >= power then error(125);
2555 gen0t(58,gattr.typtr);
2556 gattr.typtr := intptr
2557 end ;
2558
2559 procedure chr;
2560 begin
2561 if gattr.typtr <> nil then
2562 if gattr.typtr <> intptr then error(125);
2563 gen0(59);
2564 gattr.typtr := charptr
2565 end ;
2566
2567 procedure predsucc;
2568 begin
2569 if gattr.typtr <> nil then
2570 if gattr.typtr^.form <> scalar then error(125);
2571 if lkey = 7 then gen1t(31,1,gattr.typtr)
2572 else gen1t(34,1,gattr.typtr)
2573 end ;
2574
2575 procedure eof;
2576 begin
2577 if sy = lparent then
2578 begin insymbol; variable(fsys + [rparent]);
2579 if sy = rparent then insymbol else error(4)
2580 end
2581 else
2582 with gattr do
2583 begin typtr := textptr; kind := varbl; access := drct;
2584 vlevel := 1; dplmt := lcaftermarkstack
2585 end;
2586 loadaddress;
2587 if gattr.typtr <> nil then
2588 if gattr.typtr^.form <> files then error(125);
2589 if lkey = 9 then gen0(8) else gen1(30,14);
2590 gattr.typtr := boolptr
2591 end ;
2592
2593
2594
2595 procedure callnonstandard;
2596 var nxt,lcp: ctp; lsp: stp; lkind: idkind; lb: boolean;
2597 locpar, llc: addrrange;
2598 begin locpar := 0;
2599 with fcp^ do
2600 begin nxt := next; lkind := pfkind;
2601 if not externl then gen1(41,level-pflev)
2602 end;
2603 if sy = lparent then
2604 begin llc := lc;
2605 repeat lb := false;
2606 if lkind = actual then
2607 begin
2608 if nxt = nil then error(126)
2609 else lb := nxt^.klass in [proc,func]
2610 end else error(399);
2611
2617 insymbol;
2618 if lb then
2619 begin error(399);
2620 if sy <> ident then
2621 begin error(2); skip(fsys + [comma,rparent]) end
2622 else
2623 begin
2624 if nxt^.klass = proc then searchid([proc],lcp)
2625 else
2626 begin searchid([func],lcp);
2627 if not comptypes(lcp^.idtype,nxt^.idtype) then
2628 error(128)
2629 end;
2630 insymbol;
2631 if not (sy in fsys + [comma,rparent]) then
2632 begin error(6); skip(fsys + [comma,rparent]) end
2633 end
2634 end
2635 else
2636 begin expression(fsys + [comma,rparent]);
2637 if gattr.typtr <> nil then
2638 if lkind = actual then
2639 begin
2640 if nxt <> nil then
2641 begin lsp := nxt^.idtype;
2642 if lsp <> nil then
2643 begin
2644 if (nxt^.vkind = actual) then
2645 if lsp^.form <= power then
2646 begin load;
2647 if debug then checkbnds(lsp);
2648 if comptypes(realptr,lsp)
2649 and (gattr.typtr = intptr) then
2650 begin gen0(10);
2651 gattr.typtr := realptr
2652 end;
2653 locpar := locpar+lsp^.size;
2654 align(parmptr,locpar);
2655 end
2656 else
2657 begin
2658 loadaddress;
2659 locpar := locpar+ptrsize;
2660 align(parmptr,locpar)
2661 end
2662 else
2663 if gattr.kind = varbl then
2664 begin loadaddress;
2665 locpar := locpar+ptrsize;
2666 align(parmptr,locpar);
2667 end
2668 else error(154);
2669 if not comptypes(lsp,gattr.typtr) then
2670 error(142)
2671 end
2672 end
2673 end
2674 else
2675 begin
2676 end
2677 end;
2678 if (lkind = actual) and (nxt <> nil) then nxt := nxt^.next
2679 until sy <> comma;
2680 lc := llc;
2681 if sy = rparent then insymbol else error(4)
2682 end ;
2683 if lkind = actual then
2684 begin if nxt <> nil then error(126);
2685 with fcp^ do
2686 begin
2687 if externl then gen1(30,pfname)
2688 else gencupent(46,locpar,pfname);
2689 end
2690 end;
2691 gattr.typtr := fcp^.idtype
2692 end ;
2693
2694 begin
2695 if fcp^.pfdeckind = standard then
2696 begin lkey := fcp^.key;
2697 if fcp^.klass = proc then
2698 begin
2699 if not(lkey in [5,6,11,12]) then
2700 if sy = lparent then insymbol else error(9);
2701 case lkey of
2702 1,2,
2703 3,4: getputresetrewrite;
2704 5,11: read;
2705 6,12: write;
2706 7: pack;
2707 8: unpack;
2708 9: new;
2709 10: release;
2710 13: mark
2711 end;
2712 if not(lkey in [5,6,11,12]) then
2713 if sy = rparent then insymbol else error(4)
2714 end
2715 else
2716 begin
2717 if lkey <= 8 then
2718 begin
2719 if sy = lparent then insymbol else error(9);
2720 expression(fsys+[rparent]); load
2721 end;
2722 case lkey of
2723 1: abs;
2724 2: sqr;
2725 3: trunc;
2726 4: odd;
2727 5: ord;
2728 6: chr;
2729 7,8: predsucc;
2730 9,10: eof
2731 end;
2732 if lkey <= 8 then
2733 if sy = rparent then insymbol else error(4)
2734 end;
2735 end
2736 else callnonstandard
2737 end ;
2738
2739 procedure expression;
2740 var lattr: attr; lop: operator; typind: char; lsize: addrrange;
2741
2742 procedure simpleexpression(fsys: setofsys);
2743 var lattr: attr; lop: operator; signed: boolean;
2744
2745 procedure term(fsys: setofsys);
2746 var lattr: attr; lop: operator;
2747
2748 procedure factor(fsys: setofsys);
2749 var lcp: ctp; lvp: csp; varpart: boolean;
2750 cstpart: setty; lsp: stp;
2751 begin
2752 if not (sy in facbegsys) then
2753 begin error(58); skip(fsys + facbegsys);
2754 gattr.typtr := nil
2755 end;
2756 while sy in facbegsys do
2757 begin
2758 case sy of
2759 ident:
2760 begin searchid([konst,vars,field,func],lcp);
2761 insymbol;
2762 if lcp^.klass = func then
2763 begin call(fsys,lcp);
2764 with gattr do
2765 begin kind := expr;
2766 if typtr <> nil then
2767 if typtr^.form=subrange then
2768 typtr := typtr^.rangetype
2769 end
2770 end
2771 else
2772 if lcp^.klass = konst then
2773 with gattr, lcp^ do
2774 begin typtr := idtype; kind := cst;
2775 cval := values
2776 end
2777 else
2778 begin selector(fsys,lcp);
2779 if gattr.typtr<>nil then
2780 with gattr,typtr^ do
2781 if form = subrange then
2782 typtr := rangetype
2783 end
2784 end;
2785 intconst:
2786 begin
2787 with gattr do
2788 begin typtr := intptr; kind := cst;
2789 cval := val
2790 end;
2791 insymbol
2792 end;
2793 realconst:
2794 begin
2795 with gattr do
2796 begin typtr := realptr; kind := cst;
2797 cval := val
2798 end;
2799 insymbol
2800 end;
2801 stringconst:
2802 begin
2803 with gattr do
2804 begin
2805 if lgth = 1 then typtr := charptr
2806 else
2807 begin new(lsp,arrays);
2808 with lsp^ do
2809 begin aeltype := charptr; form:=arrays;
2810 inxtype := nil; size := lgth*charsize
2811 end;
2812 typtr := lsp
2813 end;
2814 kind := cst; cval := val
2815 end;
2816 insymbol
2817 end;
2818 lparent:
2819 begin insymbol; expression(fsys + [rparent]);
2820 if sy = rparent then insymbol else error(4)
2821 end;
2822 notsy:
2823 begin insymbol; factor(fsys);
2824 load; gen0(19);
2825 if gattr.typtr <> nil then
2826 if gattr.typtr <> boolptr then
2827 begin error(135); gattr.typtr := nil end;
2828 end;
2829 lbrack:
2830 begin insymbol; cstpart := [ ]; varpart := false;
2831 new(lsp,power);
2832 with lsp^ do
2833 begin elset:=nil;size:=setsize;form:=power end;
2834 if sy = rbrack then
2835 begin
2836 with gattr do
2837 begin typtr := lsp; kind := cst end;
2838 insymbol
2839 end
2840 else
2841 begin
2842 repeat expression(fsys + [comma,rbrack]);
2843 if gattr.typtr <> nil then
2844 if gattr.typtr^.form <> scalar then
2845 begin error(136); gattr.typtr := nil end
2846 else
2847 if comptypes(lsp^.elset,gattr.typtr) then
2848 begin
2849 if gattr.kind = cst then
2850 if (gattr.cval.ival < setlow) or
2851 (gattr.cval.ival > sethigh) then
2852 error(304)
2853 else
2854 cstpart := cstpart+[gattr.cval.ival]
2855 else
2856 begin load;
2857 if not comptypes(gattr.typtr,intptr)
2858 then gen0t(58,gattr.typtr);
2859 gen0(23);
2860 if varpart then gen0(28)
2861 else varpart := true
2862 end;
2863 lsp^.elset := gattr.typtr;
2864 gattr.typtr := lsp
2865 end
2866 else error(137);
2867 test := sy <> comma;
2868 if not test then insymbol
2869 until test;
2870 if sy = rbrack then insymbol else error(12)
2871 end;
2872 if varpart then
2873 begin
2874 if cstpart <> [ ] then
2875 begin new(lvp,pset); lvp^.pval := cstpart;
2876 lvp^.cclass := pset;
2877 if cstptrix = cstoccmax then error(254)
2878 else
2879 begin cstptrix := cstptrix + 1;
2880 cstptr[cstptrix] := lvp;
2881 gen2(51,5,cstptrix);
2882 gen0(28); gattr.kind := expr
2883 end
2884 end
2885 end
2886 else
2887 begin new(lvp,pset); lvp^.pval := cstpart;
2888 lvp^.cclass := pset;
2889 gattr.cval.valp := lvp
2890 end
2891 end
2892 end ;
2893 if not (sy in fsys) then
2894 begin error(6); skip(fsys + facbegsys) end
2895 end
2896 end ;
2897
2898 begin
2899 factor(fsys + [mulop]);
2900 while sy = mulop do
2901 begin load; lattr := gattr; lop := op;
2902 insymbol; factor(fsys + [mulop]); load;
2903 if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
2904 case lop of
2905 mul: if (lattr.typtr=intptr)and(gattr.typtr=intptr)
2906 then gen0(15)
2907 else
2908 begin
2909 if lattr.typtr = intptr then
2910 begin gen0(9);
2911 lattr.typtr := realptr
2912 end
2913 else
2914 if gattr.typtr = intptr then
2915 begin gen0(10);
2916 gattr.typtr := realptr
2917 end;
2918 if (lattr.typtr = realptr)
2919 and(gattr.typtr=realptr)then gen0(16)
2920 else
2921 if(lattr.typtr^.form=power)
2922 and comptypes(lattr.typtr,gattr.typtr)then
2923 gen0(12)
2924 else begin error(134); gattr.typtr:=nil end
2925 end;
2926 rdiv: begin
2927 if gattr.typtr = intptr then
2928 begin gen0(10);
2929 gattr.typtr := realptr
2930 end;
2931 if lattr.typtr = intptr then
2932 begin gen0(9);
2933 lattr.typtr := realptr
2934 end;
2935 if (lattr.typtr = realptr)
2936 and (gattr.typtr=realptr)then gen0(7)
2937 else begin error(134); gattr.typtr := nil end
2938 end;
2939 idiv: if (lattr.typtr = intptr)
2940 and (gattr.typtr = intptr) then gen0(6)
2941 else begin error(134); gattr.typtr := nil end;
2942 imod: if (lattr.typtr = intptr)
2943 and (gattr.typtr = intptr) then gen0(14)
2944 else begin error(134); gattr.typtr := nil end;
2945 andop:if (lattr.typtr = boolptr)
2946 and (gattr.typtr = boolptr) then gen0(4)
2947 else begin error(134); gattr.typtr := nil end
2948 end
2949 else gattr.typtr := nil
2950 end
2951 end ;
2952
2953 begin
2954 signed := false;
2955 if (sy = addop) and (op in [plus,minus]) then
2956 begin signed := op = minus; insymbol end;
2957 term(fsys + [addop]);
2958 if signed then
2959 begin load;
2960 if gattr.typtr = intptr then gen0(17)
2961 else
2962 if gattr.typtr = realptr then gen0(18)
2963 else begin error(134); gattr.typtr := nil end
2964 end;
2965 while sy = addop do
2966 begin load; lattr := gattr; lop := op;
2967 insymbol; term(fsys + [addop]); load;
2968 if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
2969 case lop of
2970 plus:
2971 if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
2972 gen0(2)
2973 else
2974 begin
2975 if lattr.typtr = intptr then
2976 begin gen0(9);
2977 lattr.typtr := realptr
2978 end
2979 else
2980 if gattr.typtr = intptr then
2981 begin gen0(10);
2982 gattr.typtr := realptr
2983 end;
2984 if (lattr.typtr = realptr)and(gattr.typtr = realptr)
2985 then gen0(3)
2986 else if(lattr.typtr^.form=power)
2987 and comptypes(lattr.typtr,gattr.typtr) then
2988 gen0(28)
2989 else begin error(134); gattr.typtr:=nil end
2990 end;
2991 minus:
2992 if (lattr.typtr = intptr)and(gattr.typtr = intptr) then
2993 gen0(21)
2994 else
2995 begin
2996 if lattr.typtr = intptr then
2997 begin gen0(9);
2998 lattr.typtr := realptr
2999 end
3000 else
3001 if gattr.typtr = intptr then
3002 begin gen0(10);
3003 gattr.typtr := realptr
3004 end;
3005 if (lattr.typtr = realptr)and(gattr.typtr = realptr)
3006 then gen0(22)
3007 else
3008 if (lattr.typtr^.form = power)
3009 and comptypes(lattr.typtr,gattr.typtr) then
3010 gen0(5)
3011 else begin error(134); gattr.typtr := nil end
3012 end;
3013 orop:
3014 if(lattr.typtr=boolptr)and(gattr.typtr=boolptr)then
3015 gen0(13)
3016 else begin error(134); gattr.typtr := nil end
3017 end
3018 else gattr.typtr := nil
3019 end
3020 end ;
3021
3022 begin
3023 simpleexpression(fsys + [relop]);
3024 if sy = relop then
3025 begin
3026 if gattr.typtr <> nil then
3027 if gattr.typtr^.form <= power then load
3028 else loadaddress;
3029 lattr := gattr; lop := op;
3030 if lop = inop then
3031 if not comptypes(gattr.typtr,intptr) then
3032 gen0t(58,gattr.typtr);
3033 insymbol; simpleexpression(fsys);
3034 if gattr.typtr <> nil then
3035 if gattr.typtr^.form <= power then load
3036 else loadaddress;
3037 if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
3038 if lop = inop then
3039 if gattr.typtr^.form = power then
3040 if comptypes(lattr.typtr,gattr.typtr^.elset) then
3041 gen0(11)
3042 else begin error(129); gattr.typtr := nil end
3043 else begin error(130); gattr.typtr := nil end
3044 else
3045 begin
3046 if lattr.typtr <> gattr.typtr then
3047 if lattr.typtr = intptr then
3048 begin gen0(9);
3049 lattr.typtr := realptr
3050 end
3051 else
3052 if gattr.typtr = intptr then
3053 begin gen0(10);
3054 gattr.typtr := realptr
3055 end;
3056 if comptypes(lattr.typtr,gattr.typtr) then
3057 begin lsize := lattr.typtr^.size;
3058 case lattr.typtr^.form of
3059 scalar:
3060 if lattr.typtr = realptr then typind := 'r'
3061 else
3062 if lattr.typtr = boolptr then typind := 'b'
3063 else
3064 if lattr.typtr = charptr then typind := 'c'
3065 else typind := 'i';
3066 pointer:
3067 begin
3068 if lop in [ltop,leop,gtop,geop] then error(131);
3069 typind := 'a'
3070 end;
3071 power:
3072 begin if lop in [ltop,gtop] then error(132);
3073 typind := 's'
3074 end;
3075 arrays:
3076 begin
3077 if not string(lattr.typtr)
3078 then error(134);
3079 typind := 'm'
3080 end;
3081 records:
3082 begin
3083 error(134);
3084 typind := 'm'
3085 end;
3086 files:
3087 begin error(133); typind := 'f' end
3088 end;
3089 case lop of
3090 ltop: gen2(53,ord(typind),lsize);
3091 leop: gen2(52,ord(typind),lsize);
3092 gtop: gen2(49,ord(typind),lsize);
3093 geop: gen2(48,ord(typind),lsize);
3094 neop: gen2(55,ord(typind),lsize);
3095 eqop: gen2(47,ord(typind),lsize)
3096 end
3097 end
3098 else error(129)
3099 end;
3100 gattr.typtr := boolptr; gattr.kind := expr
3101 end
3102 end ;
3103
3104 procedure assignment(fcp: ctp);
3105 var lattr: attr;
3106 begin selector(fsys + [becomes],fcp);
3107 if sy = becomes then
3108 begin
3109 if gattr.typtr <> nil then
3110 if (gattr.access<>drct) or (gattr.typtr^.form>power) then
3111 loadaddress;
3112 lattr := gattr;
3113 insymbol; expression(fsys);
3114 if gattr.typtr <> nil then
3115 if gattr.typtr^.form <= power then load
3116 else loadaddress;
3117 if (lattr.typtr <> nil) and (gattr.typtr <> nil) then
3118 begin
3119 if comptypes(realptr,lattr.typtr)and(gattr.typtr=intptr)then
3120 begin gen0(10);
3121 gattr.typtr := realptr
3122 end;
3123 if comptypes(lattr.typtr,gattr.typtr) then
3124 case lattr.typtr^.form of
3125 scalar,
3126 subrange: begin
3127 if debug then checkbnds(lattr.typtr);
3128 store(lattr)
3129 end;
3130 pointer: begin
3131 if debug then
3132 gen2t(45,0,maxaddr,nilptr);
3133 store(lattr)
3134 end;
3135 power: store(lattr);
3136 arrays,
3137 records: gen1(40,lattr.typtr^.size);
3138 files: error(146)
3139 end
3140 else error(129)
3141 end
3142 end
3143 else error(51)
3144 end ;
3145
3146 procedure gotostatement;
3147 var llp: lbp; found: boolean; ttop,ttop1: disprange;
3148 begin
3149 if sy = intconst then
3150 begin
3151 found := false;
3152 ttop := top;
3153 while display[ttop].occur <> blck do ttop := ttop - 1;
3154 ttop1 := ttop;
3155 repeat
3156 llp := display[ttop].flabel;
3157 while (llp <> nil) and not found do
3158 with llp^ do
3159 if labval = val.ival then
3160 begin found := true;
3161 if ttop = ttop1 then
3162 genujpxjp(57,labname)
3163 else error(399)
3164 end
3165 else llp := nextlab;
3166 ttop := ttop - 1
3167 until found or (ttop = 0);
3168 if not found then error(167);
3169 insymbol
3170 end
3171 else error(15)
3172 end ;
3173
3174 procedure compoundstatement;
3175 begin
3176 repeat
3177 repeat statement(fsys + [semicolon,endsy])
3178 until not (sy in statbegsys);
3179 test := sy <> semicolon;
3180 if not test then insymbol
3181 until test;
3182 if sy = endsy then insymbol else error(13)
3183 end ;
3184
3185 procedure ifstatement;
3186 var lcix1,lcix2: integer;
3187 begin expression(fsys + [thensy]);
3188 genlabel(lcix1); genfjp(lcix1);
3189 if sy = thensy then insymbol else error(52);
3190 statement(fsys + [elsesy]);
3191 if sy = elsesy then
3192 begin genlabel(lcix2); genujpxjp(57,lcix2);
3193 putlabel(lcix1);
3194 insymbol; statement(fsys);
3195 putlabel(lcix2)
3196 end
3197 else putlabel(lcix1)
3198 end ;
3199
3200 procedure casestatement;
3201 label 1;
3202 type cip = ^caseinfo;
3203 caseinfo = packed
3204 record next: cip;
3205 csstart: integer;
3206 cslab: integer
3207 end;
3208 var lsp,lsp1: stp; fstptr,lpt1,lpt2,lpt3: cip; lval: valu;
3209 laddr, lcix, lcix1, lmin, lmax: integer;
3210 begin expression(fsys + [ofsy,comma,colon]);
3211 load; genlabel(lcix);
3212 lsp := gattr.typtr;
3213 if lsp <> nil then
3214 if (lsp^.form <> scalar) or (lsp = realptr) then
3215 begin error(144); lsp := nil end
3216 else if not comptypes(lsp,intptr) then gen0t(58,lsp);
3217 genujpxjp(57,lcix);
3218 if sy = ofsy then insymbol else error(8);
3219 fstptr := nil; genlabel(laddr);
3220 repeat
3221 lpt3 := nil; genlabel(lcix1);
3222 if not(sy in [semicolon,endsy]) then
3223 begin
3224 repeat constant(fsys + [comma,colon],lsp1,lval);
3225 if lsp <> nil then
3226 if comptypes(lsp,lsp1) then
3227 begin lpt1 := fstptr; lpt2 := nil;
3228 while lpt1 <> nil do
3229 with lpt1^ do
3230 begin
3231 if cslab <= lval.ival then
3232 begin if cslab = lval.ival then error(156);
3233 goto 1
3234 end;
3235 lpt2 := lpt1; lpt1 := next
3236 end;
3237 1: new(lpt3);
3238 with lpt3^ do
3239 begin next := lpt1; cslab := lval.ival;
3240 csstart := lcix1
3241 end;
3242 if lpt2 = nil then fstptr := lpt3
3243 else lpt2^.next := lpt3
3244 end
3245 else error(147);
3246 test := sy <> comma;
3247 if not test then insymbol
3248 until test;
3249 if sy = colon then insymbol else error(5);
3250 putlabel(lcix1);
3251 repeat statement(fsys + [semicolon])
3252 until not (sy in statbegsys);
3253 if lpt3 <> nil then
3254 genujpxjp(57,laddr);
3255 end;
3256 test := sy <> semicolon;
3257 if not test then insymbol
3258 until test;
3259 putlabel(lcix);
3260 if fstptr <> nil then
3261 begin lmax := fstptr^.cslab;
3262
3263 lpt1 := fstptr; fstptr := nil;
3264 repeat lpt2 := lpt1^.next; lpt1^.next := fstptr;
3265 fstptr := lpt1; lpt1 := lpt2
3266 until lpt1 = nil;
3267 lmin := fstptr^.cslab;
3268 if lmax - lmin < cixmax then
3269 begin
3270 gen2t(45,lmin,lmax,intptr);
3271 gen2(51,1,lmin); gen0(21); genlabel(lcix);
3272 genujpxjp(44,lcix); putlabel(lcix);
3273 repeat
3274 with fstptr^ do
3275 begin
3276 while cslab > lmin do
3277 begin gen0(60);
3278 lmin := lmin+1
3279 end;
3280 genujpxjp(57,csstart);
3281 fstptr := next; lmin := lmin + 1
3282 end
3283 until fstptr = nil;
3284 putlabel(laddr)
3285 end
3286 else error(157)
3287 end;
3288 if sy = endsy then insymbol else error(13)
3289 end ;
3290
3291 procedure repeatstatement;
3292 var laddr: integer;
3293 begin genlabel(laddr); putlabel(laddr);
3294 repeat statement(fsys + [semicolon,untilsy]);
3295 if sy in statbegsys then error(14)
3296 until not(sy in statbegsys);
3297 while sy = semicolon do
3298 begin insymbol;
3299 repeat statement(fsys + [semicolon,untilsy]);
3300 if sy in statbegsys then error(14)
3301 until not (sy in statbegsys);
3302 end;
3303 if sy = untilsy then
3304 begin insymbol; expression(fsys); genfjp(laddr)
3305 end
3306 else error(53)
3307 end ;
3308
3309 procedure whilestatement;
3310 var laddr, lcix: integer;
3311 begin genlabel(laddr); putlabel(laddr);
3312 expression(fsys + [dosy]); genlabel(lcix); genfjp(lcix);
3313 if sy = dosy then insymbol else error(54);
3314 statement(fsys); genujpxjp(57,laddr); putlabel(lcix)
3315 end ;
3316
3317 procedure forstatement;
3318 var lattr: attr; lsy: symbol;
3319 lcix, laddr: integer;
3320 llc: addrrange;
3321 begin llc := lc;
3322 with lattr do
3323 begin typtr := nil; kind := varbl;
3324 access := drct; vlevel := level; dplmt := 0
3325 end;
3326 if sy = ident then
3327 begin searchid([vars],lcp);
3328 with lcp^, lattr do
3329 begin typtr := idtype; kind := varbl;
3330 if vkind = actual then
3331 begin access := drct; vlevel := vlev;
3332 dplmt := vaddr
3333 end
3334 else begin error(155); typtr := nil end
3335 end;
3336 if lattr.typtr <> nil then
3337 if (lattr.typtr^.form > subrange)
3338 or comptypes(realptr,lattr.typtr) then
3339 begin error(143); lattr.typtr := nil end;
3340 insymbol
3341 end
3342 else
3343 begin error(2); skip(fsys + [becomes,tosy,downtosy,dosy]) end;
3344 if sy = becomes then
3345 begin insymbol; expression(fsys + [tosy,downtosy,dosy]);
3346 if gattr.typtr <> nil then
3347 if gattr.typtr^.form <> scalar then error(144)
3348 else
3349 if comptypes(lattr.typtr,gattr.typtr) then
3350 begin load; store(lattr) end
3351 else error(145)
3352 end
3353 else
3354 begin error(51); skip(fsys + [tosy,downtosy,dosy]) end;
3355 if sy in [tosy,downtosy] then
3356 begin lsy := sy; insymbol; expression(fsys + [dosy]);
3357 if gattr.typtr <> nil then
3358 if gattr.typtr^.form <> scalar then error(144)
3359 else
3360 if comptypes(lattr.typtr,gattr.typtr) then
3361 begin load;
3362 if not comptypes(lattr.typtr,intptr) then
3363 gen0t(58,gattr.typtr);
3364 align(intptr,lc);
3365 gen2t(56,0,lc,intptr);
3366 genlabel(laddr); putlabel(laddr);
3367 gattr := lattr; load;
3368 if not comptypes(gattr.typtr,intptr) then
3369 gen0t(58,gattr.typtr);
3370 gen2t(54,0,lc,intptr);
3371 lc := lc + intsize;
3372 if lc > lcmax then lcmax := lc;
3373 if lsy = tosy then gen2(52,ord('i'),1)
3374 else gen2(48,ord('i'),1);
3375 end
3376 else error(145)
3377 end
3378 else begin error(55); skip(fsys + [dosy]) end;
3379 genlabel(lcix); genujpxjp(33,lcix);
3380 if sy = dosy then insymbol else error(54);
3381 statement(fsys);
3382 gattr := lattr; load;
3383 if lsy=tosy then gen1t(34,1,gattr.typtr)
3384 else gen1t(31,1,gattr.typtr);
3385 store(lattr); genujpxjp(57,laddr); putlabel(lcix);
3386 lc := llc;
3387 end ;
3388
3389
3390 procedure withstatement;
3391 var lcp: ctp; lcnt1: disprange; llc: addrrange;
3392 begin lcnt1 := 0; llc := lc;
3393 repeat
3394 if sy = ident then
3395 begin searchid([vars,field],lcp); insymbol end
3396 else begin error(2); lcp := uvarptr end;
3397 selector(fsys + [comma,dosy],lcp);
3398 if gattr.typtr <> nil then
3399 if gattr.typtr^.form = records then
3400 if top < displimit then
3401 begin top := top + 1; lcnt1 := lcnt1 + 1;
3402 with display[top] do
3403 begin fname := gattr.typtr^.fstfld;
3404 flabel := nil
3405 end;
3406 if gattr.access = drct then
3407 with display[top] do
3408 begin occur := crec; clev := gattr.vlevel;
3409 cdspl := gattr.dplmt
3410 end
3411 else
3412 begin loadaddress;
3413 align(nilptr,lc);
3414 gen2t(56,0,lc,nilptr);
3415 with display[top] do
3416 begin occur := vrec; vdspl := lc end;
3417 lc := lc+ptrsize;
3418 if lc > lcmax then lcmax := lc
3419 end
3420 end
3421 else error(250)
3422 else error(140);
3423 test := sy <> comma;
3424 if not test then insymbol
3425 until test;
3426 if sy = dosy then insymbol else error(54);
3427 statement(fsys);
3428 top := top-lcnt1; lc := llc;
3429 end ;
3430
3431 begin
3432 if sy = intconst then
3433 begin llp := display[level].flabel;
3434 while llp <> nil do
3435 with llp^ do
3436 if labval = val.ival then
3437 begin if defined then error(165);
3438 putlabel(labname); defined := true;
3439 goto 1
3440 end
3441 else llp := nextlab;
3442 error(167);
3443 1: insymbol;
3444 if sy = colon then insymbol else error(5)
3445 end;
3446 if not (sy in fsys + [ident]) then
3447 begin error(6); skip(fsys) end;
3448 if sy in statbegsys + [ident] then
3449 begin
3450 case sy of
3451 ident: begin searchid([vars,field,func,proc],lcp); insymbol;
3452 if lcp^.klass = proc then call(fsys,lcp)
3453 else assignment(lcp)
3454 end;
3455 beginsy: begin insymbol; compoundstatement end;
3456 gotosy: begin insymbol; gotostatement end;
3457 ifsy: begin insymbol; ifstatement end;
3458 casesy: begin insymbol; casestatement end;
3459 whilesy: begin insymbol; whilestatement end;
3460 repeatsy: begin insymbol; repeatstatement end;
3461 forsy: begin insymbol; forstatement end;
3462 withsy: begin insymbol; withstatement end
3463 end;
3464 if not (sy in [semicolon,endsy,elsesy,untilsy]) then
3465 begin error(6); skip(fsys) end
3466 end
3467 end ;
3468
3469 begin
3470 if fprocp <> nil then entname := fprocp^.pfname
3471 else genlabel(entname);
3472 cstptrix := 0; topnew := lcaftermarkstack; topmax := lcaftermarkstack;
3473 putlabel(entname); genlabel(segsize); genlabel(stacktop);
3474 gencupent(32,1,segsize); gencupent(32,2,stacktop);
3475 if fprocp <> nil then
3476 begin llc1 := lcaftermarkstack;
3477 lcp := fprocp^.next;
3478 while lcp <> nil do
3479 with lcp^ do
3480 begin
3481 align(parmptr,llc1);
3482 if klass = vars then
3483 if idtype <> nil then
3484 if idtype^.form > power then
3485 begin
3486 if vkind = actual then
3487 begin
3488 gen2(50,0,vaddr);
3489 gen2t(54,0,llc1,nilptr);
3490 gen1(40,idtype^.size);
3491 end;
3492 llc1 := llc1 + ptrsize
3493 end
3494 else llc1 := llc1 + idtype^.size;
3495 lcp := lcp^.next;
3496 end;
3497 end;
3498 lcmax := lc;
3499 repeat
3500 repeat statement(fsys + [semicolon,endsy])
3501 until not (sy in statbegsys);
3502 test := sy <> semicolon;
3503 if not test then insymbol
3504 until test;
3505 if sy = endsy then insymbol else error(13);
3506 llp := display[top].flabel;
3507 while llp <> nil do
3508 with llp^ do
3509 begin
3510 if not defined then
3511 begin error(168);
3512 writeln(output); writeln(output,' label ',labval);
3513 write(output,' ':chcnt+16)
3514 end;
3515 llp := nextlab
3516 end;
3517 if fprocp <> nil then
3518 begin
3519 if fprocp^.idtype = nil then gen1(42,ord('p'))
3520 else gen0t(42,fprocp^.idtype);
3521 align(parmptr,lcmax);
3522 if prcode then
3523 begin writeln(prr,'l',segsize:4,'=',lcmax);
3524 writeln(prr,'l',stacktop:4,'=',topmax)
3525 end
3526 end
3527 else
3528 begin gen1(42,ord('p'));
3529 align(parmptr,lcmax);
3530 if prcode then
3531 begin writeln(prr,'l',segsize:4,'=',lcmax);
3532 writeln(prr,'l',stacktop:4,'=',topmax);
3533 writeln(prr,'q')
3534 end;
3535 ic := 0;
3536
3538 gen1(41,0); gencupent(46,0,entname); gen0(29);
3539 if prcode then
3540 writeln(prr,'q');
3541 saveid := id;
3542 while fextfilep <> nil do
3543 begin
3544 with fextfilep^ do
3545 if not ((filename = 'input ') or (filename = 'output ') or
3546 (filename = 'prd ') or (filename = 'prr '))
3547 then begin id := filename;
3548 searchid([vars],llcp);
3549 if llcp^.idtype<>nil then
3550 if llcp^.idtype^.form<>files then
3551 begin writeln(output);
3552 writeln(output,' ':8,'undeclared ','external ',
3553 'file',fextfilep^.filename:8);
3554 write(output,' ':chcnt+16)
3555 end
3556 end;
3557 fextfilep := fextfilep^.nextfile
3558 end;
3559 id := saveid;
3560 if prtables then
3561 begin writeln(output); printtables(true)
3562 end
3563 end;
3564 end ;
3565
3566 begin
3567 dp := true;
3568 repeat
3569 if sy = labelsy then
3570 begin insymbol; labeldeclaration end;
3571 if sy = constsy then
3572 begin insymbol; constdeclaration end;
3573 if sy = typesy then
3574 begin insymbol; typedeclaration end;
3575 if sy = varsy then
3576 begin insymbol; vardeclaration end;
3577 while sy in [procsy,funcsy] do
3578 begin lsy := sy; insymbol; procdeclaration(lsy) end;
3579 if sy <> beginsy then
3580 begin error(18); skip(fsys) end
3581 until (sy in statbegsys) or eof(input);
3582 dp := false;
3583 if sy = beginsy then insymbol else error(17);
3584 repeat body(fsys + [casesy]);
3585 if sy <> fsy then
3586 begin error(6); skip(fsys) end
3587 until ((sy = fsy) or (sy in blockbegsys)) or eof(input);
3588 end ;
3589
3590 procedure programme(fsys:setofsys);
3591 var extfp:extfilep;
3592 begin
3593 if sy = progsy then
3594 begin insymbol; if sy <> ident then error(2); insymbol;
3595 if not (sy in [lparent,semicolon]) then error(14);
3596 if sy = lparent then
3597 begin
3598 repeat insymbol;
3599 if sy = ident then
3600 begin new(extfp);
3601 with extfp^ do
3602 begin filename := id; nextfile := fextfilep end;
3603 fextfilep := extfp;
3604 insymbol;
3605 if not ( sy in [comma,rparent] ) then error(20)
3606 end
3607 else error(2)
3608 until sy <> comma;
3609 if sy <> rparent then error(4);
3610 insymbol
3611 end;
3612 if sy <> semicolon then error(14)
3613 else insymbol;
3614 end;
3615 repeat block(fsys,period,nil);
3616 if sy <> period then error(21)
3617 until (sy = period) or eof(input);
3618 if list then writeln(output);
3619 if errinx <> 0 then
3620 begin list := false; endofline end
3621 end ;
3622
3623
3624 procedure stdnames;
3625 begin
3626 na[ 1] := 'false '; na[ 2] := 'true '; na[ 3] := 'input ';
3627 na[ 4] := 'output '; na[ 5] := 'get '; na[ 6] := 'put ';
3628 na[ 7] := 'reset '; na[ 8] := 'rewrite '; na[ 9] := 'read ';
3629 na[10] := 'write '; na[11] := 'pack '; na[12] := 'unpack ';
3630 na[13] := 'new '; na[14] := 'release '; na[15] := 'readln ';
3631 na[16] := 'writeln ';
3632 na[17] := 'abs '; na[18] := 'sqr '; na[19] := 'trunc ';
3633 na[20] := 'odd '; na[21] := 'ord '; na[22] := 'chr ';
3634 na[23] := 'pred '; na[24] := 'succ '; na[25] := 'eof ';
3635 na[26] := 'eoln ';
3636 na[27] := 'sin '; na[28] := 'cos '; na[29] := 'exp ';
3637 na[30] := 'sqrt '; na[31] := 'ln '; na[32] := 'arctan ';
3638 na[33] := 'prd '; na[34] := 'prr '; na[35] := 'mark ';
3639 end ;
3640
3641 procedure enterstdtypes;
3642
3643 begin
3644
3645
3646 new(intptr,scalar,standard);
3647 with intptr^ do
3648 begin size := intsize; form := scalar; scalkind := standard end;
3649 new(realptr,scalar,standard);
3650 with realptr^ do
3651 begin size := realsize; form := scalar; scalkind := standard end;
3652 new(charptr,scalar,standard);
3653 with charptr^ do
3654 begin size := charsize; form := scalar; scalkind := standard end;
3655 new(boolptr,scalar,declared);
3656 with boolptr^ do
3657 begin size := boolsize; form := scalar; scalkind := declared end;
3658 new(nilptr,pointer);
3659 with nilptr^ do
3660 begin eltype := nil; size := ptrsize; form := pointer end;
3661 new(parmptr,scalar,standard);
3662 with parmptr^ do
3663 begin size := parmsize; form := scalar; scalkind := standard end ;
3664 new(textptr,files);
3665 with textptr^ do
3666 begin filtype := charptr; size := charsize; form := files end
3667 end ;
3668
3669 procedure entstdnames;
3670 var cp,cp1: ctp; i: integer;
3671 begin
3672
3673
3674 new(cp,types);
3675 with cp^ do
3676 begin name := 'integer '; idtype := intptr; klass := types end;
3677 enterid(cp);
3678 new(cp,types);
3679 with cp^ do
3680 begin name := 'real '; idtype := realptr; klass := types end;
3681 enterid(cp);
3682 new(cp,types);
3683 with cp^ do
3684 begin name := 'char '; idtype := charptr; klass := types end;
3685 enterid(cp);
3686 new(cp,types);
3687 with cp^ do
3688 begin name := 'boolean '; idtype := boolptr; klass := types end;
3689 enterid(cp);
3690 cp1 := nil;
3691 for i := 1 to 2 do
3692 begin new(cp,konst);
3693 with cp^ do
3694 begin name := na[i]; idtype := boolptr;
3695 next := cp1; values.ival := i - 1; klass := konst
3696 end;
3697 enterid(cp); cp1 := cp
3698 end;
3699 boolptr^.fconst := cp;
3700 new(cp,konst);
3701 with cp^ do
3702 begin name := 'nil '; idtype := nilptr;
3703 next := nil; values.ival := 0; klass := konst
3704 end;
3705 enterid(cp);
3706 for i := 3 to 4 do
3707 begin new(cp,vars);
3708 with cp^ do
3709 begin name := na[i]; idtype := textptr; klass := vars;
3710 vkind := actual; next := nil; vlev := 1;
3711 vaddr := lcaftermarkstack+(i-3)*charmax;
3712 end;
3713 enterid(cp)
3714 end;
3715 for i:=33 to 34 do
3716 begin new(cp,vars);
3717 with cp^ do
3718 begin name := na[i]; idtype := textptr; klass := vars;
3719 vkind := actual; next := nil; vlev := 1;
3720 vaddr := lcaftermarkstack+(i-31)*charmax;
3721 end;
3722 enterid(cp)
3723 end;
3724 for i := 5 to 16 do
3725 begin new(cp,proc,standard);
3726 with cp^ do
3727 begin name := na[i]; idtype := nil;
3728 next := nil; key := i - 4;
3729 klass := proc; pfdeckind := standard
3730 end;
3731 enterid(cp)
3732 end;
3733 new(cp,proc,standard);
3734 with cp^ do
3735 begin name:=na[35]; idtype:=nil;
3736 next:= nil; key:=13;
3737 klass:=proc; pfdeckind:= standard
3738 end; enterid(cp);
3739 for i := 17 to 26 do
3740 begin new(cp,func,standard);
3741 with cp^ do
3742 begin name := na[i]; idtype := nil;
3743 next := nil; key := i - 16;
3744 klass := func; pfdeckind := standard
3745 end;
3746 enterid(cp)
3747 end;
3748 new(cp,vars);
3749 with cp^ do
3750 begin name := ' '; idtype := realptr; klass := vars;
3751 vkind := actual; next := nil; vlev := 1; vaddr := 0
3752 end;
3753 for i := 27 to 32 do
3754 begin new(cp1,func,declared,actual);
3755 with cp1^ do
3756 begin name := na[i]; idtype := realptr; next := cp;
3757 forwdecl := false; externl := true; pflev := 0; pfname := i - 12;
3758 klass := func; pfdeckind := declared; pfkind := actual
3759 end;
3760 enterid(cp1)
3761 end
3762 end ;
3763
3764 procedure enterundecl;
3765 begin
3766 new(utypptr,types);
3767 with utypptr^ do
3768 begin name := ' '; idtype := nil; klass := types end;
3769 new(ucstptr,konst);
3770 with ucstptr^ do
3771 begin name := ' '; idtype := nil; next := nil;
3772 values.ival := 0; klass := konst
3773 end;
3774 new(uvarptr,vars);
3775 with uvarptr^ do
3776 begin name := ' '; idtype := nil; vkind := actual;
3777 next := nil; vlev := 0; vaddr := 0; klass := vars
3778 end;
3779 new(ufldptr,field);
3780 with ufldptr^ do
3781 begin name := ' '; idtype := nil; next := nil; fldaddr := 0;
3782 klass := field
3783 end;
3784 new(uprcptr,proc,declared,actual);
3785 with uprcptr^ do
3786 begin name := ' '; idtype := nil; forwdecl := false;
3787 next := nil; externl := false; pflev := 0; genlabel(pfname);
3788 klass := proc; pfdeckind := declared; pfkind := actual
3789 end;
3790 new(ufctptr,func,declared,actual);
3791 with ufctptr^ do
3792 begin name := ' '; idtype := nil; next := nil;
3793 forwdecl := false; externl := false; pflev := 0; genlabel(pfname);
3794 klass := func; pfdeckind := declared; pfkind := actual
3795 end
3796 end ;
3797
3798 procedure initscalars;
3799 begin fwptr := nil;
3800 prtables := false; list := true; prcode := true; debug := true;
3801 dp := true; prterr := true; errinx := 0;
3802 intlabel := 0; kk := 8; fextfilep := nil;
3803 lc := lcaftermarkstack+filebuffer*charmax;
3804
3805 ic := 3; eol := true; linecount := 0;
3806 ch := ' '; chcnt := 0;
3807 globtestp := nil;
3808 mxint10 := maxint div 10; digmax := strglgth - 1;
3809 end ;
3810
3811 procedure initsets;
3812 begin
3813 constbegsys := [addop,intconst,realconst,stringconst,ident];
3814 simptypebegsys := [lparent] + constbegsys;
3815 typebegsys:=[arrow,packedsy,arraysy,recordsy,setsy,filesy]+simptypebegsys;
3816 typedels := [arraysy,recordsy,setsy,filesy];
3817 blockbegsys := [labelsy,constsy,typesy,varsy,procsy,funcsy,beginsy];
3818 selectsys := [arrow,period,lbrack];
3819 facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy];
3820 statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy];
3821 end ;
3822
3823 procedure inittables;
3824 procedure reswords;
3825 begin
3826 rw[ 1] := 'if '; rw[ 2] := 'do '; rw[ 3] := 'of ';
3827 rw[ 4] := 'to '; rw[ 5] := 'in '; rw[ 6] := 'or ';
3828 rw[ 7] := 'end '; rw[ 8] := 'for '; rw[ 9] := 'var ';
3829 rw[10] := 'div '; rw[11] := 'mod '; rw[12] := 'set ';
3830 rw[13] := 'and '; rw[14] := 'not '; rw[15] := 'then ';
3831 rw[16] := 'else '; rw[17] := 'with '; rw[18] := 'goto ';
3832 rw[19] := 'case '; rw[20] := 'type ';
3833 rw[21] := 'file '; rw[22] := 'begin ';
3834 rw[23] := 'until '; rw[24] := 'while '; rw[25] := 'array ';
3835 rw[26] := 'const '; rw[27] := 'label ';
3836 rw[28] := 'repeat '; rw[29] := 'record '; rw[30] := 'downto ';
3837 rw[31] := 'packed '; rw[32] := 'forward '; rw[33] := 'program ';
3838 rw[34] := 'function'; rw[35] := 'procedur';
3839 frw[1] := 1; frw[2] := 1; frw[3] := 7; frw[4] := 15; frw[5] := 22;
3840 frw[6] := 28; frw[7] := 32; frw[8] := 34; frw[9] := 36;
3841 end ;
3842
3843 procedure symbols;
3844 begin
3845 rsy[ 1] := ifsy; rsy[ 2] := dosy; rsy[ 3] := ofsy;
3846 rsy[ 4] := tosy; rsy[ 5] := relop; rsy[ 6] := addop;
3847 rsy[ 7] := endsy; rsy[ 8] := forsy; rsy[ 9] := varsy;
3848 rsy[10] := mulop; rsy[11] := mulop; rsy[12] := setsy;
3849 rsy[13] := mulop; rsy[14] := notsy; rsy[15] := thensy;
3850 rsy[16] := elsesy; rsy[17] := withsy; rsy[18] := gotosy;
3851 rsy[19] := casesy; rsy[20] := typesy;
3852 rsy[21] := filesy; rsy[22] := beginsy;
3853 rsy[23] := untilsy; rsy[24] := whilesy; rsy[25] := arraysy;
3854 rsy[26] := constsy; rsy[27] := labelsy;
3855 rsy[28] := repeatsy; rsy[29] := recordsy; rsy[30] := downtosy;
3856 rsy[31] := packedsy; rsy[32] := forwardsy; rsy[33] := progsy;
3857 rsy[34] := funcsy; rsy[35] := procsy;
3858 ssy['+'] := addop ; ssy['-'] := addop; ssy['*'] := mulop;
3859 ssy['/'] := mulop ; ssy['('] := lparent; ssy[')'] := rparent;
3860 ssy['$'] := othersy ; ssy['='] := relop; ssy[' '] := othersy;
3861 ssy[','] := comma ; ssy['.'] := period; ssy['''']:= othersy;
3862 ssy['['] := lbrack ; ssy[']'] := rbrack; ssy[':'] := colon;
3863 ssy['^'] := arrow ; ssy['<'] := relop; ssy['>'] := relop;
3864 ssy[';'] := semicolon;
3865 end ;
3866
3867 procedure rators;
3868 var i: integer;
3869 begin
3870 for i := 1 to 35 do rop[i] := noop;
3871 rop[5] := inop; rop[10] := idiv; rop[11] := imod;
3872 rop[6] := orop; rop[13] := andop;
3873 for i := ordminchar to ordmaxchar do sop[chr(i)] := noop;
3874 sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
3875 sop['='] := eqop; sop['<'] := ltop; sop['>'] := gtop;
3876 end ;
3877
3878 procedure procmnemonics;
3879 begin
3880 sna[ 1] :=' get'; sna[ 2] :=' put'; sna[ 3] :=' rdi'; sna[ 4] :=' rdr';
3881 sna[ 5] :=' rdc'; sna[ 6] :=' wri'; sna[ 7] :=' wro'; sna[ 8] :=' wrr';
3882 sna[ 9] :=' wrc'; sna[10] :=' wrs'; sna[11] :=' pak'; sna[12] :=' new';
3883 sna[13] :=' rst'; sna[14] :=' eln'; sna[15] :=' sin'; sna[16] :=' cos';
3884 sna[17] :=' exp'; sna[18] :=' sqt'; sna[19] :=' log'; sna[20] :=' atn';
3885 sna[21] :=' rln'; sna[22] :=' wln'; sna[23] :=' sav';
3886 end ;
3887
3888 procedure instrmnemonics;
3889 begin
3890 mn[ 0] :=' abi'; mn[ 1] :=' abr'; mn[ 2] :=' adi'; mn[ 3] :=' adr';
3891 mn[ 4] :=' and'; mn[ 5] :=' dif'; mn[ 6] :=' dvi'; mn[ 7] :=' dvr';
3892 mn[ 8] :=' eof'; mn[ 9] :=' flo'; mn[10] :=' flt'; mn[11] :=' inn';
3893 mn[12] :=' int'; mn[13] :=' ior'; mn[14] :=' mod'; mn[15] :=' mpi';
3894 mn[16] :=' mpr'; mn[17] :=' ngi'; mn[18] :=' ngr'; mn[19] :=' not';
3895 mn[20] :=' odd'; mn[21] :=' sbi'; mn[22] :=' sbr'; mn[23] :=' sgs';
3896 mn[24] :=' sqi'; mn[25] :=' sqr'; mn[26] :=' sto'; mn[27] :=' trc';
3897 mn[28] :=' uni'; mn[29] :=' stp'; mn[30] :=' csp'; mn[31] :=' dec';
3898 mn[32] :=' ent'; mn[33] :=' fjp'; mn[34] :=' inc'; mn[35] :=' ind';
3899 mn[36] :=' ixa'; mn[37] :=' lao'; mn[38] :=' lca'; mn[39] :=' ldo';
3900 mn[40] :=' mov'; mn[41] :=' mst'; mn[42] :=' ret'; mn[43] :=' sro';
3901 mn[44] :=' xjp'; mn[45] :=' chk'; mn[46] :=' cup'; mn[47] :=' equ';
3902 mn[48] :=' geq'; mn[49] :=' grt'; mn[50] :=' lda'; mn[51] :=' ldc';
3903 mn[52] :=' leq'; mn[53] :=' les'; mn[54] :=' lod'; mn[55] :=' neq';
3904 mn[56] :=' str'; mn[57] :=' ujp'; mn[58] :=' ord'; mn[59] :=' chr';
3905 mn[60] :=' ujc';
3906 end ;
3907
3908 procedure chartypes;
3909 var i : integer;
3910 begin
3911 for i := ordminchar to ordmaxchar do chartp[chr(i)] := illegal;
3912 chartp['a'] := letter ;
3913 chartp['b'] := letter ; chartp['c'] := letter ;
3914 chartp['d'] := letter ; chartp['e'] := letter ;
3915 chartp['f'] := letter ; chartp['g'] := letter ;
3916 chartp['h'] := letter ; chartp['i'] := letter ;
3917 chartp['j'] := letter ; chartp['k'] := letter ;
3918 chartp['l'] := letter ; chartp['m'] := letter ;
3919 chartp['n'] := letter ; chartp['o'] := letter ;
3920 chartp['p'] := letter ; chartp['q'] := letter ;
3921 chartp['r'] := letter ; chartp['s'] := letter ;
3922 chartp['t'] := letter ; chartp['u'] := letter ;
3923 chartp['v'] := letter ; chartp['w'] := letter ;
3924 chartp['x'] := letter ; chartp['y'] := letter ;
3925 chartp['z'] := letter ; chartp['0'] := number ;
3926 chartp['1'] := number ; chartp['2'] := number ;
3927 chartp['3'] := number ; chartp['4'] := number ;
3928 chartp['5'] := number ; chartp['6'] := number ;
3929 chartp['7'] := number ; chartp['8'] := number ;
3930 chartp['9'] := number ; chartp['+'] := special ;
3931 chartp['-'] := special ; chartp['*'] := special ;
3932 chartp['/'] := special ; chartp['('] := chlparen;
3933 chartp[')'] := special ; chartp['$'] := special ;
3934 chartp['='] := special ; chartp[' '] := chspace ;
3935 chartp[','] := special ; chartp['.'] := chperiod;
3936 chartp['''']:= chstrquo; chartp['['] := special ;
3937 chartp[']'] := special ; chartp[':'] := chcolon ;
3938 chartp['^'] := special ; chartp[';'] := special ;
3939 chartp['<'] := chlt ; chartp['>'] := chgt ;
3940 ordint['0'] := 0; ordint['1'] := 1; ordint['2'] := 2;
3941 ordint['3'] := 3; ordint['4'] := 4; ordint['5'] := 5;
3942 ordint['6'] := 6; ordint['7'] := 7; ordint['8'] := 8;
3943 ordint['9'] := 9;
3944 end;
3945
3946 procedure initdx;
3947 begin
3948 cdx[ 0] := 0; cdx[ 1] := 0; cdx[ 2] := -1; cdx[ 3] := -1;
3949 cdx[ 4] := -1; cdx[ 5] := -1; cdx[ 6] := -1; cdx[ 7] := -1;
3950 cdx[ 8] := 0; cdx[ 9] := 0; cdx[10] := 0; cdx[11] := -1;
3951 cdx[12] := -1; cdx[13] := -1; cdx[14] := -1; cdx[15] := -1;
3952 cdx[16] := -1; cdx[17] := 0; cdx[18] := 0; cdx[19] := 0;
3953 cdx[20] := 0; cdx[21] := -1; cdx[22] := -1; cdx[23] := 0;
3954 cdx[24] := 0; cdx[25] := 0; cdx[26] := -2; cdx[27] := 0;
3955 cdx[28] := -1; cdx[29] := 0; cdx[30] := 0; cdx[31] := 0;
3956 cdx[32] := 0; cdx[33] := -1; cdx[34] := 0; cdx[35] := 0;
3957 cdx[36] := -1; cdx[37] := +1; cdx[38] := +1; cdx[39] := +1;
3958 cdx[40] := -2; cdx[41] := 0; cdx[42] := 0; cdx[43] := -1;
3959 cdx[44] := -1; cdx[45] := 0; cdx[46] := 0; cdx[47] := -1;
3960 cdx[48] := -1; cdx[49] := -1; cdx[50] := +1; cdx[51] := +1;
3961 cdx[52] := -1; cdx[53] := -1; cdx[54] := +1; cdx[55] := -1;
3962 cdx[56] := -1; cdx[57] := 0; cdx[58] := 0; cdx[59] := 0;
3963 cdx[60] := 0;
3964 pdx[ 1] := -1; pdx[ 2] := -1; pdx[ 3] := -2; pdx[ 4] := -2;
3965 pdx[ 5] := -2; pdx[ 6] := -3; pdx[ 7] := -3; pdx[ 8] := -3;
3966 pdx[ 9] := -3; pdx[10] := -4; pdx[11] := 0; pdx[12] := -2;
3967 pdx[13] := -1; pdx[14] := 0; pdx[15] := 0; pdx[16] := 0;
3968 pdx[17] := 0; pdx[18] := 0; pdx[19] := 0; pdx[20] := 0;
3969 pdx[21] := -1; pdx[22] := -1; pdx[23] := -1;
3970 end;
3971
3972 begin
3973 reswords; symbols; rators;
3974 instrmnemonics; procmnemonics;
3975 chartypes; initdx;
3976 end ;
3977
3978 begin
3979
3980
3981 initscalars; initsets; inittables;
3982
3983
3984
3985
3986 level := 0; top := 0;
3987 with display[0] do
3988 begin fname := nil; flabel := nil; occur := blck end;
3989 enterstdtypes; stdnames; entstdnames; enterundecl;
3990 top := 1; level := 1;
3991 with display[1] do
3992 begin fname := nil; flabel := nil; occur := blck end;
3993
3994
3995 rewrite(prr);
3996
3997 insymbol;
3998 programme(blockbegsys+statbegsys-[casesy]);
3999
4000 end.