1 * *************************************************************************
2 * *
3 * Copyright c 1980 by Centre Interuniversitaire de Calcul de Grenoble *
4 * and Institut National de Recherche en Informatique et Automatique *
5 * *
6 ************************************************************************* *
7
8
9
10
11 * HISTORY COMMENTS:
12 1 change86-09-11JMAthane, approve86-09-11MCR7521,
13 audit86-09-15JPFauche, install86-11-12MR12.0-1212:
14 Release 8.03 for MR12
15 END HISTORY COMMENTS *)
16
17
18 $OPTIONS switch trace := true $
19 PROGRAM standstat ;
20 $IMPORT
21 * IMPORTED PROCEDURES *
22 'RACINE pascal' :
23 error,
24 inserundlab,
25 insymbol,
26 nameisref,
27 nextline,
28 recadre,
29 search_in_condition_attributes,
30 skip,
31 statement_begins,
32 statement_ends,
33 sup ;
34 'MODATTR pascal ' :
35 convreal,
36 freeattr,
37 initattrvarbl,
38 isstring,
39 lvalvarbl,
40 varissimple ;
41 'CONTEXTTABLE pascal ' :
42 checkminmax,
43 compatbin,
44 conformantdim,
45 packedsize ;
46 'MODVARIABLE pascal ' :
47 init_desc_address,
48 variable,
49 passparams ;
50 'GENERE pascal' :
51 gendesca,
52 gendescb,
53 geneism,
54 genstand,
55 inser ;
56 'EXPR pascal' :
57 expression ;
58 'UNIQUE pascal' :
59 heaperror ;
60 'GENOPER pascal' :
61 genjump ;
62 'PROCSTAT pascal' :
63 argvstat,
64 dateandtime,
65 delete_string,
66 getput,
67 insapp,
68 insert_string,
69 mvcir,
70 newir,
71 pckunpck,
72 readir,
73 stopstat,
74 writeir ;
75 'STATE pascal' :
76 addressvar,
77 calcvarient,
78 checkbnds,
79 choicerarq,
80 currwithlist,
81 enterlcst,
82 enterundlab,
83 freeallregisters,
84 freebloc,
85 gencstecode,
86 genexceptcode,
87 loadadr,
88 loadbase,
89 newbloc,
90 regenere,
91 sauvereg,
92 transfer,
93 variab,
94 withvariable ;
95 'optimized_procedures alm' :
96 search ;
97 * IMPORTED VARIABLES *
98 'DECLARE pascal' :
99 clabix,
100 labtab,
101 lab_pdl_top,
102 lkc,
103 pop_lab_pdl,
104 push_lab_pdl ;
105 'RACINE pascal' :
106 aval,
107 boolptr,
108 charptr,
109 cl,
110 ctptr,
111 currentnode,
112 display,
113 envstandard,
114 errcl,
115 exportablecode,
116 intptr,
117 ival,
118 lamptr,
119 level,
120 mapswitch,
121 mpcogout,
122 no,
123 realptr,
124 statnbr,
125 string_ptr,
126 sttindex,
127 symbolfile,
128 symbolindex,
129 symbolline,
130 symbolmap,
131 top,
132 undecptr,
133 usednames ;
134 'GENERE pascal' :
135 cb,
136 ic,
137 indfich,
138 mfari1,
139 mfari2,
140 mfreg2,
141 usednameaddr ;
142 'STATE pascal' :
143 asscheck,
144 currentbloc,
145 currentpr,
146 gattr,
147 inxcheck,
148 lcsave,
149 linktomain,
150 linktomainplace,
151 maxprused,
152 maxinxused,
153 modif,
154 opaq,
155 prinst,
156 stattrace,
157 tmax$
158
159 $EXPORT
160 compstat $
161
162
163
164 $OPTIONS page $
165
166
167 $INCLUDE 'CONSTTYPE' $
168
169 $OPTIONS page $
170
171 VAR
172
173 * REDEFINE IMPORTED VARIABLES *
174
175 * FROM DECLARE *
176
177 clabix : integer ;
178 labtab : ARRAY 1..maxlabs OF labdescr ;
179 lab_pdl_top : lab_pdl_ptr ;
180 lkc : integer ;
181
182 * FROM RACINE *
183 mpcogout : text ;
184 envstandard : stdkind ;
185 display : ARRAY 0..displimit OF recidscope ;
186 mapswitch : boolean ;
187 top : integer ;
188 sttindex : integer ;
189 symbolfile : integer ;
190 symbolindex : integer ;
191 symbolline : integer ;
192 symbolmap : boolean ;
193 usednames : typusednames ;
194 aval : alfaid ;
195 level : levrange ;
196 cl : integer ;
197 no : integer ;
198 intptr : ctp ;
199 lamptr : ctp ;
200 undecptr : ctp ;
201 realptr : ctp ;
202 ctptr : ctp ;
203 errcl : ARRAY norange OF typofsymb ;
204 ival : integer ;
205 boolptr : ctp ;
206 charptr : ctp ;
207 exportablecode : boolean ;
208 currentnode : blocknodeptr ;
209 statnbr : integer ;
210 string_ptr : ctp ;
211
212
213 * FROM GENERE *
214 ic : integer ;
215 cb : integer ;
216 indfich : integer ;
217 mfari1 : zari ;
218 mfari2 : zari ;
219 mfreg2 : mreg ;
220 usednameaddr : ctp ;
221
222
223 * FROM STATE *
224 inxcheck : boolean ;
225 asscheck : boolean ;
226 gattr : attr ;
227 currentbloc : regpt ;
228 prinst : ARRAY typepr pr1..pr6 OF istand ; * GIVES A PR INSTRUCTION *
229 tmax : integer ;
230 linktomain : boolean ;
231 linktomainplace : integer ;
232 lcsave : integer ;
233 stattrace : levtrace ;
234 maxinxused : register ;
235 maxprused : preg ;
236 modif : ARRAY nxreg..rq OF tag ;
237 opaq : ARRAY typeofop ra..reaq OF istand ; * GIVES INST. WITH AQAQEAQ *
238 currentpr : preg ;
239 withvariable : boolean ;
240 currwithlist : withreflist ;
241
242
243
244 * ************** VARIABLES LOCALES ************************* *
245
246 splitstat : ARRAY norange OF integer ; * USED TO SELECT THE GOOD STAT. *
247
248
249 $VALUE
250
251 splitstat =
252 1 2 19 * 1 3 1 4 1 1 5 1 6
253 1 7 1 8 1 1 9 12 * 1 10 1 1
254 1 1 1 1 1 1 1 $
255
256
257 $OPTIONS page $
258
259 * REDEFINE IMPORTED PROCEDURES *
260 * FROM GENERE *
261 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
262 PROCEDURE geneism fcode : ieism ; ffield : integer ; fbits : zptr ; EXTERNAL ;
263 PROCEDURE gendesca fareg : preg ; fadr fcn : integer ; fta : lgcar ;
264 fn : integer ; frlgth : mreg ; EXTERNAL ;
265 PROCEDURE gendescb fareg : preg ; fadr fc fb fn : integer ; frlgth : mreg ; EXTERNAL ;
266 PROCEDURE inser fcb : integer ; fplace : integer ; EXTERNAL ;
267
268
269 * FROM RACINE *
270 PROCEDURE error errno : integer ; EXTERNAL ;
271 PROCEDURE insymbol ; EXTERNAL ;
272 PROCEDURE search_in_condition_attributes ; EXTERNAL ;
273 PROCEDURE skip nosym : integer ; EXTERNAL ;
274 PROCEDURE nextline ; EXTERNAL ;
275 PROCEDURE search ; EXTERNAL ;
276 FUNCTION recadre fnum fmod : integer : integer ; EXTERNAL ;
277 PROCEDURE inserundlab fcb fdebchain : integer ; EXTERNAL ;
278 PROCEDURE nameisref p : ctp ; f l : integer ; EXTERNAL ;
279 PROCEDURE statement_begins genp : boolean ; EXTERNAL ;
280 PROCEDURE statement_ends sttlength : integer ; EXTERNAL ;
281 FUNCTION sup fval1 fval2 : integer : integer ; EXTERNAL ;
282
283 * FROM EXPR *
284 PROCEDURE expression ; EXTERNAL ;
285
286 * FROM MODATTR *
287 PROCEDURE freeattr VAR fattr : attr ; EXTERNAL ;
288 PROCEDURE lvalvarbl VAR fattr : attr ; EXTERNAL ;
289 PROCEDURE initattrvarbl VAR fattr : attr ; EXTERNAL ;
290 FUNCTION isstring VAR fattr : attr : boolean ; EXTERNAL ;
291 FUNCTION varissimple VAR fattr : attr : boolean ; EXTERNAL ;
292 PROCEDURE convreal VAR fattr : attr ; EXTERNAL ;
293
294
295 * FROM CONTEXTTABLE *
296
297 PROCEDURE checkminmax fvalu : integer ; fctp : ctp ; ferrnum : integer ; EXTERNAL ;
298 PROCEDURE compatbin typleft typright : ctp ; VAR fgeneric : ctp ; EXTERNAL ;
299 FUNCTION conformantdim ff : ctp : boolean ; EXTERNAL ;
300 FUNCTION packedsize fctp : ctp : integer ; EXTERNAL ;
301
302 * FROM MODVARIABLE *
303
304 PROCEDURE init_desc_address fctp : ctp ; VAR fattr : attr ; EXTERNAL ;
305 PROCEDURE variable fvarset : boolean ; EXTERNAL ;
306 PROCEDURE passparams fctplace : integer ; EXTERNAL ;
307
308
309
310 * FROM UNIQUE *
311 PROCEDURE heaperror ; EXTERNAL ;
312
313 * FROM GENOPER *
314 PROCEDURE genjump VAR inserplace : integer ; jumpdisp : integer ; EXTERNAL ;
315 * FROM PROCSTAT *
316 PROCEDURE argvstat ; EXTERNAL ;
317 PROCEDURE getput fcode : integer ; EXTERNAL ;
318 PROCEDURE readir fcode : integer ; EXTERNAL ;
319 PROCEDURE pckunpck fcode : integer ; EXTERNAL ;
320 PROCEDURE writeir fcode : integer ; EXTERNAL ;
321 PROCEDURE newir fcode : integer ; EXTERNAL ;
322 PROCEDURE stopstat ; EXTERNAL ;
323 PROCEDURE dateandtime fcode : integer ; EXTERNAL ;
324 PROCEDURE delete_string ; EXTERNAL ;
325 PROCEDURE insapp fcode : integer ; EXTERNAL ;
326 PROCEDURE insert_string ; EXTERNAL ;
327 PROCEDURE mvcir fcode : integer ; EXTERNAL ;
328
329 * FROM STATE *
330 PROCEDURE addressvar fctp : ctp ; VAR fattr : attr ; modif : boolean ; EXTERNAL ;
331 PROCEDURE choicerarq ; EXTERNAL ;
332 PROCEDURE enterlcst VAR fval : setarray ; VAR fboxpt : lcstpt ; EXTERNAL ;
333 PROCEDURE enterundlab VAR fundinx : integer ; EXTERNAL ;
334 PROCEDURE transfer VAR fattr : attr ; inwhat : destination ; EXTERNAL ;
335 PROCEDURE genexceptcode ferrcode : integer ; freg : register ; EXTERNAL ;
336 PROCEDURE variab fvarset : boolean ; EXTERNAL ;
337 PROCEDURE freebloc VAR fbtofree : regpt ; EXTERNAL ;
338 PROCEDURE loadadr VAR fattr : attr ; wantedpr : preg ; EXTERNAL ;
339 PROCEDURE calcvarient VAR fattr : attr ; VAR fbase : preg ; VAR fdisp : integer ;
340 VAR ftag : tag ; EXTERNAL ;
341 PROCEDURE gencstecode farg : integer ; finst : istand ; EXTERNAL ;
342 PROCEDURE checkbnds errcode : integer ; freg : register ; fctp : ctp ; EXTERNAL ;
343 PROCEDURE freeallregisters ; EXTERNAL ;
344 PROCEDURE loadbase flev : integer ; EXTERNAL ;
345 PROCEDURE sauvereg freg : register ; fload : boolean ; EXTERNAL ;
346 PROCEDURE newbloc freg : register ; EXTERNAL ;
347 PROCEDURE regenere oldbloc : regpt ; EXTERNAL ;
348
349 * FROM DECLARE *
350 PROCEDURE push_lab_pdl ; EXTERNAL ;
351 PROCEDURE pop_lab_pdl ; EXTERNAL ;
352
353
354 $OPTIONS page $
355
356 * **************************************************************************** *
357 * * * *
358 * * * *
359 * * STATEMENT GROUP * *
360 * * * *
361 * * * *
362 * **************************************************************************** *
363
364 PROCEDURE statement ; FORWARD ;
365
366
367
368 $OPTIONS page $
369
370 * ********************************************** COMPSTAT ******************** *
371
372 PROCEDURE compstat ;
373
374 * C.USED TO COMPILE A COMPOUND STATEMENT.
375 "BEGIN" HAS BEEN READ.
376 .EXPECTS AN "END"
377 C *
378 * ERRORS DETECTED
379 13: "END" EXPECTED
380 14: ";" EXPECTED
381 61: ILLEGAL BEGINNING SYMBOL FOR A STATEMENT
382 E *
383 LABEL 1 ; * SKIP HERE WHEN A STATEMENT *
384 * CAN BEGIN *
385 BEGIN
386 freeallregisters ;
387 REPEAT
388 insymbol ;
389 1 : statement ;
390 freeallregisters ;
391 IF errcl no = begsy THEN
392 BEGIN
393 error 14 ; GOTO 1 ;
394 END ;
395 IF no = 25 * ELSE * THEN
396 BEGIN
397 error 61 ; insymbol ; GOTO 1 ;
398 END ;
399 UNTIL no # 16 * ; * ;
400 IF no = 22 * "END" * THEN
401 BEGIN
402 insymbol
403 END
404 ELSE error 13 ;
405 END * COMPSTAT * ;
406
407
408 $OPTIONS page $
409
410 * ************************************ WITHSTAT ****************************** *
411
412 PROCEDURE withstat ;
413
414 * C COMPILE THE PASCAL STATEMENT
415 WITH <REC> REC* DO <STATE>
416 C *
417 * E ERRORS DETECTED
418 54: "DO" EXPECTED
419 140: TYPE OF VARIABLE MUST BE RECORD
420 250: TOO MANY NESTED SCOPES OF IDENTIFIERS
421 E *
422 LABEL
423 10, * EXIT PROCEDURE *
424 20 ; * CALL STATEMENT *
425 * WITHOUT CALLING INSYMBOL *
426 VAR
427 oldtop, oldlcsave : integer ;
428 currentfather, withnode : blocknodeptr ;
429 withfile, withindex : integer ;
430 BEGIN * WITHSTAT *
431 $OPTIONS compile = trace $
432 IF stattrace > none THEN
433 BEGIN
434 write mpcogout '@@@ DEBUT WITHSTAT @@@ WITH TOPLCSAVE ' top lcsave ;
435 nextline ;
436 END ;
437 $OPTIONS compile = true $
438 withnode := NIL ;
439 currentfather := currentnode ;
440 oldtop := top ; * ACTUAL LEVEL REACHED IN DISPLAY *
441 oldlcsave := lcsave ;
442 lcsave := recadre lcsave bytesindword ;
443 IF lcsave > tmax THEN tmax := lcsave ;
444 REPEAT * LOOP ON RECORD'S LIST *
445 insymbol ;
446 withfile := symbolfile ;
447 withindex := symbolindex ;
448 freeallregisters ;
449 withvariable := true ;
450 currwithlist.nbr := 0 ;
451 variab false ; * NOT ALTERED HERE *
452 withvariable := false ;
453 WITH gattr DO
454 IF typtr # NIL THEN * NO ERROR *
455 IF typtr@.form # records THEN
456 error 140 ELSE
457 IF top >= displimit THEN
458 error 250 ELSE
459 BEGIN
460 top := top + 1 ;
461 WITH display top DO
462 BEGIN
463 fname := typtr@.fstfld ; * FIRST FIELD NAME IN THE RECORD *
464 new withnode withblock ;
465 IF withnode = NIL THEN heaperror ; * EXIT COMP *
466 WITH withnode^ DO
467 BEGIN
468 blocktp := withblock ;
469 father := currentnode ;
470 recordptr := typtr ;
471 wstrfile := withfile ; wstrindex := withindex ;
472 IF symbolfile = wstrfile THEN
473 wstrlength := symbolindex - withindex
474 ELSE wstrlength := 0 ;
475 brother := currentnode^.son ;
476 currentnode^.son := withnode ;
477 son := NIL ;
478 codebegin := statnbr * 2 ;
479 codeend := 0 ;
480 first := typtr^.fstfld ;
481 currentnode := withnode ;
482 IF varissimple gattr AND NOT typtr@.pack THEN
483 BEGIN * EASY TO ADDRESS *
484 occur := cwith ; clevel := vlev ; cdspl := dplmt ;
485 IF vlev = 0 THEN wbase := statics ELSE wbase := locals ;
486 wdispl := dplmt DIV bytesinword ; windirect := false ;
487 creflist := currwithlist ;
488 END * EASY * ELSE
489 BEGIN
490 occur := vwith ; vdspl := lcsave ;
491 lcsave := lcsave + bytesindword ;
492 IF lcsave > tmax THEN tmax := lcsave ; vpack := typtr@.pack ;
493 * BUILDS ITS POINTING ON THE RECORD *
494 loadadr gattr nreg ; freebloc currentbloc ;
495 genstand pr6 vdspl DIV bytesinword
496 prinst spri currentpr tn ;
497 wbase := locals ; wdispl := vdspl DIV bytesinword ; windirect := true ;
498 vreflist := currwithlist ;
499 END * NOT EASY * ;
500 END * WITH WITHNODE^ * ;
501 END * WITH DISPLAYTOP * ;
502 END * ALL IS OKWITH GATTR * ;
503 UNTIL no # 15 * * ;
504 IF no # 31 * DO * THEN
505 BEGIN
506 IF gattr.typtr # NIL THEN error 54 ;
507 skip 31 ;
508 IF no # 31 THEN
509 BEGIN
510 IF gattr.typtr = NIL THEN error 54 ;
511 IF errcl no = begsy THEN
512 GOTO 20 * STATEMENT * ELSE
513 GOTO 10 * END PROC * ;
514 END ;
515 END * NO#31 * ;
516 IF mapswitch THEN statement_ends symbolindex - sttindex ;
517 insymbol ;
518 20 :
519 freeallregisters ;
520 push_lab_pdl ; statement ; pop_lab_pdl ;
521 10 :
522 IF mapswitch THEN statement_ends symbolindex - sttindex ;
523 $OPTIONS compile = trace $
524 IF stattrace = high THEN
525 BEGIN
526 write mpcogout '* RETURN IN WITHSTAT . TOP LCSAVE ARE NOW' top lcsave ;
527 nextline ;
528 END ;
529 $OPTIONS compile = true $
530 WHILE currentnode <> currentfather DO
531 BEGIN
532 currentnode^.codeend := statnbr * 2 ;
533 currentnode := currentnode^.father ;
534 END ;
535 top := oldtop ;
536 lcsave := oldlcsave ;
537 $OPTIONS compile = trace $
538 IF stattrace > low THEN
539 BEGIN
540 write mpcogout '@@@ FIN WITHSTAT @@@ WITH NOTOP LCSAVE ' no top lcsave ;
541 nextline ;
542 END ;
543 $OPTIONS compile = true $
544 END * WITHSTAT * ;
545
546
547 $OPTIONS page $
548
549 * ************************************ ASSIGN ******************************** *
550
551 PROCEDURE assign ;
552
553 * C COMPILATION OF
554 <VARIABLE> := <EXPRESSION>
555 C *
556 * E ERRORS DETECTED
557 29: Same length strings expected
558
559 51: ":=" EXPECTED
560 109: REAL TO INT NOT ALLOWED
561 145: TYPE CONFLICT
562 146: FILES NOT ALLOWED HERE
563 197: TRUNCATION NOT ALLOWED
564 303: VALUE ASSIGNED OUT OF BOUNDS
565 E *
566 VAR
567 check_done, len_in_desc : boolean ;
568 strlen : integer ;
569 locarray : setarray ; lretpt : lcstpt ;
570 lbloc, rbloc : regpt ;
571 lattr, tattr : attr ;
572 generic : ctp ;
573 lbase, rbase, lpr, rpr : preg ;
574 ldisp, lsize, rsize, rdisp, lmod, rmod, suplr : integer ;
575 ltag, lftag, rgtag : tag ;
576 asserr, ended : boolean ;
577 ddisp, target_length, loc1 : integer ;
578 temp : ctp ;
579 rqbox : regpt ;
580 BEGIN * ASSIGN *
581 $OPTIONS compile = trace $
582 IF stattrace > none THEN
583 BEGIN
584 write mpcogout '@@@ DEBUT ASSIGN @@@' ; nextline ;
585 END ;
586 $OPTIONS compile = true $
587 * LEFT PART *
588 check_done := false ;
589 len_in_desc := false ;
590 asserr := false ;
591 variable true ;
592 lattr := gattr ;
593 IF no # 20 * := * THEN
594 BEGIN
595 IF gattr.typtr # NIL THEN error 51 ;
596 skip 20 ;
597 END ;
598 IF no = 20 * := * THEN
599 BEGIN
600 insymbol ;
601 expression ; * RIGHT PART OF ASSIGNMENT *
602 WITH gattr DO
603 IF typtr = NIL THEN
604 BEGIN
605 skip 46 ; generic := NIL ;
606 END ELSE
607 BEGIN
608 compatbin lattr.typtr typtr generic ;
609 IF generic = NIL THEN
610 asserr := true ;
611 END ;
612 IF asserr THEN * TRY STRING ASSIGNMENT *
613 IF lattr.typtr <> NIL
614 THEN IF lattr.typtr^.father_schema = string_ptr THEN * TARGET IS A STRING *
615 WITH gattr DO
616 IF typtr = charptr * RIGHT PART IS A CHARACTER * THEN
617 BEGIN
618 IF varissimple lattr THEN
619 BEGIN
620 lbase := lattr.basereg ; ldisp := lattr.dplmt DIV bytesinword ;
621 currentbloc := NIL ;
622 END ELSE BEGIN
623 loadadr lattr nreg ; lbase := currentpr ;
624 ldisp := 0
625 END ;
626 CASE kind OF
627 sval : BEGIN
628 IF currentbloc <> NIL THEN freebloc currentbloc ;
629 locarray 0 := 1 ; locarray 1 := val * twoto27 ;
630 enterlcst locarray lretpt ;
631 enterundlab lretpt^.lplace ;
632 genstand nreg 0 iepp3 tic ;
633 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
634 geneism imlr ord ' ' p0t0r0 ;
635 gendesca pr3 0 0 l9 5 tn ;
636 WITH lattr DO
637 IF kind = varbl THEN usednameaddr := nameaddr ;
638 gendesca lbase ldisp 0 l9 5 tn ;
639 END ;
640 lval : BEGIN
641 IF currentbloc <> NIL THEN freebloc currentbloc ;
642 genstand nreg 27 opaq shiftl ldreg tn ;
643 genstand lbase ldisp + 1 opaq stor ldreg tn ;
644 genstand nreg 1 opaq load ldreg tdl ;
645 genstand lbase ldisp opaq stor ldreg tn ;
646 END ;
647 varbl : BEGIN
648 lbloc := currentbloc ;
649 IF varissimple gattr THEN
650 BEGIN
651 rbase := gattr.basereg ; rdisp := gattr.dplmt DIV bytesinword ;
652 END ELSE BEGIN
653 loadadr gattr nreg ; rbase := currentpr ;
654 rdisp := 0 ; freebloc currentbloc ;
655 END ;
656 IF lbloc <> NIL THEN BEGIN
657 regenere lbloc ; freebloc lbloc ;
658 END ELSE IF lattr.basebloc <> NIL THEN regenere lattr.basebloc ;
659 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
660 geneism imlr ord ' ' p0t0r0 ;
661 usednameaddr := gattr.nameaddr ;
662 IF pckd THEN gendesca rbase rdisp 0 l9 1 tn
663 ELSE gendesca rbase rdisp 3 l9 1 tn ;
664 usednameaddr := lattr.nameaddr ;
665 gendesca lbase ldisp + 1 0 l9 1 tn ;
666 genstand nreg 1 ilda tdl ;
667 genstand lbase ldisp ista tn ;
668 END
669 END ;
670 freeattr gattr ; freeattr lattr ;
671 END
672 ELSE
673 IF isstring gattr THEN
674 IF lattr.typtr^.actual_parameter_list = NIL THEN * nothing *
675 ELSE
676 BEGIN
677 loadadr lattr nreg ; * ADDRESS OF TARGET *
678 lpr := currentpr ; lbloc := currentbloc ;
679 IF conformantdim gattr.typtr THEN
680 BEGIN
681 init_desc_address gattr.nameaddr gattr ;
682 sauvereg rq false ;
683 regenere gattr.descbloc ;
684 genstand gattr.descreg 1 isbq tn ;
685 genstand gattr.descreg 0 isbq tn ;
686 genstand nreg 1 iadq tdl ;
687 rpr := gattr.basereg ; rbloc := gattr.basebloc ;
688 END
689 ELSE BEGIN * NOT CONFORMANT *
690 loadadr gattr nreg ;
691 rpr := currentpr ; rbloc := currentbloc ;
692 CASE kind OF
693 chain : strlen := alfactp^.alfalong ;
694 varbl : strlen := typtr^.hi - typtr^.lo + 1 ;
695 END ;
696 sauvereg rq false ;
697 gencstecode strlen ildq ;
698 IF asscheck THEN
699 IF lattr.typtr^.actual_parameter_list^.klass = konst THEN
700 IF strlen > lattr.typtr^.actual_parameter_list^.values THEN
701 error 273 ;
702 check_done := true ;
703 END ;
704 WITH lattr.typtr^.actual_parameter_list^ DO
705 IF klass = konst THEN
706 IF values < twoto12 THEN len_in_desc := true ELSE
707 gencstecode values ilda
708 ELSE BEGIN
709 addressvar lattr.typtr^.actual_parameter_list tattr false ;
710 transfer tattr inacc ; freeattr tattr ;
711 END ;
712 regenere rbloc ; regenere lbloc ;
713 IF len_in_desc THEN mfari2 := a1r0i0 ELSE
714 mfari2 := a1r1i0 ; mfari1 := a1r1i0 ;
715 geneism imlr ord ' ' p0t0r0 ;
716 gendesca rpr 0 0 l9 0 tql ;
717 IF len_in_desc THEN
718 gendesca lpr 1 0 l9 lattr.typtr^.actual_parameter_list^.values tn
719 ELSE
720 gendesca lpr 1 0 l9 0 tal ;
721 genstand lpr 0 istq tn ;
722 freebloc rbloc ;
723 IF asscheck THEN
724 IF NOT check_done THEN
725 BEGIN
726 genstand lpr 0 icmpa tn ;
727 loc1 := indfich ; genstand nreg 0 itpl tic ;
728 genexceptcode stringlength_assignment_error rq ;
729 inser cb loc1 ;
730 END ;
731 freebloc lbloc ;
732 freeattr gattr ; freeattr lattr ;
733 END
734 ELSE IF gattr.typtr^.father_schema = string_ptr THEN
735 IF lattr.typtr^.actual_parameter_list = NIL THEN * nothing *
736 ELSE
737 BEGIN
738 loadadr lattr nreg ;
739 lpr := currentpr ; lbloc := currentbloc ;
740 loadadr gattr nreg ;
741 rpr := currentpr ; rbloc := currentbloc ;
742 IF asscheck THEN
743 BEGIN
744 WITH lattr.typtr^.actual_parameter_list^ DO
745 IF klass = konst THEN
746 IF gattr.typtr^.actual_parameter_list^.klass <> konst THEN
747 gencstecode values ilda
748 ELSE BEGIN
749 IF values >= gattr.typtr^.actual_parameter_list^.values THEN check_done := true
750 END
751 ELSE BEGIN
752 addressvar lattr.typtr^.actual_parameter_list tattr false ;
753 transfer tattr inacc ; freeattr tattr ;
754 END ;
755 genstand rpr 0 icmpa tn ;
756 loc1 := indfich ; genstand nreg 0 itpl tic ;
757 genexceptcode stringlength_assignment_error ra ;
758 inser cb loc1 ;
759 END ;
760 regenere rbloc ; regenere lbloc ;
761 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
762 genstand rpr 0 ildq tn ; genstand nreg 4 iadq tdl ;
763 geneism imlr ord ' ' p0t0r0 ;
764 gendesca rpr 0 0 l9 0 tql ;
765 gendesca lpr 0 0 l9 0 tql ;
766 freebloc lbloc ; freebloc rbloc ;
767 freeattr gattr ; freeattr lattr ;
768 END
769 ELSE error 145
770 ELSE error 145 ;
771 IF generic # NIL THEN
772 WITH gattr DO
773 CASE generic@.form OF
774 reel :
775 BEGIN
776 IF gattr.typtr # realptr THEN
777 convreal gattr ELSE
778 IF lattr.typtr # realptr THEN
779 error 109 ;
780 transfer gattr inacc ;
781 transfer lattr out ;
782 END * REEL * ;
783 numeric, scalar :
784 BEGIN
785 IF kind = sval THEN
786 checkminmax val lattr.typtr 303 ELSE
787 IF asscheck THEN
788 BEGIN
789 choicerarq ;
790 checkbnds asserrcode ldreg lattr.typtr ;
791 END * asschecks * ;
792 ended := false ;
793 IF kind = sval THEN
794 BEGIN
795 IF lattr.pckd THEN
796 BEGIN
797 IF lattr.access # pointable THEN
798 IF lattr.inxbloc = NIL THEN
799 IF lattr.inxmem = 0 THEN
800 IF packedsize lattr.typtr = byteinbyte
801 * SHORTER SAID 1 *
802 THEN
803 BEGIN
804 IF val < 0 THEN * 2'S COMPLEMENT *
805 val := val + twoto9 ;
806 calcvarient lattr lbase ldisp ltag ;
807 mfari1 := a0r0i0 ; * DUMMY *
808 mfari2 := a1r0i0 ;
809 mfreg2 := ltag ;
810 geneism imlr val p0t0r0 ;
811 gendesca nreg 0 0 l9 0 tn ;
812 WITH lattr DO
813 IF kind = varbl THEN usednameaddr := nameaddr ELSE
814 IF kind = chain THEN usednameaddr := alfactp ;
815 gendesca lbase ldisp
816 lattr.dplmt MOD bytesinword l9 byteinbyte tn ;
817 ended := true ;
818 END * SIZE 1 * ;
819 END * LATTR.PCKD * ELSE
820 IF val = 0 THEN
821 BEGIN
822 calcvarient lattr lbase ldisp ltag ;
823 WITH lattr DO
824 IF kind = varbl THEN usednameaddr := nameaddr ELSE
825 IF kind = chain THEN usednameaddr := alfactp ;
826 genstand lbase ldisp istz ltag ;
827 ended := true ;
828 END * VAL=0 * ;
829 END * KIND=SVAL * ;
830 IF NOT ended THEN
831 BEGIN
832 choicerarq ;
833 transfer lattr out ;
834 END * NOT ENDED * ;
835 END * NUMERICSCALAR * ;
836 power, pointer :
837 IF typtr = lamptr THEN
838 BEGIN
839 IF varissimple lattr THEN
840 BEGIN
841 lbase := lattr.basereg ;
842 ldisp := lattr.dplmt DIV bytesinword ;
843 END ELSE
844 BEGIN
845 loadadr lattr nreg ; lbase := currentpr ;
846 freebloc currentbloc ; ldisp := 0 ;
847 lattr.dplmt := 0 ;
848 END ;
849 IF lattr.pckd THEN
850 lsize := packedsize lattr.typtr ELSE
851 lsize := lattr.typtr@.size ;
852 mfari1 := a0r0i0 ; * DUMMY * mfari2 := a1r0i0 ;
853 geneism imlr 0 * FILL BYTE * p0t0r0 ;
854 gendesca nreg 0 0 l9 0 tn ;
855 WITH lattr DO
856 IF kind = varbl THEN usednameaddr := nameaddr ELSE
857 IF kind = chain THEN usednameaddr := alfactp ;
858 gendesca lbase ldisp lattr.dplmt MOD bytesinword l9 lsize tn ;
859 END * LAMPTR * ELSE
860 BEGIN
861 IF generic^.form = power THEN
862 IF gattr.kind = sval THEN
863 BEGIN
864 checkminmax gattr.val MOD 1000 lattr.typtr^.elset 305 ;
865 checkminmax gattr.val DIV 1000 lattr.typtr^.elset 305 ;
866 END ;
867 transfer gattr inacc ;
868 transfer lattr out ;
869 END ;
870 arrays, records :
871 IF NOT conformantdim lattr.typtr THEN
872 BEGIN
873 lsize := lattr.typtr@.size ;
874 IF isstring gattr THEN
875 BEGIN
876 IF kind = chain THEN
877 rsize := alfactp@.alfalong ELSE
878 rsize := typtr@.size ;
879 IF lsize < rsize THEN
880 error 197 ;
881 END * ISSTRING * ELSE
882 rsize := lsize ;
883 rbase := nreg ;
884 IF kind # chain THEN
885 IF varissimple gattr THEN
886 BEGIN
887 rbase := basereg ;
888 rdisp := dplmt DIV bytesinword ; rmod := dplmt MOD bytesinword ;
889 END ;
890 IF rbase = nreg THEN
891 BEGIN
892 loadadr gattr pr3 ;
893 rbase := pr3 ; rdisp := 0 ; rmod := 0 ;
894 END ;
895 IF varissimple lattr THEN
896 BEGIN
897 lbase := lattr.basereg ; ldisp := lattr.dplmt DIV bytesinword ;
898 lmod := lattr.dplmt MOD bytesinword ;
899 END ELSE
900 BEGIN
901 lbase := pr2 ; loadadr lattr pr2 ; ldisp := 0 ;
902 lmod := 0 ;
903 END ;
904 suplr := sup rsize lsize ;
905 IF envstandard <> stdextend THEN
906 IF rsize <> lsize THEN
907 error 29 ;
908 IF suplr < twoto12 THEN
909 BEGIN
910 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; lftag := tn ; rgtag := tn ;
911 END ELSE
912 BEGIN
913 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ; lftag := tx6 ; rgtag := tx7 ;
914 IF suplr > twoto17m1 THEN
915 error 307 ELSE
916 BEGIN
917 genstand nreg lsize ieax6 tn ;
918 genstand nreg rsize ieax7 tn ;
919 END ;
920 lsize := 0 ; rsize := 0 ;
921 END ;
922 geneism imlr ord ' ' p0t0r0 ;
923 WITH gattr DO
924 IF kind = varbl THEN usednameaddr := nameaddr ELSE
925 IF kind = chain THEN usednameaddr := alfactp ;
926 gendesca rbase rdisp rmod l9 rsize rgtag ;
927 WITH lattr DO
928 IF kind = varbl THEN usednameaddr := nameaddr ELSE
929 IF kind = chain THEN usednameaddr := alfactp ;
930 gendesca lbase ldisp lmod l9 lsize lftag ;
931 END * array not conf records * ELSE
932 BEGIN
933 init_desc_address lattr.nameaddr lattr ;
934 * COMPUTE SIZE NOW *
935 sauvereg rq true ; sauvereg ra false ;
936 rqbox := currentbloc ;
937
938 ddisp := 0 ;
939 temp := lattr.typtr ;
940 WHILE conformantdim temp^.aeltype DO
941 BEGIN
942 ddisp := ddisp + 3 ;
943 temp := temp^.aeltype ;
944 END ;
945 regenere lattr.descbloc ;
946 genstand lattr.descreg 1 + ddisp ildq tn ; * MAX *
947 genstand lattr.descreg ddisp isbq tn ; * - MIN *
948 genstand nreg 1 iadq tdl ; * +1 *
949 genstand lattr.descreg 2 + ddisp impy tn ; * * SUBSIZE *
950 IF NOT lattr.typtr^.pack THEN * SIZE IS IN WORDS *
951 genstand nreg 2 iqls tn ; * IN BYTES NOW *
952 freebloc lattr.descbloc ;
953
954 init_desc_address gattr.nameaddr gattr ;
955 freebloc gattr.descbloc ;
956
957 mfari1 := a1r1i0 ;
958 mfari2 := a1r1i0 ;
959 regenere rqbox ; regenere lattr.basebloc ; regenere gattr.basebloc ;
960 IF lattr.typtr^.pack THEN * SIZE IS IN BITS *
961 BEGIN
962 geneism icsl 3 p0t0r0 ;
963 gendescb gattr.basereg 0 0 0 0 tql ;
964 gendescb lattr.basereg 0 0 0 0 tql ;
965 END
966 ELSE
967 BEGIN
968 geneism imlr ord ' ' p0t0r0 ;
969 gendesca gattr.basereg 0 0 l9 0 tql ;
970 gendesca lattr.basereg 0 0 l9 0 tql ;
971 END ;
972
973 freeattr gattr ; freeattr lattr ; freebloc rqbox ;
974 END ;
975 files : error 146 ;
976 END * CASE GENERIC@.FORMWITH GATTR * ;
977 END * NO=20 * ;
978 IF mapswitch THEN statement_ends symbolindex - sttindex ;
979 $OPTIONS compile = trace $
980 IF stattrace > low THEN
981 BEGIN
982 write mpcogout '@@@ FIN ASSIGN @@@ WITH NO' no : 4 ; nextline ;
983 END ;
984 $OPTIONS compile = true $
985 END * ASSIGN * ;
986
987
988 $OPTIONS page $
989
990 * ************************************ REPEATSTAT **************************** *
991
992 PROCEDURE repeatstat ;
993
994 * C .COMPILATION OF REPEAT <STATE> ;STATE* UNTIL <EXPRESSION>
995 .GENJUMP GENERATES A SKIP IF FALSE
996 C *
997 * E ERRORS DETECTED
998 6: TYPE OF EXPRESSION MUST BE BOOLEAN
999 14: ";" EXPECTED
1000 53: "UNTIL" EXPECTED
1001 61: ILLEGAL BEGINNING SYMBOL FOR A STATEMENT
1002 E *
1003 LABEL
1004 10, * INSYMBOL BEFORE CALL OF STATEMENT *
1005 20 ; * CALL OF STATEMENT *
1006 VAR
1007 locrpt : integer ;
1008 dummy : integer ;
1009 BEGIN * REPEATSTAT *
1010 $OPTIONS compile = trace $
1011 IF stattrace > none THEN
1012 BEGIN
1013 write mpcogout '@@@ DEBUT REPEATSTAT @@@' ; nextline ;
1014 END ;
1015 $OPTIONS compile = true $
1016 locrpt := cb ; * RETURN PLACE *
1017 push_lab_pdl ;
1018 REPEAT * LOOP ON STATEMENTS *
1019 10 :
1020 insymbol ;
1021 20 :
1022 freeallregisters ;
1023 statement ;
1024 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1025 IF errcl no = begsy THEN
1026 BEGIN
1027 error 14 ; GOTO 20 ;
1028 END ;
1029 IF no = 25 * ELSE * THEN
1030 BEGIN
1031 error 61 ; GOTO 10 ;
1032 END ;
1033 UNTIL no # 16 * ; * ;
1034 pop_lab_pdl ;
1035 IF no # 29 * UNTIL * THEN
1036 error 53 ELSE
1037 BEGIN
1038 IF mapswitch THEN statement_begins true ;
1039 insymbol ;
1040 freeallregisters ;
1041 expression ;
1042 IF gattr.typtr # NIL THEN
1043 BEGIN
1044 IF gattr.typtr # boolptr THEN
1045 error 6 ELSE
1046 genjump dummy locrpt ;
1047 END ELSE
1048 skip 46 ;
1049 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1050 END * UNTIL FOUND * ;
1051 $OPTIONS compile = trace $
1052 IF stattrace > low THEN
1053 BEGIN
1054 write mpcogout '@@@ FIN REPEATSTAT @@@ WITH NO' no : 4 ; nextline ;
1055 END ;
1056 $OPTIONS compile = true $
1057 END * REPEATSTAT * ;
1058
1059
1060 $OPTIONS page $
1061
1062 * ************************************ WHILESTAT ***************************** *
1063
1064 PROCEDURE whilestat ;
1065
1066 * C COMPILATION OF WHILE <EXP> DO <STATE>
1067 C *
1068 * E ERRORS DETECTED
1069 6: BOOLEAN EXPRESSION EXPECTED
1070 54: "DO" EXPECTED
1071 E *
1072 LABEL
1073 10, * EXIT PROCEDURE *
1074 * SKIPS CALL OF STATEMENT *
1075 20 ; * CALL OF STATEMENT *
1076 VAR
1077 locret, locskip : integer ;
1078 BEGIN * WHILESTAT *
1079 $OPTIONS compile = trace $
1080 IF stattrace > none THEN
1081 BEGIN
1082 write mpcogout '@@@ DEBUT WHILESTAT @@@' ; nextline ;
1083 END ;
1084 $OPTIONS compile = true $
1085 locret := cb ;
1086 locskip := 0 ; * DEFAULT MEANS NO INSER *
1087 insymbol ;
1088 freeallregisters ;
1089 expression ;
1090 IF gattr.typtr # NIL THEN
1091 BEGIN
1092 IF gattr.typtr # boolptr THEN
1093 error 6 ELSE
1094 genjump locskip 0 ;
1095 END ;
1096 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1097 IF no # 31 * DO * THEN
1098 BEGIN
1099 IF gattr.typtr # NIL THEN error 54 ;
1100 skip 31 ;
1101 IF no # 31 THEN
1102 BEGIN
1103 IF gattr.typtr = NIL THEN error 54 ;
1104 IF errcl no = begsy THEN
1105 GOTO 20 ELSE
1106 GOTO 10 ;
1107 END ;
1108 END * NO#31 * ;
1109 insymbol ;
1110 20 :
1111 freeallregisters ;
1112 push_lab_pdl ; statement ; pop_lab_pdl ;
1113 genstand nreg locret - cb DIV bytesinword itra tic ;
1114 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1115 IF locskip # 0 THEN
1116 inser cb locskip ;
1117 10 :
1118 $OPTIONS compile = trace $
1119 IF stattrace > low THEN
1120 BEGIN
1121 write mpcogout '@@@ FIN WHILESTAT @@@ WITH NO:' no : 4 ; nextline ;
1122 END ;
1123 $OPTIONS compile = true $
1124 END * WHILESTAT * ;
1125
1126
1127 $OPTIONS page $
1128
1129 * ************************************ FORSTAT ******************************* *
1130
1131 PROCEDURE forstat ;
1132
1133 * C CHECKS CONTROL VARIABLE
1134 COMPUTE FIRST EXP
1135 COMPUTE SECOND EXP
1136 STORE IF NOT SVAL
1137 TEST ONE EXECUT
1138 E1 STORE FIRST IN CONTROL
1139 E2
1140 <STATEMENT>
1141 RELOAD CONTROL
1142 TEST ENDED
1143 YES GOTO E3
1144 NO IF"TO" AOS GOTO E2
1145 IF "DOWNTO" SUB 1GOTO E1
1146 E3
1147 C *
1148 * E ERRORS DETECTED
1149 2: ID. EXPECTED
1150 51: ":=" EXPECTED
1151 54: "DO" EXPECTED
1152 55: "TO/DOWNTO" EXPECTED
1153 103: ID. IS NOT OF APPROPRIATE CLASS
1154 104: ID. NOT DECLARED
1155 145: TYPE CONFLICT
1156 194: CONTROL VARIABLE MUST BE DECLARED AND USED AT SAME LEVEL
1157 195: SCALAR OR NUMERIC FOR CONTROL VARIABLE
1158 196: VARIABLE MUST NOT BE ASSIGNED
1159 199: CONTROL VARIABLE CANNOT BE FORMAL OR EXPORTABLE
1160 303: VALUE ASSIGNED OUT OF BOUNDS
1161 E *
1162 LABEL
1163 10, * EXIT PROC *
1164 20 ; * STATEMENT *
1165 VAR
1166 lptcont : ctp ; * NIL IF ERROR ON CONTROL VARIABLE *
1167 lstate : integer ; * REACHES 3 IF NO ERROR *
1168 oldlcsave, retdispw : integer ;
1169 controlnameaddr, typvar, generic : ctp ;
1170 ldispw, lcl, supval, highdispw, locskip1, locskip2, downret, toret : integer ;
1171 lbase : preg ;
1172 totransfer, skipall, lcompare, supissval : boolean ;
1173 lattr : attr ;
1174 ldest : destination ;
1175 lstor, ejump, bjump, lsub, lcomp, lload : istand ;
1176 BEGIN * FORSTAT *
1177 $OPTIONS compile = trace $
1178 IF stattrace > none THEN
1179 BEGIN
1180 write mpcogout '@@@ DEBUT FORSTAT @@@ WITH LCSAVE:' lcsave ; nextline ;
1181 END ;
1182 $OPTIONS compile = true $
1183 controlnameaddr := NIL ;
1184 lstate := 0 ; * MUST BE 3 IF NO ERROR *
1185 oldlcsave := lcsave ;
1186 highdispw := lcsave DIV bytesinword ;
1187 lcsave := lcsave + bytesinword ;
1188 IF lcsave > tmax THEN tmax := lcsave ;
1189 lptcont := NIL ; * DEFAULT IF ERROR *
1190 typvar := NIL ;
1191 insymbol ; * CONTROL VARIABLE *
1192 IF no # 1 THEN
1193 error 2 ELSE
1194 BEGIN
1195 search ;
1196 IF ctptr = NIL THEN
1197 error 104 ELSE
1198 BEGIN
1199 IF symbolmap THEN nameisref ctptr symbolfile -symbolline ;
1200 IF ctptr@.klass # vars THEN
1201 error 103 ELSE
1202 IF ctptr@.vtype # NIL THEN
1203 IF NOT ctptr@.vtype@.form IN numeric scalar THEN
1204 error 195 ELSE
1205 BEGIN lstate := 1 ; * NO ERROR HERE FLAG *
1206 IF ctptr@.vlevel # level THEN error 194 ;
1207 IF ctptr@.visreadonly THEN error 196 ;
1208 IF ctptr@.vkind # actual THEN error 199 ;
1209 lptcont := ctptr ; typvar := ctptr@.vtype ;
1210 ldispw := ctptr@.vaddr DIV bytesinword ;
1211 IF level = 0 THEN
1212 lbase := prstatic ELSE lbase := pr6 ;
1213 controlnameaddr := ctptr ;
1214 WITH ctptr@ DO
1215 BEGIN
1216 visused := true ;
1217 visset := true ; * VISREADONLY AFTER "DO" *
1218 END ;
1219 insymbol ;
1220 END ;
1221 END ;
1222 END * NO=1 * ;
1223 * CHECK := *
1224 IF no # 20 THEN
1225 BEGIN
1226 IF lptcont # NIL THEN error 51 ;
1227 skip 20 ;
1228 IF no # 20 THEN
1229 BEGIN lstate := 0 ; * ERROR FLAG *
1230 IF lptcont = NIL THEN error 51 ;
1231 IF errcl no = begsy THEN
1232 GOTO 20 * STATEMENT * ELSE
1233 GOTO 10 * EXIT PROC * ;
1234 END ;
1235 END ;
1236 * ANALYSIS OF FIRST EXPRESSION *
1237 freeallregisters ;
1238 insymbol ; expression ;
1239 compatbin typvar gattr.typtr generic ;
1240 IF generic = NIL OR generic = realptr THEN
1241 error 145 ELSE
1242 BEGIN * NO TYPE ERROR *
1243 WITH gattr DO
1244 IF kind = sval THEN
1245 checkminmax val typvar 303 ELSE
1246 BEGIN * NOT SVAL *
1247 totransfer := true ;
1248 IF kind = varbl THEN
1249 IF NOT asscheck THEN
1250 IF varissimple gattr THEN
1251 totransfer := false ;
1252 IF totransfer THEN
1253 BEGIN
1254 IF kind # lval THEN
1255 transfer gattr inq ;
1256 IF asscheck THEN
1257 checkbnds forerricode ldreg typvar ;
1258 END * TOTRANSFER * ;
1259 END * NOT SVAL WITH GATTR * ;
1260 lstate := lstate + 1 ; * NO ERROR HERE FLAG *
1261 END * NO TYPE ERROR * ;
1262 * ANALYSIS OF TO/DOWNTO *
1263 IF no # 33 * TO/DOWNTO * THEN
1264 BEGIN
1265 IF gattr.typtr # NIL THEN error 55 ;
1266 skip 33 ;
1267 IF no # 33 THEN
1268 BEGIN lstate := 0 ; * ERROR FLAG *
1269 IF gattr.typtr = NIL THEN error 55 ;
1270 IF errcl no = begsy THEN
1271 GOTO 20 * STATE * ELSE
1272 GOTO 10 ; * END PROC *
1273 END ;
1274 END * NO#33 * ;
1275 * ANALYSIS OF ENDING EXPRESSION *
1276 lcl := cl ; * 1:TO 2:DOWNTO *
1277 lattr := gattr ;
1278 insymbol ; expression ;
1279 compatbin typvar gattr.typtr generic ;
1280 IF generic = NIL OR generic = realptr THEN
1281 error 145 ELSE
1282 BEGIN * NO TYPE ERR *
1283 WITH gattr DO
1284 IF kind = sval THEN
1285 BEGIN
1286 supissval := true ; supval := val ;
1287 checkminmax val typvar 303 ;
1288 END * SVAL * ELSE
1289 BEGIN * NOT SVAL *
1290 supissval := false ;
1291 IF kind # lval THEN
1292 BEGIN
1293 IF lattr.kind # lval THEN ldest := inacc ELSE
1294 IF lattr.ldreg = ra THEN ldest := inq ELSE ldest := inacc ;
1295 transfer gattr ldest ;
1296 END ;
1297 IF asscheck THEN
1298 checkbnds forerrscode ldreg typvar ;
1299 usednameaddr := controlnameaddr ;
1300 genstand pr6 highdispw opaq stor ldreg tn ;
1301 freebloc ldregbloc ;
1302 END * NOT SVALWITH GATTR * ;
1303 lstate := lstate + 1 ; * NO ERROR HERE *
1304 END * NO TYPE ERROR * ;
1305 * ANALYSIS FOR DO *
1306 IF no # 31 * DO * THEN
1307 BEGIN
1308 IF gattr.typtr # NIL THEN error 54 ;
1309 skip 31 ;
1310 IF no # 31 THEN
1311 BEGIN lstate := 0 ; * ERROR FLAG *
1312 IF gattr.typtr = NIL THEN error 54 ;
1313 IF errcl no = begsy THEN
1314 GOTO 20 * STATEMENT * ELSE
1315 GOTO 10 * EXIT PROC * ;
1316 END ;
1317 END * NO # 31 * ;
1318 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1319 * CODE GENERATION *
1320 IF lstate = 3 * NO ERROR * THEN
1321 BEGIN
1322 skipall := false ; lcompare := true ;
1323 IF lattr.kind = sval THEN
1324 BEGIN
1325 IF supissval THEN
1326 BEGIN
1327 lcompare := false ;
1328 IF lcl = 1 * TO * THEN
1329 BEGIN
1330 IF lattr.val > supval THEN skipall := true ;
1331 END ELSE * DOWNTO *
1332 IF lattr.val < supval THEN skipall := true ;
1333 END * SUPISSVAL * ;
1334 END * LATTR IS SVAL * ELSE
1335 IF lattr.kind = lval THEN
1336 lvalvarbl lattr ;
1337 IF lattr.kind # lval THEN
1338 transfer lattr inacc ;
1339 IF lattr.ldreg = ra THEN
1340 BEGIN
1341 lcomp := icmpa ; lstor := ista ; lload := ilda ; lsub := isba ;
1342 END * RA * ELSE
1343 BEGIN * RQ *
1344 lcomp := icmpq ; lstor := istq ; lload := ildq ; lsub := isbq ;
1345 END * RQ * ;
1346 IF lcl = 1 * TO * THEN
1347 BEGIN bjump := itpnz ; ejump := itpl ; END ELSE
1348 BEGIN bjump := itmi ; ejump := itmoz END ;
1349 IF skipall THEN
1350 BEGIN
1351 locskip1 := indfich ; genstand nreg 0 itra tic ;
1352 END ELSE
1353 IF lcompare THEN
1354 BEGIN
1355 IF supissval THEN
1356 gencstecode supval lcomp ELSE
1357 genstand pr6 highdispw lcomp tn ;
1358 locskip1 := indfich ; genstand nreg 0 bjump tic ;
1359 END * LCOMPARE * ELSE locskip1 := 0 ;
1360 downret := cb ; usednameaddr := controlnameaddr ; genstand lbase ldispw lstor tn ;
1361 freebloc lattr.ldregbloc ;
1362 toret := cb ;
1363 END * NO ERROR * ;
1364 insymbol ;
1365 20 :
1366 IF lptcont # NIL THEN lptcont@.visreadonly := true ;
1367 freeallregisters ;
1368 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1369 push_lab_pdl ; statement ; pop_lab_pdl ;
1370 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1371 * NOW ENDING OF LOOP *
1372 IF lstate = 3 * NO ERROR * THEN
1373 BEGIN
1374 * RELOAD CONTROL VARIABLE *
1375 IF mapswitch THEN statement_begins true ;
1376 usednameaddr := controlnameaddr ;
1377 genstand lbase ldispw lload tn ;
1378 IF supissval THEN
1379 gencstecode supval lcomp ELSE
1380 genstand pr6 highdispw lcomp tn ;
1381 locskip2 := indfich ; genstand nreg 0 ejump tic ;
1382 IF lcl = 1 THEN
1383 BEGIN
1384 usednameaddr := controlnameaddr ;
1385 genstand lbase ldispw iaos tn ;
1386 retdispw := toret - cb DIV bytesinword ;
1387 END ELSE
1388 BEGIN * DOWNTO *
1389 genstand nreg 1 lsub tdl ;
1390 retdispw := downret - cb DIV bytesinword ;
1391 END * DOWNTO * ;
1392 genstand nreg retdispw itra tic ;
1393 IF locskip1 # 0 THEN inser cb locskip1 ;
1394 inser cb locskip2 ;
1395 END * LSTATE=3 NO ERROR * ;
1396 IF lptcont # NIL THEN
1397 lptcont@.visreadonly := false ;
1398 10 : * EXIT PROC *
1399 lcsave := oldlcsave ;
1400 IF mapswitch THEN statement_ends 3 ; * "end" *
1401 $OPTIONS compile = trace $
1402 IF stattrace > low THEN
1403 BEGIN
1404 write mpcogout '@@@ FIN FORSTAT @@@ WITH LCSAVENO' lcsave no ; nextline ;
1405 END ;
1406 $OPTIONS compile = true $
1407 END * FORSTAT * ;
1408
1409
1410 $OPTIONS page $
1411
1412 * ************************************ GOTOSTAT ****************************** *
1413
1414 PROCEDURE gotostat ;
1415
1416 * C .INSTRUCTION COMPILED IS GOTO <INTEGER> .
1417 .ALL DECLARED LABELS ARE IN LABTAB FROM 1 TO CLABIX
1418 .IF DECLARED LEVEL IS CURRENT LEVEL THEN IT IS A LOCAL GOTO
1419 FORWARDS IF LABDEF=0 BACKWARDS OTHERWISE.
1420 IF NOT RETURNS IN A PREVIOUS PROC THEN IT IS NECESSARY TO CLOSE
1421 LOCAL LIVING FILES AND TO GET THE OLD STACK FRAME.
1422 C *
1423 * E ERRORS DETECTED
1424 15: INTEGER EXPECTED
1425 167: UNDECLARED LABEL
1426 E *
1427 LABEL
1428 20 ; * EXIT OF LOOP *
1429 VAR
1430 it : integer ;
1431 refbox : refptr ;
1432 BEGIN * GOTOSTAT *
1433 $OPTIONS compile = trace $
1434 IF stattrace > none THEN
1435 BEGIN
1436 write mpcogout '@@@ DEBUT GOTOSTAT @@@' ; nextline ;
1437 END ;
1438 $OPTIONS compile = true $
1439 insymbol ;
1440 IF no # 2 OR cl # 1 THEN * NOT AN INTEGER CSTE *
1441 BEGIN
1442 error 15 ; skip 46 ;
1443 END ELSE
1444 BEGIN
1445 * SEARCHS IVAL IN LABTAB *
1446 FOR it := clabix DOWNTO 1 DO
1447 WITH labtab it DO
1448 IF labval = ival THEN * LABEL FOUND *
1449 BEGIN
1450 IF labbox <> NIL THEN
1451 WITH labbox^ DO
1452 BEGIN
1453 refbox := references ;
1454 IF refbox <> NIL THEN BEGIN
1455 IF refbox^.refnbr = maxref THEN BEGIN
1456 new refbox ;
1457 WITH refbox^ DO
1458 BEGIN
1459 nextref := references ;
1460 references := refbox ;
1461 refnbr := 1
1462 END ;
1463 END
1464 ELSE
1465 WITH refbox^ DO
1466 refnbr := refnbr + 1 ;
1467 WITH refbox^ DO
1468 WITH refs refnbr DO BEGIN
1469 filen := symbolfile ;
1470 place := ic ;
1471 IF lablev <> level THEN
1472 linen := -symbolline
1473 ELSE
1474 linen := symbolline ;
1475 END ;
1476 END ;
1477 END ;
1478 IF lablev # level THEN
1479 BEGIN * GOTO EXIT *
1480 * REMOVE FRAMES *
1481 IF lablev = 0 AND exportablecode THEN
1482 BEGIN
1483 IF NOT linktomain THEN
1484 BEGIN
1485 linktomainplace := lkc ; lkc := lkc + bytesindword ;
1486 linktomain := true
1487 END ;
1488 genstand prlink linktomainplace DIV bytesinword iepp1 tny ;
1489 IF labexit = 0 THEN
1490 BEGIN
1491 labexit := lkc ; lkc := lkc + bytesindword
1492 END ;
1493 genstand prlink labexit DIV bytesinword iepp2 tny ;
1494 genstand pr0 gotoexitextplace itsp3 tn ;
1495 END
1496 ELSE
1497 BEGIN
1498 loadbase lablev ;
1499 IF currentpr # pr1 THEN genstand currentpr 0 iepp1 tn ;
1500 freebloc currentbloc ;
1501 IF labexit = 0 THEN * FIRST OCCUR *
1502 BEGIN
1503 labexit := lkc ; lkc := lkc + bytesindword ;
1504 END ;
1505 genstand prlink labexit DIV bytesinword iepp2 tny ;
1506 genstand pr0 gotoexitplace itsp3 tn ;
1507 END ;
1508 * EXIT LOOP * GOTO 20 ;
1509 END * GOTO EXT * ELSE
1510 BEGIN * LOCAL GOTO *
1511 IF labdef # 0 THEN * ALREADY DEFINED *
1512 genstand nreg labdef - cb DIV bytesinword itra tic ELSE
1513 BEGIN * NOT YET RESOLVED *
1514 enterundlab labch1 ;
1515 genstand nreg 0 itra tic ;
1516 END * NOT YET RESOLV. * ;
1517 * EXIT LOOP * GOTO 20 ;
1518 END * LOCAL GOTOIFIFWITHFOR * ;
1519 END ;
1520 * AT THIS POINT *
1521 * NOT FOUND INTEGER IN LABTAB *
1522 error 167 ;
1523 20 : * EXIT LOOP FOR *
1524 insymbol ;
1525 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1526 END * INTEGER FOUND * ;
1527 $OPTIONS compile = trace $
1528 IF stattrace > low THEN
1529 BEGIN
1530 write mpcogout '@@@ FIN GOTOSTAT @@@ WITH NO' no : 4 ; nextline ;
1531 END ;
1532 $OPTIONS compile = true $
1533 END * GOTOSTAT * ;
1534
1535
1536 $OPTIONS page $
1537
1538 * ************************************ IFSTAT ******************************** *
1539
1540 PROCEDURE ifstat ;
1541
1542 * C .COMPILATION OF IF <EXPRESSION> THEN <STATE>
1543 IF <EXPRESSION> THEN <STATE> ELSE <STATE>
1544 .GENJUMP GENERATES A BRANCH USING THE SETTING OF CONDITION CODES
1545 C *
1546 * E ERRORS DETECTED
1547 6 : BOOLEAN EXPRESSION EXPECTED
1548 52 : "THEN" EXPECTED
1549 E *
1550 LABEL
1551 20, * CALL OF STATEMENT AFTER THEN *
1552 30 ; * SKIP STATEMENT AFTER THEN *
1553 VAR
1554 locthen, locelse : integer ;
1555 BEGIN * IFSTAT *
1556 $OPTIONS compile = trace $
1557 IF stattrace > none THEN
1558 BEGIN
1559 write mpcogout '@@@ DEBUT IFSTAT @@@' ; nextline ;
1560 END ;
1561 $OPTIONS compile = true $
1562 locthen := 0 ; * DEFAULT MEANS NO INSER TO DO *
1563 freeallregisters ;
1564 insymbol ; expression ;
1565 IF gattr.typtr # NIL THEN
1566 BEGIN
1567 IF gattr.typtr # boolptr THEN
1568 error 6 ELSE
1569 genjump locthen 0 ;
1570 END ;
1571 IF no # 24 * THEN * THEN
1572 BEGIN
1573 IF gattr.typtr # NIL THEN error 52 ;
1574 skip 24 ;
1575 IF no # 24 THEN
1576 BEGIN
1577 IF gattr.typtr = NIL THEN error 52 ;
1578 IF errcl no = endsy THEN
1579 GOTO 30 ELSE
1580 GOTO 20 ;
1581 END ;
1582 END * NO#24 * ;
1583 insymbol ;
1584 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1585 20 :
1586 freeallregisters ;
1587 push_lab_pdl ; statement ; pop_lab_pdl ;
1588 30 :
1589 IF no = 25 * ELSE * THEN
1590 BEGIN
1591 locelse := indfich ; genstand nreg 0 itra tic ;
1592 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1593 END ;
1594 IF locthen # 0 THEN
1595 inser cb locthen ;
1596 IF no = 25 * ELSE * THEN
1597 BEGIN
1598 insymbol ;
1599 freeallregisters ;
1600 push_lab_pdl ; statement ; pop_lab_pdl ;
1601 inser cb locelse ;
1602 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1603 END ;
1604 $OPTIONS compile = trace $
1605 IF stattrace > low THEN
1606 BEGIN
1607 write mpcogout '@@@ FIN IFSTAT @@@ WITH NO' no : 4 ; nextline ;
1608 END ;
1609 $OPTIONS compile = true $
1610 END * IFSTAT * ;
1611
1612
1613 $OPTIONS page $
1614
1615 * ************************************ CASESTAT ****************************** *
1616
1617 PROCEDURE casestat ;
1618
1619 * C .ANALYSIS AND CODE GENERATION FOR THE STATEMENT <CASE>
1620 .GENERATED CODE IS THE FOLLOWING
1621 ********************
1622 * *
1623 * SELECTOR IN RA *
1624 *** ***
1625 TRA SWITCH
1626 *** ***
1627 * * FOR MIN MIN+2
1628 E1 * STATEMENT_1 *
1629 * *
1630 * TRA END *
1631 ................
1632 * * FOR MAX
1633 EN * STATEMENT_N *
1634 *
1635 * TRA END
1636 ********************
1637 * *
1638 SWITCH * RA TO ZERO POINT*
1639 * RA IN MIN..MAX*
1640 * TRA VECTORRA *
1641 * *
1642 ********************
1643 VECTOR * TRA E1 * MINSELECT
1644 * TRA END * MIN+1
1645 * TRA E1 * MIN+2
1646 * ....... * .....
1647 * TRA EN * MAXSELECT
1648 ********************
1649 END.
1650 C *
1651 * E ERRORS DETECTED
1652 1: SCALAR OR NUMERIC EXPECTED AS SELECTOR
1653 7 ":" EXPECTED
1654 8: "OF" EXPECTED
1655 13 "END" EXPECTED
1656 14 : ";" EXPECTED
1657 20 "" EXPECTED
1658 23 "CASE LABEL" EXPECTED
1659 60: "OR" NOT ALLOWED AS MONADIC OPERATOR
1660 61 : ILLEGAL BEGINNING SYMBOL FOR A STATEMENT
1661 103 IDENTIFIER IS NOT OF APPROPRIATE CLASS
1662 104 UNDECLARED IDENTIFIER
1663 105 SIGN NOT ALLOWED HERE
1664 147 TYPE CONFLICT WITH THE CASE SELECTOR
1665 148 CASE VECTOR TRANSFER TOO LARGE
1666 156 DUPLICATE CASE LABEL
1667 304 VALUE OUT OF BOUNDS
1668 E *
1669 LABEL
1670 1, * EXIT WHILE * * INSERTION OF A NEW LABEL BOX *
1671 2, * SKIP HERE IF DUPLICATE CASE LABEL *
1672 3,
1673 10 ; * EXIT PROC BEFORE ALL THE "DISPOSE" *
1674 TYPE
1675 ptcas = @ reccas ;
1676 reccas = RECORD
1677 next : ptcas ; * LINK IN GROWING ORDER THESE BOXES *
1678 cslab : integer ; * SELECTING CASE LABEL VALUE *
1679 addr : integer ; * "CB" VALUE OF FIRST INSTR. *
1680 * FOR THIS STATEMENT *
1681 END ;
1682 * SUCH A BOX IS BUILD *
1683 * FOR EACH CASE LABEL *
1684 ptend = @ recend ;
1685 recend = RECORD
1686 succ : ptend ; * REVERSE LINK *
1687 indf : integer ; * PLACE WHERE AN INSERTION OF *
1688 * EXIT ADDRESS MUST BE MADE *
1689 END ;
1690 VAR
1691 seltype, labtype, generic : ctp ;
1692 locitra, locminexit, locmaxexit, loctabl, otherwiseplace : integer ;
1693 firstetiq, firstcase, minus, sign, stoploop, noterr, errintab, ierr, otherwise : boolean ;
1694 headcase, ptboxcur, ptlast, workpt, savept : ptcas ;
1695 ptchnend, pttetend, savept2 : ptend ;
1696 lastgen, longtabl, maxselect, minselect, valselect : integer ;
1697 BEGIN * CASESTAT *
1698 $OPTIONS compile = trace $
1699 IF stattrace > none THEN
1700 BEGIN
1701 write mpcogout '@@@ DEBUT CASESTAT @@@' ; nextline ;
1702 END ;
1703 $OPTIONS compile = true $
1704 otherwise := false ;
1705 seltype := NIL ; locitra := 0 ;
1706 headcase := NIL ; pttetend := NIL ;
1707 minselect := 0 ; maxselect := 0 ;
1708 * *SELECTOR ANALYSIS *
1709 freeallregisters ;
1710 insymbol ; expression ;
1711 WITH gattr DO
1712 BEGIN
1713 IF typtr # NIL THEN
1714 IF typtr@.form IN numeric scalar THEN
1715 BEGIN
1716 transfer gattr inacc ; freebloc gattr.ldregbloc ;
1717 seltype := typtr ;
1718 locitra := indfich ; genstand nreg 0 itra tic ;
1719 END ELSE
1720 error 1 ;
1721 END * WITH GATTR * ;
1722 * *
1723 * <OF> *
1724 * *
1725 IF no # 27 THEN
1726 BEGIN
1727 IF gattr.typtr # NIL THEN error 8 ;
1728 skip 27 ;
1729 IF no # 27 THEN
1730 IF gattr.typtr = NIL THEN error 8 ;
1731 END ELSE
1732 insymbol ;
1733 noterr := true ;
1734 * *
1735 * ** MAIN LOOP ON STATEMENT BLOCKS *
1736 * *
1737 firstcase := true ;
1738 REPEAT
1739 IF no = 7 * + - OR * THEN
1740 BEGIN
1741 minus := cl = 2 ; * - *
1742 IF cl = 3 THEN error 60 ;
1743 insymbol ; sign := true ;
1744 END ELSE
1745 BEGIN
1746 minus := false ; sign := false ;
1747 END ;
1748 IF no <= 2 THEN * CAN BE A CASE LABEL *
1749 BEGIN
1750 stoploop := false ;
1751 firstetiq := true ;
1752 REPEAT * LOOP ON LABELS FOR ONE BLOCK *
1753 labtype := NIL ;
1754 IF no = 1 * ID * THEN
1755 BEGIN
1756 search ;
1757 IF ctptr = NIL THEN
1758 BEGIN
1759 IF firstetiq AND NOT firstcase THEN
1760 IF envstandard > stdsol THEN
1761 IF aval = usednames 6 THEN * OTHERWISE !! *
1762 BEGIN
1763 otherwise := true ;
1764 otherwiseplace := cb ;
1765 REPEAT
1766 insymbol ;
1767 freeallregisters ;
1768 3 : push_lab_pdl ; statement ; pop_lab_pdl ;
1769 IF errcl no = begsy THEN
1770 BEGIN
1771 error 14 ; GOTO 3 ;
1772 END ;
1773 IF no = 25 * ELSE * THEN
1774 BEGIN
1775 error 61 ; insymbol ; GOTO 3 ;
1776 END ;
1777 UNTIL no <> 16 * ; * ;
1778 IF no <> 22 THEN BEGIN
1779 error 13 ;
1780 GOTO 10 ;
1781 END ;
1782 new ptchnend ; IF ptchnend = NIL THEN heaperror ; * EXIT COMP *
1783 ptchnend@.succ := pttetend ; pttetend := ptchnend ;
1784 ptchnend@.indf := indfich ;
1785 genstand nreg 0 itra tic ; * EXIT OF CASE *
1786 GOTO 10 ;
1787 END ;
1788 error 104 ; insymbol ; skip 46 ;
1789 END ELSE
1790 BEGIN
1791 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1792 WITH ctptr@ DO
1793 IF klass # konst THEN
1794 BEGIN
1795 IF klass >= vars THEN stoploop := true ;
1796 error 103 ; insymbol ; skip 46 ;
1797 END * # KONST * ELSE
1798 BEGIN * KONST *
1799 IF contype # NIL THEN
1800 BEGIN
1801 labtype := contype ;
1802 IF minus THEN valselect := -values
1803 ELSE valselect := values ;
1804 END ;
1805 END * KONST * ;
1806 END
1807 END * NO=1 * ELSE
1808 IF no = 2 * CSTE * THEN
1809 BEGIN
1810 CASE cl OF
1811 1 : labtype := intptr ;
1812 2, 3 : error 1 ;
1813 4 : labtype := charptr ;
1814 END ;
1815 IF labtype # NIL THEN
1816 IF minus THEN valselect := -ival ELSE valselect := ival ;
1817 END * NO=2 * ELSE
1818 BEGIN
1819 error 23 ;
1820 END ;
1821 * TYPE COMPATIBILTY *
1822 IF labtype # NIL THEN
1823 BEGIN
1824 IF seltype = NIL THEN
1825 seltype := labtype ELSE
1826 BEGIN
1827 compatbin seltype labtype generic ;
1828 IF generic = NIL OR generic = realptr THEN
1829 BEGIN
1830 error 147 ; labtype := NIL ;
1831 END ELSE
1832 BEGIN
1833 IF generic@.form # numeric THEN
1834 IF sign THEN error 105 ;
1835 checkminmax valselect seltype 304 ;
1836 END * GENERIC NOT NIL * ;
1837 END * SELTYPE#NIL * ;
1838 END * LABTYPE #NIL * ;
1839 IF labtype # NIL THEN
1840 BEGIN
1841 noterr := true ;
1842 ptboxcur := headcase ; ptlast := NIL ;
1843 WHILE ptboxcur # NIL DO
1844 BEGIN
1845 IF ptboxcur@.cslab >= valselect THEN
1846 BEGIN
1847 IF ptboxcur@.cslab = valselect THEN
1848 BEGIN error 156 ; GOTO 2 ;
1849 END ;
1850 GOTO 1 ; * EXIT LOOP *
1851 END ;
1852 ptlast := ptboxcur ;
1853 ptboxcur := ptboxcur@.next ;
1854 END ;
1855 * HERE MAXSELECT MUST BE CHANGED. *
1856 * BOXES ARE LINKED VIA NEXT *
1857 * IN GROWTHING ORDER *
1858 * HEADCASE POINTS THE SMALLEST *
1859 maxselect := valselect ;
1860 1 : * CREATES A NEW LABEL BOX *
1861 new workpt ; IF workpt = NIL THEN heaperror ; * EXIT COMP *
1862 WITH workpt@ DO
1863 BEGIN
1864 next := ptboxcur ; cslab := valselect ; addr := cb ;
1865 END ;
1866 IF ptlast = NIL THEN * BOX =NEW BEGINNING OF LIST *
1867 BEGIN
1868 headcase := workpt ; minselect := valselect ;
1869 END ELSE
1870 ptlast@.next := workpt ;
1871 END * LABTYPE#NILCREATES THEN A NEW LABEL BOX * ;
1872 2 : * SKIP HERE IF DUPLICATE LABEL *
1873 IF NOT stoploop THEN
1874 BEGIN
1875 insymbol ;
1876 IF no = 19 * : * THEN
1877 stoploop := true ELSE
1878 BEGIN
1879 IF no = 15 THEN * *
1880 BEGIN
1881 insymbol ;
1882 IF no = 7 THEN
1883 BEGIN
1884 minus := cl = 2 ; sign := true ;
1885 IF cl = 3 THEN error 60 ;
1886 insymbol ;
1887 END ELSE
1888 BEGIN
1889 minus := false ; sign := false ;
1890 END ;
1891 END * NO=15 * ELSE
1892 error 20 ;
1893 ierr := false ;
1894 WHILE NOT no IN 1 2 19 AND errcl no = irrelsy DO
1895 BEGIN
1896 insymbol ; ierr := true ;
1897 END ;
1898 IF ierr THEN error 7 ;
1899 IF no > 2 THEN stoploop := true ;
1900 END * NO#19 * ;
1901 END * NOT STOPLOOP * ;
1902 firstetiq := false ;
1903 UNTIL stoploop ;
1904 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1905 * *
1906 * STATEMENT BLOCK *
1907 * *
1908 IF no = 19 OR errcl no = begsy THEN
1909 BEGIN
1910 IF no = 19 THEN insymbol ;
1911 freeallregisters ;
1912 * ********* *
1913 push_lab_pdl ; statement ; pop_lab_pdl ;
1914 * ********* *
1915 END ;
1916 new ptchnend ; IF ptchnend = NIL THEN heaperror ; * EXIT COMP *
1917 ptchnend@.succ := pttetend ; pttetend := ptchnend ;
1918 ptchnend@.indf := indfich ;
1919 genstand nreg 0 itra tic ; * EXIT OF CASE *
1920 IF mapswitch THEN statement_ends symbolindex - sttindex ;
1921 END * NO <=2 CAN BE A CASE LABEL * ELSE
1922 BEGIN
1923 IF noterr THEN
1924 BEGIN
1925 error 23 ; noterr := false ;
1926 END ;
1927 skip 46 ;
1928 IF no # 22 THEN
1929 IF errcl no = begsy THEN
1930 statement ELSE
1931 insymbol ;
1932 END * NO >2 THEN ERROR * ;
1933 IF no = 16 * ; * THEN
1934 insymbol ELSE
1935 IF no # 22 * END * AND noterr THEN
1936 BEGIN
1937 error 13 ; GOTO 10 ; * EXIT LOOP *
1938 END ;
1939 firstcase := false ;
1940 UNTIL no = 22 ; * END *
1941 10 :
1942 longtabl := maxselect - minselect + 1 ;
1943 IF longtabl > maxfich - indfich DIV bytesinhword THEN
1944 BEGIN
1945 error 148 ;
1946 errintab := true ; locmaxexit := 0 ;
1947 END ELSE
1948 errintab := false ;
1949 * *
1950 * CODE GENERATION *
1951 * *
1952 IF mapswitch THEN statement_begins true ;
1953 IF locitra # 0 THEN
1954 inser cb locitra ;
1955 IF inxcheck THEN
1956 IF seltype # NIL THEN
1957 checkbnds caserrcode ra seltype ;
1958 * ZERO POINT *
1959 IF minselect # 0 THEN
1960 gencstecode minselect isba ;
1961 * NOOP OR STOP IF < MIN >MAX *
1962 * *
1963 genstand nreg 0 icmpa tdl ;
1964 IF otherwise THEN
1965 genstand nreg otherwiseplace - cb DIV bytesinword itmi tic ELSE
1966 BEGIN
1967 locminexit := indfich ; genstand nreg 0 itmi tic ;
1968 END ;
1969 IF NOT errintab THEN
1970 BEGIN
1971 genstand nreg longtabl - 1 icmpa tdl ;
1972 IF otherwise THEN
1973 genstand nreg otherwiseplace - cb DIV bytesinword itpnz tic ELSE
1974 BEGIN
1975 locmaxexit := indfich ; genstand nreg 0 itpnz tic ;
1976 END ;
1977 END ;
1978 * HERE EXP IS IN MIN..MAX *
1979 loctabl := indfich ; genstand nreg 0 iepp3 tic ; * POINTS FIRST SWITCH *
1980 genstand pr3 0 itra tal ;
1981 inser cb loctabl ;
1982 lastgen := minselect - 1 ;
1983 WHILE headcase # NIL DO
1984 BEGIN
1985 IF NOT errintab THEN
1986 WHILE headcase@.cslab # lastgen + 1 DO
1987 BEGIN
1988 * NO OP THEN EXIT OR STOP *
1989 IF otherwise THEN
1990 genstand nreg otherwiseplace - cb DIV bytesinword itra tic ELSE
1991 genstand nreg longtabl + minselect - 1 - lastgen itra tic ;
1992 lastgen := lastgen + 1 ;
1993 END ;
1994 * HERE EQUALITY *
1995 * THEN GOTO SUITABLE STATEMENT BLOCK *
1996 IF NOT errintab THEN
1997 genstand nreg headcase@.addr - cb DIV bytesinword itra tic ;
1998 lastgen := headcase@.cslab ;
1999 savept := headcase ; headcase := headcase@.next ;
2000 savept := NIL ;
2001 END * WHILE * ;
2002 IF NOT otherwise THEN
2003 BEGIN
2004 inser cb locminexit ;
2005 IF locmaxexit # 0 THEN
2006 inser cb locmaxexit ;
2007 IF inxcheck THEN
2008 BEGIN IF minselect # 0 THEN gencstecode minselect iada ;
2009 genexceptcode caserrcode ra ;
2010 END ;
2011 END ;
2012 * INSER ALL ENDING JUMPS *
2013 ptchnend := pttetend ;
2014 WHILE ptchnend # NIL DO
2015 BEGIN
2016 inser cb ptchnend@.indf ; savept2 := ptchnend ;
2017 ptchnend := ptchnend@.succ ; savept2 := NIL ;
2018 END ;
2019 IF mapswitch THEN statement_ends 3 ; * "end" *
2020 insymbol ;
2021 $OPTIONS compile = trace $
2022 IF stattrace > low THEN
2023 BEGIN
2024 write mpcogout '@@@ FIN CASESTAT @@@ WITH NOCL:' no : 4 cl : 4 ; nextline ;
2025 END ;
2026 $OPTIONS compile = true $
2027 END * CASESTAT * ;
2028
2029 * ************************************ STATEMENT ***************************** *
2030
2031 PROCEDURE statement ;
2032
2033 * C EACH STATEMENT CAN BE PREFIXED BY A LABEL INT:
2034 AFTER LABEL ANALYSIS SPLITSTAT NO IS A SWITCH TO SEVERAL PROCEDURES
2035 C *
2036
2037 * E ERRORS DETECTED
2038 7: ":" EXPECTED
2039 42 Sol procedure not in PASCAL
2040 44 Sol procedure not yet implemented
2041 45 Extended pascal not allowed at this level
2042 61: ILLEGAL BEGINNING SYMBOL FOR A STATEMENT
2043 86: THIS FUNCTION MUST BE ASSIGNED IN HIS BLOCK
2044 103: IDENTIFIER IS NOT OF APPROPRIATE CLASS
2045 104: IDENTIFIER NOT DECLARED
2046 150: ASSIGNMENT TO STANDARD FUNCTION NOT ALLOWED
2047 165: MULTIDEFINED LABEL
2048 167: LABEL IS NOT DECLARED
2049 196: ASSIGNMENT NOT ALLOWED FOR THIS VARIABLE
2050 306: LABEL MUST HAVE AT MOST 4 DIGITS
2051 E *
2052 LABEL
2053 1 ; * EXIT FOR WHEN LABEL FOUND *
2054 VAR
2055 it : integer ;
2056 BEGIN * STATEMENT *
2057 $OPTIONS compile = trace $
2058 IF stattrace > none THEN
2059 BEGIN
2060 write mpcogout '@@@ DEBUT STATEMENT @@@ WITH NO' no : 4 ; nextline ;
2061 END ;
2062 $OPTIONS compile = true $
2063 * FIRST CHECK FOR LABEL *
2064 IF no = 2 THEN * CSTE *
2065 IF cl = 1 THEN * " INTEGER *
2066 BEGIN
2067 IF ival > 9999 THEN error 306 ;
2068 FOR it := clabix DOWNTO 1 DO
2069 WITH labtab it DO
2070 IF labval = ival THEN * FOUND *
2071 BEGIN
2072 IF labbox <> NIL THEN
2073 WITH labbox^ DO
2074 BEGIN
2075 deffile := symbolfile ; defline := symbolline ; locinbytes := ic ;
2076 WITH lab_pdl_top^ DO
2077 BEGIN
2078 next_in_block := first_in_block ;
2079 first_in_block := labbox ;
2080 END ;
2081 END ;
2082 IF lablev <> level THEN
2083 error 167 ELSE
2084 IF labdef <> 0 THEN * MULTIDEFINED *
2085 error 165 ELSE
2086 BEGIN * FIRST OCCUR ==> RESOLVE IT *
2087 labdef := cb ; * PLACE IN CODE FOR CURRENT PROCEDURE *
2088 IF labch1 # 0 THEN
2089 BEGIN * USED BEFORE DEFINITION *
2090 inserundlab cb labch1 ;
2091 labch1 := 0 ; * FLAG RESOLVED *
2092 END * USED * ;
2093 IF labexit <> 0 THEN
2094 BEGIN * USED IN GOTO EXIT *
2095 genstand pr6 pr4depw iepp4 tny ;
2096 * RESET PR4 DEL. BY UNWINDER OPER. *
2097 END * USED IN GOTO EXIT * ;
2098 END * FIRST OCCURNO ERR * ;
2099 * EXIT LOOP * GOTO 1 ;
2100 END * LABEL FOUNDWITHFOR * ;
2101 * HERE LABEL NOT FOUND *
2102 error 167 ;
2103 1 : insymbol ;
2104 IF no = 19 * : * THEN
2105 insymbol ELSE
2106 BEGIN
2107 error 7 ; skip 46 ;
2108 END ;
2109 END * CL=1 NO=2 * ;
2110 freeallregisters ;
2111
2112 IF splitstat no <> 1 THEN
2113 IF mapswitch THEN statement_begins true ;
2114
2115 CASE splitstat no OF
2116 * NOOP * 1 : * ENDSYIRRELSY * ;
2117 * IDENTIF. * 2 :
2118 BEGIN
2119 search ;
2120 IF ctptr = NIL THEN
2121 BEGIN
2122 error 104 ; ctptr := undecptr ;
2123 END ;
2124 WITH ctptr@ DO
2125 IF klass <= konst THEN
2126 error 103 ELSE
2127 * VARS PROC FIELD *
2128 IF klass = proc THEN * PROC OR FUNCT *
2129 BEGIN
2130 IF proctype = ctptr THEN * not a function *
2131 BEGIN * PROC *
2132 IF symbolmap THEN
2133 nameisref ctptr symbolfile symbolline ;
2134 insymbol ;
2135 CASE ploc OF
2136 notpredef : BEGIN * PROGRAMMER PROC *
2137 passparams 0 ; * NOT USED FOR A PROC *
2138 END ;
2139 instdpure :
2140 CASE segsize OF
2141 0, 1, 2, 3 : getput segsize ; * INCLUDE RESET POINTER *
2142 4, 5 : newir segsize - 4 ;
2143 6, 7 : readir segsize - 6 ;
2144 8, 9, 10 : writeir segsize - 8 ;
2145 11, 12 : pckunpck segsize - 11 ;
2146 END ;
2147 instdcompiler : insapp segsize ;
2148 instdsol :
2149 BEGIN
2150 IF envstandard = stdpure THEN
2151 error 42 ;
2152 CASE segsize OF
2153 0, 1, 2, 3, 4, 5, 6 : getput segsize + 4 ;
2154 7 : writeir 3 ;
2155 8 : argvstat ;
2156 9 : stopstat ;
2157 END ;
2158 END * INSTDSOL * ;
2159 instdextend :
2160 BEGIN
2161 IF envstandard <> stdextend THEN error 45 ;
2162 CASE segsize OF
2163 2 : mvcir 0 ;
2164 0, 1 : dateandtime segsize ;
2165 3 : insert_string ;
2166 4 : delete_string ;
2167 END ;
2168 END * INSTDEXTEND * ;
2169
2170 END * case PLOC * ;
2171 END * PROCEDURE * ELSE
2172 BEGIN * FUNCTION IDENTIFIER ASSIGNMENT *
2173 IF ploc <> notpredef THEN
2174 BEGIN
2175 IF symbolmap THEN
2176 nameisref ctptr symbolfile -symbolline ;
2177 error 150 ; skip 46 ;
2178 END ELSE
2179 BEGIN
2180 genstand nreg level - proclevel - 1 ilda tdl ;
2181 genstand pr0 functionvaluesetplace itsp3 tn ;
2182 procisassigned := true ;
2183
2184 IF NOT procinscope THEN error 86 ;
2185
2186
2187 assign ;
2188
2189
2190 END * NO ERRORS FOR FUNCT. ID * ;
2191 END * FUNCT. IDENTIFIER * ;
2192 END * KLASS=PROC * ELSE
2193 BEGIN * VARS OR FIELD *
2194 IF klass = vars THEN
2195 BEGIN
2196 * VISUSED SET IN ADDRESSVAR *
2197 IF visreadonly THEN error 196 ;
2198 visset := true ;
2199 END * VARS * ;
2200
2201
2202 assign ;
2203
2204
2205 END * VARS OR FIELD * ;
2206 IF mapswitch THEN statement_ends symbolindex - sttindex ;
2207 END * IDENT. SPLITSTAT=2 * ;
2208 3 * BEGIN * : compstat ;
2209 4 * IF * : ifstat ;
2210 5 * CASE * : casestat ;
2211 6 * REPEAT * : repeatstat ;
2212 7 * WHILE * : whilestat ;
2213 8 * FOR * : forstat ;
2214 9 * GOTO * : gotostat ;
2215 10 * WITH * : withstat ;
2216 END * CASE SPLITSTAT * ;
2217
2218 * FREEALLREGISTERS MUST BE CALLED HERE BECAUSE IT MAY GENERATE CODE
2219 WHICH IS LOGICALLY RELATED TO CODE GENERATED DURING STATEMENT.
2220 THIS IS DUE TO NEW STACK EXTENSION MECHANISM USED FOR SOME TEMPORARY
2221 VARIABLES IN STRING EXPRESSIONS EVALUATION *
2222
2223 freeallregisters ;
2224 IF errcl no = irrelsy THEN
2225 BEGIN
2226 error 61 ; skip 46 ;
2227 END ;
2228 $OPTIONS compile = trace $
2229 IF stattrace > low THEN
2230 BEGIN
2231 write mpcogout '@@@ FIN STATEMENT @@@ WITH NO=' no : 4 ; nextline ;
2232 END ;
2233 $OPTIONS compile = true $
2234 END * STATEMENT * ;
2235
2236
2237 * END OF STATE MODULE ******************************************* * BEGIN
2238 END.