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 page $
19
20 $OPTIONS switch trace := true ; switch security := true ; t + $
21 PROGRAM declare ;
22 $IMPORT
23 * IMPORTED PROCEDURES *
24 'pascal_context_ alm' : asciiformataddr, octalformataddr ;
25 * FROM PL1 *
26 'pascal_gen_bin_area pl1' : genbinarea ;
27 'pascal_gen_ext_variable pl1' : genextvariable ;
28 'pascal_gen_entry_point pl1' : genentrypoint ;
29 'pascal_gen_export_file pl1' : genexportfile ;
30 'pascal_gen_rel_$text pl1' : genreltext ;
31 'RACINE pascal' :
32 crealfabox,
33 error,
34 generrorlink,
35 geninputlink,
36 genoutputlink,
37 inconst,
38 inserundlab,
39 insymbol,
40 nameisref,
41 nextline,
42 poweroftwo,
43 recadre,
44 skip,
45 skipextd,
46 skiptochapter,
47 statement_begins,
48 statement_ends,
49 sup,
50 warning ;
51 'UNIQUE pascal' :
52 heaperror ;
53 'STANDSTAT pascal' :
54 compstat ;
55 'CONTEXTTABLE pascal' :
56 boundary,
57 bytesneeded,
58 checkminmax,
59 compatbin,
60 create_vars_box,
61 create_types_box,
62 create_proc_box,
63 create_field_box,
64 create_konst_box,
65 create_tagfield_box,
66 create_dummyclass_box,
67 existfileintype,
68 packedcadre,
69 packedsize,
70 printrec ;
71
72 'GENERE pascal' :
73 closefile,
74 exitlabel,
75 enterreftosymbol,
76 genalfa,
77 genc,
78 gencodfonct,
79 geninsertion,
80 gen_init_fsb_trap_structures,
81 genmulticsnil,
82 genpgexit,
83 genprcentry,
84 genprcexit,
85 genprolog,
86 genr,
87 genstand,
88 genstring,
89 infich,
90 initiozone,
91 writout ;
92 'optimized_procedures alm' : search, srchrec ;
93 * IMPORTED VARIABLES *
94 'RACINE pascal' :
95 alfaptr,
96 aval,
97 boxheader,
98 bufval,
99 charptr,
100 check_id,
101 cl,
102 conint,
103 conreel,
104 ctptr,
105 currentnode,
106 declarationpart,
107 display,
108 environt,
109 envstandard,
110 errtotal,
111 exportablecode,
112 extcalltrapplace,
113 forbidden_id,
114 init_fsb_trap_flag,
115 intptr,
116 ival,
117 lastproc,
118 level,
119 listyes,
120 longchaine,
121 longstring,
122 majmin,
123 mapswitch,
124 mpcogerr,
125 mpcogout,
126 next,
127 nilptr,
128 no,
129 progname,
130 realptr,
131 staticswordcount,
132 statnbr,
133 string_ptr,
134 symbolfile,
135 symbolindex,
136 symbolline,
137 symbolmap,
138 top,
139 usednames,
140 version,
141 xc ;
142 'GENERE pascal' :
143 cb,
144 fichinter,
145 ic,
146 indfich,
147 usednameaddr ;
148 'STATE pascal' :
149 currlcstpt,
150 currllcstpt,
151 currrcstpt,
152 currwcstpt,
153 lcsave,
154 linktoend,
155 linktoendplace,
156 tmax$
157
158 $EXPORT
159 body,
160 analyzing_schema,
161 building_from_schema,
162 checkexternalitem,
163 clabix,
164 createexternalbox,
165 decltrace,
166 externallistheader,
167 filpts,
168 filtop,
169 firstlabbox,
170 forbidden_id_list,
171 getpr4afterstop,
172 hdrfile,
173 hdrindex,
174 hdrlength,
175 hdrline,
176 initdeclare,
177 labtab,
178 lc,
179 lkc,
180 maxctp,
181 nextalf,
182 lab_pdl_top,
183 push_lab_pdl,
184 pop_lab_pdl,
185 symbtabl,
186 tabform,
187 tabkinds,
188 tabklass,
189 tabkonst,
190 tabpdef$
191
192
193
194
195
196
197 $INCLUDE 'CONSTTYPE' $
198
199
200
201 $OPTIONS page $
202
203 VAR
204 * REDEFINE NOW IMPORTED VARIABLES *
205 * FROM RACINE *
206 alfaptr : ctp ;
207 aval : alfaid ;
208 boxheader : PACKED ARRAY 1..120 OF char ;
209 bufval : ARRAY 1..maxval OF char ;
210 charptr : ctp ;
211 check_id : boolean ;
212 cl : integer ;
213 conint : integer ;
214 conreel : real ;
215 currentnode : blocknodeptr ;
216 ctptr : ctp ;
217 declarationpart : boolean ;
218 display : ARRAY 0..displimit OF recidscope ;
219 entrylength : integer ;
220 environt : contexte ;
221 envstandard : stdkind ;
222 errtotal : integer ;
223 exportablecode : boolean ;
224 extcalltrapplace : integer ;
225 forbidden_id : alfaid ;
226 init_fsb_trap_flag : boolean ;
227 functionflag : boolean ;
228 intptr : ctp ;
229 ival : integer ;
230 lastproc : blocknodeptr ;
231 level : levrange ;
232 listyes : boolean ;
233 longchaine : integer ;
234 longstring : integer ;
235 majmin : ARRAY 0..127 OF integer ;
236 mpcogerr : text ;
237 mpcogout : text ;
238 next : ctp ;
239 nilptr : ctp ;
240 no : integer ;
241 progname : alfaid ;
242 realptr : ctp ;
243 staticswordcount : integer ;
244 statnbr : integer ;
245 string_ptr : ctp ;
246 symbolfile : integer ;
247 symbolindex : integer ;
248 symbolline : integer ;
249 symbolmap : boolean ;
250 top : integer ;
251 usednames : typusednames ;
252 version : integer ;
253 xc : integer ;
254 * FROM GENERE *
255 mapswitch : boolean ;
256 cb : integer ;
257 fichinter : ^binartype ;
258 ic : integer ;
259 indfich : integer ;
260 usednameaddr : ctp ;
261 * FROM STATE *
262 currlcstpt : lcstpt ;
263 currllcstpt : llcstpt ;
264 currrcstpt : rcstpt ;
265 currwcstpt : wcstpt ;
266 lcsave : integer ;
267 tmax : integer ;
268 linktoend : boolean ;
269 linktoendplace : integer ;
270 * FROM ALM OR PL1 *
271 asciiformataddr : ctp ;
272 octalformataddr : ctp ;
273
274
275 * NOW DEFINE EXPORTABLE VARIABLES *
276
277 analyzing_schema,
278 building_from_schema : schema_status ;
279 clabix : integer ;
280 * POINTS LAST USED ENTRY IN LABTAB *
281 decltrace : levtrace ; * TO USE TRACE IN COMPILATION OF DECLARE *
282 externallistheader : ptexternalitem ;
283 filpts : ARRAY 0..fillimit OF ctp ; * CONTAINS POINTERS ON BOXES "VAR" *
284 * FOR EACH DECLARED FILE *
285 filtop : integer ;
286 firstlabbox : labelblockptr ;
287 forbidden_id_list : alfalistptr ;
288 getpr4afterstop : boolean ; * TRUE IF STOP USES UNWINDER *
289 * POINTS LAST USED ENTRY IN FILPTS *
290 hdrfile : integer ; * FILE OF PROGRAM OR PROCEDURE HEADER *
291 hdrindex : integer ; * INDEX OF PROGRAM OR PROCEDURE HEADER *
292 hdrlength : integer ; * LENGTH OF PROGRAM OR PROCEDURE HEADER *
293 hdrline : integer ; * LINE OF PROGRAM OR PROCEDURE HEADER *
294 lab_pdl_top : lab_pdl_ptr ; * CURRENT PUSH-POP LABEL BLOCK BLOCK PTR *
295 labtab : ARRAY 1..maxlabs OF labdescr ;
296 * FOR EACH LEVEL DECLARED LABELS ARE *
297 * MEMORIZED FROM FSTIX BODY --> CLABIX *
298 lc : integer ;
299 * DISPLACEMENT COUNTER OF STACK'S ELEMENTS *
300 lkc : integer ; * OFFSET IN LINK. SECTION FOR ALL EXT. ITEMS *
301 maxctp : ctp ;
302 * MAX POSITION REACHED IN HEAP *
303 nextalf : ctp ; * GIVES THE BEGINNING OF THE CHAIN OF *
304 * USED 'ALFA CONSTANTES' IN A PROCEDURE *
305 symbtabl : boolean ; * INDICATES IF INFORMATIONS FOR *
306 * SYMBOLIC DUMP IS TO BE GENERATED *
307
308 * NOW DEFINE INTERNAL VARIABLES *
309 cadre : integer ;
310 * USED IN TYPEDECL TO FIND THE NEEDED *
311 * BOUNDARY FOR A VARIABLEFIELD *
312 dversion : integer ; * VERSION OF DECLARE *
313 err : boolean ;
314 exportscode : boolean ;
315 * PROPAGATES AN ERROR CONDITION *
316 filev : ARRAY levrange OF integer ;
317 * FILES DECLARED AT LEVEL "N" *
318 * ARE MEMORIZED IN ENTRIES *
319 * FILEVN ..FILTOP IN ARRAY FILPTS *
320 first_forbidden_id : alfalistptr ;
321 globnbpar : integer ; * NUMBER OF PARAMETERS USED IN A PROCEDURE. *
322 * +1 FOR FUNCTION +4 FOR EACH CONF. ARRAY *
323 globdescriptors : boolean ;
324 longparam : integer ;
325 * LENGTH OF PARAMETER'S LIST *
326 old_check_id : boolean ;
327 np : blocknodeptr ;
328 pendingtypeallowed : boolean ;
329 ptlist : ARRAY 0..ptlimit OF
330 RECORD
331 hname : alfaid ; * USED BUT NOT DECLARED NAME *
332 pptr : ctp ; * BOX ASSOCIATED WITH POINTER ON THIS NAME *
333 rfil, rlin : integer ;
334 END ;
335 ptx : integer ;
336 * POINTS FIRST FREE ENTRY IN PTLIST *
337 structispack : boolean ;
338 * ASSOCIATED WITH "PACKED" FOR A STRUCTURE *
339 tabklass : ARRAY idklass OF alfa ;
340 tabform : ARRAY typform OF alfa ;
341 tabkonst : ARRAY consttype OF alfa ;
342 tabkinds : ARRAY idkinds OF alfa ;
343 tabpdef : ARRAY idprocdef OF alfa ;
344 * TRACES . ALFA ASSOCIATED WITH SCALAR TYPES *
345 terrcl : ARRAY norange OF typofsymb ;
346 * ERR. RECOVERY IN TYPE DECL. PART *
347 valuenb : integer ; * VALUEDECL'CALLS COUNTER .MUST BE 1 *
348
349 * END OF VARIABLES FOR MODULE DECLARE *
350
351
352 $OPTIONS page $
353
354 $VALUE
355 tabklass = 'TYPES ' 'KONST ' 'PROC ' 'VARS ' 'FIELD ' 'TAGFIELD'
356 'DUMMYCLA' ;
357 tabform = 'REEL ' 'NUMERIC ' 'SCALAR ' 'POINTER ' 'POWER ' 'ARRAYS '
358 'RECORDS ' 'FILES ' 'ALIASTYP' ;
359 tabkonst = 'WORDCONS' 'DWORCONS' 'ALFACONS' ;
360 tabkinds = 'ACTUAL ' 'FORMAL ' 'ARRAYBOU' 'EXPORTAB' 'IMPORTED' ;
361 tabpdef = 'STANDDEF' 'FORWDEF' 'EXTDEF' ;
362 terrcl = 9 * irrelsy
363 begsy * 9 *
364 endsy * 10 *
365 irrelsy
366 endsy * 12 ] *
367 3 * irrelsy
368 endsy * 16 ; *
369 irrelsy
370 begsy * 18 ^ *
371 2 * irrelsy
372 3 * endsy * 21 BEGIN 22 END 23 IF *
373 2 * irrelsy
374 endsy * 26 CASE *
375 irrelsy
376 endsy * 28 REPEAT *
377 irrelsy
378 endsy * 30 WHILE *
379 irrelsy
380 endsy * 32 FOR *
381 2 * irrelsy
382 endsy * 35 GOTO *
383 irrelsy
384 endsy * 37 TYPE *
385 begsy * 38 ARRAY RECORD FILE SET *
386 irrelsy
387 2 * endsy * 40 LABEL 41 CONST *
388 irrelsy
389 3 * endsy * 43 VAR 44 FUNCTION 45 PROCEDURE *
390 2 * irrelsy
391 endsy * 48 WITH *
392 irrelsy
393 endsy * 50 PROGRAM *
394 7 * endsy * 51 $RENAME 52 $IMPORT 53 $EXPORT 54 $VALUE 57 $ * $
395
396
397
398 $OPTIONS page $
399
400 * IMPORTED PROCEDURES HEADERS *
401 * FROM RACINE *
402 FUNCTION recadre fnumber fmod : integer : integer ; EXTERNAL ;
403 PROCEDURE insymbol ; EXTERNAL ;
404 PROCEDURE error errno : integer ; EXTERNAL ;
405 PROCEDURE srchrec fbegsearch : ctp ; EXTERNAL ;
406 PROCEDURE inconst VAR code : integer ; VAR restype : ctp ; fnxt : ctp ; expression_allowed : boolean ; EXTERNAL ;
407 PROCEDURE crealfabox VAR fkonstbox : ctp ; EXTERNAL ;
408 PROCEDURE skip nosymb : integer ; EXTERNAL ;
409 PROCEDURE skipextd nosymb : setofno ; EXTERNAL ;
410 PROCEDURE skiptochapter ; EXTERNAL ;
411 PROCEDURE search ; EXTERNAL ;
412 PROCEDURE nextline ; EXTERNAL ;
413 FUNCTION sup fval1 fval2 : integer : integer ; EXTERNAL ;
414 PROCEDURE inserundlab fcb fdebchn : integer ; EXTERNAL ;
415 FUNCTION poweroftwo fval : integer : integer ; EXTERNAL ;
416 PROCEDURE nameisref p : ctp ; f l : integer ; EXTERNAL ;
417 PROCEDURE statement_begins genp : boolean ; EXTERNAL ;
418 PROCEDURE statement_ends sttlength : integer ; EXTERNAL ;
419 PROCEDURE warning errno : integer ; EXTERNAL ;
420
421 * FROM UNIQUE *
422 PROCEDURE heaperror ; EXTERNAL ;
423
424 * PROCEDURES FROM STANDSTAT *
425
426 PROCEDURE compstat ; EXTERNAL ;
427
428 * PROCEDURES FROM CONTEXTTABLE *
429
430 FUNCTION boundary objform : typform ; ispack : boolean ; pcksize : integer : integer ; EXTERNAL ;
431 FUNCTION bytesneeded objform : typform ; highest : integer ; ispack : boolean : integer ; EXTERNAL ;
432 PROCEDURE checkminmax fvalue : integer ; fctp : ctp ; ferrnum : integer ; EXTERNAL ;
433 PROCEDURE compatbin typleft typright : ctp ; VAR fgeneric : ctp ; EXTERNAL ;
434 PROCEDURE create_vars_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
435 PROCEDURE create_types_box VAR fvbox : ctp ; fname : alfaid ; fform : typform ; fbool : boolean ; EXTERNAL ;
436 PROCEDURE create_proc_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
437 PROCEDURE create_field_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
438 PROCEDURE create_konst_box VAR fvbox : ctp ; fname : alfaid ; ftypofconst : consttype ; EXTERNAL ;
439 PROCEDURE create_tagfield_box VAR fvbox : ctp ; fname : alfaid ; ftagval : boolean ; EXTERNAL ;
440 PROCEDURE create_dummyclass_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
441 FUNCTION existfileintype ptontype : ctp : boolean ; EXTERNAL ;
442 FUNCTION packedcadre ftype : ctp : integer ; EXTERNAL ;
443 FUNCTION packedsize ftype : ctp : integer ; EXTERNAL ;
444 PROCEDURE printrec ptbox : ctp ; EXTERNAL ;
445
446
447 * FROM GENERE OR PL1 *
448 FUNCTION enterreftosymbol ctplace : ctp : integer ; EXTERNAL ;
449 PROCEDURE genreltext relcode halfwordcount : integer ; EXTERNAL ;
450 PROCEDURE gen_init_fsb_trap_structures filpt : ctp ; EXTERNAL ;
451 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
452 PROCEDURE genmulticsnil ; EXTERNAL ;
453 PROCEDURE genexportfile nam : alfaid ; pr4disp : integer ; VAR returncode : integer ; EXTERNAL ;
454 PROCEDURE genprolog VAR fplace : integer ; VAR fdebic : integer ; EXTERNAL ;
455 PROCEDURE genpgexit ; EXTERNAL ;
456 PROCEDURE genprcentry VAR fplace : integer ; fptproc : ctp ; VAR fdebic : integer ; EXTERNAL ;
457 PROCEDURE writout zonedisp endcode : integer ; EXTERNAL ;
458 PROCEDURE closefile filept : ctp ; EXTERNAL ;
459 PROCEDURE exitlabel flabinx : integer ; flabplace : integer ; EXTERNAL ;
460 PROCEDURE geninsertion fplace : integer ; fptproc : ctp ; EXTERNAL ;
461 PROCEDURE gencodfonct fptproc : ctp ; EXTERNAL ;
462 PROCEDURE genprcexit fptproc : ctp ; EXTERNAL ;
463 PROCEDURE infich fval : integer ; EXTERNAL ;
464 PROCEDURE genr frval : real ; EXTERNAL ;
465 PROCEDURE genc fval : integer ; EXTERNAL ;
466 PROCEDURE genstring falfapt : ctp ; EXTERNAL ;
467 PROCEDURE genalfa ; EXTERNAL ;
468 PROCEDURE initiozone filpt : ctp ; EXTERNAL ;
469
470 * **************************************** GENEXTVARIABLE ******************** *
471
472 PROCEDURE genextvariable segname varname generator : alfaid ;
473 pr4disp varlength endpoint : integer ;
474 VAR binarea : binartype ;
475 VAR returncode : integer ; EXTERNAL ;
476
477 * C VARNAME NAME OF THE VARIABLE
478 Can be found in IMPORT_STRING
479 SEGNAME 32 CHARS STRING
480 GENERATOR " "" ""
481 PR4DISP BYTES OFFSET OF "ITS" WANTED
482 . < 0 FOR IMPORTED VARS
483 VARLENGTH BYTES SIZE OF THE VARIABLE
484 ENDPOINT MAX INDEX REACHED IN BINAREA
485 BINAREA BINARY ITEMS
486 RETURNCODE 0 MEANS OK
487 C *
488
489
490 $OPTIONS page $
491
492 * ********************************************* GENBINAREA ****************** *
493
494 PROCEDURE genbinarea bytdisp codearea endpoint endcode : integer ;
495 VAR binarea : binartype ;
496 VAR returncode : integer ; EXTERNAL ;
497
498 * C BYTDISP OFFSET IN AREA OF FIRST BYTE TO BE INIT.
499 CODEAREA 1 = TEXT ; 3 = STATICINIT
500 4 = STATICNON INIT
501 ENDPOINT MAX INDEX REACHED IN BINAREA
502 FOR "4" NUMBER OF HALFWORDS
503 ENDCODE LAST RELOCATABLE ITEM TEXT SECTION
504 BINAREA BINARY ITEMS TO BE GENERATED
505 RETURNCODE 0 means OK
506 C *
507
508
509 * ************************************ GENENTRYPOINT PL/1 ***************** *
510
511 PROCEDURE genentrypoint textbytes pr4bytes typofentry : integer ;
512 segname entryname : alfaid ; functionflag : boolean ; VAR entrylength : integer ;
513 VAR returncode : integer ; EXTERNAL ;
514
515 * C .TYPOFENTRY 0 PASCAL INTERNAL PROCEDURE
516 1 PASCAL EXPORTABLE PROCEDURE
517 2 IMPORTED PROCEDURE ===> NO ENTRY SEQUENCE
518 4 EXIT LABEL ===> NO ENTRY SEQUENCE
519 .TEXTBYTES OFFSET IN BYTES IN TEXT SECTION OF ENTRY POINT
520 NO MEANINGS IF TYPOFENTRY=2
521 .PR4BYTES BYTES OFFSET OF AN EVEN-WORD IN LINKAGE SECTION TO BE FILLED
522 WITH AN ITS
523 .SEGNAME 32 CHARS STRING BLANK FOR EXPORTABLE or LOCAL
524 FOUND IN IMPORTSTRING FOR IMPORTED
525 .ENTRYNAME 32 CHARS STRING Pascal name LOCAL or EXPORT
526 FOUND IN IMPORTSTRING
527 .RETURNCODE 0 means OK
528
529 NO MEANING FOR 04
530 C *
531
532
533 PROCEDURE geninputlink pr4disp : integer ; VAR returncode : integer ; EXTERNAL ;
534 PROCEDURE genoutputlink pr4disp : integer ; VAR returncode : integer ; EXTERNAL ;
535 PROCEDURE generrorlink pr4disp : integer ; VAR returncode : integer ; EXTERNAL ;
536 * END OF IMPORTED PROCEDURES *
537
538
539
540
541 $OPTIONS page $
542
543 * ******************************************** INITDECLARE ******************* *
544
545 PROCEDURE initdeclare ;
546
547 * C THIS PROCEDURE INITIALIZES THE GLOBALS OF DECLARE AND IS CALLED IN
548 INITIALISE IN THE MODULE UNIQUE C *
549 BEGIN * INITDECLARE *
550 analyzing_schema.on := false ;
551 building_from_schema.on := false ;
552 clabix := 0 ;
553 exportscode := false ;
554 externallistheader := NIL ;
555 globdescriptors := false ;
556 filtop := -1 ; filev 0 := 0 ;
557 new firstlabbox ;
558 IF firstlabbox = NIL THEN heaperror ;
559 WITH firstlabbox^ DO
560 BEGIN
561 new next ;
562 IF next = NIL THEN heaperror ;
563 number := -1 ;
564 WITH next^ DO
565 BEGIN
566 next := NIL ;
567 number := 10000 ;
568 END ;
569 END ;
570 new lab_pdl_top ;
571 WITH lab_pdl_top^ DO
572 BEGIN
573 first_in_block := NIL ;
574 start := -1 ;
575 previous := NIL ;
576 next := NIL
577 END ;
578 new first_forbidden_id ;
579 WITH first_forbidden_id^ DO
580 BEGIN
581 previous := NIL ;
582 next := NIL ;
583 name := ' '
584 END ;
585 forbidden_id_list := first_forbidden_id ;
586 functionflag := false ;
587 getpr4afterstop := false ;
588 lc := 0 ;
589 lkc := 0 ;
590 decltrace := none ;
591 ptx := 0 ;
592 symbtabl := false ;
593 dversion := 00 ;
594 IF dversion > version THEN version := dversion ;
595 valuenb := 0 ; * COUNTER FOR CALLS OF VALUEDECL *
596 END * INITDECLARE * ;
597
598
599 $OPTIONS page $
600
601
602 * ********+**************************** PRINTEXTERNALBOX ********************* *
603
604 $OPTIONS compile = trace $
605 PROCEDURE printexternalbox boxtoprint : ptexternalitem ;
606
607 BEGIN
608 WITH boxtoprint^ DO
609 BEGIN
610 nextline ; write mpcogout boxheader ; nextline ;
611 write mpcogout '* This extern box is pointed by ^' ord boxtoprint ;
612 nextline ;
613 write mpcogout '* EXTERNNAME EXTNEXTEXTRFILE1 LINE1 FILE2 LINE2 and EXTDECL are:'
614 extname ' ^' ord extnext ' ^' extrfile1 extrline1 extrfile2 extrline2
615 ord extdecl ; nextline ;
616 write mpcogout '* EXTIMTEMTYPE is ORD' ord extitemtype ' EXTKIND is'
617 tabkinds extkind ; nextline ;
618 write mpcogout '* EXTPLTDISPEXTAREADISP and EXTLONG are :'
619 extpltdisp : 8 extareadisp extlong ; nextline ;
620 write mpcogout '* EXTSEGNAMEGENERATORENTRYNAME are :'
621 '%' extsegname '%' extgenerator '%' extentryname '%' ;
622 nextline ;
623 write mpcogout boxheader ; nextline ; nextline ;
624 END ;
625 END * PRINTEXTERNALBOX * ;
626 $OPTIONS compile = true $
627
628
629
630 $OPTIONS page $
631
632 * ************************************************* CHECKEXTERNALITEM *
633
634 PROCEDURE checkexternalitem fname : alfaid ; VAR foundext : ptexternalitem ;
635
636 * C
637 DURING THE COMPILATION OF GLOBAL VARIABLES FUNCTIONS AND
638 PROCEDURES EACH TIME A NEW IDENTIFIER ARRRIVES WE MUST VERIFY IF IT IS
639 THE DEFINITION OF A YET DECLARED IMPORTED OR EXPORTED ITEM.
640 IF FOUND RETURNS THE POINTER TO THE EXTERNALITEM BOX EITHER RETURNS NIL.
641 IF FOUND THE FIELD EXTDECL WILL BE FILLED AFTER SUCCESSFUL COMPILATION OF ITEM
642
643 C *
644 * E
645 446 : THE EXTERNAL NAME FOUND WAS ALREADY DEFINED
646 E *
647
648 LABEL
649 1 ; * EXIT WHILE *
650 VAR
651 workpt : ptexternalitem ;
652
653 BEGIN * CHECKEXTERNALITEM *
654 $OPTIONS compile = trace $
655 IF decltrace > none THEN
656 BEGIN
657 write mpcogout '@@@ begining of CHECKEXTERNALITEM @@@ for name:'
658 fname ; nextline ;
659 END ;
660 $OPTIONS compile = true $
661 workpt := externallistheader ;
662 foundext := NIL ; * default means "not found" *
663 WHILE workpt <> NIL DO
664 BEGIN
665 IF workpt^.extname = fname THEN
666 BEGIN
667 foundext := workpt ;
668 GOTO 1 * exit while * ;
669 END ELSE
670 workpt := workpt^.extnext ;
671 END * while * ;
672 1 : * exit while *
673 $OPTIONS compile = security $
674 IF foundext <> NIL THEN
675 IF foundext^.extdecl <> NIL THEN
676 IF foundext^.extdecl^.klass = vars THEN error 446 ELSE
677 IF foundext^.extdecl^.procdef <> forwdef THEN
678 error 446 ;
679 $OPTIONS compile = true $
680 $OPTIONS compile = trace $
681 IF decltrace = high THEN
682 BEGIN
683 write mpcogout ' @@@ fin de CHECKEXTERNALITEM @@@ avec pointeur retournee a ^' ord foundext ;
684 nextline ;
685 END ;
686 $OPTIONS compile = true $
687 END * CHECKEXTERNALITEM * ;
688
689
690 $OPTIONS page $
691
692 * ***************************** CREATEEXTERNALBOX *********************** *
693
694 PROCEDURE createexternalbox fname : alfaid ; fitemtype : externalitemtype ;
695 fkind : idkinds ; VAR fvextbox : ptexternalitem ;
696
697 * C Creates a external box with specified values.
698 Returns the pointer on created box
699 Modify EXTERNALLISTHEADER new box created
700 C *
701
702 * E Errors detected
703 Heaperror
704 E *
705
706 VAR
707 wkexternpt : ptexternalitem ;
708
709 BEGIN * CREATEEXTERNALBOX *
710 new wkexternpt ; IF wkexternpt = NIL THEN heaperror ; * Exit comp *
711 WITH wkexternpt^ DO
712 BEGIN
713 extname := fname ; extrfile1 := symbolfile ; extrline1 := symbolline ;
714 extrfile2 := 0 ; extrline2 := 0 ;
715 extnext := externallistheader ; externallistheader := wkexternpt ;
716 extsegname := blank ; extgenerator := blank ; extentryname := blank ;
717 extdecl := NIL ; * Filled later if item is declared *
718 extkind := fkind ; extitemtype := fitemtype ;
719 extpltdisp := 0 ; extareadisp := 0 ; extlong := 0 ;
720 END * with * ;
721
722 * <----- *
723 fvextbox := wkexternpt ;
724 END * CREATEEXTERNALBOX * ;
725
726
727 $OPTIONS page $
728
729 PROCEDURE push_lab_pdl ;
730
731 * PUSH-POP LABEL BLOCK SYSTEM *
732
733 BEGIN
734 IF lab_pdl_top^.next = NIL THEN
735 BEGIN
736 new lab_pdl_top^.next ;
737 WITH lab_pdl_top^.next^ DO
738 BEGIN
739 previous := lab_pdl_top ;
740 next := NIL ;
741 END
742 END ;
743 lab_pdl_top := lab_pdl_top^.next ;
744 WITH lab_pdl_top^ DO
745 BEGIN
746 start := ic ;
747 first_in_block := NIL ;
748 END
749 END * PUSH_LAB_PDL * ;
750
751 $OPTIONS page $
752
753 PROCEDURE pop_lab_pdl ;
754
755 * PUSH-POP LABEL BLOCK SYSTEM *
756
757 VAR
758 lbp : labelblockptr ;
759
760 BEGIN
761 WITH lab_pdl_top^ DO
762 BEGIN
763 lbp := first_in_block ;
764 WHILE lbp <> NIL DO
765 BEGIN
766 lbp^.ref_allowed.ic_from := start ;
767 lbp^.ref_allowed.ic_to := ic - 1 ;
768 lbp := lbp^.next_in_block ;
769 END
770 END ;
771
772 IF lab_pdl_top^.previous <> NIL THEN * SECURITY *
773 lab_pdl_top := lab_pdl_top^.previous ;
774 END * POP_LAB_PDL * ;
775
776 $OPTIONS page $
777
778 * ******************************** CHECKDEFININGPOINT *************** *
779
780 PROCEDURE checkdefiningpoint fname : alfaid ; fbegsearch : ctp ;
781
782 * C
783 A new identifier is to be defined at this level.
784 Before we must verify that this name is not already used:
785 . as the name of a normally declared item
786 . to identify an item declared in an englobing procedure
787 and already used in the level we try to redeclare it
788 . as the name of an item in course of declaration
789 C *
790
791 * E ERRORS DETECTED
792 101 : Identifier declared twice
793 118 : Identifier already used at this level with another meaning
794 E *
795
796 LABEL
797 1 * exit while * ;
798
799 VAR
800 * WORKPT : PTLOCKEDITEM *
801
802 BEGIN * CHECKDEFININGPOINT *
803 $OPTIONS compile = trace $
804 IF decltrace > none THEN
805 BEGIN
806 write mpcogout '@@@ Debut de CHECKDEFININGPOINT @@@ '
807 ' avec FBEGSEARCH ^' ord fbegsearch : 8
808 ' et le nom:' fname ;
809 nextline ;
810 END ;
811 $OPTIONS compile = true $
812 srchrec fbegsearch ;
813 IF ctptr <> NIL THEN
814 BEGIN
815 IF symbolmap THEN
816 nameisref ctptr symbolfile symbolline ;
817 error 101 ;
818 END ELSE
819 BEGIN * new identifier *
820 * This name was not already declared at this level.
821 Is it already used or pending ? *
822 *
823 WORKPT:= LOCKEDLISTHEADER ;
824 while WORKPT<>nil do
825 if WORKPT^.LOCKEDNAME=FNAME then
826 begin
827 ERROR118 ; goto 1 ;
828 end else
829 WORKPT:= WORKPT^.LOCKEDNEXT ;
830 *
831 1 : * exit while *
832 END * new identifier * ;
833 $OPTIONS compile = trace $
834 IF decltrace = high THEN
835 BEGIN
836 write mpcogout '@@@ Fin de CHECKDEFININGPOINT @@@ ' ;
837 nextline ;
838 END ;
839 $OPTIONS compile = true $
840 END * CHECKDEFININGPOINT * ;
841
842 $OPTIONS page $
843
844 * *********************************************************TYPEDECL*********** *
845
846 PROCEDURE typedecl VAR returnsize : integer ; VAR returntype : ctp ;
847
848 * C CALLED AT EACH OCCURENCE OF <TYPE> IN PASCAL'S GRAMMAR:
849 EITHER TO RECOGNIZE AN EXISTING TYPE
850 OR TO CREATE BOXES ASSOCIATED WITH A NEW TYPE.
851 IN BOTH CASESRETURNS SIZE OF AN OBJECT OF THIS TYPE AND POINTER ON THIS
852 TYPE.
853 WHEN AN ERROR IS FOUND RETURNTYPE IS NIL. C *
854 * E ERRORS DETECTED :
855 HEAPERROR
856 2 IDENTIFIER EXPECTED
857 4 '' EXPECTED
858 8 'OF' EXPECTED
859 10 ERROR IN TYPE DECLARATION
860 11 '' EXPECTED
861 12 '' EXPECTED
862 13 'END' EXPECTED
863 15 INTEGER EXPECTED
864 62 Pointed type not defined
865 96 ILLEGAL POINTED ITEM
866 98 'PACKED' NOT ALLOWED HERE
867 108 File not allowed here
868 112 TOO LARGE ARRAY
869 115 BASE TYPE MUST BE SCALAR OR NUMERIC
870 169 ERROR IN BASE TYPE OF A SET
871 268 TOO MANY FORWARD DEFINED POINTERS
872 305 VALUE IN A SET OUT OF BOUNDS E *)
873 LABEL
874 11, * ANALYSIS FOR TYPE OF ARRAY ELEMENT *
875 19 ; * END OF ARRAY TYPE *
876 VAR
877 bigsize : real ;
878 indexflag, lerr, packflag : boolean ;
879 li, lh, lcad, elsize, displ, bdispl, sl, sh : integer ;
880 nxta, lp, lt, eltyp, rtyp, nxtf, lastfld, recvpt,
881 spt, locpt, lfpt, oldnxtf, pp : ctp ;
882 check_id_saved : boolean ;
883
884
885 * *********************************************************SKIPT < TYPEDECL*** *
886
887 PROCEDURE skipt fno : integer ;
888
889 * C SKIPS ANY SYMBOL WHICH IS NOT BEGSYENDSY OR THE SPECIFIED
890 ITEM " FNO " C *
891 BEGIN
892 $OPTIONS compile = trace $
893 IF decltrace > none THEN
894 BEGIN
895 write mpcogout ' @@@ DEBUT SKIPT @@@ WITH FNO ' fno : 4 ; nextline ;
896 END ;
897 $OPTIONS compile = true $
898 WHILE terrcl no = irrelsy AND fno # no DO insymbol ;
899 END * SKIPT * ;
900
901
902 * *********************************************************TYPERR < TYPEDECL** *
903
904 PROCEDURE typerr ferrno : integer ;
905
906 * C ASSIGNS RETURNED PARAMETERS OF TYPEDECL WITH DEFAULT VALUES SKIPS
907 ANY IRRELEVANT SYMBOL AND PRODUCES AN ERROR MESSAGE C *
908 BEGIN
909 returnsize := 0 ; err := true ;
910 returntype := NIL ;
911 error ferrno ;
912 skipt 46 ; * 46 IS NOT ASSIGNED => SYMBOLS ARE *
913 * SKIPPED UNTIL BEGSY OR ENDSY *
914 END * TYPERR * ;
915
916
917 * ***********************************************SIMPLETYPE<TYPEDECL********** *
918
919 PROCEDURE simpletype VAR sretmin sretmax : integer ; VAR srettype : ctp ;
920
921 * C THIS PROCEDURE IS CALLED IN ORDER TO
922 EITHER RECOGNIZE A TYPE IDENTIFIER
923 EITHER CREATE A SCALAR TYPE ID1ID2....
924 EITHER CREATE A SUBRANGE TYPE CST1..CST2
925 OR FIND MINMAX OF A SUBRANGE WITHOUT CREATING ATYPE INDEXFLAG TRUE
926 AND ASSIGNS RETURNSIZE FOR TYPEDECL
927 C *
928 * E ERRORS DETECTED
929 2: IDENTIFIER EXPECTED
930 4: '' EXPECTED
931 99: ILLEGAL BEGINNING ITEM FOR A SIMPLE TYPE
932 101: IDENTIFIER DECLARED TWICE
933 103: IDENTIFIER IS NOT OF APPROPRIATE CLASS
934 104: IDENTIFIER NOT DECLARED
935 113: INDEX TYPE MUST BE SCALAR OR NUMERIC
936 E *)
937 LABEL
938 2 ; * SKIP HERE IF ERROR *
939 * IN IDENTIFIER'S LIST *
940 VAR
941 lerr : boolean ;
942 cv : integer ;
943 lp, nxtc, ltyp : ctp ;
944 lnext, saved_next, lctp, generic, ctype : ctp ;
945 ltop, saved_top, ccode, it : integer ;
946
947
948 * *************************************SUBRANGE < SIMPLETYPE < TYPEDECL******* *
949
950 PROCEDURE subrange VAR lowbound highbound : integer ; VAR typcstes : ctp ;
951 fbegsearch : ctp ;
952
953 * C USED TO RECOGNIZE A SUBRANGEFIRST SYMBOL OF THE SUBRANGE HAS YET BEEN READ
954 THE BOUNDS ARE RETURNED IN LOWBOUND AND HIGHBOUND.
955 THE TYPE OF THE CONSTANTS IS RETURNED IN TYPCSTES.
956 FBEGSEARCH GIVES THE FIRST ITEM TO BE INSPECTED IN CONTEXTTABLE.
957 THE GLOBAL VARIABLE ERR GETS THE VALUE "TRUE" IF AN ERROR OCCURSNO SKIP.
958 C *
959 * E ERRORS: 5 '..' EXPECTED
960 102 HIGHBOUND MUST NOT BE LOWER THAN LOWBOUND
961 113 INDEX TYPE MUST BE SCALAR OR NUMERIC
962 114 BASE TYPE MUST BE SCALAR OR NUMERIC
963 145 TYPE CONFLICT E *
964 VAR
965 dummy : integer ;
966 lowtype, hightype : ctp ;
967 BEGIN
968 $OPTIONS compile = trace $
969 IF decltrace > none THEN
970 BEGIN
971 write mpcogout ' @@@ DEBUT SUBRANGE @@@ WITH FBEGSEARCH' ord fbegsearch ;
972 nextline ;
973 END ;
974 $OPTIONS compile = true $
975 inconst dummy lowtype fbegsearch false ;
976 IF symbolmap THEN
977 IF lowtype <> NIL THEN
978 IF lowtype^.name <> blank THEN
979 nameisref lowtype symbolfile symbolline ;
980 typcstes := lowtype ;
981 IF lowtype # NIL THEN
982 IF lowtype@.form IN numeric scalar THEN
983 BEGIN
984 lowbound := conint ; * CONINT ASSIGNED BY INCONST *
985 IF no = 39 * .. * THEN
986 insymbol ELSE
987 BEGIN error 5 ; err := true ;
988 END ;
989 inconst dummy hightype next false ;
990 IF lowtype # hightype THEN
991 BEGIN
992 IF symbolmap THEN
993 IF hightype <> NIL THEN
994 IF hightype^.name <> blank THEN
995 nameisref hightype symbolfile symbolline ;
996 error 145 ; err := true ;
997 END ELSE
998 BEGIN
999 highbound := conint ; * SEE INCONST *
1000 IF lowbound > highbound THEN
1001 BEGIN
1002 error 102 ; err := true ;
1003 END ;
1004 END ; * NO ERROR IN HIGHTYPE *
1005 END * NO ERROR IN LOWTYPE * ELSE
1006 BEGIN
1007 err := true ; IF indexflag THEN error 113 ELSE error 114 ;
1008 END * TYPE NOT SCALAR OR NUMERIC * ELSE * LOWTYPE = NIL *
1009 err := true ; * ERROR IS CALLED BY INCONST *
1010 $OPTIONS compile = trace $
1011 IF decltrace > low THEN
1012 BEGIN
1013 write mpcogout ' @@@ FIN SUBRANGE @@@ WITH V.LOWHIGHTYP BOUNDS' lowbound
1014 highbound ord typcstes ;
1015 nextline ;
1016 END ;
1017 $OPTIONS compile = true $
1018 END * SUBRANGE * ;
1019
1020
1021 * *************************************SCALDECL < SIMPLETYPE < TYPEDECL******* *
1022
1023 PROCEDURE scaldecl fbegsearch : ctp ;
1024
1025 * C THIS PROCEDURE IS CALLED IN ORDER TO BUILD THE BOX ASSOCIATED WITH A TYPE
1026 CST1..CST2 NOT CALLED FOR INDEX
1027 THE BUILT TYPE IS EITHER TYPESNUMERIC
1028 EITHER TYPESSCALARTRUE
1029 THE RETURNED VALUES ARE:
1030 SRETMINSRETMAX SIMPLETYPE
1031 SRETTYPE SIMPLETYPE
1032 RETURNSIZE TYPEDECL
1033 CADRE GLOBAL C *
1034 VAR
1035 lmin, lmax : integer ;
1036 i1, i2 : integer ;
1037 lp, lpp : ctp ;
1038 BEGIN
1039 $OPTIONS compile = trace $
1040 IF decltrace > none THEN
1041 BEGIN
1042 write mpcogout ' @@@ DEBUT SCALDECL @@@ WITH FBEGSEARCH' ord fbegsearch ;
1043 nextline ;
1044 END ;
1045 $OPTIONS compile = true $
1046 subrange lmin lmax lpp fbegsearch ;
1047 IF NOT err THEN
1048 BEGIN
1049 IF lpp@.form = scalar THEN
1050 BEGIN
1051 create_types_box lp blank scalar true ;
1052 WITH lp^ DO
1053 BEGIN
1054 spksize := bytesneeded scalar lmax true ;
1055 smin := lmin ; smax := lmax ;
1056 typset := lpp ;
1057 cadrage := boundary scalar packflag spksize ;
1058 IF packflag THEN
1059 size := spksize ELSE
1060 size := bytesneeded scalar 0 false ;
1061 END ;
1062 END * SCALAR * ELSE
1063 BEGIN * NUMERIC *
1064 create_types_box lp blank numeric false ;
1065 WITH lp^ DO
1066 BEGIN
1067 IF lmin >= 0 THEN
1068 i1 := lmin ELSE
1069 i1 := lmin + 1 ;
1070 IF lmax >= 0 THEN
1071 i2 := lmax ELSE
1072 i2 := lmax + 1 ;
1073 npksize := bytesneeded numeric sup abs i1 abs i2 true ;
1074 nmin := lmin ; nmax := lmax ;
1075 cadrage := boundary numeric packflag npksize ;
1076 IF packflag THEN
1077 size := npksize ELSE
1078 size := bytesneeded numeric 0 false ;
1079 END ;
1080 END ; * NUMERIC *
1081 WITH lp@ DO
1082 BEGIN
1083 name := blank ; nxtel := NIL ; klass := types ; pack := packflag ;
1084 references := NIL ;
1085 END ;
1086 $OPTIONS compile = trace $
1087 printrec lp ;
1088 $OPTIONS compile = true $
1089 sretmin := lmin ; sretmax := lmax ; * FOR SIMPLETYPE *
1090 srettype := lp ; * FOR SIMPLETYPE *
1091 returnsize := lp@.size ; * FOR TYPEDECL *
1092 cadre := sup cadre lp@.cadrage ;
1093 END * NOT ERR * ELSE
1094 srettype := NIL ;
1095 $OPTIONS compile = trace $
1096 IF decltrace > low THEN
1097 BEGIN
1098 write mpcogout ' @@@ FIN SCALDECL @@@ WITH SRET MIN MAX TYPE;RETSIZECADRE'
1099 sretmin sretmax ord srettype returnsize cadre ;
1100 nextline ;
1101 END ;
1102 $OPTIONS compile = true $
1103 END * SCALDECL * ;
1104
1105
1106 BEGIN * SIMPLETYPE *
1107 $OPTIONS compile = trace $
1108 IF decltrace > none THEN
1109 BEGIN
1110 write mpcogout
1111 ' @@@ DEBUT SIMPLETYPE @@@ WITH NEXT NOCADREPACKFLAG' ord next
1112 no cadre packflag ;
1113 nextline ;
1114 END ;
1115 $OPTIONS compile = true $
1116 IF no = 1 * ID * THEN
1117 BEGIN
1118 lerr := err ; err := false ;
1119 srchrec next ; IF ctptr = NIL THEN search ;
1120 IF ctptr = NIL * ID. NOT FOUND * THEN
1121 BEGIN
1122 error 104 ; skipt 16 ; * ; * srettype := NIL ; err := true ;
1123 END ELSE
1124 IF ctptr^.klass = schema THEN
1125 BEGIN
1126 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1127 WITH building_from_schema DO
1128 IF on THEN typerr 511
1129 ELSE
1130 BEGIN
1131 schema_ptr := ctptr ;
1132 current_parameter := ctptr^.formal_parameter_list ;
1133 current_token := ctptr^.token_list ;
1134 insymbol ; * "" *
1135 IF no <> 9 THEN typerr 9 ;
1136 lnext := ctptr^.next_for_schema ;
1137 WHILE NOT err AND current_parameter <> NIL DO
1138 BEGIN
1139 insymbol ;
1140 inconst ccode ctype next true ;
1141 compatbin ctype current_parameter^.vtype generic ;
1142 IF generic = NIL OR generic = realptr THEN typerr 271 * ILLEGAL SHEMA PARAMETER SUBSTITUTION *
1143 ELSE
1144 BEGIN
1145 checkminmax conint current_parameter^.vtype 272 ;
1146 create_konst_box lctp current_parameter^.name wordconst ;
1147 WITH lctp^ DO
1148 BEGIN
1149 values := conint ; contype := generic ;
1150 succ := lnext ;
1151 END ;
1152 lnext := lctp ;
1153 END ;
1154 current_parameter := current_parameter^.nxtel ;
1155 IF NOT err THEN
1156 IF current_parameter <> NIL THEN
1157 IF no <> 15 * * THEN typerr 20 ELSE insymbol
1158 ELSE
1159 IF no <> 10 THEN typerr 4
1160 END ; * PARAMETER WHILE LOOP *
1161 IF err THEN srettype := NIL
1162 ELSE
1163 BEGIN
1164 on := true ;
1165 insymbol ;
1166 saved_next := next ; saved_top := top ;
1167 next := lnext ; top := schema_ptr^.top_for_schema ;
1168 typedecl returnsize srettype ;
1169 next := saved_next ; top := saved_top ;
1170 on := false ;
1171 IF srettype <> NIL THEN
1172 WITH srettype^ DO
1173 BEGIN
1174 father_schema := schema_ptr ;
1175 actual_parameter_list := lnext ;
1176 lctp := lnext ;
1177 it := father_schema^.parameter_count ;
1178 WHILE it <> 1 DO
1179 BEGIN
1180 it := it - 1 ;
1181 lctp := lctp^.nxtel
1182 END ;
1183 lctp^.nxtel := NIL ; * END OF ACTUAL PARAMETER LIST *
1184 END ;
1185 END ;
1186 END * BUILDING FROM SHEMA *
1187 END
1188 ELSE
1189 BEGIN * ID. FOUND *
1190 IF ctptr@.klass = types * ID. TYPE * THEN
1191 BEGIN
1192 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1193 IF ctptr@.form = aliastype THEN ctptr := ctptr@.realtype ;
1194 IF packflag THEN returnsize := packedsize ctptr ELSE
1195 returnsize := ctptr@.size ;
1196 IF indexflag * ARRAY INDEX * THEN
1197 IF NOT ctptr@.form IN scalar numeric THEN
1198 BEGIN
1199 error 113 ; err := true ;
1200 END ;
1201 srettype := ctptr ;
1202 IF ctptr@.form > pointer THEN
1203 cadre := ctptr@.cadrage ELSE
1204 cadre := boundary ctptr@.form packflag returnsize ;
1205 WITH ctptr@ DO
1206 CASE form OF
1207 numeric : BEGIN sretmin := nmin ; sretmax := nmax ;
1208 END ;
1209 scalar : IF subrng THEN * SUBRANGE *
1210 BEGIN sretmin := smin ; sretmax := smax ;
1211 END ELSE * NO SUBRANGE *
1212 BEGIN sretmin := 0 ; sretmax := fconst@.values ;
1213 END ;
1214 power pointer arrays records reel files aliastype
1215 : BEGIN sretmin := 0 ; sretmax := 0 ; * NO MEANING *
1216 END ;
1217 END ; * CASE WITH *
1218 insymbol ;
1219 END * TYPE ID * ELSE
1220 IF ctptr@.klass = konst * CONST. ID. * THEN
1221 IF indexflag THEN * ARRAY INDEX *
1222 subrange sretmin sretmax srettype ctptr ELSE * NOT INDEX *
1223 scaldecl ctptr ELSE * NOT A CONSTANT *
1224 BEGIN
1225 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1226 typerr 103
1227 END ;
1228 END * CTPTR # NIL * ;
1229 IF NOT err THEN err := lerr ;
1230 END * NO = 1 * ELSE
1231 IF no IN 2 7 * CONSTSIGN * THEN
1232 BEGIN
1233 lerr := err ; err := false ;
1234 IF indexflag THEN * ARRAY INDEX *
1235 subrange sretmin sretmax srettype next ELSE
1236 scaldecl next ;
1237 IF NOT err THEN err := lerr ;
1238 END * SUBRANGE * ELSE
1239 IF no = 9 * * THEN
1240 BEGIN * IDENTIFIER LIST *
1241 cv := -1 * COUNTER GIVES A VALUE FOR EACH IDENTIFIER * ;
1242 lerr := err ; err := false ;
1243 create_types_box lp blank scalar false ;
1244 WITH lp^ DO
1245 BEGIN
1246 pack := packflag ;
1247 END ;
1248 ltyp := lp ; nxtc := NIL ; * CHAIN OF CONST *
1249 REPEAT
1250 insymbol ; cv := cv + 1 ;
1251 IF no # 1 * ID. * THEN
1252 BEGIN
1253 error 2 ; skipt 15 ; * *
1254 GOTO 2 ; * BEFORE UNTIL *
1255 END ;
1256 srchrec next ;
1257 IF ctptr <> NIL THEN BEGIN
1258 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1259 error 101
1260 END
1261 ELSE
1262 BEGIN
1263 create_konst_box lp aval wordconst ;
1264 WITH lp^ DO
1265 BEGIN
1266 contype := ltyp ; values := cv ; succ := nxtc ;
1267 next := lp ; nxtc := lp ;
1268 END ;
1269 next := lp ; nxtc := lp ;
1270 END ;
1271 $OPTIONS compile = trace $
1272 printrec lp ;
1273 $OPTIONS compile = true $
1274 insymbol ;
1275 2 : * HAVE WE ? *
1276 UNTIL no # 15 ; * SYMBOL READ NOT *
1277 WITH ltyp@ DO
1278 BEGIN
1279 fconst := next ; * LAST CREATED BOX *
1280 spksize := bytesneeded scalar cv true ;
1281 cadrage := boundary scalar packflag spksize ;
1282 size := bytesneeded scalar cv packflag ;
1283 END ;
1284 returnsize := ltyp@.size ; cadre := sup cadre ltyp@.cadrage ;
1285 sretmin := 0 ; sretmax := cv ; srettype := ltyp ;
1286 * NOW CREATES SET BOX *
1287 create_types_box lp blank power false ;
1288 WITH lp^ DO
1289 BEGIN
1290 ppksize := bytesneeded power cv true ;
1291 setlength := cv + 1 ;
1292 pack := packflag ;
1293 cadrage := boundary power packflag ppksize ;
1294 size := bytesneeded power cv packflag ;
1295 elset := ltyp ;
1296 END ;
1297 ltyp@.sptcstepw := lp ;
1298 $OPTIONS compile = trace $
1299 printrec ltyp ; printrec lp ;
1300 $OPTIONS compile = true $
1301 IF no = 10 * * THEN
1302 insymbol ELSE typerr 4 ;
1303 IF NOT err THEN err := lerr ;
1304 END * IDENTIFIER LIST * ELSE
1305 typerr 99 ;
1306 $OPTIONS compile = trace $
1307 IF decltrace > low THEN
1308 BEGIN
1309 write mpcogout ' @@@ FIN SIMPLETYPE @@@ WITH V.SRET MINMAXTYPE;CADRE;RETURNSIZE'
1310 sretmin sretmax ord srettype cadre returnsize ;
1311 nextline ;
1312 END ;
1313 $OPTIONS compile = true $
1314 END ; * SIMPLETYPE *
1315
1316
1317 * ***********************************************FIELDLIST < TYPEDECL********* *
1318
1319 PROCEDURE fieldlist VAR maxsize : integer ; VAR varptr nxtf : ctp ;
1320
1321 * C ANALYZES A LIST OF FIELDS + VARIANT PART . EACH LIST IN THE CASE IS
1322 ANALYZED BY CALLING AGAIN FIELDLIST.
1323 RETURNS MAXSIZE : MAX. SIZE OF THE RECORD
1324 VARPTR : POINTER ON THE TAGFIELD BOX
1325 NXTF:POINTER ON THE LAST FIELDHAS THE SAME MEANING IN INPUT C *
1326 * E ERRORS 2 IDENTIFIER EXPECTED
1327 4 '' EXPECTED
1328 7 ':' EXPECTED
1329 8 'OF' EXPECTED
1330 9 '' EXPECTED
1331 50 ERROR IN CONSTANT
1332 101 IDENTIFIER DECLARED TWICE
1333 103 IDENTIFIER IS NOT OF APPROPRIATE CLASS
1334 104 IDENTIFIER NOT DECLARED
1335 108 File not allowed here
1336 110 ERROR IN THE TYPE IDENTIFIER OF A TAGFIELD
1337 111 INCOMPATIBLE WITH TAGFIELD TYPE
1338 301 CASE VARIANT OUT OF BOUND E *
1339 VAR
1340 tagflag lerr casefield llast : boolean ;
1341 nbfield lcad i lsize it minsize casebytes mxl fieldsize : integer ;
1342 auxalf : alfaid ;
1343 lp lpp pp nxt fieldtype nxtdeb nxtc tempctptr tagtype : ctp ;
1344 selfield oldnxt ffld : ctp ;
1345 oldfile oldline : integer ;
1346 checkcase : SET OF 0..maxset ;
1347 origin max ccount k : integer ;
1348 negative : boolean ;
1349
1350
1351 * *************************************ADJUST < FIELDLIST < TYPEDECL********** *
1352
1353 PROCEDURE adjust ;
1354
1355 * C PROCEDURE USED IN ORDER TO ADJUST THE BOUNDARY OF A FIELD IN A
1356 PACKED PART OF A RECORD
1357 IF IT IS THE FIRST FIELD OF THE RECORD NOTHING IS DONE.
1358 OTHERWISE : 1IF THE LAST FIELD IS NOT A TAGFIELD:
1359 -MOVE IT TO THE RIGHT OF THE WORD
1360 -SET ITS WIDTH TO WORD SIZE IF IT IS THE ONLY FIELD OF THE
1361 WORD AND IF IT IS SMALLER THAN A WORD.
1362 2ALWAYS INCREASE DISPL AND RESET BDISPL
1363 ASSERTION : AN ITEM GREATER THAN A WORD BEGINS AT A WORD BOUNDARY C *)
1364 BEGIN
1365 $OPTIONS compile = trace $
1366 IF decltrace > none THEN
1367 BEGIN
1368 write mpcogout ' @@@ DEBUT ADJUST @@@ WITH DISPLBDISPLTAGFLAGLASTFLD:' displ
1369 bdispl : 4 tagflag : 7 ord lastfld ;
1370 nextline ;
1371 END ;
1372 $OPTIONS compile = true $
1373 IF lastfld # NIL THEN * NOT FIRST FIELD *
1374 BEGIN
1375 IF NOT tagflag THEN WITH lastfld@ DO * NOT A TAGFIELD *
1376 IF fldtype@.form <= power THEN
1377 IF fldaddr MOD bytesinword = 0 THEN * FIRST FIELD OF A WORD *
1378 BEGIN
1379 IF bytwidth < bytesinword THEN bytwidth := bytesinword
1380 END ELSE
1381 BEGIN
1382 fldaddr := recadre fldaddr bytesinword - bytwidth ;
1383 END ;
1384 displ := displ + bytesinword - bdispl ;
1385 bdispl := 0 ;
1386 END ;
1387 $OPTIONS compile = trace $
1388 IF decltrace > low THEN
1389 BEGIN
1390 write mpcogout ' @@@ FIN ADJUST @@@ WITH DISPLBDISPL:' displ bdispl : 4 ;
1391 nextline ;
1392 END ;
1393 $OPTIONS compile = true $
1394 END * ADJUST * ;
1395
1396
1397 BEGIN * FIELDLIST *
1398 $OPTIONS compile = trace $
1399 IF decltrace > none THEN
1400 BEGIN
1401 write mpcogout ' @@@ DEBUT FIELDLIST @@@ WITH NXTF AT' ord nxtf ; nextline ;
1402 END ;
1403 $OPTIONS compile = true $
1404 tagflag := true * FIRST FIELD OF A RECORD OR OF A LIST IN THE CASE * ;
1405 nxt := nxtf * LAST FIELD FOUND IN THE SAME RECORD INITIALY NIL TYPEDECL * ;
1406
1407 * ANALYSIS OF FIXED PART NO#26 'CASE' *
1408 REPEAT * LOOP ON XYZ:TYPID; *
1409 IF no # 26 * NOT CASE * THEN
1410 BEGIN
1411 IF no = 1 * ID * THEN
1412 BEGIN
1413 nbfield := 0 ; * NB OF ID OF THE SAME TYPE * ; nxtdeb := NIL ; * DEFAULT *
1414 REPEAT * LOOP ON XY... *
1415 srchrec nxt ;
1416 IF ctptr # NIL THEN * TWO IDENTICAL FIELDS *
1417 BEGIN
1418 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1419 error 101
1420 END
1421 ELSE
1422 BEGIN * NEW ID. AT THIS LEVEL *
1423 create_field_box lp aval ;
1424 WITH lp^ DO
1425 BEGIN
1426 nxtel := nxt ;
1427 END ;
1428 IF nbfield # 0 THEN nxt@.fldtype := lp * FORWARD LINKAGE * ELSE
1429 nxtdeb := lp * POINTS ON THE FIRST FIELD OF THE LIST * ;
1430 nxt := lp ; nbfield := nbfield + 1 ;
1431 END ; * NEW ID. *
1432 insymbol ;
1433 IF no = 15 * * THEN
1434 BEGIN
1435 insymbol ;
1436 IF no # 1 * ID * THEN
1437 BEGIN
1438 error 2 ; skipt 46 ;
1439 END ;
1440 END ;
1441 UNTIL no # 1 ;
1442 nxt@.fldtype := NIL ; * ENDS FORWARD LINKAGE *
1443
1444 check_id := old_check_id ;
1445
1446 IF no # 19 * : * THEN error 7 ELSE
1447 insymbol ;
1448 lcad := cadre ; cadre := 0 ;
1449 lerr := err ; err := false ;
1450 llast := structispack ;
1451 typedecl fieldsize fieldtype ;
1452
1453 check_id := false ;
1454
1455 structispack := llast ;
1456 IF fieldtype = NIL OR err THEN
1457 err := true ELSE
1458 BEGIN
1459 IF cadre = 0 THEN cadre := bytesinword ; * Security *
1460 IF fieldtype@.form > records THEN
1461 BEGIN error 108 ; err := true ;
1462 END ELSE
1463 BEGIN
1464 IF NOT structispack THEN
1465 BEGIN * UNPACKED *
1466 IF cadre < bytesinword THEN cadre := bytesinword ;
1467 displ := recadre displ cadre ;
1468 IF nbfield > 1 THEN fieldsize := recadre fieldsize cadre ;
1469 pp := nxtdeb ; * FIRST FIELD OF THE LIST *
1470 FOR i := 1 TO nbfield DO
1471 BEGIN
1472 lp := pp ; lp@.fldaddr := displ ;
1473 lp@.bytwidth := fieldsize ;
1474 pp := lp@.fldtype ; * FORWARD LINKAGE * ;
1475 lp@.fldtype := fieldtype ;
1476 displ := displ + fieldsize ;
1477 $OPTIONS compile = trace $
1478 printrec lp ;
1479 $OPTIONS compile = true $
1480 END ;
1481 END * UNPACKED * ELSE
1482 BEGIN * PACKED *
1483 IF fieldtype@.form = pointer THEN cadre := bytesinword ;
1484 IF fieldtype@.form >= power THEN
1485 lsize := fieldtype@.size ELSE
1486 lsize := packedsize fieldtype ;
1487 pp := nxtdeb ; * FIRST FIELD OF THE LIST *
1488 IF fieldtype@.form <= power THEN * NEITHER ARRAY NOR RECORD *
1489 FOR i := 1 TO nbfield DO
1490 BEGIN * A FIELD > 1 WORD MUST BEGIN *
1491 * AT A WORD BOUNDARY *
1492 IF bdispl + lsize > bytesinword AND bdispl # 0
1493 THEN adjust ;
1494 WITH pp@ DO
1495 BEGIN
1496 bytwidth := lsize ;
1497 displ := recadre displ cadre ;
1498 fldaddr := displ ;
1499 END ;
1500 displ := displ + lsize ; bdispl := displ MOD bytesinword ;
1501 lp := pp ; pp := lp@.fldtype ; lp@.fldtype := fieldtype ;
1502 tagflag := false ; lastfld := lp ;
1503 $OPTIONS compile = trace $
1504 printrec lp ;
1505 $OPTIONS compile = true $
1506 END ELSE * ARRAYS AND RECORDS MUST *
1507 * START AT WORD LIMIT *
1508 FOR i := 1 TO nbfield DO
1509 BEGIN
1510 IF bdispl # 0 THEN adjust ;
1511 WITH pp@ DO
1512 BEGIN
1513 displ := recadre displ cadre ;
1514 fldaddr := displ ; bytwidth := lsize ;
1515 END ;
1516 bdispl := lsize MOD bytesinword ; displ := displ + lsize ;
1517 lp := pp ; pp := lp@.fldtype ; lp@.fldtype := fieldtype ;
1518 tagflag := false ; lastfld := lp ;
1519 $OPTIONS compile = trace $
1520 printrec lp ;
1521 $OPTIONS compile = true $
1522 END ; * ARRAYS AND RECORDS *
1523 END ; * PACKED *
1524 END ; * FORM <= RECORD AND *
1525 * NO PREVIOUS ERROR *
1526 END ;
1527 IF err THEN
1528 BEGIN * SET FLDTYPE TO NIL *
1529 pp := nxt ;
1530 FOR i := nbfield DOWNTO 1 DO
1531 BEGIN
1532 pp@.fldtype := NIL ;
1533 $OPTIONS compile = trace $
1534 printrec pp ;
1535 $OPTIONS compile = true $
1536 pp := pp@.nxtel ;
1537 END ;
1538 END ELSE err := lerr ;
1539 cadre := sup cadre lcad ;
1540 END ; * NO = 1 *
1541 IF no = 16 THEN
1542 insymbol ELSE
1543 BEGIN
1544 IF no = 1 THEN error 14 ;
1545 END ;
1546 END ; * NO# 26 'CASE' *
1547 UNTIL NOT no IN 1 16 ; * ; ID *
1548 maxsize := displ ; varptr := NIL ;
1549 IF no = 26 * CASE * THEN
1550 BEGIN
1551 insymbol ;
1552 IF no # 1 * ID * THEN error 2 ELSE
1553 BEGIN
1554 srchrec nxt ; tempctptr := ctptr ; * IT MAY BE A FIELD OR *
1555 srchrec next ;
1556 IF ctptr = NIL THEN search ; * A TYPE IDENTIFIER *
1557 auxalf := aval ;
1558 oldfile := symbolfile ; oldline := symbolline ;
1559 insymbol ;
1560 IF no = 19 * : * THEN * SELECTOR HAS A FIELD *
1561 BEGIN
1562 IF tempctptr # NIL THEN error 101 * ALLREADY USED * ELSE
1563 BEGIN
1564 create_field_box lp auxalf ;
1565 WITH lp^ DO
1566 BEGIN
1567 nxtel := nxt ; deffile := oldfile ; defline := oldline ;
1568 END ;
1569 nxt := lp ;
1570 selfield := lp ;
1571 END ; * TAG FIELD IS NEW FIELD *
1572 insymbol ; * LOOK AT THE TYPE IDENTIFIER *
1573 IF no # 1 * ID * THEN error 2 ELSE
1574 BEGIN
1575 srchrec next ;
1576 IF ctptr = NIL THEN search ;
1577 END ;
1578 casefield := true ;
1579 oldfile := symbolfile ; oldline := symbolline ;
1580 insymbol ;
1581 END ELSE * SELECTOR HAS NO FIELD *
1582 casefield := false ;
1583 IF ctptr = NIL THEN error 104 * UNKNOWN TYPE * ELSE
1584 BEGIN
1585 IF symbolmap THEN nameisref ctptr oldfile oldline ;
1586 IF ctptr@.klass # types THEN error 110 ELSE
1587 BEGIN
1588 IF ctptr@.form = aliastype THEN ctptr := ctptr@.realtype ;
1589 origin := 0 ; max := 0 ;
1590 WITH ctptr^ DO
1591 IF form = numeric THEN
1592 IF ctptr = intptr THEN error 106 ELSE
1593 BEGIN
1594 origin := nmin ; max := nmax - nmin ;
1595 END
1596 ELSE
1597 IF form = scalar THEN
1598 IF subrng THEN
1599 BEGIN
1600 origin := smin ; max := smax - smin ;
1601 END ELSE
1602 BEGIN
1603 origin := 0 ; max := fconst^.values ;
1604 END
1605 ELSE
1606 error 110 ;
1607
1608 ccount := -1 ; checkcase := ;
1609 IF max > maxset THEN
1610 BEGIN
1611 error 32 ; max := maxset ;
1612 END ;
1613 END ;
1614 END ;
1615 IF no # 27 * OF * THEN error 8 ;
1616 tagtype := ctptr ;
1617 IF casefield THEN
1618 BEGIN * CASE ID: TYPE OF *
1619 IF tagtype # NIL THEN
1620 BEGIN
1621 IF NOT structispack THEN
1622 BEGIN
1623 displ := recadre displ tagtype@.cadrage ;
1624 lsize := tagtype@.size ;
1625 END ELSE
1626 BEGIN
1627 lsize := packedsize tagtype ;
1628 IF bdispl # 0 AND bdispl + lsize > bytesinword THEN adjust ;
1629 tagflag := false ; lastfld := lp ;
1630 END ; * PACKED *
1631 WITH lp@ DO
1632 BEGIN
1633 fldaddr := displ ; bytwidth := lsize ; fldtype := tagtype ;
1634 END ;
1635 $OPTIONS compile = trace $
1636 printrec lp ;
1637 $OPTIONS compile = true $
1638 displ := displ + lsize ; bdispl := displ MOD bytesinword ;
1639 END ; * TAGTYPE # NIL *
1640 END ; * TAG IDENTIFIER *
1641 minsize := displ ; maxsize := minsize ; nxtc := NIL ;
1642 casebytes := bdispl ;
1643 insymbol ;
1644 REPEAT * LOOP ON CASE 'LABELS' *
1645 i := 0 ; * COUNT THE CONSTANTS FOR ONE CASE *
1646 REPEAT * SAME CASE *
1647 IF no = 7 AND cl = 2 THEN
1648 BEGIN
1649 negative := true ;
1650 insymbol
1651 END
1652 ELSE negative := false ;
1653 IF no > 2 OR no = 2 AND NOT cl IN 1 4 THEN
1654 BEGIN * ILLEGAL CASE LABEL *
1655 error 50 ; skipt 46 ;
1656 END ELSE
1657 BEGIN
1658 IF tagtype # NIL THEN
1659 IF no = 1 * ID * THEN
1660 BEGIN
1661 srchrec next ; IF ctptr = NIL THEN search ;
1662 IF ctptr = NIL THEN error 104 ELSE
1663 BEGIN
1664 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1665 WITH ctptr@ DO
1666 IF klass # konst THEN error 103 ELSE
1667 BEGIN
1668 IF tagtype@.form = scalar AND contype # tagtype AND
1669 tagtype@.typset # contype OR
1670 tagtype@.form = numeric AND contype # intptr THEN
1671 BEGIN
1672 error 111 ; it := 0 ;
1673 END ELSE
1674 IF tagtype^.form = scalar AND negative THEN
1675 BEGIN
1676 error 50 ; it := 0
1677 END
1678 ELSE
1679 BEGIN
1680 it := values ; IF negative THEN it := -it ;
1681 checkminmax it tagtype 301 ;
1682 END ;
1683 END * ELSEWITH *
1684 END ;
1685 END * NO=1 * ELSE * EXPLICIT CONST *
1686 BEGIN
1687 IF negative THEN ival := -ival ;
1688 it := ival ;
1689 IF cl = 1 AND tagtype@.form # numeric OR cl = 4 AND
1690 tagtype # charptr AND tagtype@.typset # charptr
1691 THEN error 111 ;
1692 checkminmax it tagtype 301 ;
1693 END * NUMERIC * ELSE * TAGTYPE = NIL *
1694 it := 0 ;
1695 k := it - origin ;
1696 IF k >= 0 AND k <= max THEN
1697 IF k IN checkcase THEN error 310 ELSE
1698 BEGIN
1699 checkcase := checkcase + k ;
1700 ccount := ccount + 1 ;
1701 END ELSE
1702 error 312 ;
1703 create_tagfield_box lp blank true ;
1704 WITH lp^ DO
1705 BEGIN
1706 nxtel := nxtc ; caseval := it ;
1707 END ;
1708 nxtc := lp ; i := i + 1 ;
1709 insymbol ;
1710 END ; * CONSTANT *
1711 IF no <> 19 THEN
1712 IF no = 15 THEN insymbol
1713 ELSE error 317 ;
1714 UNTIL no > 2 AND no <> 7 ;
1715 IF no # 19 * : * THEN error 7 ELSE insymbol ;
1716 oldnxt := nxt ;
1717 IF no = 9 * * THEN
1718 BEGIN * START OF FIELDS LIST *
1719 displ := minsize ; bdispl := casebytes ; insymbol ;
1720 fieldlist mxl pp nxt ;
1721 IF no = 10 * * THEN insymbol ELSE error 4 ;
1722 END * NO=9 * ELSE
1723 BEGIN
1724 error 9 ; pp := NIL ; mxl := minsize ; skipt 46 ;
1725 END ;
1726 lpp := nxtc ;
1727 IF nxt = oldnxt THEN ffld := NIL
1728 ELSE
1729 BEGIN
1730 ffld := nxt ;
1731 WHILE ffld^.nxtel <> oldnxt DO
1732 ffld := ffld^.nxtel ;
1733 END ;
1734 FOR i := i DOWNTO 1 DO * END OF THE FILLING OF *
1735 * TAG VALUES RECORDS *
1736 IF lpp # NIL THEN WITH lpp@ DO
1737 BEGIN
1738 casesize := mxl ; variants := pp ;
1739 firstfield := ffld ;
1740 $OPTIONS compile = trace $
1741 printrec lpp ;
1742 $OPTIONS compile = true $
1743 lpp := nxtel ;
1744 END ; * THENWITH *
1745 maxsize := sup mxl maxsize ; * MAX. SIZE OF THE RECORD *
1746 IF no = 16 * ; * THEN insymbol ;
1747 UNTIL no > 2 ; * LOOP ON CASE 'LABELS' *
1748 IF ccount <> max THEN
1749 IF envstandard <> stdextend THEN error 311 ELSE warning 313 ;
1750 create_tagfield_box lp blank false ;
1751 WITH lp^ DO
1752 BEGIN
1753 casesize := maxsize ; variants := nxtc ; casetype := tagtype ;
1754 IF casefield THEN selectorfield := selfield
1755 END ;
1756 $OPTIONS compile = trace $
1757 printrec lp ;
1758 $OPTIONS compile = true $
1759 varptr := lp ;
1760 END ; * NO=1 *
1761 END ; * NO=26 'CASE' *
1762 nxtf := nxt ;
1763 $OPTIONS compile = trace $
1764 IF decltrace > low THEN
1765 BEGIN
1766 IF decltrace = high THEN
1767 BEGIN
1768 write mpcogout ' DISPLBDISPLCADREERR ' displ bdispl cadre err ;
1769 nextline ;
1770 END ;
1771 write mpcogout ' @@@ FIN FIELDLIST @@@ WITH V.MAXSIZE V.VARPTR V.NXTF' maxsize
1772 ord varptr ord nxtf ;
1773 nextline ;
1774 END ;
1775 $OPTIONS compile = true $
1776 END * FIELDLIST * ;
1777
1778
1779 BEGIN * TYPEDECL *
1780 $OPTIONS compile = trace $
1781 IF decltrace > none THEN
1782 BEGIN
1783 write mpcogout
1784 ' @@@ DEBUT TYPEDECL @@@ WITH CADREERRNOCLSTRUCTISPACK' cadre : 4
1785 err no : 4 cl : 4 structispack ;
1786 nextline ;
1787 END ;
1788 $OPTIONS compile = true $
1789 packflag := structispack ; structispack := false ;
1790 indexflag := false * USED IN SIMPLETYPE FOR ARRAY'S INDEX * ;
1791 IF no = 42 * PACKED * THEN
1792 BEGIN
1793 insymbol ;
1794 IF no IN 1 2 7 9 18 THEN * IDCONSTSIGN@ *
1795 error 98 ELSE
1796 BEGIN structispack := true ; packflag := true ;
1797 END ;
1798 END ;
1799 IF no IN 1 2 7 9 THEN * IDCONSTSIGN *
1800 simpletype li lh returntype * RETURNSIZE IS ASSIGNED IN PROC * ELSE
1801 IF no = 38 * STRUCTURED TYPES * THEN
1802 BEGIN
1803 CASE cl OF
1804 1 : BEGIN * ARRAYS *
1805 insymbol ;
1806 IF no # 11 * *) THEN
1807 BEGIN
1808 error 11 ;
1809 IF NOT no IN 1 2 7 THEN * NOT SUBRANGE BEGINNING *
1810 insymbol ;
1811 END ;
1812 indexflag := true ; * FOR EACH DIMENSION *
1813 nxta := NIL * USED TO CHAIN SUBARRAYS VIA AELTYPE * ;
1814 REPEAT * LOOP ON DIMENSIONS *
1815 * ONE BOX 'ARRAYS' FOR EACH DIM. *
1816 create_types_box lp blank arrays false ;
1817 WITH lp^ DO
1818 BEGIN
1819 pack := structispack ;
1820 aeltype := nxta ;
1821 * Temporary reverse linkage *
1822 END ;
1823 nxta := lp ;
1824 insymbol ;
1825 lerr := err ; err := false ;
1826 simpletype li lh lt ; * DIMENSION 'S INDEX = SUBRANGE *
1827 * CHECK FOR TYPE OF INDEX MADE *
1828 * EITHER IN SIMPLETYPE *
1829 * EITHER IN SUBRANGE *
1830 IF err THEN
1831 BEGIN
1832 skipt 15 ; * FIND * li := 0 ; lh := 0 ; lt := NIL ;
1833 END ELSE
1834 err := lerr ;
1835 WITH nxta@ DO
1836 BEGIN
1837 lo := li ; hi := lh ; inxtype := lt ;
1838 END ;
1839 UNTIL no # 15 * * ;
1840 indexflag := false ;
1841 IF no # 12 * ] * THEN
1842 BEGIN
1843 error 12 ; skipt 27 ; * ==> OF *
1844 IF terrcl no = begsy THEN GOTO 11 ; * TYPE OF ELEMENT *
1845 IF no = 27 * OF * THEN
1846 BEGIN
1847 insymbol ; GOTO 11 ;
1848 END ;
1849 IF no # 12 * ] * THEN
1850 BEGIN
1851 returntype := NIL ; returnsize := 0 ; GOTO 19 ; * END OF ARRAY TYPE *
1852 END ;
1853 END * NO#12 * ;
1854 insymbol ;
1855 IF no = 27 * OF * THEN
1856 insymbol ELSE error 8 ;
1857 11 : * ANALYSIS OF ELEMENT TYPE *
1858 lcad := cadre ; cadre := 0 ; lerr := err ; err := false ;
1859 typedecl elsize eltyp ;
1860 IF eltyp # NIL THEN
1861 IF eltyp@.form > records THEN
1862 BEGIN error 108 ; eltyp := NIL ; err := true ;
1863 END ELSE
1864 IF cadre = 0 OR err THEN * PREVIOUS ERRORS *
1865 BEGIN
1866 eltyp := NIL ; err := true ;
1867 END ELSE
1868 BEGIN
1869 REPEAT
1870 WITH nxta@ DO
1871 BEGIN
1872 IF NOT pack THEN cadre := sup cadre bytesinword ;
1873 elsize := recadre elsize cadre ;
1874 subsize := elsize ; opt2 := poweroftwo elsize ;
1875 bigsize := hi ; bigsize := bigsize - lo + 1 ;
1876 bigsize := bigsize * elsize ;
1877 IF bigsize >= twoto18 * bytesinword THEN
1878 BEGIN error 112 ; bigsize := 1 ;
1879 hi := 1 ; lo := 1 ; * PROTECT *
1880 END ;
1881 elsize := round bigsize ;
1882 size := elsize ; cadrage := cadre ;
1883 lp := aeltype ; aeltype := eltyp ; * REVERSE LINKAGE *
1884 END ;
1885 $OPTIONS compile = trace $
1886 printrec nxta ;
1887 $OPTIONS compile = true $
1888 eltyp := nxta ; nxta := lp ;
1889 UNTIL nxta = NIL ;
1890 returnsize := elsize ; * SIZE FOR THE TOTAL ARRAY *
1891 err := lerr ;
1892 END ;
1893 returntype := eltyp ; * MAY BE NIL *
1894 cadre := sup lcad cadre ;
1895 19 : END * ARRAYS NO=38 CL=1 * ;
1896 2 : BEGIN * RECORDS *
1897 create_types_box lp blank records false ;
1898 WITH lp^ DO
1899 BEGIN
1900 pack := structispack ;
1901 END ;
1902 rtyp := lp ;
1903
1904 old_check_id := check_id ; check_id := false ;
1905
1906 insymbol ;
1907 nxtf := NIL ;
1908 displ := 0 ; bdispl := 0 ; * DISP. IN RECORD AND IN WORD IN BYTES *
1909 lastfld := NIL * TO INHIBIT USE OF ADJUST FUNCTION WITH FIRST FIELD * ;
1910 lerr := err ; lcad := cadre ;
1911 err := false ; cadre := 0 ;
1912 fieldlist returnsize recvpt nxtf ; * ANALYZIS OF FIELDS' LIST *
1913
1914 check_id := old_check_id ;
1915
1916 IF no # 22 * END * THEN error 13 ;
1917 IF err THEN
1918 typerr 10 ELSE
1919 BEGIN * NO PREVIOUS ERROR *
1920 err := lerr ;
1921 returntype := rtyp ;
1922 cadre := sup lcad cadre ;
1923 IF nxtf # NIL THEN * REVERSE FIELDS'POINTERS *
1924 * TO HAVE REAL ORDER *
1925 BEGIN
1926 oldnxtf := nxtf ; pp := nxtf@.nxtel ;
1927 WHILE pp # NIL DO
1928 BEGIN
1929 lp := pp ; pp := lp@.nxtel ; lp@.nxtel := nxtf ; nxtf := lp ;
1930 END ;
1931 oldnxtf@.nxtel := NIL ;
1932 END ;
1933 WITH rtyp@ DO
1934 BEGIN
1935 size := returnsize ; fstfld := nxtf ; recvar := recvpt ;
1936 cadrage := cadre ;
1937 END ;
1938 $OPTIONS compile = trace $
1939 printrec rtyp ;
1940 $OPTIONS compile = true $
1941 END ; * NO ERROR *
1942 IF no = 22 * END * THEN insymbol ;
1943 END * RECORDS NO=38 CL=2 * ;
1944 3 : BEGIN * FILES *
1945 create_types_box lp blank files false ;
1946 WITH lp^ DO
1947 BEGIN
1948 pack := structispack ;
1949 cadrage := boundary files false 0 ;
1950 END ;
1951 insymbol ;
1952 IF no = 27 * OF * THEN
1953 insymbol ELSE error 8 ;
1954 lcad := cadre ; cadre := 0 ;
1955 lerr := err ; err := false ;
1956 typedecl returnsize lfpt ;
1957 IF lfpt = NIL OR cadre = 0 OR err THEN
1958 typerr 10 ELSE
1959 IF lfpt@.form > records THEN
1960 BEGIN
1961 error 108 ; returntype := NIL ; err := true ;
1962 END ELSE
1963 BEGIN
1964 locpt := lp ; * BOX FILES *
1965 cadre := locpt@.cadrage ; err := lerr ;
1966 lp@.feltype := lfpt ;
1967 lp@.size := fsbpointersize ;
1968 $OPTIONS compile = trace $
1969 printrec lp ;
1970 $OPTIONS compile = true $
1971 returntype := lp ;
1972 END ;
1973 cadre := sup cadre lcad ;
1974 END ; * FILES NO=38 CL=3 *
1975 4 : BEGIN * SET *
1976 insymbol ;
1977 IF no = 27 * OF * THEN
1978 insymbol ELSE error 8 ;
1979 lerr := err ; err := false ; lcad := cadre ; cadre := 0 ;
1980 * SET IS PACKED ONLY IF *
1981 * WE HAVE "PACKED SET" *
1982 packflag := structispack ;
1983 simpletype sl sh spt ; * CHECK MADE HERE FOR TYPE *
1984 IF err OR spt = NIL OR cadre = 0 THEN
1985 typerr 169 ELSE
1986 BEGIN
1987 err := lerr ;
1988 IF NOT spt@.form IN numeric scalar THEN typerr 115 ELSE
1989 IF sl < 0 OR sh > maxset THEN
1990 typerr 305 ELSE
1991 BEGIN
1992 create_types_box lp blank power false ;
1993 WITH lp^ DO
1994 BEGIN
1995 ppksize := bytesneeded power sh true ;
1996 setlength := sh + 1 ;
1997 pack := structispack ;
1998 cadrage := boundary power packflag ppksize ;
1999 size := bytesneeded power sh packflag ;
2000 elset := spt ;
2001 END ;
2002 $OPTIONS compile = trace $
2003 printrec lp ;
2004 $OPTIONS compile = true $
2005 returnsize := lp@.size ;
2006 returntype := lp ;
2007 cadre := sup lcad lp@.cadrage ;
2008 END ;
2009 END ;
2010 END ; * POWER NO=38 CL=4 *
2011 END * CASE CL *
2012 END * NO = 38 * ELSE
2013 IF no = 18 * @ * THEN
2014 BEGIN * POINTER *
2015 check_id_saved := check_id ; check_id := false ;
2016 insymbol ;
2017 check_id := check_id_saved ;
2018 IF no # 1 * ID * THEN
2019 typerr 2 ELSE
2020 BEGIN
2021 returnsize := bytesneeded pointer 0 packflag ;
2022 create_types_box lp blank pointer false ;
2023 WITH lp^ DO
2024 BEGIN
2025 size := returnsize ;
2026 pack := packflag ;
2027 ptpksize := bytesneeded pointer 0 true ;
2028 cadrage := boundary pointer packflag ptpksize ;
2029 END ;
2030 srchrec next ; IF ctptr = NIL THEN search ;
2031 IF ctptr # NIL * ID. FOUND * THEN BEGIN
2032 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
2033 IF ctptr@.klass = vars AND ctptr@.vtype = NIL THEN
2034 ctptr := NIL ; * ERROR SECURITY; *
2035 IF ctptr^.klass = types THEN
2036 IF ctptr^.tlevel < level THEN
2037 IF pendingtypeallowed THEN
2038 ctptr := NIL ; * IN CASE OF DEFINITION ALTER AT THIS LEVEL *
2039 * ERROR DETECTED AT END OF VARDECL *
2040 END ;
2041 IF ctptr = NIL THEN
2042 BEGIN * UNDEC TYPE *
2043 IF NOT pendingtypeallowed THEN
2044 BEGIN
2045 error 62 ; returntype := NIL ; returnsize := 0 ;
2046 END ELSE
2047 IF ptx > ptlimit THEN
2048 BEGIN
2049 error 268 ; returntype := NIL ; returnsize := 0 ;
2050 END ELSE
2051 WITH ptlist ptx lp@ DO
2052 BEGIN
2053 hname := aval ; pptr := lp ;
2054 domain := lp ; eltype := lp ;
2055 returntype := lp ; ptx := ptx + 1 ; * POINTS NEXT FREE ENTRY *
2056 rfil := symbolfile ; rlin := symbolline ;
2057 END ;
2058 insymbol ;
2059 END * UNDECLAR * ELSE
2060 BEGIN returntype := lp ; insymbol ;
2061 IF ctptr@.klass = types THEN
2062 IF ctptr@.form = aliastype THEN ctptr := ctptr@.realtype ;
2063 WITH ctptr@ DO
2064 BEGIN
2065 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
2066 IF klass = types AND form <= records THEN
2067 BEGIN
2068 lp@.domain := lp ;
2069 lp@.eltype := ctptr ; * DOMAIN FLAG NEW ON HEAP *
2070 END ELSE
2071 error 96 ;
2072 END ;
2073 END ;
2074 $OPTIONS compile = trace $
2075 printrec lp ;
2076 $OPTIONS compile = true $
2077 cadre := sup cadre lp@.cadrage ;
2078 END * NOT ERROR *
2079 END * POINTER * ELSE
2080 typerr 10 ;
2081 $OPTIONS compile = trace $
2082 IF decltrace > low THEN
2083 BEGIN
2084 write mpcogout ' @@@ FIN TYPEDECL @@@ WITH V.RETSIZETYPE ;CADREERRSTRUCTISPACK '
2085 returnsize ord returntype cadre err structispack ;
2086 nextline ;
2087 END ;
2088 $OPTIONS compile = true $
2089 END * TYPEDECL * ;
2090
2091
2092 $OPTIONS page $
2093
2094 * *******************************************************************BODY***** *
2095
2096 PROCEDURE body surrptr firstentry : ctp ;
2097
2098 * C THIS PROCEDURE COMPILES A PASCAL 'BLOCK'.
2099 LABEL DECLARATION
2100 CONST " " ..... INCONST
2101 TYPE " " ..... TYPEDECL
2102 VAR " " ..... VARDECL
2103 VALUE VALUEDECL
2104 PROCEDURE FUNCTION
2105 INSTRUCTION ..... ENTERBODY
2106 COMPSTAT
2107 LEAVEBODY.
2108 ALL NEEDED INFORMATIONS ARE MEMORIZED IN BOXES OF SEVERAL KLASS
2109 TYPESKONSTVARS PROC AND SOON
2110 THESE BOXES ARE BUILT IN SEVERAL PROCEDURESALL CALLED BY 'BODY'
2111 ARE USED IN GENERATION PART
2112 PARAMETER'S MEANINGS
2113 SURRPTR POINTS ON THE BOX 'PROC' WHICH DECLARATION PART IS
2114 ACTUALLY COMPILED
2115 NIL FOR THE MAIN
2116 FIRSTENTRY POINTS A BOX 'DUMMYCLASS' WHICH IDENTIFIES THE
2117 BEGINNING OF ALL BOXES LIVING THE SAME TIME
2118 AS THE PROCEDURE COMPILED USE WITH RESET
2119 C *
2120 * E ERRORS DETECTED
2121 HEAPERROR
2122 2 IDENTIFIER EXPECTED
2123 4 '' EXPECTED
2124 7 ':' EXPECTED
2125 14 ';' EXPECTED
2126 15 INTEGER EXPECTED
2127 16 '=' EXPECTED
2128 17 'BEGIN' EXPECTED
2129 20 '' EXPECTED
2130 65 VALUE PART ONLY FOR GLOBALS
2131 87 PROC MUST BE DEFINED IN EXTERNAL LIST
2132 88 INVALID DIRECTIVE
2133 101 IDENTIFIER DECLARED TWICE
2134 103 IDENTIFIER NOT OF APPROPRIATE CLASS
2135 104 IDENTIFIER NOT DECLARED
2136 108 File not allowed here
2137 116 Forward redefinition conflict with declaration
2138 117 UNDEF FORWARD PROCEDURE
2139 119 REPETITION OF PARAMETER LIST NOT ALLOWED FORWARD
2140 120 FUNCTION TYPE MUST BE REALNUMERICSCALAR OR POINTER
2141 123 RESULT TYPE IDENTIFIER EXPECTED
2142 166 MULTIDECLARED LABELS
2143 214 SIZE ALLOWED FOR GLOBALS EXCEEDED
2144 251 TOO MANY NESTED PROC AND OR FUNCTIONS
2145 267 TOO MANY LABELS MAXLABS
2146 306 LABEL MUST HAVE AT MOST 4 DIGITS
2147 E *)
2148 LABEL
2149 1 ; * BODY BEGINS. USED FOR ERR. RECOVERY *
2150 VAR
2151 lca lic : integer ; * INITIALIZEDAND USED *
2152 * IN ENTERBODYLEAVEBODY *
2153 saved_level it : integer ;
2154 lprockind : idkinds ;
2155 typofproc : idprocdef ;
2156 lp procptr lfirstentry : ctp ;
2157 fstix lno oldlev oldlc nestproc locreturncode : integer ;
2158 locerr : boolean ;
2159 lextpt : ptexternalitem ;
2160 locsegname locentryname : alfaid ;
2161 workextp : ptexternalitem ;
2162
2163 * ***********************************************FINDSEMICOLON < BODY********* *
2164
2165 PROCEDURE findsemicolon ;
2166
2167 * C USED TO VERIFY IF THE READ SYMBOL IS ;AND TO PERFORM THE NEXT INSYMBOL
2168 IF ; IS NOT FOUND THEN
2169 SKIP UNTIL ; USING ERRCL
2170 IF ; NOT FOUND THEN GOTO EXIT 1 IN BODY LABEL PART
2171 C *
2172 * E ERRORS DETECTED
2173 14 : ';' EXPECTED
2174 E *
2175 BEGIN * FINDSEMICOLON *
2176 IF no # 16 * ; * THEN
2177 BEGIN
2178 error 14 ; skip 16 ;
2179 IF no # 16 * ; * THEN GOTO 1 ; * EXIT AT LABEL PART IN BODY *
2180 END ;
2181 insymbol ;
2182 END * FINDSEMICOLON * ;
2183
2184
2185 * ***********************************************ENTERBODY < BODY************* *
2186
2187 PROCEDURE enterbody ;
2188
2189 * C CALLED AT BEGINNING OF THE STATEMENT PART OF A PROCPROGRAM
2190 . GENERATES CODE TO OPEN FILES
2191 . GENERATES PROCEDURE PROGRAM PROLOG
2192 . INITIALIZES LOCAL TABLES FOR THIS LEVEL
2193 . INITIALIZE PHYSICAL POINTER ON CLASSES
2194 . INIT LIC LCA DEFINED IN BODY
2195 LIC HAS THE VALUE OF THE INITIAL IC
2196 LCA IS OBTAINED EITHER BY GENPROLOG OR BY GENPROCENTRY AND GIVES THE
2197 ADDRESS OF AN UNCOMPLETED WORD OF PUSH WHICH WILL BE FILLED IN
2198 LEAVEBODY
2199 C *
2200 VAR
2201 it : integer ;
2202 BEGIN
2203 $OPTIONS compile = trace $
2204 IF decltrace > none THEN
2205 BEGIN
2206 write mpcogout ' @@@ DEBUT ENTERBODY @@@ PROCPTRICLC ' ord procptr ic lc ;
2207 nextline ;
2208 END ;
2209 $OPTIONS compile = true $
2210 * PROGRAM OR PROCEDURE ENTRY CODE *
2211 environt := code ;
2212 lic := ic ; * DEPL OF FIRST INSTR. OF THIS *
2213 * PROCEDURELIC DEFINED IN BODY *
2214 cb := 0 ;
2215 * BY LEVEL INITIALIZE *
2216 * CONSTANT'S LISTS *
2217 currwcstpt := NIL ; * WORDS *
2218 currlcstpt := NIL ; * DOUBLE-WORDS *
2219 currllcstpt := NIL ; * EIGHT-WORDS SETS *
2220 currrcstpt := NIL ; * REAL *
2221 nextalf := NIL ;
2222 IF mapswitch THEN BEGIN
2223 WITH currentnode^ DO
2224 BEGIN
2225 symbolindex := hdrind ;
2226 symbolfile := hdrfil ;
2227 symbolline := hdrlin ;
2228 END ;
2229 statement_begins false ;
2230 END ;
2231 IF level = 0 THEN * MAIN PROGRAM *
2232 BEGIN
2233 genprolog lca lic ;
2234 lc := pascdebstacklocal ;
2235 END ELSE
2236 * PASCAL PROCEDURE ENTRY CODE *
2237 genprcentry lca surrptr lic ;
2238 IF mapswitch THEN BEGIN
2239 statement_ends 5 ; * "begin" *
2240 statement_begins true ;
2241 END ;
2242 * NOW GENERATES LOCAL FILES FSB *
2243 FOR it := filev level TO filtop DO initiozone filpts it ;
2244 * RECADRE LC AND INITIALIZES TMAX AND LCSAVE *
2245 lc := recadre lc bytesindword ;
2246 lcsave := lc ; tmax := lc ;
2247 IF mapswitch THEN statement_ends 5 ; * "begin" *
2248 $OPTIONS compile = trace $
2249 IF decltrace > low THEN
2250 BEGIN
2251 write mpcogout ' @@@ FIN ENTERBODY @@@ WITH IC AT' ic ; nextline ;
2252 END ;
2253 $OPTIONS compile = true $
2254 END ; * ENTERBODY *
2255
2256
2257 * *****************************************LEAVEBODY < BODY******************** *
2258
2259 PROCEDURE leavebody ;
2260
2261 * C FUNCTIONS OF THIS PROCEDURE
2262 . CLOSE FILES
2263 . CHECK FOR UNDEFINED LABELS AND EXIT LABELS
2264 . FREES LOCAL TABLES
2265 . EXIT CODE FOR A FUNCTION
2266 . GENERATES IN LINES CSTES
2267 . GENERATES EXIT CODE FOR PROC OR PROGRAM.
2268 C *
2269 * E ERRORS DETECTED
2270 155: FUNCTION IDENTIFIER HAS NOT BEEN ASSIGNED
2271 168: UNDEFINED LABEL ; SEE MESSAGE
2272 227 : SOME LABELS DECLARED IN THIS PROCEDURE ARE ILLEGALLY REFERENCED.
2273 E *
2274 VAR
2275 it endcode : integer ;
2276 lerr : boolean ;
2277 locreturncode : integer ;
2278 lp lpaux : ctp ;
2279 locintext : integer ;
2280 trans : RECORD
2281 CASE boolean OF
2282 true : name : alfaid ;
2283 false : half_wd : PACKED ARRAY 1..4 OF shrtint ;
2284 END ;
2285 message : PACKED ARRAY 1..132 OF char ;
2286 iter index : integer ;
2287 ref_err : boolean ;
2288 refbox : refptr ;
2289 BEGIN * LEAVEBODY *
2290 $OPTIONS compile = trace $
2291 IF decltrace > none THEN
2292 BEGIN
2293 write mpcogout ' @@@ DEBUT LEAVEBODY @@@ WITH LICLCA IC' lic lca ic ;
2294 nextline ;
2295 END ;
2296 $OPTIONS compile = true $
2297 IF mapswitch THEN statement_begins true ;
2298 IF level = 0 THEN
2299 BEGIN
2300 genstand pr0 returnzeroplace itsp3 tn ;
2301 IF linktoend THEN
2302 IF errtotal = 0 THEN
2303 BEGIN
2304 genentrypoint ic linktoendplace 4 * EXIT LABEL *
2305 blank blank
2306 functionflag entrylength
2307 locreturncode ;
2308 IF locreturncode <> 0 THEN
2309 error 510 ;
2310 IF getpr4afterstop THEN
2311 genstand pr6 pr4depw iepp4 tny ;
2312 IF mapswitch THEN BEGIN
2313 statement_ends 1 ;
2314 statement_begins true ;
2315 END ;
2316 END ;
2317 END ;
2318 * CLOSE FILES AND FREES FILEV * * FILES *
2319 FOR it := filev level TO filtop DO
2320 closefile filpts it ;
2321 * * CHECK FOR UNDEFINED LABELS FREES LABTAB * * LABELS *
2322 ref_err := false ;
2323 lerr := false ;
2324 FOR it := fstix TO clabix DO
2325 WITH labtab it DO
2326 IF labdef = 0 THEN
2327 BEGIN
2328 nextline ;
2329 writeln mpcogerr ' ***** UNDEFINED LABEL :' labval : 5 ;
2330 write mpcogout ' ***** UNDEFINED LABEL :' labval : 5 ; nextline ;
2331 lerr := true ;
2332 END ELSE
2333 BEGIN
2334 IF labexit # 0 THEN
2335 exitlabel labexit lic + labdef ;
2336 WITH labbox^ DO
2337 BEGIN
2338 refbox := references ;
2339 WHILE refbox <> NIL DO
2340 BEGIN
2341 WITH refbox^ DO
2342 FOR iter := 1 TO refnbr DO
2343 WITH refs iter DO
2344 IF place < ref_allowed.ic_from OR
2345 place > ref_allowed.ic_to THEN
2346 BEGIN
2347 ref_err := true ;
2348 index := swrite message 1 ' ***** ILLEGAL REFERENCE TO LABEL ' labval : 1 ' AT LINE ' ;
2349 IF filen <> 0 THEN
2350 index := swrite message index filen : 1 '-' ;
2351 IF linen > 0 THEN
2352 index := swrite message index linen : 1 ELSE
2353 index := swrite message index -linen : 1 ;
2354 write mpcogout message : index - 1 ; nextline ;
2355 writeln mpcogerr message : index - 1
2356 END ;
2357 refbox := refbox^.nextref
2358 END
2359 END
2360 END ;
2361 IF ref_err THEN error 227 ;
2362 IF lerr THEN error 168 ;
2363 clabix := fstix - 1 ;
2364 * INSER MAX STACK DEPL IN INST GENERATED IN PROLOG * * INSER *
2365 IF lca # 0 THEN * NOT PREVIOUS ERROR *
2366 geninsertion lca surrptr ; * LCA INIT IN ENTERBODY *
2367 * BY GENPROCENTRY *
2368 IF mapswitch THEN BEGIN
2369 statement_ends 1 ;
2370 statement_begins true ;
2371 END ;
2372 IF surrptr = NIL THEN level := 0 ; * FOR ERRORS SAVING *
2373 * FUNCTION CODE * * FUNCTION *
2374 IF level # 0 THEN
2375 IF surrptr@.proctype # surrptr * FUNCTION FLAG * THEN
2376 BEGIN
2377 IF NOT surrptr@.procisassigned THEN error 155 ;
2378 surrptr@.procinscope := false ;
2379 genstand pr0 functionvaluecheckplace itsp3 tn ;
2380 gencodfonct surrptr ;
2381 END ;
2382 * GENERATES PROCEDURE PROGRAM EXIT * * EXIT CODE *
2383 IF level = 0 THEN
2384 genpgexit ELSE
2385 genprcexit surrptr ;
2386 IF mapswitch THEN BEGIN
2387 statement_ends 1 ;
2388 statement_begins false ;
2389 END ;
2390 * GENERATE F.REF. INFO IF FSB INIT. BY TRAP *
2391 IF level = 0 AND init_fsb_trap_flag THEN
2392 FOR it := filev 0 TO filtop DO
2393 gen_init_fsb_trap_structures filpts it ;
2394
2395 filtop := filev level - 1 ;
2396
2397
2398 * SCANS PROC DEF. AT THIS LEVEL *
2399 * AS FORWARD AND NOT DEFINED *
2400 lp := next ;
2401 WHILE lp <> NIL DO
2402 WITH lp@ DO
2403 IF klass = proc THEN
2404 BEGIN
2405 IF prockind = imported THEN
2406 BEGIN
2407 * GENERATES LINK "ITS" *
2408 * FOR IMPORTED PROCEDURES *
2409 IF errtotal = 0 THEN
2410 BEGIN
2411 IF procextitem <> NIL THEN
2412 BEGIN
2413 locsegname := procextitem^.extsegname ;
2414 locentryname := procextitem^.extentryname ;
2415 END ELSE
2416 BEGIN
2417 locsegname := blank ; locentryname := blank ;
2418 END ;
2419
2420 IF pwantdescs THEN locintext := ic ELSE locintext := 0 ;
2421 genentrypoint locintext procaddr 2
2422 locsegname locentryname
2423 functionflag entrylength
2424 locreturncode ;
2425 IF locreturncode <> 0 THEN
2426 error 505 ;
2427 IF pwantdescs THEN BEGIN
2428 usednameaddr := octalformataddr ;
2429 lp^.pextcalltrapinfoplace := ic DIV bytesinword ;
2430 * FILL NOW TRAP INFO STRUCTURE FOR EXT CALL WANTING DESCS.
2431 FOR CONTENTS SEE : pascal_ext_call_trap_info.incl.pl1 *
2432 infich 1 ; * VERSION NUMBER IN TRAP INFO STRUCTURE *
2433 infich 0 ; * REL OFFSET TO PARM DESCS _ FILLED IN PASCAL_CREATE_TABLES *
2434 usednameaddr := octalformataddr ;
2435 infich enterreftosymbol lp ;
2436 infich pdescsaddrplace DIV bytesinword ;
2437 genreltext absl 3 ; genreltext int18 1 ;
2438 trans.name := lp^.procextitem^.extgenerator ;
2439 FOR it := 1 TO 4 DO
2440 BEGIN
2441 usednameaddr := asciiformataddr ;
2442 infich trans.half_wd it ;
2443 END ;
2444 genreltext absl 4 ;
2445 END ;
2446 END ;
2447 END ELSE
2448 IF procdef = forwdef THEN
2449 BEGIN
2450 nextline ;
2451 write mpcogout ' ***** PROC NOT DEFINED :' name ; nextline ;
2452 error 117 ;
2453 END ;
2454 lp := nxtel ;
2455 END ELSE
2456 lp := nxtel ;
2457 endcode := indfich - 1 ;
2458 * GENERATION OF WORD CSTES *
2459 WHILE currwcstpt # NIL DO
2460 WITH currwcstpt@ DO
2461 BEGIN
2462 inserundlab cb cstplace ;
2463 usednameaddr := octalformataddr ;
2464 genc valu ;
2465 currwcstpt := cstnext ;
2466 END ;
2467 IF ic MOD bytesindword # 0 THEN genc 0 ;
2468 * GENERATION OF D-WORD CSTES *
2469 WHILE currlcstpt # NIL DO
2470 WITH currlcstpt@ DO
2471 BEGIN
2472 inserundlab cb lplace ;
2473 usednameaddr := octalformataddr ; genc lvalu 0 ; usednameaddr := octalformataddr ; genc lvalu 1 ;
2474 currlcstpt := lnext ;
2475 END ;
2476 * GENERATION OF REAL CSTES *
2477 WHILE currrcstpt # NIL DO
2478 WITH currrcstpt@ DO
2479 BEGIN
2480 inserundlab cb rplace ;
2481 genr rvalu ;
2482 currrcstpt := rnext ;
2483 END ;
2484 * GENERATION OF SET8 W CSTES *
2485 WHILE currllcstpt # NIL DO
2486 WITH currllcstpt@ DO
2487 BEGIN
2488 inserundlab cb llplace ;
2489 FOR it := 0 TO bornesupset DO BEGIN usednameaddr := octalformataddr ; genc llvalu it ; END ;
2490 currllcstpt := llnext ;
2491 END ;
2492 * NOW GENERATES ALFA STRINGS *
2493 lp := nextalf ; * LAST ALFA CONST USED *
2494 WHILE lp # NIL DO
2495 WITH lp@ DO
2496 BEGIN
2497 IF unddeb <> 0 THEN
2498 BEGIN
2499 inserundlab cb unddeb ;
2500 genstring lp ;
2501 IF NOT odd indfich THEN infich 0 ; unddeb := 0 ;
2502 END ;
2503 lpaux := lp ; lp := succ ; lpaux@.succ := lpaux ; * NEXT AND FREE OLD OCC. *
2504 END ;
2505 writout lic endcode ;
2506 IF mapswitch THEN
2507 statement_ends 0 ;
2508 $OPTIONS compile = trace $
2509 IF decltrace > low THEN
2510 BEGIN
2511 write mpcogout ' @@@ FIN LEAVEBODY @@@ WITH ICCB ' ic cb ; nextline ;
2512 END ;
2513 $OPTIONS compile = true $
2514 END * LEAVEBODY * ;
2515
2516
2517 * ***********************************************VALUEDECL < BODY *********** *
2518
2519 PROCEDURE valuedecl ;
2520
2521 * C THIS PROCEDURE IS USED IN ORDER TO ANALYZE THE VALUE PART OF A MAIN
2522 PROGRAM. SPACE IS KEPT FOR ALL VARIABLES AND VARIABLES WHICH
2523 OCCUR IN VALUE PART ARE INITIALIZED. C *
2524 * E 2 IDENTIFIER EXPECTED
2525 15 INTEGER EXPECTED
2526 16 '=' EXPECTED
2527 64 '' OR '' EXPECTED IN VALUE PART
2528 69 VALUE PART NOT ALLOWED STANDARD
2529 104 IDENTIFIER NOT DECLARED
2530 130 NIL NO MORE ALLOWED STANDARD
2531 138 TYPE OF THE VARIABLE IS NOT ARRAY OR RECORD
2532 145 TYPE CONFICT
2533 178 ALPHANUMERIC STRING IS TOO LONG
2534 179 INITIALIZATION LIST IS TOO LONG
2535 180 INITIALIZATION OF IMPORTED VARIABLE NOT ALLOWED
2536 181 VARIABLE MUST BE ARRAY OR RECORD
2537 182 PACKED VARIABLE NOT ALLOWED HERE
2538 183 ILLEGAL VARIABLE TYPE IN VALUE PART
2539 184 IDENTIFIER MUST BE VARIABLE VALUE
2540 185 VARIABLES MUST BE INITIALIZED IN THEIR DECLARATION ORDER E *)
2541 LABEL 10 * END OF VALUE PART *
2542 20 * EMERGENCY LABEL USED IF *
2543 * SEVERAL CALLS OCCUR *
2544 5 ; * STOPS LIST INSPECTION *
2545 VAR
2546 wkextpt : ptexternalitem ;
2547 itisstring invalue valerr : boolean ;
2548 addcurrent nbpack alfamax nbitem nrep i nitem it kt : integer ;
2549 cstkind : 1..4 ; strlen : integer ;
2550 oldnext generic before curritem pt pteltype toinit : ctp ;
2551 filesize : integer ;
2552 locreturncode : integer ;
2553 wkname : alfaid ;
2554
2555
2556 * *************************************VALERROR < VALUEDECL < BODY************ *
2557
2558 PROCEDURE valerror fnoerr : integer ;
2559
2560 * C PRODUCES AN ERROR MESSAGE AND FINDS A SEMI-COLON. VALERR IS SET TRUE C *
2561 BEGIN
2562 error fnoerr ;
2563 valerr := true ;
2564 skip 16 ;
2565 IF no # 16 THEN
2566 BEGIN error 14 ; GOTO 1 ; * LABEL PART IN BODY * END ; insymbol ;
2567 END * VALERROR * ;
2568
2569
2570 BEGIN * VALUEDECL *
2571 $OPTIONS compile = trace $
2572 IF decltrace > none THEN
2573 BEGIN
2574 write mpcogout ' @@@ DEBUT VALUEDECL @@@ WITH NEXT XC ' ord next xc ;
2575 nextline ;
2576 END ;
2577 $OPTIONS compile = true $
2578 valuenb := valuenb + 1 ; * IF NO ERROR MUST BE ONE *
2579 IF valuenb > 1 THEN GOTO 20 ; * EXIT WITH EMERGENCY *
2580 * REVERSE LINKAGE OF THE *
2581 * CONTEXTE TABLE TO THIS LEVEL *
2582 IF next # NIL THEN
2583 BEGIN
2584 oldnext := NIL ; before := next@.nxtel ;
2585 WHILE before # NIL DO
2586 BEGIN
2587 next@.nxtel := oldnext ;
2588 oldnext := next ;
2589 next := before ;
2590 before := before@.nxtel ;
2591 END ;
2592 next@.nxtel := oldnext ;
2593 END ;
2594 IF no = 54 * VALUE * THEN
2595 BEGIN
2596 IF envstandard = stdpure THEN
2597 error 69 ;
2598 insymbol ; invalue := true ;
2599 END ELSE invalue := false ;
2600 addcurrent := xc ; * CURRENT ADDRESS IN BYTES *
2601 curritem := next ; * CURRENT ITEM OF CONTEXTABLE *
2602 toinit := NIL ; * LAST INITIALIZED VALUE *
2603 oldnext := next ; * FIRST INITIALIZABLE VAR *
2604 WHILE curritem # NIL DO * SCAN CONTEXTABLE *
2605 WITH curritem@ DO
2606 IF klass # vars THEN curritem := nxtel * NOT A VARIABLE * ELSE
2607 IF vtype = NIL THEN curritem := nxtel * ERROR IN TYPE * ELSE
2608 BEGIN
2609 IF vtype^.form = files THEN
2610 BEGIN
2611 IF vkind <> imported THEN
2612 BEGIN
2613 IF vkind = exportable THEN
2614 BEGIN
2615 environt := linkage ; vaddr := lkc ;
2616 lkc := lkc + bytesindword ;
2617 IF errtotal = 0 THEN
2618 BEGIN
2619 genexportfile name vaddr locreturncode ;
2620 IF locreturncode <> 0 THEN
2621 error 509 ;
2622 END ;
2623 indfich := 1 ; environt := data ;
2624 END * EXPORTABLE * ELSE
2625 BEGIN
2626 addcurrent := vaddr ;
2627 genmulticsnil ;
2628 writout addcurrent 0 ;
2629 addcurrent := vaddr + bytesneeded files 0 false ;
2630 END * STATIC or PERMANENT FILE * ;
2631 END * not IMPORTED * ;
2632 END * FILES * ELSE
2633 IF invalue THEN * LOOK IF THE CURRENT VARIABLE *
2634 * IS IN VALUE LIST *
2635 BEGIN
2636 WHILE no # 1 DO * SEEKS INITIALIZED IDENTIFIERS *
2637 BEGIN
2638 IF no IN 21 44 45 55 * BEGINPROCEDUREFUNCTION $ * THEN
2639 BEGIN
2640 IF no <> 55 THEN
2641 error 76 ELSE
2642 insymbol ;
2643 invalue := false ; GOTO 10 * EXIT INVALUE * ;
2644 END ;
2645 error 2 ; skip 46 ;
2646 IF no # 16 * ; * THEN
2647 BEGIN
2648 invalue := false ; GOTO 10 * EXIT INVALUE * ;
2649 END ;
2650 insymbol ;
2651 END ;
2652 * IDENTIFIER HAS BEEN FOUND *
2653 srchrec next ; * LOOKS IN CONTEXTTABLE *
2654 IF ctptr = NIL THEN valerror 104 * UNDECLARED * ELSE
2655 IF ctptr@.klass # vars THEN valerror 184 * NOT A VARIABLE * ELSE
2656 toinit := ctptr ;
2657 IF toinit = curritem THEN
2658 BEGIN * DECLARED IDENTIFIER *
2659 srchrec oldnext ;
2660 IF symbolmap THEN
2661 nameisref ctptr symbolfile -symbolline ;
2662 IF ctptr = NIL THEN valerror 185 ELSE
2663 WITH ctptr@ DO * INITIALIZABLE *
2664 IF vkind = imported THEN valerror 180 ELSE
2665 BEGIN
2666 valerr := false ;
2667 IF vkind = exportable THEN
2668 environt := linkage ELSE
2669 addcurrent := vaddr ;
2670 insymbol ;
2671 IF no # 8 OR cl # 6 * = *
2672 THEN error 16 ELSE insymbol ;
2673 pteltype := vtype ; itisstring := false ; nbpack := 0 ;
2674 WHILE pteltype@.form = arrays DO
2675 BEGIN
2676 IF pteltype@.pack THEN
2677 BEGIN
2678 nbpack := nbpack + 1 ; * NBR OF SUBTYPES PACKED *
2679 IF nbpack = 1 THEN
2680 IF pteltype@.aeltype = charptr THEN
2681 BEGIN
2682 itisstring := true ;
2683 * SIZE OF ALFA STRING : *
2684 alfamax := pteltype@.size ;
2685 END * STRING OF CHAR * ;
2686 END ;
2687 pteltype := pteltype@.aeltype ;
2688 IF pteltype = NIL THEN valerror 183 ;
2689 END ;
2690 IF pteltype^.father_schema = string_ptr THEN
2691 BEGIN
2692 cstkind := 4 ;
2693 alfamax := pteltype^.actual_parameter_list^.values ;
2694 END ELSE
2695 BEGIN
2696 IF pteltype@.form IN
2697 pointer power files aliastype THEN
2698 valerror 183 ELSE
2699 IF nbpack # 0 THEN
2700 IF itisstring THEN cstkind := 3 ELSE
2701 valerror 182 ELSE
2702 IF pteltype = realptr
2703 THEN cstkind := 2 ELSE cstkind := 1 ;
2704 IF NOT valerr THEN
2705 IF vtype@.form = records OR
2706 vtype@.form = arrays AND NOT vtype@.pack
2707 THEN
2708 BEGIN
2709 IF no # 9 * * THEN valerror 009 ;
2710 END
2711 ELSE
2712 IF no = 9 THEN valerror 138 ;
2713 END ;
2714 IF NOT valerr THEN
2715 BEGIN
2716 IF no = 9 THEN * LIST OF VALUES *
2717 BEGIN
2718 IF vtype@.form = records THEN
2719 BEGIN
2720 pteltype := intptr ; cstkind := 1 ;
2721 END ;
2722 CASE cstkind OF
2723 1 : nbitem := vtype@.size DIV intptr@.size ;
2724 2 : nbitem := vtype@.size DIV realptr@.size ;
2725 3 : nbitem := vtype@.size DIV alfamax ;
2726 4 : nbitem := vtype^.size DIV alfamax + 4 ;
2727 END * CASE * ;
2728 nitem := 0 ;
2729 REPEAT
2730 insymbol ; inconst i pt next false ;
2731 nrep := 1 ;
2732 IF no = 6 AND cl = 1 * * * THEN
2733 BEGIN
2734 IF i = 1 AND conint > 0
2735 THEN nrep := conint ELSE error 15 ;
2736 insymbol ; inconst i pt next true ;
2737 END ;
2738 nitem := nitem + nrep ;
2739 IF nitem > nbitem THEN * TOO MANY ITEMS IN THE LIST *
2740 BEGIN
2741 valerror 179 ;
2742 GOTO 5 ; * SKIP INITIAL VALUE -> ; *
2743 END ;
2744 CASE cstkind OF
2745 1 : BEGIN
2746 compatbin pteltype pt generic ;
2747 IF generic = NIL OR generic = realptr
2748 THEN error 145 ELSE
2749 BEGIN
2750 IF pteltype # intptr THEN
2751 checkminmax conint pteltype 303 ;
2752 FOR it := 1 TO nrep DO genc conint ;
2753 END ;
2754 END ;
2755 2 : BEGIN
2756 IF pt # pteltype THEN
2757 IF pt = intptr
2758 THEN conreel := conint ELSE
2759 error 145 ;
2760 FOR it := 1 TO nrep DO genr conreel ;
2761 END ;
2762 3 : IF pt # alfaptr THEN error 145 ELSE
2763 BEGIN
2764 IF longstring > alfamax THEN error 178 ;
2765 longstring := alfamax ; * TRUNC OR PAD *
2766 FOR it := 1 TO nrep DO genalfa ;
2767 END ;
2768 4 : IF pt <> alfaptr THEN
2769 IF pt = charptr THEN
2770 FOR it := 1 TO nrep DO
2771 BEGIN
2772 genc 1 ; genc conint * twoto27 ;
2773 IF alfamax > 4 THEN
2774 FOR kt := 1 TO alfamax - 1 DIV 4 DO genc 0 ;
2775 END
2776 ELSE error 145
2777 ELSE
2778 BEGIN
2779 IF longstring > alfamax THEN
2780 BEGIN
2781 error 178 ;
2782 strlen := alfamax ;
2783 END ELSE
2784 strlen := longstring ;
2785 longstring := alfamax ; * TRUNC OR PAD *
2786 FOR it := 1 TO nrep DO
2787 BEGIN
2788 genc strlen ;
2789 genalfa ;
2790 END ;
2791 END ;
2792 END * CASE * ;
2793 IF NOT no IN 10 15 * * THEN error 64 ;
2794 UNTIL no # 15 ;
2795 IF no = 10 THEN insymbol ;
2796 END ELSE * ONE CONSTANT ONLY *
2797 BEGIN
2798 inconst i pt next true ;
2799 CASE cstkind OF
2800 1 : BEGIN
2801 compatbin pteltype pt generic ;
2802 IF generic = NIL OR generic = realptr THEN
2803 error 145 ELSE
2804 BEGIN
2805 IF pteltype # intptr THEN
2806 checkminmax conint pteltype 303 ;
2807 genc conint ;
2808 END ;
2809 END ;
2810 2 : BEGIN
2811 IF pt # pteltype THEN
2812 IF pt = intptr
2813 THEN conreel := conint ELSE error 145 ;
2814 genr conreel ;
2815 END ;
2816 3 : IF pt # alfaptr THEN error 145 ELSE
2817 BEGIN
2818 IF longstring > alfamax THEN error 178 ;
2819 longstring := alfamax ;
2820 genalfa ;
2821 END ;
2822 4 : IF pt <> alfaptr THEN
2823 IF pt = charptr THEN
2824 BEGIN
2825 genc 1 ; genc conint * twoto27 ;
2826 IF alfamax > 4 THEN
2827 FOR it := 1 TO alfamax - 1 DIV 4 DO genc 0 ;
2828 END
2829 ELSE error 145
2830 ELSE
2831 BEGIN
2832 IF longstring > alfamax THEN
2833 BEGIN
2834 error 178 ;
2835 genc alfamax ;
2836 END
2837 ELSE
2838 genc longstring ;
2839 longstring := alfamax ;
2840 genalfa ;
2841 END ;
2842 END * CASE * ;
2843 END * ONE CONSTANT ONLY * ;
2844 IF NOT no IN 16 55 THEN
2845 BEGIN
2846 error 76 ; skip 46 ;
2847 END ELSE
2848 IF no = 16 * ; * THEN
2849 BEGIN
2850 insymbol ;
2851 IF no = 55 THEN
2852 BEGIN insymbol ; invalue := false ;
2853 END ELSE
2854 IF no <> 1 THEN
2855 error 76 ;
2856 END ELSE
2857 BEGIN insymbol ; invalue := false ;
2858 END ;
2859 END * NOT VALERR * ;
2860 5 :
2861 IF environt = linkage THEN
2862 BEGIN
2863 vaddr := lkc ;
2864 lkc := lkc + bytesindword ;
2865 IF errtotal = 0 THEN
2866 BEGIN
2867 genextvariable blank name blank
2868 vaddr vtype^.size indfich - 1 fichinter^
2869 locreturncode ;
2870 IF locreturncode <> 0 THEN
2871 error 508 ;
2872 END ;
2873 indfich := 1 ;
2874 environt := data ;
2875 END ELSE
2876 BEGIN
2877 writout addcurrent 0 ;
2878 addcurrent := recadre addcurrent + vtype@.size
2879 bytesinword ;
2880 END ;
2881 END ; * WITH CTPTRINITIALIZABLE *
2882 * NOT IMPORTED *
2883 END ; * DECLARED ID. *
2884 END ; * INVALUE *
2885 10 : curritem := curritem@.nxtel ;
2886 END ; * SCAN CONTEXT TABLE *
2887 IF addcurrent < lc THEN
2888 IF errtotal = 0 THEN
2889 BEGIN
2890 genbinarea addcurrent 4
2891 lc - addcurrent DIV bytesinhword
2892 0 fichinter^
2893 locreturncode ;
2894 IF locreturncode <> 0 THEN
2895 error 507 ;
2896 END ;
2897 * NOW CREATES "ITS" FOR IMPORT *
2898 * OR EXPORTED NOT YET RESOLVED *
2899 wkextpt := externallistheader ;
2900 WHILE wkextpt <> NIL DO
2901 BEGIN
2902 WITH wkextpt^ DO
2903 IF extdecl <> NIL THEN
2904 IF extdecl^.klass = vars THEN
2905 IF extdecl^.vaddr = -1 THEN
2906 IF extdecl^.vtype <> NIL THEN
2907 IF extdecl^.vtype^.form = files AND extdecl^.vkind = exportable THEN ELSE
2908 WITH extdecl^ DO
2909 BEGIN
2910 vaddr := lkc ; lkc := lkc + bytesindword ;
2911 IF vtype # NIL THEN
2912 IF vkind = imported THEN i := -vtype@.size ELSE i := vtype@.size ;
2913 IF errtotal = 0 THEN
2914 BEGIN
2915 IF name = usednames 1 THEN
2916 geninputlink vaddr locreturncode ELSE
2917 IF name = usednames 2 THEN
2918 genoutputlink vaddr locreturncode ELSE
2919 IF name = usednames 3 THEN
2920 generrorlink vaddr locreturncode ELSE
2921 BEGIN
2922 IF i < 0 THEN
2923 wkname := extentryname * IMPORTED * ELSE
2924 wkname := extname ;
2925 genextvariable extsegname wkname extgenerator
2926 vaddr i 0
2927 fichinter^
2928 locreturncode ;
2929 END ;
2930 IF locreturncode <> 0 THEN
2931 error 506 ;
2932 END ;
2933 END ;
2934 wkextpt := wkextpt ^.extnext ;
2935 END ;
2936 $OPTIONS compile = trace $
2937 IF decltrace > low THEN
2938 BEGIN
2939 write mpcogout ' @@@ FIN VALUEDECL @@@ WITH LKCLC ' lkc lc ;
2940 nextline ;
2941 END ;
2942 $OPTIONS compile = true $
2943 20 : * SKIP HERE IF NOT FIRST *
2944 * CALL OF VALUEDECL *
2945 END * VALUEDECL * ;
2946
2947
2948 * ***********************************************FORMPARM < BODY************** *
2949
2950 PROCEDURE formparm ;
2951
2952 * C ANALYZES THE LIST OF PARAMETERS OF A PROCEDURE OR A FUNCTION
2953 IF NESTPROC =0 PARAMETERS ARE RELEVANT
2954 IF NESTPROC #0 PARAMETERS ARE DUMMY AND USED ONLY FOR TYPE COMPATIBILITY
2955 IN PROCEDURE OR FUNCTION PARAMETERS
2956 CONFORMANT ARRAY TYPES ARE ANALYZED WITH PROCEDURE CONFORMARRAY
2957 C *
2958 * E HEAPERROR
2959 2 IDENTIFIER EXPECTED
2960 4 '' EXPECTED
2961 7 ':' EXPECTED
2962 101 IDENTIFIER DECLARED TWICE
2963 103 IDENTIFIER IS NOT OF APPROPRIATE CLASS
2964 104 IDENTIFIER NOT DECLARED
2965 120 FUNCTION RESULT TYPE MUST BE SCALARSUBRANGEREAL OR POINTER
2966 121 FILE MUST BE VAR PARAMETER
2967 123 MISSING RESULT IDENTIFIER IN FUNCTION DECLARATION
2968 E *)
2969 VAR
2970 it nbpar savenbpar lcaux : integer ;
2971 lp lp1 savenext : ctp ;
2972 itisproc itisvar rep : boolean ;
2973 savedescriptors : boolean ;
2974 locended : boolean ;
2975 loccounter : integer ;
2976 locad : integer ;
2977 lctop : integer ;
2978 nbofdim : integer ;
2979 lctp : ctp ;
2980 lctp1 lctp2 lctp3 : ctp ;
2981 schema_parameter_count : integer ;
2982
2983
2984 PROCEDURE conformarray VAR fvnombofdim : integer ;
2985
2986 * C
2987 As output FVNOMBOFDIM is the number of pseudo-parameters
2988 created for Read-Only bounds.
2989
2990 Analyses a <conformant array schema>
2991 Is a local procedure of FORMPARM to avoid a "too long procedure"
2992 error in FORMPARM.
2993 Is invocated with NO=42 "packed"
2994 or NO=38 and CL=1 "array"
2995 Expects :
2996 packed array "" <id>..<id> : <type-id> ; <id>..<id> : <type-id> *
2997 "" of <param_type>
2998 At the call the descriptive boxes of the parameters have been
2999 constructed with a nil VTYPE. NEXT is the head of the backward chain
3000 of parameters. NBPAR is the number of variables of the conformant array
3001 schema to be analysed.
3002 It constructs as many array boxes as dimensions declared and two VAR
3003 READONLY boxes one for lower bound one for higher bound by dimension.
3004 The bound boxes are inserted in the backward parameter's chain.
3005 At the end of CONFORMARRAY the variable boxes are completed with
3006 VTYPE and VADDR.
3007 C *
3008
3009 * E ERRORS DETECTED
3010 2 identifier expected
3011 5 .. expected
3012 7 : expected
3013 8 OF expected
3014 11 expected
3015 12 expected
3016 56 type identifier or conformant array schema expected
3017 57 conformant array schema expected
3018 103 identifier is not of the appropriate CLASS
3019 104 identifier not declared
3020 71 Pack allowed only on last dimension
3021 113 Index type must be scalar or numeric
3022 E *
3023
3024 LABEL
3025 1 ; * exit in case of non recoverable error *
3026
3027 VAR
3028 it : integer ;
3029 conformagain : boolean ;
3030 lp : ctp ;
3031 packedfound : boolean ;
3032 ptfirstbound : ctp ;
3033 ptfirstdim : ctp ;
3034 ptlastdim : ctp ;
3035 ptfirstvar : ctp ;
3036 ptsecondvar : ctp ;
3037 ptlastvar : ctp ;
3038 nbofdim : integer ;
3039 ptsecondbound : ctp ;
3040
3041 BEGIN * CONFORMARRAY *
3042
3043 $OPTIONS compile = trace $
3044 IF decltrace > none THEN
3045 BEGIN
3046 write mpcogout '@@@ Debut de CONFORMARRAY @@@ avec NO :'
3047 no : 5 ' CL:' cl : 5 ' NBPAR :' nbpar : 5 ' NEXT en^' ord next ;
3048 nextline ;
3049 END ;
3050 $OPTIONS compile = true $
3051
3052
3053 fvnombofdim := 0 ;
3054 nbofdim := 0 ;
3055 ptfirstbound := NIL ;
3056 lctop := 0 ;
3057 ptsecondbound := NIL ; packedfound := false ;
3058 ptfirstdim := NIL ;
3059 ptlastdim := NIL ;
3060 ptlastvar := next ;
3061
3062 REPEAT
3063 conformagain := false ;
3064
3065 * CHECK IF SYMBOL FOUND IS "PACKED" OR "ARRAY" *
3066
3067 IF no = 42 THEN * packed *
3068 BEGIN
3069 insymbol ;
3070 IF packedfound THEN
3071 error 71 ;
3072 packedfound := true ;
3073 END ELSE
3074 packedfound := false ;
3075
3076 IF NOT no = 38 AND cl = 1 THEN * array *
3077 BEGIN
3078 error 57 ;
3079 skipextd 10 ;
3080 GOTO 1 ;
3081 END ELSE
3082 BEGIN * ARRAY *
3083 insymbol ;
3084 IF no <> 11 THEN * *)
3085 BEGIN
3086 error 11 ;
3087 skipextd 10 ;
3088 GOTO 1 ;
3089 END ELSE
3090 BEGIN
3091
3092 REPEAT * LOOP ON DIMENSIONS *
3093
3094 * FIRST BOUND *
3095
3096 insymbol ;
3097 IF no <> 1 THEN
3098 BEGIN
3099 error 2 ;
3100 skipextd 10 ;
3101 GOTO 1 ;
3102 END ;
3103 checkdefiningpoint aval next ;
3104 create_vars_box lp aval ;
3105 WITH lp^ DO
3106 BEGIN
3107 vkind := arraybound ;
3108 visset := true ;
3109 visreadonly := true ;
3110 END ;
3111 next := lp ;
3112 ptfirstbound := lp ;
3113 fvnombofdim := fvnombofdim + 1 ; * <-------- *
3114
3115 * BOUNDS SEPARATOR .. *
3116
3117 insymbol ;
3118 IF no <> 39 THEN
3119 BEGIN
3120 error 5 ;
3121 skipextd 10 39 ;
3122 IF no <> 39 THEN
3123 GOTO 1 ;
3124 END ;
3125
3126 * SECOND BOUND *
3127
3128 insymbol ;
3129 IF no <> 1 THEN
3130 BEGIN
3131 error 2 ;
3132 skipextd 10 ;
3133 GOTO 1 ;
3134 END ;
3135 checkdefiningpoint aval next ;
3136 create_vars_box lp aval ;
3137 WITH lp^ DO
3138 BEGIN
3139 vkind := arraybound ;
3140 visset := true ;
3141 visreadonly := true ;
3142 END ;
3143 next := lp ;
3144 fvnombofdim := fvnombofdim + 1 ; * <-------- *
3145 ptsecondbound := lp ;
3146
3147 * DECLARED TYPE FOR BOUNDS *
3148
3149 insymbol ;
3150 IF no <> 19 THEN * : *
3151 BEGIN
3152 error 7 ;
3153 skipextd 10 19 ;
3154 IF no <> 19 THEN
3155 GOTO 1 ;
3156 END ;
3157 insymbol ;
3158 IF no <> 1 THEN
3159 BEGIN
3160 error 2 ;
3161 skipextd 10 ;
3162 GOTO 1 ;
3163 END ;
3164 srchrec next ; IF ctptr = NIL THEN search ;
3165 IF ctptr = NIL THEN * not found *
3166 BEGIN
3167 error 104 ;
3168 END ELSE
3169 BEGIN
3170 IF symbolmap THEN
3171 nameisref ctptr symbolfile symbolline ;
3172 IF ctptr^.klass = types THEN
3173 BEGIN
3174 * LOCKNAMEAVALUSEDNAME ; *
3175 IF ctptr^.form = aliastype THEN
3176 ctptr := ctptr^.realtype ;
3177 IF NOT ctptr^.form IN scalar numeric THEN
3178 error 113 ;
3179 END ELSE
3180 BEGIN
3181 error 103 ;
3182 ctptr := NIL ;
3183 END ;
3184 END ;
3185 next^.vtype := ctptr ;
3186 next^.nxtel^.vtype := ctptr ;
3187
3188 * CREATE CONFORMANT ARRAY DIMENSION BOX *
3189
3190 create_types_box lp blank arrays true ;
3191 WITH lp^ DO
3192 BEGIN
3193 pack := packedfound ;
3194 inxtype := ctptr ;
3195 ptlow := ptfirstbound ;
3196 pthigh := ptsecondbound ;
3197 END ;
3198
3199 IF ptlastdim = NIL THEN
3200 ptfirstdim := lp ELSE
3201 ptlastdim^.aeltype := lp ;
3202 lp^.nxtel := ptlastdim ;
3203 ptlastdim := lp ;
3204 nbofdim := nbofdim + 1 ;
3205
3206 insymbol ;
3207 IF no <> 16 AND no <> 12 THEN * ; or ] *
3208 BEGIN
3209 error 12 ;
3210 skipextd 10 12 ;
3211 * it would be hazardous to consider ";" if found by SKIP
3212 as a separator of dimensions instead of a separator
3213 of parameters *
3214 IF no <> 12 THEN
3215 GOTO 1 ;
3216 END ;
3217
3218 $OPTIONS compile = trace $
3219 IF decltrace > none THEN
3220 BEGIN
3221 write mpcogout '@ CONFORMARRAY until NO <> 16 :' ; nextline ;
3222 write mpcogout '@ CONFORMARRAY until ... NEXT est en ^'
3223 ord next ' PTLASTDIMPTFIRSTDIM en ^'
3224 ord ptlastdim ord ptfirstdim ;
3225 nextline ;
3226 END ;
3227 $OPTIONS compile = true $
3228
3229 UNTIL no <> 16 ; * ; *
3230 * FIN LOOP ON DIMENSIONS *
3231
3232
3233
3234 * EXPECTED SYMBOLS ARE NOW
3235 12 ]
3236 27 of
3237 1 Type_Identifier
3238 *
3239
3240 IF no <> 12 THEN * ] *
3241 BEGIN
3242 error 12 ;
3243 skipextd 10 12 ;
3244 IF no <> 12 THEN
3245 GOTO 1 ELSE
3246 insymbol ;
3247 END ELSE
3248 insymbol ;
3249 IF no <> 27 THEN * of *
3250 BEGIN
3251 error 8 ;
3252 skipextd 10 27 ;
3253 IF no <> 27 THEN
3254 GOTO 1 ELSE
3255 insymbol ;
3256 END ELSE
3257 insymbol ;
3258
3259 * TYPE IDENTIFIER ? *
3260
3261 IF no = 1 THEN
3262 BEGIN
3263 srchrec next ; IF ctptr = NIL THEN search ;
3264 IF ctptr = NIL THEN * not found *
3265 BEGIN
3266 error 104 ;
3267 END ELSE
3268 BEGIN
3269 IF symbolmap THEN
3270 nameisref ctptr symbolfile symbolline ;
3271 IF ctptr^.klass = types THEN
3272 BEGIN
3273 * LOCKNAMEAVALUSEDNAME ; *
3274 IF ctptr^.form = aliastype THEN
3275 ctptr := ctptr^.realtype ;
3276 END ELSE
3277 BEGIN
3278 error 103 ;
3279 ctptr := NIL ;
3280 END ;
3281 END ;
3282 ptlastdim^.aeltype := ctptr ;
3283 IF ctptr <> NIL THEN
3284 BEGIN
3285 lp := ptlastdim ;
3286 WHILE lp <> NIL DO
3287 BEGIN
3288 IF packedfound THEN
3289 lp^.cadrage := packedcadre ctptr ELSE
3290 lp^.cadrage := ctptr^.cadrage ;
3291 lp := lp^.nxtel ;
3292 END ;
3293 END ;
3294 END ELSE
3295 IF no = 42 OR no = 38 AND cl = 1 THEN * array *
3296 BEGIN
3297 conformagain := true ;
3298 END ELSE
3299 BEGIN
3300 error 56 ;
3301 skipextd 10 ;
3302 GOTO 1 ;
3303 END ;
3304 END * NO=11 * ;
3305 END * NO=38 and CL=1 * ;
3306 UNTIL NOT conformagain ;
3307
3308 lp := ptfirstdim ; * FILL NOW VDISPL FIELD IN BOUNDS BOXES *
3309 FOR it := nbofdim DOWNTO 1 DO
3310 IF lp <> NIL THEN
3311 BEGIN
3312 lp^.ptlow^.vdispl := it * 12 - 8 ;
3313 lp^.pthigh^.vdispl := it * 12 - 4 ;
3314 lp := lp^.aeltype
3315 END ;
3316
3317 IF nbpar = 1 THEN
3318 BEGIN
3319 ptlastvar^.vtype := ptfirstdim ;
3320 END ELSE
3321 BEGIN
3322 * Break NXTEL chain *
3323 lp := ptlastvar ;
3324 FOR it := 1 TO nbpar DO
3325 BEGIN
3326 lp^.vtype := ptfirstdim ;
3327 lp := lp^.nxtel ;
3328 END ;
3329 ptfirstvar := ptlastvar ;
3330 FOR it := 1 TO nbpar - 1 DO
3331 BEGIN
3332 ptsecondvar := ptfirstvar ;
3333 ptfirstvar := ptfirstvar^.nxtel ;
3334 END ;
3335 ptsecondvar^.nxtel := next ;
3336 next := ptlastvar ;
3337 ptfirstbound^.nxtel := ptfirstvar ;
3338 END ;
3339 1 :
3340
3341 $OPTIONS compile = trace $
3342 IF decltrace = high THEN
3343 BEGIN
3344 write mpcogout '@@@ Fin de CONFORMARRAY @@@ avec NOCL:' no : 5 cl : 5 ' '
3345 'PTLASTDIMPTFIRSTDIM ^' ord ptlastdim ord ptfirstdim
3346 ' PTFIRSTVARPTSECONDVARPTLASTVAR en ^'
3347 ord ptfirstvar ord ptsecondvar ord ptlastvar ;
3348 nextline ;
3349 write mpcogout '@@@ CONFORMARRAY returns FVNOMBOFDIM =' fvnombofdim ;
3350 nextline ;
3351 END ;
3352 $OPTIONS compile = true $
3353 END * CONFORMARRAY * ;
3354
3355
3356 BEGIN * FORMPARM *
3357 $OPTIONS compile = trace $
3358 IF decltrace > none THEN
3359 BEGIN
3360 write mpcogout ' @@@ DEBUT FORMPARM @@@ WITH NESTPROCLCNEXT' nestproc lc
3361 ord next ; nextline ;
3362 END ;
3363 $OPTIONS compile = true $
3364 REPEAT
3365 IF no IN 44 45 * FUNC OR PROC PARAMETER * THEN
3366 BEGIN
3367 itisproc := no = 45 ; insymbol ;
3368 IF no # 1 THEN error 2 ELSE
3369 BEGIN
3370 srchrec next ;
3371 IF ctptr # NIL THEN error 101 * PARAMETER YET USED * ELSE
3372 BEGIN
3373 create_proc_box lp aval ;
3374 WITH lp^ DO
3375 BEGIN
3376 proctype := lp ; prockind := formal ;
3377 IF nestproc = 0 THEN
3378 BEGIN
3379 procaddr := lc ;
3380 lc := lc + bytesindword ;
3381 END ;
3382 END ;
3383 globnbpar := globnbpar + 1 ;
3384 next := lp ;
3385 nestproc := nestproc + 1 ;
3386 savenext := next ; next := NIL ;
3387 insymbol ;
3388 savenbpar := globnbpar ;
3389 globnbpar := 0 ;
3390 savedescriptors := globdescriptors ;
3391 globdescriptors := false ;
3392 IF no = 9 THEN * *
3393 BEGIN
3394 insymbol ; formparm ;
3395 IF no = 10 THEN insymbol ;
3396 END ;
3397 IF NOT itisproc THEN
3398 BEGIN
3399 IF no = 19 * : * THEN insymbol ELSE error 7 ;
3400 IF no # 1 THEN
3401 BEGIN
3402 error 123 ; lp@.proctype := NIL ; skip 46 ;
3403 END ELSE
3404 BEGIN
3405 search ;
3406 IF ctptr # NIL THEN
3407 BEGIN
3408 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
3409 IF ctptr@.klass # types THEN
3410 BEGIN
3411 error 103 ; ctptr := NIL ;
3412 END ELSE
3413 BEGIN
3414 IF ctptr@.form = aliastype THEN ctptr := ctptr@.realtype ;
3415 IF ctptr@.form >= power THEN
3416 BEGIN
3417 error 120 ; ctptr := NIL ;
3418 END ;
3419 END ;
3420 END ELSE error 104 ;
3421 globnbpar := globnbpar + 1 ;
3422 lp@.proctype := ctptr ;
3423 insymbol ;
3424 END ;
3425 END ; * TYPE OF FUNCTION *
3426 lp@.nbparproc := globnbpar ;
3427 globnbpar := savenbpar ;
3428 lp^.phasdescriptor := globdescriptors ;
3429 globdescriptors := savedescriptors ;
3430 lp@.segsize := nestproc ; * LEVEL OF NESTING *
3431 lp@.formals := next ; * LIST OF PARAMETERS *
3432 next := savenext ;
3433 nestproc := nestproc - 1 ;
3434 END ; * CTPTR=NIL *
3435 END ; * NO=1 *
3436 END * NO IN 4445 * ELSE
3437 BEGIN
3438 IF no = 43 * VAR * THEN
3439 BEGIN
3440 itisvar := true ;
3441 insymbol ;
3442 END ELSE itisvar := false ;
3443 IF no = 1 THEN
3444 BEGIN
3445 nbpar := 0 ;
3446 REPEAT * ID1ID2... *
3447 srchrec next ;
3448 IF ctptr # NIL THEN
3449 BEGIN
3450 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
3451 error 101 * YET USED *
3452 END
3453 ELSE
3454 BEGIN
3455 nbpar := nbpar + 1 ;
3456 create_vars_box lp aval ;
3457 WITH lp^ DO
3458 BEGIN
3459 vkind := formal ; varparam := itisvar ; visset := true ;
3460 END ;
3461 next := lp ;
3462 globnbpar := globnbpar + 1 ;
3463 END ; * NEW PARAMETER *
3464 insymbol ;
3465 IF no = 15 * * THEN
3466 BEGIN
3467 insymbol ;
3468 IF no = 19 * : * THEN error 2 ; * TO DETECT : *
3469 END ELSE
3470 IF no <> 19 THEN
3471 BEGIN error 7 ; insymbol ;
3472 END ;
3473 UNTIL no # 1 ;
3474 IF no = 19 * : * THEN insymbol ;
3475 IF no = 42 * PACKED * OR no = 38 AND cl = 1 THEN
3476 BEGIN
3477 conformarray nbofdim ;
3478 globdescriptors := true ;
3479 IF nestproc = 0 THEN
3480 BEGIN
3481 lc := lc + nbpar * bytesindword ; lcaux := lc ;
3482 lp := next ; lctop := lcaux ;
3483 FOR it := 1 TO nbofdim + nbpar DO
3484 BEGIN
3485 IF lp <> NIL THEN
3486 BEGIN
3487 IF lp^.vkind <> arraybound THEN
3488 BEGIN
3489 lcaux := lcaux - bytesindword ;
3490 lp^.vaddr := lcaux ;
3491 lp^.vdescaddr := -1 ;
3492 END ;
3493 lp := lp^.nxtel ;
3494 END ;
3495 END ;
3496 END ;
3497 END ELSE
3498 IF no # 1 THEN error 2 ELSE
3499 BEGIN * TYPE IDENTIFIER *
3500 search ;
3501 IF ctptr = NIL THEN
3502 error 104
3503 ELSE
3504 BEGIN
3505 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
3506 IF ctptr^.klass = schema THEN
3507 BEGIN
3508 IF procptr^.pwantspl1descriptors THEN
3509 error 448 ;
3510 IF NOT itisvar THEN
3511 BEGIN
3512 itisvar := true ;
3513 error 281 ;
3514 END ;
3515 create_types_box lctp ctptr^.name records false ;
3516 WITH lctp^ DO
3517 BEGIN
3518 father_schema := ctptr ;
3519 END ;
3520 ctptr := lctp ;
3521 globdescriptors := true ;
3522 END ;
3523 IF ctptr@.klass # types THEN error 103 ELSE
3524 BEGIN
3525 IF ctptr@.form = aliastype THEN ctptr := ctptr@.realtype ;
3526 IF ctptr^.form = files AND NOT itisvar THEN
3527 BEGIN
3528 error 121 ; * File must be VAR parameter *
3529 itisvar := true ;
3530 END ;
3531 IF nestproc = 0 THEN * NOT DUMMY PARAMETERS *
3532 BEGIN
3533 lc := lc + nbpar * bytesindword ; lcaux := lc ;
3534 lp := next ;
3535 END * NOT DUMMY PARAMETER *
3536 ELSE BEGIN
3537 IF ctptr^.father_schema <> NIL THEN
3538 IF ctptr^.actual_parameter_list = NIL THEN * BUILD ACTUAL PARAMETER LIST FOR SCHEMA *
3539 WITH ctptr^ DO
3540 BEGIN
3541 lctp1 := father_schema^.formal_parameter_list ;
3542 WHILE lctp1 <> NIL DO
3543 BEGIN
3544 create_vars_box lctp2 lctp1^.name ;
3545 lctp2^.vtype := lctp1^.vtype ;
3546 lctp2^.vkind := arraybound ;
3547 lctp2^.visset := true ;
3548 lctp2^.visreadonly := true ;
3549 IF actual_parameter_list = NIL THEN
3550 actual_parameter_list := lctp2
3551 ELSE
3552 lctp3^.nxtel := lctp2 ;
3553 lctp1 := lctp1^.nxtel ;
3554 lctp3 := lctp2 ;
3555 END ;
3556 END ;
3557 END ;
3558 FOR it := nbpar DOWNTO 1 DO
3559 BEGIN
3560 IF nestproc = 0 THEN
3561 BEGIN
3562 lcaux := lcaux - bytesindword ;
3563 lp@.vaddr := lcaux ;
3564 END ;
3565 lp^.varparam := itisvar ;
3566 IF ctptr^.father_schema <> NIL THEN
3567 IF ctptr^.actual_parameter_list = NIL THEN lp^.vdescaddr := -1 ; * needs descriptor *
3568 lp := lp@.nxtel ;
3569 END ; * FOR *
3570 lp := next ;
3571 FOR it := nbpar DOWNTO 1 DO
3572 BEGIN
3573 lp@.vtype := ctptr ;
3574 lp := lp@.nxtel ;
3575 END ;
3576 END ; * CORRECT TYPE *
3577 END ;
3578 END ;
3579 insymbol ;
3580 END ELSE
3581 BEGIN * FIRST ITEM OF THE'LIST IS ILLEGAL *
3582 error 2 ;
3583 skip 10 ; * *
3584 END ;
3585 END ; * NEITHER PROCEDURE NOR FUNCTION *
3586 IF no = 16 * ; * THEN
3587 BEGIN
3588 insymbol ;
3589 IF no = 10 THEN
3590 BEGIN
3591 rep := false ; error 2 ; * TO DETECT ; *)
3592 END ELSE rep := true ;
3593 END ELSE rep := no IN 1 43 44 45 ; * IDVARFUNCPROC *
3594 UNTIL NOT rep ;
3595 IF no # 10 THEN
3596 BEGIN
3597 error 4 ; skip 10 ;
3598 IF no IN 37 40 41 43 44 45 * TYPELABELCONSTVARPROCFUNC * THEN
3599 GOTO 1 ; * LEAVES FORMPARM * * 1 DEFINED IN BODY *
3600 END ; * NO # 10 *
3601 * LINKAGE REVERSE *
3602 lp := next ; next := NIL ;
3603 WHILE lp # NIL DO
3604 BEGIN
3605 lp1 := lp ; lp := lp@.nxtel ;
3606 lp1@.nxtel := next ; next := lp1 ;
3607 END ;
3608 * La chaine est dans le bon ordre. Termine le remplissage *
3609 lp := next ; locended := false ; loccounter := 0 ;
3610 locad := 0 ;
3611 WHILE NOT locended DO
3612 IF lp = NIL THEN
3613 locended := true ELSE
3614 WITH lp^ DO
3615 BEGIN
3616 schema_parameter_count := 0 ;
3617 IF klass = proc THEN
3618 BEGIN
3619 IF prockind <> formal THEN
3620 locended := true ELSE
3621 BEGIN
3622 loccounter := loccounter + 1 ;
3623 $OPTIONS compile = trace $
3624 printrec lp ;
3625 $OPTIONS compile = true $
3626 lp := nxtel ;
3627 END * FORMAL * ;
3628 END * PROC * ELSE
3629 IF klass <> vars THEN
3630 locended := true ELSE
3631 BEGIN
3632 IF vkind = formal THEN
3633 BEGIN
3634 locad := vaddr ; loccounter := loccounter + 1 ;
3635 IF vdescaddr = -1 THEN
3636 BEGIN
3637 vdescaddr := vaddr + globnbpar * bytesindword ;
3638 IF vtype <> NIL THEN
3639 WITH vtype^ DO
3640 IF father_schema <> NIL AND actual_parameter_list = NIL THEN
3641 * THIS VARIABLE HAS A SCHEMA FOR TYPE.
3642 BUILD ACTUAL PARAMETER LIST FOR THIS TYPE PASSED IN DESCRIPTOR *
3643 BEGIN
3644 lctp1 := father_schema^.formal_parameter_list ;
3645 WHILE lctp1 <> NIL DO
3646 BEGIN
3647 create_vars_box lctp2 lctp1^.name ;
3648 lctp2^.vtype := lctp1^.vtype ;
3649 lctp2^.vkind := arraybound ;
3650 lctp2^.vaddr := locad + globnbpar * bytesindword ;
3651 lctp2^.visset := true ;
3652 lctp2^.visreadonly := true ;
3653 lctp2^.vdispl := 8 * TWO WORDS FOR MULTICS EXTENDED ARG DESC HEADER *
3654 + 4 * ONE WORD FOR ACTUAL SIZE OF PASSED SCHEMA *
3655 + 4 * schema_parameter_count ; * ONE WORD PER SCHEMA PARAMETER * ;
3656 schema_parameter_count := schema_parameter_count + 1 ;
3657 IF actual_parameter_list = NIL THEN
3658 actual_parameter_list := lctp2
3659 ELSE
3660 lctp3^.nxtel := lctp2 ;
3661 lctp1 := lctp1^.nxtel ;
3662 lctp3 := lctp2 ;
3663 END ;
3664 END ;
3665 END ;
3666 $OPTIONS compile = trace $
3667 printrec lp ;
3668 $OPTIONS compile = true $
3669 lp := nxtel ;
3670 END * FORMAL * ELSE
3671 IF vkind = arraybound THEN
3672 BEGIN
3673 vaddr := locad + globnbpar * bytesindword ;
3674 $OPTIONS compile = trace $
3675 printrec lp ;
3676 $OPTIONS compile = true $
3677 lp := nxtel ;
3678 END * ARRAYBOUND * ELSE
3679 locended := true ;
3680 END * VARS * ;
3681 IF loccounter > globnbpar THEN
3682 locended := true ; * Security *
3683 END ; * with LP^ LP <> nil while not ENDED *
3684 IF nestproc = 0 THEN
3685 IF globdescriptors THEN
3686 lc := lc + globnbpar * bytesindword ;
3687 $OPTIONS compile = trace $
3688 IF decltrace > low THEN
3689 BEGIN
3690 write mpcogout ' @@@ FIN FORMPARM @@@ WITH NESTPROCLCNEXT ' nestproc lc
3691 ord next ;
3692 nextline ;
3693 END ;
3694 $OPTIONS compile = true $
3695 END * FORMPARM * ;
3696
3697
3698 * *********************************** IMPORTPARTDECL < BODY ************** *
3699
3700 PROCEDURE importpartdecl ;
3701
3702 * C . Before call $IMPORT has been read.
3703 . Caution:
3704 This declaration is allowed only for globals in mode not standard.
3705 . The name of origin is not used.
3706 C *
3707
3708 * E Errors detected
3709 2 Identifier expected
3710 7 ":" expected
3711 19 String expected
3712 20 "" expected
3713 37 Invalid Multics string for imported item
3714 76 "$" expected
3715 77 $IMPORT must appear at global level after the program header
3716 78 $IMPORT EXPORT not standard features
3717 100 Duplicate external name
3718 E *
3719
3720 LABEL
3721 10 ; * Procedure exit *
3722
3723 VAR
3724 wkexternpt : ptexternalitem ;
3725 errorfound : boolean ;
3726 locsegname
3727 locentryname
3728 locgenerator : alfaid ;
3729 locwantdescs : boolean ;
3730 loconlyone : boolean ;
3731 locerrfound : boolean ;
3732 locsamestring : integer ;
3733
3734 * **************************** DECODESTRING < IMPORTPARTDECL ***** *
3735
3736 PROCEDURE decodestring VAR fsegname fentryname fgenerator : alfaid ;
3737 VAR fwantdescs fonlyone ferrfound : boolean ;
3738
3739 * Given the output of INSYMBOL : BUFVAL filled on LONGCHAINE chars
3740 this procedure try to find
3741 - A segment name followed if any by
3742 - "$" entryname
3743 - in all cases "" genrator_name ""
3744
3745 If there is an entryname only one element in the following list
3746
3747 One exception : The word 'external_static'
3748 Obsolete 'external_statics' still supported..
3749
3750 In all cases for each entity all caracters are allowed
3751 except < > ? $ *
3752 C *
3753
3754 VAR
3755 index : integer ;
3756 iderr : boolean ;
3757 locerr : boolean ;
3758 currch : char ;
3759 locdescs : alfaid ;
3760 stopch : char ;
3761
3762 PROCEDURE getamulticsid VAR fid : alfaid ; VAR fstopch : char ; low : boolean ; VAR ferr : boolean ;
3763
3764 VAR
3765 ended : boolean ;
3766 locerr : boolean ;
3767 loci : integer ;
3768 locid : alfaid ;
3769 it : integer ;
3770
3771 BEGIN
3772 fstopch := chr 000 ; * Means ended *
3773 * Skip leading spaces *
3774
3775 locerr := false ;
3776 ended := NOT currch IN ' ' chr 9 * TAB * ;
3777 WHILE NOT ended DO
3778 BEGIN
3779 index := index + 1 ;
3780 IF index > longchaine THEN
3781 BEGIN
3782 locerr := true ; ended := true ; currch := chr 000 ;
3783 END ELSE
3784 BEGIN
3785 currch := bufval index ;
3786 ended := NOT currch IN ' ' chr 9 * TAB * ;
3787 END ;
3788 END ;
3789
3790 IF currch IN '' '$'] THEN
3791 BEGIN
3792 index := index + 1 ;
3793 IF index > longchaine THEN
3794 locerr := true ELSE
3795 currch := bufval index ;
3796 END ;
3797 loci := 0 ; locid := ' ' ;
3798 ended := NOT currch IN ' ' chr 9 * TAB * ;
3799 WHILE NOT ended DO
3800 BEGIN
3801 index := index + 1 ;
3802 IF index > longchaine THEN
3803 BEGIN
3804 locerr := true ; ended := true ;
3805 END ELSE
3806 BEGIN
3807 currch := bufval index ;
3808 ended := NOT currch IN ' ' chr 9 * TAB * ;
3809 END ;
3810 END ;
3811
3812 * Now first char of identifier multics expected *
3813
3814
3815
3816 ended := currch IN '' '' '$' '<' '>' '*' '?' ;
3817
3818 IF NOT locerr THEN
3819 WHILE NOT ended DO
3820 BEGIN
3821
3822 loci := loci + 1 ;
3823 IF loci > maxident THEN
3824 BEGIN
3825 ended := true ; locerr := true ;
3826 END ELSE
3827 BEGIN
3828 locid loci := currch ;
3829 index := index + 1 ;
3830 IF index > longchaine THEN
3831 BEGIN
3832 locerr := true ; currch := chr 0 ;
3833 END ELSE
3834 currch := bufval index ;
3835 ended := currch IN '' '' '$' '<' '>' '*' '?' ' ' chr 9 * TAB * chr 000 ;
3836 END ;
3837 END * while * ;
3838
3839 * Here stops on end caracter or end strings *
3840 IF currch IN ' ' chr 9 * TAB * THEN
3841 BEGIN
3842 * Skip until a good end caracter *
3843 REPEAT
3844 index := index + 1 ;
3845 IF index > longchaine THEN
3846 currch := chr 000 ELSE
3847 currch := bufval index ;
3848 UNTIL NOT currch IN ' ' chr 9 * TAB * ;
3849 END * Skip * ;
3850
3851 fstopch := currch ;
3852 fid := locid ;
3853 ferr := locerr ;
3854
3855 IF low THEN
3856 FOR it := 1 TO maxident DO
3857 fid it := chr majmin ord fid it ;
3858
3859 $OPTIONS compile = trace $
3860 IF decltrace = high THEN
3861 BEGIN
3862 write mpcogout ' Fin de GET_A_MULTICS_ID avec FERR FSTOPCH INDEX:'
3863 ferr : 7 '%' fstopch '%' index : 5
3864 ' et LOCI ' loci : 4 ;
3865 nextline ;
3866 END ;
3867 $OPTIONS compile = true $
3868
3869
3870
3871 END * GET_A_MULTICS_ID * ;
3872
3873
3874
3875 BEGIN * DECODESTRING *
3876
3877 locdescs := blank ;
3878 fsegname := blank ; fgenerator := blank ; fentryname := blank ;
3879 fonlyone := false ; ferrfound := false ;
3880 index := 0 ; currch := ' ' ; iderr := false ; locerr := false ;
3881 fwantdescs := false ;
3882
3883 getamulticsid fsegname stopch false locerr ;
3884 IF locerr THEN
3885 iderr := true ;
3886 IF stopch = chr 000 THEN
3887 BEGIN
3888 IF fsegname <> 'external_statics' AND fsegname <> 'external_static' THEN
3889 ferrfound := true
3890 ELSE
3891 iderr := false ;
3892 END ELSE
3893 BEGIN
3894 IF stopch = '$' THEN
3895 BEGIN
3896 fonlyone := true ;
3897 getamulticsid fentryname stopch false locerr ;
3898 IF locerr THEN
3899 iderr := true ;
3900 IF stopch <> '' THEN
3901 ferrfound := true ;
3902 END ;
3903
3904 IF stopch = '' THEN
3905 BEGIN
3906 getamulticsid fgenerator stopch true locerr ;
3907 IF locerr THEN
3908 iderr := true ;
3909 IF stopch IN 'd' 'D' THEN
3910 BEGIN
3911 getamulticsid locdescs stopch true locerr ;
3912 IF locdescs = 'descriptors' THEN
3913 fwantdescs := true
3914 ELSE ferrfound := true ;
3915 END ;
3916 IF stopch <> '' THEN
3917 ferrfound := true ;
3918 END ;
3919
3920 IF fgenerator = blank THEN
3921 ferrfound := true ;
3922
3923 END ; * STOPCH <> chr000 *
3924
3925 ferrfound := ferrfound OR iderr ;
3926
3927 $OPTIONS compile = trace $
3928 IF decltrace = high THEN
3929 BEGIN
3930 write mpcogout ' Fin de DECODESTRING avec IDERRFERRFOUND :' iderr : 7
3931 ferrfound : 7 ; nextline ;
3932 write mpcogout ' "" "" avec FONLYONE =' fonlyone : 7 ;
3933 nextline ;
3934 END ;
3935 $OPTIONS compile = true $
3936
3937
3938 END * DECODESTRING * ;
3939
3940
3941 BEGIN * IMPORTPARTDECL *
3942 $OPTIONS compile = trace $
3943 IF decltrace > none THEN
3944 BEGIN
3945 write mpcogout ' @@@ Debut de IMPORTPARTDECL @@@' ; nextline ;
3946 END ;
3947 $OPTIONS compile = true $
3948 IF level <> 0 THEN
3949 BEGIN
3950 error 77 ; skiptochapter ; GOTO 10 ; * Exit proc *
3951 END ;
3952 IF envstandard = stdpure THEN
3953 error 78 ;
3954
3955 insymbol ;
3956 IF no <> 2 OR cl <> 3 THEN
3957 BEGIN
3958 error 19 ; skipextd 16 55 ;
3959 END ;
3960 WHILE no = 2 AND cl = 3 DO * String *
3961 BEGIN
3962
3963 decodestring locsegname locentryname locgenerator locwantdescs
3964 loconlyone locerrfound ;
3965 IF locerrfound THEN
3966 error 37 ;
3967
3968 locsamestring := 0 ;
3969
3970 insymbol ;
3971 IF no <> 19 * : * THEN
3972 BEGIN
3973 error 7 ; skipextd 1 16 55 ;
3974 END ELSE
3975 insymbol ;
3976
3977 IF no <> 1 * Identifier * THEN
3978 BEGIN
3979 error 2 ; skipextd 16 55 2 ;
3980 END ;
3981
3982 WHILE no = 1 DO
3983 BEGIN
3984 * Check if it is a new external identifier *
3985 errorfound := false ;
3986 checkexternalitem aval wkexternpt ;
3987 IF wkexternpt <> NIL THEN
3988 BEGIN
3989 * External box found may be for a REMANENT file *
3990 wkexternpt^.extrfile2 := symbolfile ; wkexternpt^.extrline2 := symbolline ;
3991 IF wkexternpt^.extkind = actual THEN
3992 wkexternpt^.extkind := imported ELSE
3993 BEGIN
3994 error 100 ; wkexternpt := NIL ;
3995 END ;
3996 END ELSE
3997 createexternalbox aval extnotresolved imported wkexternpt ;
3998 IF wkexternpt <> NIL THEN
3999 BEGIN
4000
4001 wkexternpt^.extsegname := locsegname ;
4002 locsamestring := locsamestring + 1 ;
4003 wkexternpt^.extgenerator := locgenerator ;
4004 wkexternpt^.extwantdescs := locwantdescs ;
4005 IF locentryname <> blank THEN
4006 wkexternpt^.extentryname := locentryname ELSE
4007 wkexternpt^.extentryname := aval ;
4008 END * Create a box for a new external * ;
4009
4010 insymbol ;
4011 IF no = 15 * * THEN
4012 BEGIN insymbol ;
4013 IF no <> 1 THEN
4014 BEGIN error 2 ; skipextd 2 16 55 ;
4015 END
4016 END ELSE
4017 BEGIN
4018 IF NOT no IN 16 55 THEN
4019 BEGIN error 20 ; errorfound := true ;
4020 END ;
4021 END ;
4022 END * while NO=1 * ;
4023
4024
4025 * IF loconlyone THEN
4026 IF locsamestring <> 1 THEN
4027 error 37 ; *
4028 IF no = 16 * ; * THEN
4029 insymbol ELSE
4030 IF no <> 55 * $ * THEN
4031 BEGIN
4032 IF NOT errorfound THEN error 76 ;
4033 skipextd 2 55 ;
4034 IF no = 16 * ; * THEN insymbol ;
4035 END ;
4036
4037 END * While NO=2 CL=3 * ;
4038
4039 IF no <> 55 THEN
4040 BEGIN
4041 error 76 ; skiptochapter ;
4042 END ELSE
4043 insymbol ;
4044
4045 $OPTIONS compile = trace $
4046 IF decltrace = high THEN
4047 BEGIN
4048 write mpcogout ' ** Boxes created in IMPORTPARTDECL are the following' ;
4049 nextline ; wkexternpt := externallistheader ;
4050 WHILE wkexternpt <> NIL DO
4051 BEGIN
4052 printexternalbox wkexternpt ;
4053 wkexternpt := wkexternpt^.extnext ;
4054 END ;
4055 END ;
4056 $OPTIONS compile = true $
4057
4058 10 : * Procedure exit *
4059
4060 $OPTIONS compile = trace $
4061 IF decltrace = high THEN
4062 BEGIN
4063 write mpcogout ' @@@ Fin de IMPORTPARTDECL @@@ with NOCL'
4064 no : 4 cl : 4 ; nextline ;
4065 END ;
4066 $OPTIONS compile = true $
4067
4068 END * IMPORTPARTDECL * ;
4069
4070 * ******************************************* EXPORTPARTDECLBODY *
4071
4072 PROCEDURE exportpartdecl ;
4073
4074 * C Before call $EXPORT has been read
4075 C *
4076
4077 * E
4078 2 IDENTIFIER expected
4079 20 '' expected
4080 76 $ expected
4081 78 $IMPORT et $EXPORT not allowed in STANDARD
4082 79 $EXPORT only in global part
4083 80 EXPORTED ITEM CANNOT HAVE SAME NAME THAN PROGRAM.
4084 100 duplicate external name
4085 447 externbox not nil for a box found
4086 E *
4087
4088 LABEL
4089 10 ; * exit procedure *
4090
4091 VAR
4092 $OPTIONS compile = trace $
4093 currextpt : ptexternalitem ;
4094 $OPTIONS compile = true $
4095 wkexternpt : ptexternalitem ;
4096
4097 BEGIN * EXPORTPARTDECL *
4098 $OPTIONS compile = trace $
4099 IF decltrace > none THEN
4100 BEGIN
4101 write mpcogout '@@@ begin of EXPORTPARTDECL @@@ with EXTERNALHEADER at ^'
4102 ord externallistheader ; nextline ;
4103 END ;
4104 currextpt := externallistheader ;
4105 $OPTIONS compile = true $
4106
4107 IF level <> 0 THEN
4108 BEGIN
4109 error 79 ; skiptochapter ; GOTO 10 * exit proc * ;
4110 END ;
4111 IF envstandard = stdpure THEN
4112 error 78 ;
4113 insymbol ;
4114
4115 init_fsb_trap_flag := true ;
4116
4117 IF NOT no IN 1 55 THEN * Ident $ *
4118 BEGIN error 2 ; skipextd 1 ;
4119 END ;
4120 WHILE no = 1 DO
4121 BEGIN
4122 checkexternalitem aval wkexternpt ;
4123 IF wkexternpt <> NIL THEN
4124 BEGIN
4125 * External box found may be for a REMANENT file *
4126 wkexternpt^.extrfile2 := symbolfile ; wkexternpt^.extrline2 := symbolline ;
4127 IF wkexternpt^.extkind = actual THEN
4128 wkexternpt^.extkind := exportable ELSE
4129 error 100 ;
4130 END ELSE
4131 BEGIN * new external *
4132 createexternalbox aval extnotresolved exportable wkexternpt ;
4133 END * new external * ;
4134 IF aval = progname THEN error 80 ;
4135 insymbol ;
4136 IF no = 15 * * THEN
4137 BEGIN
4138 insymbol ;
4139 IF no <> 1 THEN
4140 BEGIN error 2 ;
4141 skipextd 1 ;
4142 END ;
4143 END ELSE
4144 IF no <> 55 THEN
4145 BEGIN
4146 error 20 ;
4147 IF no <> 1 THEN skipextd 1 ;
4148 END ;
4149 END * while NO=1 * ;
4150 IF no <> 55 * $ * THEN
4151 BEGIN
4152 error 76 ; skiptochapter ;
4153 END ELSE
4154 insymbol ;
4155 $OPTIONS compile = trace $
4156 IF decltrace = high THEN
4157 BEGIN
4158 write mpcogout '* boxes created in EXPORTPARTDECL are the following:' ;
4159 nextline ;
4160 wkexternpt := externallistheader ;
4161 WHILE wkexternpt <> currextpt DO
4162 BEGIN
4163 printexternalbox wkexternpt ;
4164 wkexternpt := wkexternpt^.extnext ;
4165 END ;
4166 END ;
4167 $OPTIONS compile = true $
4168 10 : * exit proc *
4169 $OPTIONS compile = trace $
4170 IF decltrace = high THEN
4171 BEGIN
4172 write mpcogout '@@@ end of EXPORTPARTDECL @@@ with NOCL:'
4173 no : 4 cl : 4 ;
4174 nextline ;
4175 END ;
4176 $OPTIONS compile = true $
4177 END * EXPORTPARTDECL * ;
4178
4179 * ************************************* LABELPARTDECL < BODY ************** *
4180
4181 PROCEDURE labelpartdecl ;
4182
4183 * C Compilation of LABEL lab1 lab2 ..... ;
4184 Called if the key-word LABEL NO=40 was encountered.
4185 C *
4186
4187 * E ERRORS DETECTED
4188 15 integer EXPECTED
4189 20 '' EXPECTED
4190 166 MULTIDECLARED LABELS
4191 267 TOO MANY LABELS MAXLABS
4192 306 LABEL MUST HAVE AT MOST 4 DIGITS
4193 E *
4194
4195 LABEL
4196 2 ; * Skip here if bideclared label *
4197 VAR
4198 i : integer ;
4199 currlabbox : labelblockptr ;
4200 BEGIN * LABELPARTDECL *
4201 insymbol ;
4202 WHILE no = 2 AND cl = 1 * CSTE integer * DO
4203 BEGIN
4204 * SEARCH for UNIQUE DECLARATION AT THIS LEVEL *
4205 FOR i := fstix TO clabix DO
4206 IF labtab i.labval = ival THEN
4207 BEGIN
4208 error 166 ; GOTO 2 ;
4209 END ;
4210 * CHECK if AT MOST 4 DIGITS *
4211 IF ival > 9999 THEN error 306 ;
4212 * ALL OK ENTER IT IN LABTAB *
4213 IF clabix = maxlabs THEN
4214 error 267 ELSE
4215 BEGIN
4216 clabix := clabix + 1 ;
4217 WITH labtab clabix DO
4218 BEGIN
4219 labval := ival ; lablev := level ;
4220 labdef := 0 ; labexit := 0 ; labch1 := 0 ;
4221 labbox := NIL ;
4222 new labbox ;
4223 IF labbox = NIL THEN heaperror ;
4224 WITH labbox^ DO
4225 BEGIN
4226 number := ival ;
4227 next := NIL ;
4228 ref_allowed.ic_from := 0 ;
4229 ref_allowed.ic_to := maxint ;
4230 next_in_block := NIL ;
4231 brother := currentnode ^.firstlabel ;
4232 currentnode^.firstlabel := labbox ;
4233 procnode := currentnode ;
4234 dclfile := symbolfile ;
4235 dclline := symbolline ;
4236 deffile := 0 ; defline := 0 ;
4237 new references ;
4238 IF references = NIL THEN heaperror ;
4239 WITH references^ DO
4240 BEGIN refnbr := 0 ; nextref := NIL END ;
4241 BEGIN
4242 next := firstlabbox ^.next ;
4243 firstlabbox^.next := labbox ;
4244 currlabbox := firstlabbox ;
4245 WHILE next^.number < ival DO
4246 BEGIN
4247 currlabbox^.next := next ;
4248 currlabbox := next ;
4249 next := next^.next ;
4250 currlabbox^.next := labbox ;
4251 END ;
4252 END ;
4253 END ;
4254 END ;
4255 END ;
4256 2 : * SKIP HERE if BIDECLARED *
4257 insymbol ;
4258 IF no = 15 * * THEN
4259 BEGIN
4260 insymbol ;
4261 IF no <> 2 OR cl <> 1 THEN error 15 ;
4262 END ELSE
4263 IF no <> 16 THEN error 20 ;
4264 END ; * while integer CSTE *
4265 IF no = 16 * ; * THEN
4266 insymbol ;
4267 $OPTIONS compile = trace $
4268 IF decltrace = high THEN
4269 BEGIN
4270 write mpcogout ' @ BODY.END LABEL PART @@@CLABIXFSTIX ARE' clabix : 4 fstix : 4 ;
4271 nextline ;
4272 END ;
4273 $OPTIONS compile = true $
4274 END * LABELPARTDECL * ;
4275
4276 * ****************************** CONSTPARTDECL < BODY *********************** *
4277
4278 PROCEDURE constpartdecl ;
4279
4280 * C
4281 Compile CONST CONSTID = constante; CONSTID= ....... ;
4282 C *
4283
4284
4285 * E ERRORS DETECTED
4286 HEAPERROR
4287 16 '=' EXPECTED
4288 101 Identifier declared twice
4289 130 Nil not allowed in standard
4290 226 : THIS IDENTIFIER HAS BEEN PREVIOUSLY REFERENCED AT SAME LEVEL
4291 E *
4292
4293 VAR
4294 constid : alfaid ;
4295 typcste lp : ctp ;
4296 codcste : integer ;
4297 tnp : alfalistptr ;
4298 oldfile oldline : integer ;
4299
4300 BEGIN * CONSTPARTDECL *
4301 forbidden_id_list := first_forbidden_id ;
4302 insymbol ;
4303 WHILE no = 1 * ID * DO * LOOP ON < CST_ID = CSTE ; > *
4304 BEGIN
4305 srchrec next ;
4306 IF ctptr # NIL THEN
4307 BEGIN
4308 IF listyes THEN nameisref ctptr symbolfile symbolline ;
4309 error 101
4310 END ;
4311 constid := aval ;
4312 oldfile := symbolfile ; oldline := symbolline ;
4313 tnp := forbidden_id_list ;
4314 WHILE tnp <> first_forbidden_id DO
4315 IF tnp^.name = constid THEN
4316 BEGIN
4317 error 226 ;
4318 tnp := first_forbidden_id
4319 END
4320 ELSE tnp := tnp^.previous ;
4321 insymbol ;
4322 IF no = 8 AND cl = 6 * = * THEN
4323 BEGIN
4324 forbidden_id := constid ; check_id := true ;
4325 insymbol
4326 END ELSE error 16 ;
4327 IF no = 36 * NIL * THEN
4328 BEGIN
4329 IF envstandard <> stdextend THEN
4330 error 130 ;
4331 create_konst_box lp constid wordconst ;
4332 WITH lp^ DO
4333 BEGIN
4334 contype := nilptr ;
4335 IF listyes THEN nameisref nilptr symbolfile symbolline ;
4336 END ;
4337 insymbol ;
4338 END * NIL * ELSE
4339 BEGIN
4340 inconst codcste typcste next true ;
4341 CASE codcste OF
4342 1 * integer * 4 * CHAR * 5 * SCALAR * 0 * ERR * :
4343 BEGIN
4344 create_konst_box lp constid wordconst ;
4345 WITH lp^ DO
4346 BEGIN
4347 values := conint ;
4348 END ;
4349 END ;
4350 2 * REAL * :
4351 BEGIN
4352 create_konst_box lp constid dwordconst ;
4353 WITH lp^ DO
4354 BEGIN
4355 valreel := conreel ;
4356 END ;
4357 END ;
4358 3 * ALFA * :
4359 BEGIN
4360 create_konst_box lp constid alfaconst ;
4361 WITH lp^ DO
4362 BEGIN
4363 succ := lp ; * Means Not Used *
4364 END ;
4365 crealfabox lp ; * Init ALFALONG ALFADEB *
4366 END * ALFA * ;
4367 END * CASE CODCSTE * ;
4368 lp^.contype := typcste ;
4369 END * not NIL * ;
4370 check_id := false ;
4371 WITH lp^ DO
4372 BEGIN
4373 deffile := oldfile ; defline := oldline ;
4374 END ;
4375 $OPTIONS compile = trace $
4376 printrec lp ;
4377 $OPTIONS compile = true $
4378 next := lp ;
4379 findsemicolon ;
4380 END ; * while NO=1 *
4381 $OPTIONS compile = trace $
4382 IF decltrace = high THEN
4383 BEGIN
4384 write mpcogout ' @ BODY.END CONST PART @@@' ; nextline ;
4385 END ;
4386 $OPTIONS compile = true $
4387 END * CONSTPARTDECL * ;
4388
4389 * ******************************** TYPEPARTDECL < BODY ******************** *
4390
4391 PROCEDURE typepartdecl ;
4392
4393 * C
4394 TYPE NO=37 has been read and tested before call
4395 C *
4396
4397 * E Errors DETECTED
4398 16 = expected
4399 93 Non resolved forward declared type identifier
4400 101 Identifier declared twice
4401 108 File not allowed here
4402 226 : THIS IDENTIFIER HAS BEEN PREVIOUSLY REFERENCED AT SAME LEVEL
4403 E *
4404
4405 VAR
4406 typid : alfaid ;
4407 lp retpt : ctp ;
4408 oldfile oldline : integer ;
4409 tl : integer ;
4410 i j : integer ;
4411 tnp : alfalistptr ;
4412
4413 BEGIN * TYPEPARTDECL *
4414 forbidden_id_list := first_forbidden_id ;
4415 insymbol ;
4416 WHILE no = 1 * ID * DO * LOOP ON TYPE DECLARATION TYPID = TYPE ; *
4417 BEGIN
4418 srchrec next ;
4419 IF ctptr <> NIL THEN
4420 BEGIN
4421 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
4422 error 101 ;
4423 END ;
4424 oldfile := symbolfile ; oldline := symbolline ;
4425 typid := aval ;
4426 tnp := forbidden_id_list ;
4427 WHILE tnp <> first_forbidden_id DO
4428 IF tnp^.name = typid THEN
4429 BEGIN
4430 error 226 ;
4431 tnp := first_forbidden_id
4432 END
4433 ELSE tnp := tnp^.previous ;
4434 insymbol ;
4435 IF no = 8 AND cl = 6 * = * THEN
4436 BEGIN
4437 check_id := true ; forbidden_id := typid ;
4438 insymbol
4439 END ELSE error 16 ;
4440
4441 structispack := false ; err := false ; cadre := 0 ;
4442 typedecl tl retpt ;
4443 check_id := false ;
4444 IF NOT err AND retpt <> NIL THEN
4445 IF retpt^.name <> blank THEN
4446 BEGIN * SYNONYMY *
4447 create_types_box lp typid aliastype false ;
4448 WITH lp^ DO
4449 BEGIN
4450 realtype := retpt ;
4451 END ;
4452 $OPTIONS compile = trace $
4453 printrec lp ;
4454 $OPTIONS compile = true $
4455 next := lp ;
4456 END * ALIAS * ELSE
4457 BEGIN * NEW TYPE *
4458 WITH retpt^ DO
4459 BEGIN
4460 name := typid ; nxtel := next ;
4461 deffile := oldfile ; defline := oldline ; alfathread := NIL ;
4462 new references ; IF references = NIL THEN heaperror ;
4463 WITH references^ DO
4464 BEGIN
4465 refnbr := 0 ; nextref := NIL ;
4466 END ;
4467 END * with RETPT * ;
4468 next := retpt ;
4469 END * NEW TYPE * ;
4470 $OPTIONS compile = trace $
4471 IF decltrace = high THEN
4472 BEGIN
4473 write mpcogout ' ON TYPE DEFINED AT ' ord retpt ' NAME AND NXTEL ARE '
4474 typid : 9 ord next ;
4475 nextline ;
4476 END ;
4477 $OPTIONS compile = true $
4478 * WAS THIS TYPE ALREADY *
4479 * IN PTLIST @TYPID *
4480 FOR i := ptx - 1 DOWNTO 0 DO
4481 WITH ptlist i DO
4482 IF hname = typid AND retpt <> NIL THEN
4483 IF retpt^.form = files THEN
4484 error 108 ELSE
4485 BEGIN
4486 pptr^.eltype := retpt ; ptx := ptx - 1 ; pptr^.domain := pptr ;
4487 * NOW FREES TOP OF ARRAY PTLIST *
4488 hname := ptlist ptx.hname ; pptr := ptlist ptx.pptr ;
4489 IF listyes THEN nameisref next rfil rlin ;
4490 END ; * WITHFOR *
4491 findsemicolon ; * SEARCH ; and READ NEXT SYMBOL *
4492
4493 END * while NO=1 * ;
4494 IF ptx > 0 THEN
4495 FOR j := ptx - 1 DOWNTO 0 DO
4496 WITH ptlist j DO
4497 BEGIN
4498 aval := hname ; search ;
4499 IF ctptr <> NIL THEN
4500 BEGIN
4501 IF ctptr^.klass = types THEN
4502 IF ctptr^.form = aliastype THEN ctptr := ctptr^.realtype ;
4503 WITH ctptr^ DO
4504 IF klass = types AND form <= records THEN
4505 BEGIN
4506 pptr^.eltype := ctptr ; ptx := ptx - 1 ; pptr^.domain := pptr ;
4507 hname := ptlist ptx.hname ; pptr := ptlist ptx.pptr ;
4508 END
4509 ELSE
4510 BEGIN
4511 error 96 ;
4512 nextline ;
4513 write mpcogout ' ****** ITEM POINTED BY TYPE ' pptr^.name ' IS OF ILLEGAL TYPE.' ;
4514 writeln mpcogerr ' ****** ITEM POINTED BY TYPE ' pptr^.name ' IS OF ILLEGAL TYPE.' ;
4515 nextline
4516 END
4517 END
4518 END ;
4519 IF ptx > 0 THEN
4520 BEGIN
4521 error 93 ;
4522 FOR j := ptx - 1 DOWNTO 0 DO
4523 BEGIN
4524 nextline ;
4525 write mpcogout ' ****** IDENTIFIER PENDING :' ptlist j.hname ;
4526 writeln mpcogerr ' ****** IDENTIFIER PENDING :' ptlist j.hname ;
4527 nextline ;
4528 END ;
4529 ptx := 0 ;
4530 END * PTX>0 * ;
4531 $OPTIONS compile = trace $
4532 IF decltrace = high THEN
4533 BEGIN
4534 write mpcogout ' ^ BODY.END TYPE PART ^^^' ; nextline ;
4535 END ;
4536 $OPTIONS compile = true $
4537 END * TYPEPARTDECL * ;
4538
4539 * ******************************** VARPARTDECL < BODY************************* *
4540
4541 PROCEDURE varpartdecl ;
4542
4543 * C .COMPILES ALL VARIABLES DECLARATION PART FOR A GIVEN LEVEL
4544 .CREATES 'VARS' BOXES
4545 ACTUAL EXPORTABLE or IMPORTED
4546 .ENTER FILES IN FILPTS
4547 C *
4548 * E ERRORS DETECTED
4549 2: IDENTIFIER EXPECTED
4550 7: ':' EXPECTED
4551 101 : Identifier declared twice
4552 258: TOO MANY FILES
4553 262: STARTING POINT FOR VARIABLE TOO BIG IN SEGMENT
4554 264: PLT DISP TOO HIGH
4555 E *
4556 LABEL
4557 10 ; * FIND SEMICOLON *
4558 VAR
4559 varsize : integer ;
4560 recvarsize : integer ;
4561 locdata : integer ;
4562 lextpt : ptexternalitem ;
4563 liactual liimport liexport : integer ;
4564 locerr : boolean ;
4565 lp vardeb varpoint vartype : ctp ;
4566 BEGIN * VARPARTDECL *
4567 $OPTIONS compile = trace $
4568 IF decltrace > none THEN
4569 BEGIN
4570 write mpcogout ' @@@ DEBUT VARPARTDECL @@@ with NEXT LC' ord next lc ; nextline ;
4571 END ;
4572 $OPTIONS compile = true $
4573 locdata := 0 ;
4574 insymbol ;
4575 WHILE no = 1 * ID. * DO * LOOP Ident_list: type ; Ident_list:type* *
4576 BEGIN
4577 liactual := 0 ; liexport := 0 ; liimport := 0 ;
4578 * Counters for actual exportable imported variables of same type *
4579 vardeb := next ;
4580 REPEAT * SECONDARY LOOP ON ABC... *
4581 locerr := false ;
4582 srchrec next ;
4583 IF ctptr <> NIL THEN
4584 BEGIN
4585 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
4586 error 101 ; locerr := true ;
4587 END ;
4588 create_vars_box lp aval ;
4589 WITH lp^ DO
4590 BEGIN
4591 vaddr := -1 ;
4592 lextpt := NIL ;
4593 IF level = 0 AND NOT locerr THEN
4594 BEGIN
4595 checkexternalitem aval lextpt ;
4596 IF lextpt = NIL THEN
4597 vkind := actual ELSE
4598 BEGIN
4599 IF symbolmap THEN
4600 BEGIN
4601 nameisref lp lextpt^.extrfile1 lextpt^.extrline1 ;
4602 IF lextpt^.extrline2 <> 0 THEN
4603 nameisref lp lextpt^.extrfile2 lextpt^.extrline2 ;
4604 END ;
4605 IF lextpt^.extitemtype = remanentfile THEN
4606 BEGIN
4607 vfilelocation := permanentfile ;
4608 lextpt^.extdecl := lp ;
4609 END ;
4610 vkind := lextpt^.extkind ;
4611 END ;
4612 END ELSE
4613 vkind := actual ;
4614 vptextitem := lextpt ;
4615 END ;
4616
4617 IF lp^.vkind = actual THEN liactual := liactual + 1 ELSE
4618 BEGIN
4619 lextpt^.extdecl := lp ;
4620 IF lp^.vkind = exportable THEN
4621 BEGIN
4622 liexport := liexport + 1 ;
4623 lextpt^.extitemtype := exportvar ;
4624 END ELSE
4625 BEGIN
4626 liimport := liimport + 1 ;
4627 lextpt^.extitemtype := importvar ;
4628 lp^.visset := true ;
4629 END ;
4630 END ;
4631 next := lp ;
4632 insymbol ; * EXPECT or : *
4633 IF no = 15 * * THEN
4634 BEGIN
4635 insymbol ;
4636 IF no <> 1 * ID. * THEN
4637 BEGIN
4638 error 2 ; skip 1 ;
4639 END ;
4640 END ELSE
4641 IF no <> 19 * : * THEN
4642 BEGIN
4643 error 7 ;
4644 END ;
4645 UNTIL no <> 1 ;
4646 varpoint := next ;
4647
4648 * NOW COMES TYPE FOR THESE VARIABLES *
4649
4650 IF no = 19 * : * THEN
4651 insymbol ELSE error 7 ;
4652 err := false ; cadre := 0 ; structispack := false ;
4653 typedecl varsize vartype ;
4654 IF err OR vartype = NIL THEN
4655 GOTO 10 ;
4656
4657
4658 * ADJUST SIZE FUNCTION OF CADRE *
4659 * A VARIABLE STARTS AT LESS ON A WORD BOUNDARY *
4660 cadre := sup vartype^.cadrage bytesinword ;
4661 recvarsize := recadre vartype^.size cadre ;
4662 * Adjust BOUNDARIES *
4663 IF liactual > 0 THEN
4664 BEGIN
4665 lc := recadre lc cadre + liactual * recvarsize ;
4666 locdata := lc ;
4667 END ;
4668 IF locdata - recvarsize > twoto17 - 1 THEN
4669 BEGIN
4670 error 260 ;
4671 recvarsize := bytesindword ;
4672 lc := 0 ;
4673 locdata := liactual * bytesindword ;
4674 END ;
4675
4676 IF varpoint <> vardeb THEN
4677 REPEAT
4678 WITH varpoint^ DO
4679 BEGIN
4680 vtype := vartype ;
4681 CASE vkind OF
4682 actual :
4683 BEGIN
4684 locdata := locdata - recvarsize ;
4685 vaddr := locdata ;
4686 END ;
4687 imported :
4688 BEGIN
4689 vptextitem^.extlong := vartype^.size ;
4690 END ;
4691 exportable :
4692 BEGIN
4693 vptextitem^.extlong := vartype^.size ;
4694 END ;
4695 END * case VKIND * ;
4696 IF existfileintype vtype THEN
4697 BEGIN
4698 IF filtop = fillimit THEN
4699 error 258 ELSE
4700 BEGIN
4701 filtop := filtop + 1 ;
4702 filpts filtop := varpoint ;
4703 IF level = 0 THEN
4704 BEGIN
4705 IF varpoint^.vfilelocation <> permanentfile THEN
4706 varpoint^.vfilelocation := workfile ;
4707 END ELSE
4708 varpoint^.vfilelocation := localfile ;
4709 END ;
4710 END ;
4711 $OPTIONS compile = trace $
4712 printrec varpoint ;
4713 $OPTIONS compile = true $
4714 varpoint := nxtel ;
4715 END * WITH VARPOINT * ;
4716 UNTIL varpoint = vardeb ;
4717 10 :
4718 findsemicolon ;
4719 END ; * while NO=1 MAIN LOOP *
4720 $OPTIONS compile = trace $
4721 IF decltrace > low THEN
4722 BEGIN
4723 write mpcogout ' @@@ FIN VARPARTDECL @@@ with LC' lc ; nextline ;
4724 END ;
4725 $OPTIONS compile = true $
4726 END * VARPARTDECL * ;
4727
4728
4729
4730
4731
4732 * ************************************************ MAIN de BODY ********** *
4733 BEGIN * BODY *
4734 $OPTIONS compile = trace $
4735 IF decltrace > none THEN
4736 BEGIN
4737 write mpcogout ' @@@ DEBUT BODY @@@' ; nextline ;
4738 END ;
4739 $OPTIONS compile = true $
4740 environt := data ; saved_level := level ;
4741 declarationpart := true ;
4742 fstix := clabix + 1 ;
4743 * LABELS DECLARED AT THIS LEVEL ARE FROM FSTIX to CLABIX *
4744
4745 currentnode^.nextproc := lastproc ;
4746 lastproc := currentnode ;
4747 currentnode ^.codebegin := statnbr * 2 ;
4748 IF level = 1 * Procedure globale * THEN
4749 IF surrptr <> NIL THEN
4750 exportablecode := exportscode ;
4751
4752
4753 1 : * BEGINNING OF DECLARATION PART *
4754 level := saved_level ; * FOR SECURITY IN CASE OF ERROR *
4755 $OPTIONS compile = trace $
4756 IF decltrace > low THEN
4757 BEGIN
4758 write mpcogout ' @@@ LABEL 1 IN BODY @@@' ; nextline ;
4759 END ;
4760 $OPTIONS compile = true $
4761
4762 push_lab_pdl ;
4763
4764 IF no = 52 * $IMPORT * THEN
4765 importpartdecl ;
4766
4767 IF no = 53 * $EXPORT * THEN
4768 exportpartdecl ;
4769
4770 IF no = 40 * LABEL * THEN
4771 labelpartdecl ;
4772
4773 IF no = 41 * CONST * THEN
4774 constpartdecl ;
4775
4776 pendingtypeallowed := true ;
4777 IF no = 37 * TYPE * THEN
4778 typepartdecl ;
4779 pendingtypeallowed := false ;
4780
4781 IF level <> 0 THEN
4782 filev level := filtop + 1 ;
4783
4784 * THE FILES DECLARED AT LEVEL N ARE IN ARRAY FILPTS FROM
4785 FILEVN to FILTOP . *
4786
4787 IF no = 43 * VAR * THEN
4788 varpartdecl ;
4789 IF level = 0 THEN
4790 BEGIN * GLOBAL LEVEL *
4791 workextp := externallistheader ;
4792 WHILE workextp <> NIL DO
4793 BEGIN
4794 IF workextp^.extdecl = NIL THEN
4795 IF workextp^.extitemtype IN extnotresolved remanentfile THEN
4796 exportscode := true ;
4797 workextp := workextp^.extnext ;
4798 END ;
4799 IF lc > maxglobsize THEN error 214 ELSE
4800 valuedecl ;
4801 END ELSE
4802 BEGIN * NOT GLOBAL LEVEL *
4803 IF no = 54 * VALUE * THEN
4804 BEGIN
4805 error 65 ;
4806 REPEAT
4807 skip 46 ; * NOT ASSIGNED *
4808 UNTIL no # 16 ; * ; *
4809 END ;
4810 END ;
4811 $OPTIONS compile = trace $
4812 IF decltrace = high THEN
4813 BEGIN
4814 write mpcogout ' @ BODY.END VAR PART @@@ ' ; nextline ;
4815 END ;
4816 $OPTIONS compile = true $
4817 IF no IN 44 45 * FUNCTIONPROCEDURE * THEN
4818 BEGIN
4819 REPEAT
4820 IF mapswitch THEN
4821 BEGIN
4822 hdrfile := symbolfile ;
4823 hdrindex := symbolindex ;
4824 hdrline := symbolline ;
4825 END ;
4826 lno := no ; oldlev := level ;
4827 lextpt := NIL ;
4828 IF level < maxlevel THEN
4829 level := level + 1 ELSE
4830 error 251 ;
4831 insymbol ;
4832 IF no # 1 THEN * NOT ID. *
4833 BEGIN
4834 error 2 ; level := oldlev ;
4835 GOTO 1 ; * BEGINNING OF BODY *
4836 END ;
4837 locerr := false ;
4838 srchrec next ;
4839 IF ctptr # NIL * ID. FOUND * THEN
4840 BEGIN
4841 IF ctptr@.klass # proc * FORWARDS ? * THEN
4842 BEGIN
4843 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
4844 error 101 ; ctptr := NIL ; locerr := true ;
4845 END ;
4846 END ;
4847 IF ctptr = NIL THEN * UNDECLARED PROC OR FUNCT. *
4848 BEGIN
4849 create_proc_box procptr aval ;
4850 WITH procptr^ DO
4851 BEGIN
4852 proctype := procptr ; * Default means not a fucntion *
4853 IF oldlev = 0 AND NOT locerr THEN
4854 BEGIN
4855 checkexternalitem aval lextpt ;
4856 IF lextpt = NIL THEN
4857 lprockind := actual ELSE
4858 BEGIN
4859 lprockind := lextpt^.extkind ;
4860 END ;
4861 END ELSE
4862 lprockind := actual ;
4863 IF lextpt <> NIL THEN
4864 BEGIN
4865 IF symbolmap THEN
4866 BEGIN
4867 nameisref procptr lextpt^.extrfile1 lextpt^.extrline1 ;
4868 IF lextpt^.extrline2 <> 0 THEN
4869 nameisref procptr lextpt^.extrfile2 lextpt^.extrline2 ;
4870 END ;
4871 lextpt^.extdecl := procptr ;
4872 IF lprockind = imported THEN
4873 WITH lextpt^ DO
4874 BEGIN
4875 pwantdescs := extwantdescs ;
4876 IF extgenerator = 'pl1' OR
4877 extgenerator = 'pl/i' OR
4878 extgenerator = 'pl/1' THEN extgenerator := 'PL/1'
4879 ELSE IF extgenerator = 'fortran' THEN extgenerator := 'FORTRAN'
4880 ELSE IF extgenerator = 'pascal' THEN extgenerator := 'Pascal'
4881 ELSE IF extgenerator = 'cobol' THEN extgenerator := 'COBOL'
4882 ELSE IF extgenerator = 'alm' THEN extgenerator := 'ALM'
4883 ELSE extgenerator := 'Unknown' ;
4884 pwantspl1descriptors :=
4885 extgenerator = 'PL/1' OR extgenerator = 'FORTRAN' OR extgenerator = 'COBOL' ;
4886 lextpt^.extitemtype := importproc END ELSE
4887 lextpt^.extitemtype := exportproc ;
4888 END ;
4889
4890 prockind := lprockind ;
4891 proclevel := oldlev ; * LEVEL -1 *
4892 procextitem := lextpt ;
4893 END ;
4894 * NOW BEGINS NEW LEVEL *
4895 display top.fname := procptr ;
4896 next := NIL ;
4897 insymbol ; * PARAMETER LIST BEGINS IF ANY *
4898 oldlc := lc ;
4899 lc := pascdebstacklocal ; longparam := 0 ;
4900 IF lno = 44 * FUNCTION * THEN
4901 BEGIN
4902 globnbpar := 1 ; * ONE FOR FUNCTION RESULT *
4903 IF no = 9 * * THEN
4904 BEGIN
4905 insymbol ; nestproc := 0 ; formparm ;
4906 IF no = 10 * * THEN
4907 insymbol ;
4908 END ;
4909 lc := lc + bytesindword ; * FUNCTION RESULT "ITS" *
4910 longparam := lc - pascdebstacklocal ;
4911 * TYPE OF FUNCTION *
4912 IF no = 19 * : * THEN
4913 insymbol ELSE error 7 ;
4914 * MUST BE A TYPE IDENTIFIER < POWER *
4915 IF no # 1 * ID * THEN
4916 BEGIN
4917 error 123 ; procptr@.proctype := NIL ; skip 46 ;
4918 END ELSE
4919 BEGIN
4920 search ;
4921 IF ctptr # NIL THEN
4922 BEGIN
4923 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
4924 IF ctptr@.klass # types THEN
4925 BEGIN error 103 ; ctptr := NIL ;
4926 END ELSE
4927 BEGIN
4928 IF ctptr@.form = aliastype THEN ctptr := ctptr@.realtype ;
4929 IF ctptr@.form >= power THEN
4930 BEGIN error 120 ; ctptr := NIL ;
4931 END ;
4932 END ;
4933 END ELSE error 104 ;
4934 procptr@.proctype := ctptr ;
4935 insymbol ;
4936 END * TYPID RESULT FUNCTION * ;
4937 END * LNO=44 FUNCTION * ELSE
4938 BEGIN * PROCEDURE *
4939 globnbpar := 0 ;
4940 IF no = 9 * * THEN
4941 BEGIN
4942 insymbol ; nestproc := 0 ; formparm ;
4943 longparam := lc - pascdebstacklocal ;
4944 IF no = 10 * * THEN
4945 insymbol ;
4946 END * NO=9 * ;
4947 END ; * PROCEDURE *
4948 procptr@.segsize := longparam ;
4949 hdrlength := symbolindex - hdrindex ;
4950 IF no = 16 * ; * THEN
4951 insymbol ELSE
4952 BEGIN
4953 error 14 ; skip 16 ; * ; *
4954 END ;
4955 procptr@.formals := next ; * NIL OR FIRST PARAM *
4956 typofproc := standdef ;
4957 procptr@.nbparproc := globnbpar ;
4958 procptr^.phasdescriptor := globdescriptors ;
4959 IF no = 1 * ID * THEN
4960 BEGIN
4961 IF aval = usednames 4 THEN
4962 BEGIN
4963 typofproc := forwdef ;
4964 WITH procptr@ DO
4965 BEGIN
4966 nameisref procptr deffile defline ;
4967 deffile := 0 ; defline := 0 ;
4968 END ;
4969 END ELSE
4970 IF aval = usednames 5 THEN
4971 typofproc := extdef ELSE
4972 BEGIN
4973 error 88 ; typofproc := extdef ;
4974 END ;
4975 next := procptr ;
4976 IF NOT typofproc IN standdef forwdef THEN
4977 IF procptr@.prockind # imported THEN
4978 BEGIN error 87 ; procptr@.prockind := imported ; END ;
4979 procptr@.procdef := typofproc ; procptr@.procinscope := false ;
4980 insymbol ;
4981 IF no <> 16 THEN
4982 BEGIN
4983 error 14 ; skip 16 ;
4984 END ;
4985 END ;
4986 WITH procptr@ DO
4987 BEGIN
4988 procaddr := lkc ;
4989 lkc := lkc + bytesindword ;
4990 IF pwantdescs THEN
4991 BEGIN
4992 lkc := lkc + bytesindword ; * PLACE FOR LINK TO INFO FOR TRAP PROC *
4993 oldlc := recadre oldlc bytesindword ;
4994 pdescsaddrplace := oldlc ; * PLACE FOR VECTOR OF PTRS TO ARG DESCRIPTORS *
4995 oldlc := oldlc + bytesindword * nbparproc ;
4996 IF extcalltrapplace = 0 THEN
4997 BEGIN
4998 extcalltrapplace := lkc ;
4999 lkc := lkc + bytesindword ;
5000 genentrypoint 0 extcalltrapplace 2 'pascal_ext_call_trap_proc_'
5001 'pascal_ext_call_trap_proc_' false entrylength locreturncode ;
5002 IF locreturncode <> 0 THEN error 505 ;
5003 END ;
5004 END ;
5005 END ;
5006 $OPTIONS compile = trace $
5007 printrec procptr ;
5008 $OPTIONS compile = true $
5009 IF procptr@.procdef = standdef THEN
5010 BEGIN
5011 * COMPILE BODY OF THIS PROC *
5012 top := level + 1 ;
5013 WITH display top DO
5014 BEGIN
5015 fname := next ; occur := block ;
5016 END ;
5017 create_dummyclass_box lfirstentry blank ;
5018 new np procblock ;
5019 WITH np^ DO
5020 BEGIN
5021 father := currentnode ;
5022 brother := currentnode^.son ;
5023 currentnode^.son := np ;
5024 son := NIL ;
5025 nextproc := NIL ;
5026 blockbox := procptr ;
5027 procptr^.procisactive := true ;
5028 codebegin := 0 ;
5029 codeend := 0 ;
5030 structureplace := 0 ;
5031 first := NIL ;
5032 firstlabel := NIL ;
5033 blocktp := procblock ;
5034 hdrlin := hdrline ;
5035 hdrfil := hdrfile ;
5036 hdrind := hdrindex ;
5037 hdrlen := hdrlength ;
5038 END ;
5039 currentnode := np ;
5040 * ***************************** *
5041 body procptr lfirstentry ;
5042 * ************************** *
5043 currentnode^.codeend := statnbr * 2 ;
5044 procptr^.procisactive := false ;
5045 currentnode := currentnode^.father ;
5046 END * COMPILE BODY OF A NEW PROC *
5047 END * THIS WAS A NEW PROC * ELSE
5048 BEGIN * ALREADY DECLARED *
5049 WITH ctptr@ DO
5050 IF procdef <> forwdef THEN
5051 BEGIN
5052 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
5053 error 101 ;
5054 END
5055 ELSE
5056 BEGIN
5057 IF lno = 45 * PROC * AND
5058 ctptr^.proctype <> ctptr OR
5059 lno = 44 AND ctptr^.proctype = ctptr THEN
5060 error 116 ;
5061 deffile := symbolfile ; defline := symbolline
5062 END ;
5063 insymbol ;
5064 IF no = 9 * * THEN * IGNORE PARMLIST *
5065 BEGIN
5066 error 119 ;
5067 REPEAT
5068 skip 10 ;
5069 IF no IN 16 40 37 41 43 44 45 THEN insymbol ;
5070 * ;LABEL CONST TYPE VAR FUNC PROC *
5071 UNTIL NOT no IN 1 16 40 37 41 43 44 45 ;
5072 IF no = 10 THEN
5073 insymbol ELSE error 4 ;
5074 hdrlength := symbolindex - hdrindex ;
5075 END * IGNORE PARMLIST * ;
5076 IF no = 15 * * THEN skip 16 ;
5077 IF no = 16 THEN
5078 insymbol ELSE error 14 ;
5079 IF no = 1 THEN
5080 BEGIN insymbol ; error 88 ; findsemicolon ; END ELSE
5081 BEGIN * COMPILE BODY OF AN OLD DEFINED PROC *
5082 procptr := ctptr ;
5083 WITH procptr@ DO
5084 BEGIN
5085 lc := segsize ; procdef := standdef ; * NO MORE FORWARD *
5086 lc := lc + pascdebstacklocal ; procinscope := true ;
5087 next := formals ;
5088 END ;
5089 top := level + 1 ;
5090 WITH display top DO
5091 BEGIN
5092 fname := next ; occur := block ;
5093 END ;
5094 $OPTIONS compile = trace $
5095 printrec procptr ;
5096 $OPTIONS compile = true $
5097 create_dummyclass_box lfirstentry blank ;
5098 new np procblock ;
5099 WITH np^ DO
5100 BEGIN
5101 father := currentnode ;
5102 brother := currentnode^.son ;
5103 currentnode^.son := np ;
5104 son := NIL ;
5105 nextproc := NIL ;
5106 blockbox := procptr ;
5107 procptr^.procisactive := true ;
5108 codebegin := 0 ;
5109 codeend := 0 ;
5110 structureplace := 0 ;
5111 first := NIL ;
5112 firstlabel := NIL ;
5113 blocktp := procblock ;
5114 hdrlin := hdrline ;
5115 hdrfil := hdrfile ;
5116 hdrind := hdrindex ;
5117 hdrlen := hdrlength ;
5118 END ;
5119 currentnode := np ;
5120 * **************************** *
5121 body procptr lfirstentry ;
5122 * ************************ *
5123 currentnode^.codeend := statnbr * 2 ;
5124 procptr^.procisactive := false ;
5125 currentnode := currentnode^.father ;
5126 END * BODY OF AN OLD PROC * ;
5127 END * ALREADY DECLARED * ;
5128 lc := oldlc ;
5129 level := oldlev ;
5130 findsemicolon ;
5131 UNTIL NOT no IN 44 45 ; * FUNCT PROC *
5132 $OPTIONS compile = trace $
5133 IF decltrace = high THEN
5134 BEGIN
5135 write mpcogout ' @ BODY.END PROC/FUNCPART @@@' ; nextline ;
5136 END ;
5137 $OPTIONS compile = true $
5138 END * FUNCTION OR PROCEDURE * ;
5139 display top.fname := next ;
5140 IF level = 0 THEN
5141 staticswordcount := lc + bytesinword - 1 DIV bytesinword ;
5142
5143 IF NOT no = 21 THEN
5144 BEGIN * BEGIN EXPECTED AND NOT FOUND *
5145 error 17 ; skip 46 ;
5146 WHILE no IN 16 22 DO * ; END *
5147 BEGIN
5148 insymbol ; skip 46 ;
5149 END ;
5150 IF no IN 37 40 41 43 44 45 THEN GOTO 1 * BODY BEGINNING *
5151 END * BEGIN NOT FOUND * ;
5152 * STATEMENT PART *
5153 declarationpart := false ;
5154 enterbody ;
5155 compstat ;
5156 leavebody ;
5157 declarationpart := true ;
5158 currentnode^.first := display top.fname ;
5159 IF surrptr # NIL THEN
5160 BEGIN
5161 surrptr@.segsize := lc ;
5162 create_dummyclass_box lp blank ;
5163 IF lp > maxctp THEN maxctp := lp ;
5164 firstentry := NIL ;
5165 top := level ;
5166 next := display top.fname ;
5167 END * NOT NIL * ;
5168
5169 pop_lab_pdl ;
5170
5171 $OPTIONS compile = trace $
5172 IF decltrace > low THEN
5173 BEGIN
5174 write mpcogout ' @@@ END BODY @@@' ; nextline ;
5175 END ;
5176 $OPTIONS compile = true $
5177 END * BODY * ;
5178
5179 * END OF THE DECLARE MODULE ********************************************** * BEGIN
5180 END.