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 * ******************************************************************************************
19 * *
20 * MULTICS PASCAL COMPILER *
21 * _________________________ *
22 * *
23 * This compiler is the result of a team work . *
24 * Three people Jean.Michel Athane C.I.C.G Jean.Pierre Fauche CRISS-IREP *
25 * Bernard Huc C.S.L./C.T.G. *
26 * during one yearsome nights and week-ends ... worked together for this *
27 * result. If you are not happy with this compileryou can must see one of these *
28 * three people. For this reason their addresses are not given here. *
29 * We hope anyway you don't have any trouble with this finesophisticated compiler. *
30 * *
31 * Some of data structures used in some places are derived from the original CDC compiler *
32 * issued in Zurich in 1972 by N. Wirth and his team. *
33 * The experience of CRISS on Pascal compilers is also included here as well as the ideas *
34 * taken judiciously chosen in the SFER Pascal compiler. *
35 * It is obvious that the authors have developped here their personal ideas. *
36 * Sorry for this.... *
37 * *
38 * at GRENOBLE FRANCE on August28th 1980. *
39 * sincerely yours *
40 * the authors *
41 * *
42 ****************************************************************************************** *
43 $OPTIONS page $
44
45 $OPTIONS switch trace := true ; switch security := true ; t - $
46 PROGRAM racine mpcogerr mpcogin mpcogout ;
47 $IMPORT
48 * LIST OF IMPORTED PROCEDURES *
49 'UNIQUE pascal' :
50 displaysymbols,
51 heaperror,
52 initclasse,
53 initialise,
54 progdecl,
55 prterrmeans,
56 statistiques ;
57 'DECLARE pascal' :
58 body ;
59 'CONTEXTTABLE pascal' :
60 create_dummyclass_box,
61 create_vars_box ;
62 'STATE pascal' :
63 freeallregisters ;
64 'EXPR pascal' :
65 expression ;
66 'MODATTR pascal' :
67 initattrvarbl ;
68 'GENERE pascal' :
69 genlongprofileref,
70 genprofileref,
71 inser ;
72 'optimized_procedures alm' :
73 search,
74 srchrec ;
75 'pascal pl1' :
76 listhead ;
77 * LIST OF IMPORTED VARIABLES *
78 'STATE pascal' :
79 asscheck,
80 divcheck,
81 errorctp,
82 gattr,
83 inputctp,
84 inxcheck,
85 outputctp,
86 stattrace ;
87 'DECLARE pascal' :
88 building_from_schema,
89 decltrace,
90 externallistheader,
91 filpts,
92 filtop,
93 forbidden_id_list,
94 hdrfile,
95 hdrindex,
96 hdrlength,
97 hdrline,
98 lc,
99 lkc,
100 symbtabl ;
101 'GENERE pascal' :
102 fichinter,
103 genetrace,
104 ic,
105 illegal_generation,
106 outcode,
107 writecode ;
108 * FROM PL/1 *
109 'pascal_build_object$pascal_build_object pl1' : buildobject ;
110 'pascal_sources_management_$init_source pl1' : initsource ;
111 'pascal_sources_management_$begin_source pl1' : beginsource ;
112 'pascal_sources_management_$end_source pl1' : endsource ;
113 'pascal_sources_management_$display_sources pl1' : displaysources ;
114 'pascal_statement_map_$return_map_ptr pl1' : getmapptr ;
115 'pascal_statement_map_$return_prof_ptr pl1' : getprofptr ;
116 'pascal_convert_real$pascal_convert_real pl1' : convertreal ;
117 'pascal_gen_io_ref_ pl1' : geninput, genoutput, genentree, gensortie, generror, generreur
118 $
119
120 $EXPORT
121
122 alfaptr,
123 anytrace,
124 aval,
125 boolptr,
126 boxheader,
127 bufval,
128 ch8flag,
129 charptr,
130 chnix,
131 cl,
132 codelist,
133 conint,
134 conreel,
135 crealfabox,
136 ctptr,
137 currentnode,
138 declarationpart,
139 display,
140 disx,
141 environt,
142 envstandard,
143 errcl,
144 error,
145 errorflag,
146 errorsfound,
147 errtotal,
148 exportablecode,
149 extcalltrapplace,
150 check_id,
151 fastoperator,
152 firstcond,
153 forbidden_id,
154 init_fsb_trap_flag,
155 init_fsb_trap_info_place,
156 init_fsb_trap_links_place,
157 init_fsb_trap_number_of_files,
158 generrorlink,
159 geninputlink,
160 genoutputlink,
161 inconst,
162 initracine,
163 inputflag,
164 inserundlab,
165 insymbol,
166 interactive,
167 intptr,
168 iowarnings,
169 ival,
170 lamptr,
171 lastproc,
172 level,
173 liglues,
174 linkswordcount,
175 listyes,
176 longchaine,
177 longprofile,
178 longstring,
179 majmin,
180 mapswitch,
181 maxstring_ptr,
182 mpcogerr,
183 mpcogin,
184 mpcogout,
185 nameisref,
186 next,
187 nextline,
188 nextpage,
189 nilptr,
190 no,
191 no_compilation_warnings,
192 outputflag,
193 pageserrors,
194 pascalfrench,
195 pnumptr,
196 poweroftwo,
197 profilewordcount,
198 profptr,
199 progname,
200 programnode,
201 realptr,
202 recadre,
203 returnstop,
204 rval,
205 selectivetable,
206 skip,
207 skipextd,
208 skiptochapter,
209 sourceindex,
210 sourcenbr,
211 startic,
212 statement_begins,
213 statement_ends,
214 staticswordcount,
215 statnbr,
216 string_ptr,
217 sttfile,
218 sttindex,
219 sttline,
220 sup,
221 symbolfile,
222 symbolindex,
223 symbolline,
224 symbolmap,
225 textfilectp,
226 top,
227 undecptr,
228 undlab,
229 usednames,
230 version,
231 warning,
232 xc,
233 xrefneed $
234
235
236
237 LABEL 100 ; * END OF THE COMPILATION *
238
239
240
241
242
243 $OPTIONS page $
244
245 $INCLUDE 'CONSTTYPE' $
246
247
248
249 $OPTIONS page $
250
251 VAR
252 * REDEFINE IMPORTED VARIABLES *
253 * FROM STATE *
254 asscheck : boolean ;
255 divcheck : boolean ;
256 errorctp : ctp ;
257 gattr : attr ;
258 inputctp : ctp ;
259 inxcheck : boolean ;
260 outputctp : ctp ;
261 stattrace : levtrace ;
262 * FROM DECLARE *
263 building_from_schema : schema_status ;
264 decltrace : levtrace ;
265 externallistheader : ptexternalitem ;
266 forbidden_id_list : alfalistptr ;
267 hdrfile : integer ;
268 hdrindex : integer ;
269 hdrlength : integer ;
270 hdrline : integer ;
271 filpts : ARRAY 0..fillimit OF ctp ;
272 filtop : integer ;
273 lc : integer ;
274 lkc : integer ;
275 symbtabl : boolean ;
276 * FROM GENERE *
277 fichinter : ^binartype ;
278 genetrace : levtrace ;
279 ic : integer ;
280 illegal_generation : boolean ;
281 outcode : boolean ;
282 writecode : boolean ;
283
284 * DEFINE EXPORTABLE VARIABLES *
285 alfaptr : ctp ; * CHAR'S STRINGS TYPE POINTER *
286 anytrace : levtrace ;
287 aval : alfaid ; * OUTPUT OF INSYM BOL *
288 boolptr : ctp ; * BOOLEAN TYPE POINTER *
289 boxheader : PACKED ARRAY 1..120 OF char ; * USED TO PRINT *
290 * BOXES IN TRACE ENVIRONEMENT *
291 bufval : ARRAY 1..maxval OF char ; * OUTPUT OF INSYMBOL *
292 ch8flag : boolean ;
293 check_id : boolean ;
294 charptr : ctp ; * CHAR TYPE POINTER *
295 chnix : integer ; * POINTS THE HEAD OF *
296 * FREE LIST IN UNDLAB *
297 cl : integer ; * OUTPUT OF INSYMBOL *
298 codelist : boolean ; * TRUE IF "-list" OPTION *
299 conint : integer ; * OUTPUT OF INSYMBOL *
300 conreel : real ; * " " " *
301 ctptr : ctp ; * OUTPUT OF SRCHREC AND SEARCH *
302 currentnode : blocknodeptr ; * PTR TO CURRENT PROC NODE *
303 declarationpart : boolean ;
304 display : ARRAY 0..displimit OF recidscope ;
305
306 * EACH ENTRY 0..TOP IS THE BEGINNING OF A LIST OF
307 IDENTIFIERS IN CONTEXTTABLE.
308 EACH LIST CORRESPONDS
309 EITHER AT A LEVEL PROC NESTED
310 EITHER AT A SCOPE DUE TO A WITH
311 THE ORDER OF SCANNING GIVES THE PASCAL SCOPE *
312 disx : integer ; * FIRST FREE ENTRY IN DISPLAY *
313 * TO DECIDE BETWEEN DIGIT.. *
314 * OR DIGIT.DIGIT IN INSYMBOL *
315 environt : contexte ;
316 * DATA CODE AND SO ON.. *
317 envstandard : stdkind ;
318 errcl : ARRAY norange OF typofsymb ;
319 * ERROR RECOVERY IN PASCAL PROGRAM *
320 * NOT IN TYPE PART *
321 errorflag : ptexternalitem ;
322 errorsfound : ARRAY 0..maxerpg OF SET OF 0..maxset ;
323 * SUMMARY OF ENCOUNTERED ERRORS *
324 * DURING THETOTAL COMPILATION *
325 errtotal : integer ;
326 * GIVES TOTAL NUMBER OF *
327 * ENCOUNTERED ERRORS *
328 exportablecode : boolean ;
329 extcalltrapplace : integer ; * IF NON NULL BYTE DISP IN LINK OF LINK TO EXT CALL TRAP PROC *
330 fastoperator : boolean ; * INIT IN CARTEEXEC. *
331 * FORCES FAST OPERATORS TO BE CALLED *
332 * USED IN GENERE *
333 firstcond : condaddr ; * PRT TO FIRST CONDITIONNAL VARIABLE BOX *
334 forbidden_id : alfaid ; * IDENTIFIER FORBIDDEN IF CHECK_ID IS TRUE *
335 init_fsb_trap_flag : boolean ; * TRUE IF FSB INITIALIZED BY F.REF. TRAP *
336 init_fsb_trap_info_place, * BYTE DISP IN TEXT OF OINFO FOR THIS TRAP *
337 init_fsb_trap_links_place, * BYTE DISP IN LINK OF LINKS FOR THIS TRAP *
338 init_fsb_trap_number_of_files : integer ; * NBR OF FILES INIT. BY THIS TRAP *
339 inputflag : ptexternalitem ; * #0 IF INPUT IS IN PRG. PARAM. *
340 interactive : boolean ; * TRUE IF INTERACTIVE MODE *
341 intptr : ctp ; * INTEGER TYPE POINTER *
342 iowarnings : boolean ; * TRUE IF IO WARNINGS WANTED DEFAULT *
343 ival : integer ; * OUTPUT OF INSYMBOL *
344 lamptr : ctp ; * POINTS EMPTY SET TYPE *
345 lastproc : blocknodeptr ; * PTR TO NODE FOR LAST GENERATED PROC *
346 level : levrange ;
347 liglues : integer ; * TOTAL READ LINES COUNTER *
348
349 linkswordcount : integer ; * WORD COUNT FOR LINKS GENERATION *
350 listyes : boolean ; * TRUE IF LISTING REQUE STED *
351 longchaine : integer ; * LGTH USED IN BUFVAL *
352 longprofile : boolean ; * TRUE IF LONG_PROFILE OPTION *
353 longstring : integer ; * LENGTH OF STRING IN CONALFA *
354 majmin : ARRAY 0..127 OF integer ;
355 mapswitch : boolean ; * TRUE IF STATEMEMNT MAP NEEDED *
356 maxstring_ptr : ctp ; * PTR TO MAXSTRING PREDEFINED CONSTANT *
357 mpcogerr, mpcogin, mpcogout : text ;
358 next : ctp ; * LAST ITEM IN CONTTEXTTABLE *
359 * NOT ALLWAYS *
360 nilptr : ctp ; * NIL POINTER TYPE POINTER *
361 no : integer ; * OUTPUT OF IN SYMBOL *
362 no_compilation_warnings : boolean ;
363 outputflag : ptexternalitem ; * #0 IF OUTPUT IS IN PRG. PARAM. *
364 pageserrors : ARRAY 0..maxerpg OF SET OF 0..maxset ; * TO KEEP PAGES *
365 pascalfrench : boolean ;
366 pnumptr : ctp ; * NUM. SET TYPE POINTER * * WHERE ARE ERRS *
367 profilewordcount : integer ; * TOTAL PROFILE COUNTERS WORD COUNT *
368 profptr : profareaptr ; * PTR TO PROFILE COUNTERS GENERATION AREA *
369 progname : alfaid ; * NAME OF PRG.; FILLED IN PROGDECL *
370 programnode : blocknodeptr ; * PTR TO FIRST NODE OF PROGRAM *
371 realptr : ctp ; * REAL TYPE POINTER *
372 rval : real ; * OUTPUT OF INSYMBOL *
373 selectivetable : boolean ; * TRUE IF SOME SYMBOL TABLES REQUIRED *
374 sourceindex : integer ; * INDEX IN SOURCE STRING *
375 sourcenbr : integer ; * CURRENT SOURCE NO *
376 startic : integer ; * INDEX OF FIRST NON PROFILE INSTR OF CURR STTMT *
377 staticswordcount : integer ; * TOTAL STATICS WORD COUNT *
378 statnbr : integer ; * TOTAL NBR OF STATEMENTS IN STT MAP *
379 string_ptr : ctp ; * PTR TO STANDARD STRING FORMAT *
380 sttfile : integer ; * FILE NO OF CURR STTMT *
381 sttindex : integer ; * INDEX IN SOURCE OF CURR STTMT *
382 sttline : integer ; * LINE NO OF CURR STTMT *
383 sttplace : integer ; * LOC FOR CURRENT STATEMENT *
384 symbolfile : integer ; * SOURCE FILE OF CURRENT SYMBOL *
385 symbolindex : integer ; * INDEX IN SOURCE OF CURR SYMBOL *
386 symbolline : integer ; * SOURCE LINE OF CURRENT SYMBOL *
387 symbolmap : boolean ; * TRUE IF SYMBOLS MAP REQUESTED *
388 textfilectp : ctp ; * TEXT FILE TYPE POINTER *
389 top : integer ; * LAST USED ENTRY IN DISPLAY *
390 undecptr : ctp ; * FOR UNDEFINED VARS *
391 undlab : ARRAY 1..undmax OF occurence ;
392 * USED TO KEEP SEVERAL LISTS *
393 * OF UNRESOLVED REFERENCES *
394 usednames : typusednames ;
395 version : integer ; * CURRENT RELEASE OF THE COMPILER *
396 xc : integer ; * COUNTER FOR GLOBALS *
397 xrefneed : boolean ; * TRUE IF CROSS REFERENCES USED *
398
399 * DEFINE INTERNALLY USED VARIABLES *
400 adrligic : integer ;
401 adrliglc : integer ;
402 * USED IN ORDER TO PRINT COUNTERS *
403 * AT BEGINNING OF EACH LINE *
404 beginline : boolean ; * TRUE IF READING BEGINNING OF SOURCE LINE *
405 brieftable : boolean ; * TRUE IF BRIEF TABLE NEEDED *
406 bufold, bufnew : PACKED ARRAY 1..maxsliceline OF char ;
407 ch : char ; * OUTPUT OF NEXTCH INPUT OF INSYMBOL *
408 chcnt : integer ; * COLUMN NUMBER IN A SOURCE LINE *
409 checks : boolean ; * INIT IN CARTEEXEC OR IN MAIN *
410 column : integer ; * CURRENT COLUMN IN SOURCE LINE *
411 compencours : boolean ;
412 currdate : alfa ; * CURRENT DATE DD**MM**YY *
413 cursttmap : sttmapptr ; * PTR TO CURRENT STT MAP STRUCTURE *
414 digits : SET OF char ; * 0..9 *
415 dpoint : boolean ;
416 end_statement : boolean ; * TRUE IF STTMAP HAS BEEN GENERATED FOR CURR STT *
417 erredited : ARRAY 0..maxerpg OF SET OF 0..maxset ;
418 errinx : integer ;
419 errlist : ARRAY 1..maxerrline OF
420 RECORD
421 pos, nmr : integer ; * TO KEEP ERR NUMBERS AND POSITIONS *
422 END ;
423 err257 : boolean ;
424 * FLAG FOR A LINE TOO LONG *
425 err149 : boolean ; * FLAG *
426 filetoprint : integer ; * FILE NBR TO PRINT AT THE BEGINNING OF A SOURCE LINE *
427 iligne : integer ; * COUNTER OF LINES ON A PAGE *
428 instring : boolean ; * TRUE IF IN A STRING *
429 * IN INSYMBOL AND NEXTCH *
430 incomment : boolean ; * TRUE IF IN A COMMENT *
431 lastfile : integer ; * FILE OF LAST EDITED LINE ON ERROR FILE *
432 lastlig : integer ; * LAST EDITED LINE ON ERROR FILE *
433 letters : SET OF char ;
434 linetoprint : integer ; * LINE NBR TO PRINT AT THE BEGINNING OF A SOURCE LINE *
435 longpad : integer ; * '' " IN BUFVAL *
436 mapptr : sttmapptr ; * PTR TO STATEMENT MAP GENERATION AREA *
437 nbccond : integer ; * NESTED CONDITIONAL COMP *
438 oldfile : integer ; * FILE OF PREVIOUS STATEMENT *
439 oldic : integer ; * IC OF PREVIOUS STATEMENT *
440 oldindex : integer ; * INDEX OF OLD STATEMENT MAP *
441 oldline : integer ; * LINE OF PREVIOUS STATEMENT *
442 pagelength : integer ; * INIT BY MAXPAGELINE OR CARTEEXEC *
443 pageno : integer ; * NUMBER OF CURRENT PAGE *
444 pos1 : integer ; * LAST ERROR'S POSITION IN LINE *
445 prevfile : integer ; * FILE OF PREVIOUS LINE *
446 prevlig : integer ; * LIEN NO OF PREVIOUS LINE *
447 profile : boolean ; * TRUE IF PROFILE OPTION *
448 pt : ctp ; * WORK POINTER *
449 skipcode : boolean ; * IF TRUE THEN DONT COMPILE SOURCE *
450 skippage : boolean ; * TRUE ALTER $PAGE *
451
452 sourcectx : char ; * '*' if line begins in a comment ' 'otherwise *
453 sttinline : integer ; * NBR OF STATEMENT IN LINE *
454 symbline : PACKED ARRAY 0..maxlinepascal OF char ; * CHARS OF A SOURCE LINE *
455 symbol_listing : boolean ; * TRUE IF CROSS REFERENCE OF SYMBOLS ON LISTING *
456 symcl : ARRAY 0..127 OF integer ; * CL FOR EACH PASCAL 0..127 *
457 symno : ARRAY 0..127 OF integer ; * NO " " " " *
458 rversion : integer ; * VERSION OF RACINE *
459 tsetinargs : boolean ; * TRUE IF T OPTION SET AT COMMAND LEVEL *
460 usednamesa,
461 usednamesf : typusednames ;
462 wcl,
463 wcla,
464 wclf : ARRAY 0..maxnbofkeywords OF integer ;
465 wd,
466 wda,
467 wdf : ARRAY 0..maxnbofkeywords OF alfaid ;
468 wkextpt : ptexternalitem ;
469 wl1,
470 wl1a,
471 wl1f : ARRAY 1..maxkeylength OF integer ;
472 wl2,
473 wl2a,
474 wl2f : ARRAY 1..maxkeylength OF integer ;
475 wno,
476 wnoa,
477 wnof : ARRAY 0..maxnbofkeywords OF integer ;
478 wnoset : setofno ;
479 wdsetinargs : boolean ; * TRUE IF WD OPTION SET AT COMMAND LEVEL *
480 wgsetinargs : boolean ; * TRUE IF WG OPTION SET AT COMMAND LEVEL *
481 wssetinargs : boolean ; * TRUE IF WS OPTION SET AT COMMAND LEVEL *
482
483 * KEY-WORD XXX IS IN WD AT ENTRY "N" OF LENGTH I
484 WNONWCLN ARE ASSOCIATED NO AND CL
485 ALL KEY WORDS OF LENGTH I ARE IN WD BETWEEN ENTRIES
486 WL1I .. WL2I
487 *
488
489
490 $OPTIONS page $
491
492 $VALUE
493 errcl = 16 * irrelsy
494 endsy * 16 ; *
495 4 * irrelsy
496 begsy * 21 BEGIN *
497 endsy * 22 END *
498 begsy * 23 IF *
499 irrelsy * THEN *
500 endsy * 25 ELSE *
501 begsy * 26 CASE *
502 irrelsy * OF *
503 begsy * 28 REPEAT *
504 endsy * 29 until *
505 begsy * 30 WHILE *
506 irrelsy * DO *
507 begsy * 32 FOR *
508 2 * irrelsy * TO DOWNTO *
509 begsy * 35 GOTO *
510 irrelsy * 36 nil *
511 endsy * 37 TYPE *
512 irrelsy * 38 array record file set *
513 irrelsy * 39 .. *
514 2 * endsy * 40 LABEL 41 CONST *
515 irrelsy * PACKED *
516 3 * endsy * 43 VAR 44 FUNCTION 45 PROCEDURE *
517 2 * irrelsy
518 begsy * 48 WITH *
519 irrelsy
520 endsy * 50 PROGRAM *
521 7 * endsy * 51 $RENAME 52 $IMPORT 53 $EXPORT 54 $VALUE 55 $ * ;
522 majmin = 0 1 2 3 4 5 6 7 8 32 * SPACE * 10 11 12 13 14 15
523 16 17 18 19 20 21 22 23 24 25
524 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
525 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
526 * MAJ TO MIN *
527 97 98 99 100 101 102 103 104 105 106
528 107 108 109 110 111 112 113 114 115 116 117
529 118 119 120 121 122
530 * now same order *
531 91 92 93 94 95 96 97 98 99 100 101 102
532 103 104 105 106 107 108 109 110 111 112
533 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 ;
534 symcl = 35 * 0 5 6 * 0 1 1 0 2 0 2 12 * 0 1 6 4 65 * 0 ;
535 symno = 35 * 0 8 4 * 0 9 10 6 7 15 7 17 6 10 * 0
536 19 16 3 * 8 0 18 26 * 0 11 0 12 18
537 33 * 0 ;
538 usednamesa = 'input' 'output' 'error' 'forward' 'external' 'otherwise'
539 ;
540 usednamesf = 'entree' 'sortie' 'erreur' 'plusloin' 'externe' 'autrement'
541 ;
542 wcla = 0
543 0 0 1 0 7 3
544 0 0 0 4 5 0
545 3 1 4
546 0 0 0 0 0 0
547 3
548 0 0 0 1
549 0 0
550 0 2 2 0 0
551 0 0 0 0
552 0 0 0
553 0 ;
554 wclf =
555 0
556 0 3 3 0
557 2 0 4 0 5 0 1 0
558 0 7 1 0 0
559 0 0 0 0 0
560 0 0 0
561 2 3 0 1 0 0 0
562 4 0 0 0 0 0
563 0 0 0
564 ;
565 wda = '$ '
566 'if ' 'do ' 'to ' 'of ' 'in ' 'or '
567 'end ' 'nil ' 'for ' 'div ' 'mod ' 'var '
568 'and ' 'not ' 'set '
569 'then ' 'else ' 'goto ' 'case ' 'with ' 'type '
570 'file '
571 'begin ' 'until ' 'while ' 'array '
572 'const ' 'label '
573 'repeat ' 'downto ' 'record ' 'packed ' '$value '
574 'program ' '$rename ' '$import ' '$export'
575 'function' '$include' '$options'
576 'procedure' ;
577 wdf =
578 '$ '
579 'de' 'et' 'ou' 'si'
580 'bas' 'cas' 'div' 'fin' 'mod' 'nil' 'non' 'var'
581 'avec' 'dans' 'haut' 'pour' 'type'
582 'alors' 'const' 'debut' 'faire' 'sinon'
583 'allera' 'jusque' 'paquet'
584 'article' 'fichier' 'repeter' 'tableau' 'tantque' '$valeur' '$rename'
585 'ensemble' 'fonction' '$exporte' '$importe' '$include' '$options'
586 'etiquette' 'procedure' 'programme'
587 ;
588 wl1a = 0 1 7 16 23 29 34 38 41 ;
589 wl1f = 0 1 5 13 18 23 26 33 39 ;
590 wl2a = 0 6 15 22 28 33 37 40 41 ;
591 wl2f = 0 4 12 17 22 25 32 38 41 ;
592 wnoa = 55
593 23 31 33 27 8 7
594 22 36 32 6 6 43
595 6 5 38
596 24 25 35 26 48 37
597 38
598 21 29 30 38
599 41 40
600 28 33 38 42 54
601 50 51 52 53
602 44 56 57
603 45 ;
604 wnof =
605 55
606 27 6 7 23
607 33 26 6 22 6 36 5 43
608 48 8 33 32 37
609 24 41 21 31 25
610 35 29 42
611 38 38 28 38 30 54 51
612 38 44 53 52 56 57
613 40 45 50
614 $
615
616
617 $OPTIONS page $
618
619 * IMPORTED FROM "UNIQUE" *
620 PROCEDURE initialise ; EXTERNAL ;
621 PROCEDURE progdecl ; EXTERNAL ;
622 PROCEDURE initclasse ; EXTERNAL ;
623 PROCEDURE heaperror ; EXTERNAL ;
624 PROCEDURE prterrmeans VAR ff : text ; numerr : integer ; EXTERNAL ;
625 PROCEDURE statistiques ; EXTERNAL ;
626 PROCEDURE displaysymbols ; EXTERNAL ;
627
628 * IMPORTED FROM "DECLARE" *
629 PROCEDURE body surrptr firstentry : ctp ; EXTERNAL ;
630
631 * IMPORTED FROM CONTEXTTABLE *
632
633 PROCEDURE create_vars_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
634 PROCEDURE create_dummyclass_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
635
636
637 * IMPORTED FORM "GENERE" *
638 PROCEDURE genprofileref ; EXTERNAL ;
639 PROCEDURE genlongprofileref ; EXTERNAL ;
640 PROCEDURE inser fcb fplace : integer ; EXTERNAL ;
641 PROCEDURE listhead ; EXTERNAL ;
642
643
644 * IMPORTED FROM STATE *
645 PROCEDURE freeallregisters ; EXTERNAL ;
646
647 * IMPORTED FROM EXPR *
648 PROCEDURE expression ; EXTERNAL ;
649
650 * IMPORTED FROM MODATTR *
651 PROCEDURE initattrvarbl VAR fattr : attr ; EXTERNAL ;
652
653 * IMPORTED FROM PL1 *
654
655 PROCEDURE buildobject ; EXTERNAL ;
656 PROCEDURE initsource ; EXTERNAL ;
657 PROCEDURE beginsource
658 filename : externid ; stringdeb : alfaid ; ldeb : integer ; stringfin : alfaid ; lfin : integer ; EXTERNAL ;
659 PROCEDURE endsource ; EXTERNAL ;
660 PROCEDURE displaysources ; EXTERNAL ;
661 * FROM PL1 *
662 PROCEDURE geninput pr4disp : integer ; VAR fret : integer ; EXTERNAL ;
663 PROCEDURE genoutput pr4disp : integer ; VAR fret : integer ; EXTERNAL ;
664 PROCEDURE generror pr4disp : integer ; VAR fret : integer ; EXTERNAL ;
665 PROCEDURE genentree pr4disp : integer ; VAR fret : integer ; EXTERNAL ;
666 PROCEDURE gensortie pr4disp : integer ; VAR fret : integer ; EXTERNAL ;
667 PROCEDURE generreur pr4disp : integer ; VAR fret : integer ; EXTERNAL ;
668
669 PROCEDURE getmapptr VAR mapptr : sttmapptr ; EXTERNAL ;
670 PROCEDURE getprofptr VAR profptr : profareaptr ; EXTERNAL ;
671 PROCEDURE convertreal string : numberstring ; exp : integer ; VAR reel : real ; EXTERNAL ;
672
673
674 PROCEDURE geninputlink pr4disp : integer ; VAR fret : integer ;
675
676 BEGIN
677 IF pascalfrench THEN
678 genentree pr4disp fret ELSE
679 geninput pr4disp fret ;
680 END ;
681
682
683 PROCEDURE genoutputlink pr4disp : integer ; VAR fret : integer ;
684
685 BEGIN
686 IF pascalfrench THEN
687 gensortie pr4disp fret ELSE
688 genoutput pr4disp fret ;
689 END ;
690
691
692 PROCEDURE generrorlink pr4disp : integer ; VAR fret : integer ;
693
694 BEGIN
695 IF pascalfrench THEN
696 generreur pr4disp fret ELSE
697 generror pr4disp fret ;
698 END ;
699
700
701 * ********************************************************** NEXTPAGE ******* *
702
703 PROCEDURE nextpage ; FORWARD ;
704
705
706 $OPTIONS page $
707
708 * ************************************* INITRACINE *********************** *
709
710 PROCEDURE initracine ;
711
712 * C THIS PROCEDURE IS USED TO INITIALIZE THE GLOBALS OF RACINE AND IS
713 CALLED IN THE MODULE UNIQUE PROCEDURE INITILALISE C *
714 VAR
715 it : integer ;
716 BEGIN * INITRACINE *
717 adrligic := 0 ; adrliglc := 0 ;
718 anytrace := none ;
719 beginline := false ;
720 bufold := ' ' ; bufnew := ' ' ;
721 rewrite mpcogerr ;
722 reset mpcogin ;
723 initsource ;
724 brieftable := false ;
725 ch := ' ' ;
726 chcnt := 0 ;
727 check_id := false ;
728 chnix := 1 ;
729 codelist := false ;
730 column := 0 ;
731 compencours := true ;
732 cursttmap := NIL ;
733 date currdate ;
734 declarationpart := true ;
735 digits := '0'..'9' ;
736 FOR it := 0 TO displimit DO
737 display it.fname := NIL ; * FOR SECURITY *
738 dpoint := false ;
739 end_statement := true ;
740 environt := data ;
741 errinx := 0 ; fastoperator := false ;
742 errorflag := NIL ;
743 exportablecode := false ;
744 extcalltrapplace := 0 ;
745 FOR it := 0 TO maxerpg DO
746 BEGIN
747 pageserrors it := ;
748 errorsfound it := ;
749 erredited it := ;
750 END ;
751 errtotal := 0 ;
752 err257 := false ;
753 filetoprint := 0 ;
754 * firstcond IS SET IN pascal COMMAND BEFORE CALL TO racine *
755 iligne := 0 ;
756 init_fsb_trap_flag := false ;
757 init_fsb_trap_info_place := 0 ;
758 init_fsb_trap_links_place := 0 ;
759 init_fsb_trap_number_of_files := 0 ;
760 inputflag := NIL ;
761 interactive := false ;
762 iowarnings := true ;
763 envstandard := stdpure ;
764 instring := false ;
765 lastfile := 0 ;
766 lastlig := 0 ;
767 lastproc := NIL ;
768 letters := 'a'..'z' 'A'..'Z' ;
769 incomment := false ;
770 liglues := 1 ;
771 linetoprint := 1 ;
772 next := NIL ;
773 level := 0 ;
774 longpad := maxval ;
775 longprofile := false ;
776 mapptr := NIL ;
777 mapswitch := false ;
778 maxstring_ptr := NIL ;
779 nbccond := 0 ;
780 oldfile := -1 ;
781 oldindex := 0 ;
782 oldline := 0 ;
783 outputflag := NIL ;
784 pageno := 0 ; pagelength := maxpageline ; * DEFAULT *
785 pascalfrench := false ;
786 pos1 := 0 ;
787 prevfile := 0 ;
788 prevlig := 0 ;
789 profile := false ;
790 profilewordcount := 0 ;
791 profptr := NIL ;
792 progname := blank ;
793 programnode := NIL ;
794 rversion := 0 ;
795 selectivetable := false ;
796 string_ptr := NIL ;
797 sourceindex := -1 ;
798 version := rversion ;
799 skipcode := false ; skippage := false ;
800 sourcectx := ' ' ;
801 sourcenbr := 0 ;
802 startic := -1 ;
803 statnbr := 0 ;
804 symbol_listing := false ;
805 symbolmap := false ;
806 top := 0 ;
807 FOR it := 1 TO undmax - 1 DO
808 undlab it.succ := it + 1 ;
809 undlab undmax.succ := 0 ;
810 wnoset := 5 6 7 8 21 22 23 24 25 26 27 28 29 30 31 32 33 35 36 37 38 40 41 42 43 44 45 48 50 ;
811 wdsetinargs := false ;
812 wgsetinargs := false ;
813 wssetinargs := false ;
814 xc := firstglobal * bytesinword ;
815 xrefneed := false ;
816 FOR it := 1 TO 120 DO boxheader it := '*' ;
817 END * INITRACINE * ;
818
819
820 $OPTIONS page $
821
822 * *************************************NEXTLINE******************************* *
823
824 PROCEDURE nextline ;
825
826 * C PRINTS THE CURRENT LINE WRITELN
827 BUFFER OF OUTPUT MUST BE FILLED BEFORE C *
828 BEGIN
829 IF listyes THEN writeln mpcogout ;
830 iligne := iligne + 1 ; * NUMBER OF LINES IN CURRENT PAGE *
831 IF skippage OR iligne >= pagelength THEN nextpage ;
832 END * NEXTLINE * ;
833
834
835
836
837 $OPTIONS page $
838
839 * ******************************************************* RETURNSTOP ****** *
840
841 PROCEDURE returnstop ;
842
843 * C THIS PROCEDURE IS CALLED BY HEAPERROR IN UNIQUE IN ORDER TO STOP
844 THE COMPILATION C *
845 BEGIN
846 GOTO 100 ; * END OF COMPILATION. HEAP IS FULL *
847 END * RETURNSTOP * ;
848
849
850 $OPTIONS page $
851
852 * *********************************************************ERROR************** *
853
854 PROCEDURE error errno : integer ;
855
856 * C ENTERS .NEW ERROR IN ERRLIST FOR EACH LINE
857 .NEW ERROR IN ERRORSFOUND FOR END OF COMPILATION MEANINGS
858 .LISTING'S PAGE NUMBER IN PAGEERRORS C *
859 * E ERRORS DETECTED
860 255: TOO MANY ERRORS ON THIS LINE
861 381: ERROR NUMBER EXCEED HIGH BOUND
862 382: PAGE NUMBER " " " E *
863 BEGIN
864 $OPTIONS compile = trace $
865 IF anytrace > none THEN
866 BEGIN
867 write mpcogout ' @@@ DEBUT ERROR WITH ERRNO ' errno : 5 ; nextline ;
868 IF anytrace = high THEN
869 BEGIN
870 write mpcogout ' ERRINXPOS1COLUMN ' errinx pos1 column ; nextline ;
871 END
872 END ;
873 $OPTIONS compile = true $
874 IF errinx = maxerrline - 1 THEN
875 errno := 255 ; * TOO MANY ERRORS *
876 IF errinx < maxerrline THEN
877 BEGIN
878 IF column > pos1 THEN pos1 := column ;
879 errinx := errinx + 1 ;
880 WITH errlist errinx DO
881 BEGIN pos := pos1 ; nmr := errno ;
882 END ;
883 pos1 := pos1 + 1 ;
884 $OPTIONS compile = security $
885 IF errno > maxerrnum THEN error 381 ELSE
886 $OPTIONS compile = true $
887 errorsfound errno DIV setrange := errorsfound errno DIV setrange +
888 errno MOD setrange ;
889 $OPTIONS compile = security $
890 IF pageno > maxpage THEN error 382 ELSE
891 $OPTIONS compile = true $
892 pageserrors pageno DIV setrange := pageserrors pageno DIV setrange +
893 pageno MOD setrange ;
894 errtotal := errtotal + 1 ;
895 END ;
896 $OPTIONS compile = trace $
897 IF anytrace > low THEN
898 BEGIN
899 IF anytrace = high THEN
900 BEGIN
901 write mpcogout ' NOW ERRINX POS1 ARE ' errinx pos1 ; nextline ;
902 END ;
903 write mpcogout ' @@@ FIN ERROR @@@ ' ; nextline ;
904 END ;
905 $OPTIONS compile = true $
906 END * ERROR * ;
907
908
909 $OPTIONS page $
910
911 * ******************************************* WARNING ************** *
912
913 PROCEDURE warning errno : integer ;
914
915 * C ENTERS .NEW WARNING IN ERRLIST FOR EACH LINE
916 .NEW WARNING IN ERRORSFOUND FOR END OF COMPILATION MEANINGS
917 .LISTING'S PAGE NUMBER IN PAGEERRORS
918
919 EXACTLY THE CONTENTS OF the procedure ERROR EXCEPT
920 ERRTOTAL' INCREMENT .
921 C *
922 * E ERRORS DETECTED
923 255: TOO MANY ERRORS ON THIS LINE
924 381: ERROR NUMBER EXCEED HIGH BOUND
925 382: PAGE NUMBER " " " E *
926 BEGIN
927 $OPTIONS compile = trace $
928 IF anytrace > none THEN
929 BEGIN
930 write mpcogout ' @@@ DEBUT WARNING WITH ERRNO ' errno : 5 ; nextline ;
931 IF anytrace = high THEN
932 BEGIN
933 write mpcogout ' ERRINXPOS1COLUMN ' errinx pos1 column ; nextline ;
934 END
935 END ;
936 $OPTIONS compile = true $
937
938 IF NOT no_compilation_warnings THEN
939 BEGIN
940 IF errinx = maxerrline - 1 THEN
941 errno := 255 ; * TOO MANY ERRORS *
942 IF errinx < maxerrline THEN
943 BEGIN
944 IF column > pos1 THEN pos1 := column ;
945 errinx := errinx + 1 ;
946 WITH errlist errinx DO
947 BEGIN pos := pos1 ; nmr := errno ;
948 END ;
949 pos1 := pos1 + 1 ;
950 $OPTIONS compile = trace $
951 IF errno > maxerrnum THEN error 381 ELSE
952 $OPTIONS compile = true $
953 errorsfound errno DIV setrange := errorsfound errno DIV setrange +
954 errno MOD setrange ;
955 $OPTIONS compile = trace $
956 IF pageno > maxpage THEN error 382 ELSE
957 $OPTIONS compile = true $
958 pageserrors pageno DIV setrange := pageserrors pageno DIV setrange +
959 pageno MOD setrange ;
960 * NO INCREMENT OF ERRTOTAL *
961 END ;
962 END ;
963 $OPTIONS compile = trace $
964 IF anytrace > low THEN
965 BEGIN
966 IF anytrace = high THEN
967 BEGIN
968 write mpcogout ' NOW ERRINX POS1 ARE ' errinx pos1 ; nextline ;
969 END ;
970 write mpcogout ' @@@ FIN WARNING @@@ ' ; nextline ;
971 END ;
972 $OPTIONS compile = true $
973 END * WARNING * ;
974
975
976 $OPTIONS page $
977
978 * ***********************************************NEXTPAGE********************* *
979
980 PROCEDURE nextpage ;
981
982 * C NEXTLINE ON OUTPUT BEGINS AT BEGINNING OF A NEW PAGE ON LISTING
983 INCREMENTS PAGENO;
984 PRINTS PAGE NUMBER
985 C *
986 * E ERRORS DETECTED
987 383: MAX NUMBER OF LISTING'S PAGES EXCEEDED E *
988 BEGIN
989 skippage := false ;
990 pageno := pageno + 1 ;
991 $OPTIONS compile = trace $
992 IF pageno > maxpage THEN error 383 ;
993 $OPTIONS compile = true $
994 IF listyes THEN page mpcogout ; * NEXT LINE ON A NEW PAGEMPCOGOUT *
995 * WRITE PAGE NUMBER *
996 IF listyes THEN
997 write mpcogout '*** MULTICS PASCAL COMPILER - V8.0' version : 1
998 ' **** PROGRAM ' progname : 32
999 ' *** ON ' currdate ' *** ' ' ' : 11
1000 'PAGE ' pageno : 5 ;
1001 iligne := 0 ;
1002 nextline ;
1003 * DUMMY SPACE LINE *
1004 nextline ;
1005 * INIT COUNTER FOR ALLOWED LINES *
1006 * ON A PAGE *
1007 END * NEXTPAGE * ;
1008
1009
1010 $OPTIONS page $
1011
1012 * ***********************************************FCT SUP******************** *
1013
1014 FUNCTION sup fval1 fval2 : integer : integer ;
1015
1016 * C SUP IS THE GREATEST VALUE BETWEEN FVAL1 AND FVAL2 C *
1017 BEGIN
1018 IF fval1 > fval2 THEN
1019 sup := fval1 ELSE
1020 sup := fval2 ;
1021 END * SUP * ;
1022
1023
1024 $OPTIONS page $
1025
1026 * ************************************ FCT. POWEROFTWO *********************** *
1027 FUNCTION poweroftwo fval : integer : integer ;
1028
1029 * C RETURNS N IF FVAL=2**N
1030 -1 IF FVAL <=0
1031 0 IF FVAL= 1
1032 C *
1033 LABEL
1034 10 ; * EXIT LOOP *
1035 VAR
1036 lvalu, it : integer ;
1037 BEGIN * POWEROFTWO *
1038 IF fval <= 0 THEN
1039 * <==== * lvalu := -1 ELSE
1040 FOR it := 0 TO bitsinword - 2 DO
1041 IF fval = 1 THEN
1042 BEGIN
1043 * <==== * lvalu := it ; GOTO 10 ; * EXITLOOP *
1044 END * FVAL=1 * ELSE
1045 IF odd fval THEN
1046 BEGIN
1047 * <==== * lvalu := -1 ; GOTO 10 ; * EXIT LOOP *
1048 END * ODD * ELSE
1049 fval := fval DIV 2 ;
1050 10 : * EXIT LOOP *
1051 poweroftwo := lvalu ;
1052 $OPTIONS compile = trace $
1053 IF anytrace > none THEN
1054 BEGIN
1055 write mpcogout '@@@ DEBUT-FIN POWEROFTWO @@@ WITH FVAL COMPUTED VALUE'
1056 fval lvalu ;
1057 nextline ;
1058 END ;
1059 $OPTIONS compile = true $
1060 END * POWEROFTWO * ;
1061
1062
1063 $OPTIONS page $
1064
1065 * ************************************ INSERUNDLAB *************************** *
1066
1067 PROCEDURE inserundlab fcb fdebchain : integer ;
1068
1069 * C "FCB" IS A BYTES DISPLACEMENT IN THE CODE FOR THE ACTUAL PROCEDURE.
1070 "FDEBCHAIN" IS THE BEGINNING IN UNDLAB OF A LIST OF UNRESOLVED
1071 REFERENCES USING THIS VALUE OF "FCB".
1072 EACH ITEM OF THE LIST IS
1073 .THE PLACE IN CODE IN FICHINTER OF INCOMPLETE INSTRUCTION
1074 .THE POINTER ON THE NEXT LIST'S ITEM
1075 C *
1076 * E ERRORS DETECTED
1077 407 FDEBCHAIN MUST NOT BE 0 EMPTY LIST
1078 E *
1079 LABEL 1 ; * EXIT IF COMPILER'S ERROR *
1080 VAR
1081 it : integer ;
1082 BEGIN * INSERUNDLAB *
1083 $OPTIONS compile = trace $
1084 IF stattrace > none THEN
1085 BEGIN
1086 write mpcogout '@@@ DEBUT INSERUNDLAB @@@ WITH FCBFDEBCHAIN' fcb fdebchain : 6 ;
1087 nextline ;
1088 END ;
1089 $OPTIONS compile = true $
1090 IF fdebchain = 0 THEN
1091 BEGIN
1092 IF errtotal = 0 THEN error 407 ;
1093 GOTO 1 ;
1094 END ;
1095 it := fdebchain ;
1096 WHILE undlab it.succ # 0 DO
1097 BEGIN
1098 inser fcb undlab it.place ;
1099 it := undlab it.succ ;
1100 END ;
1101 * NOW THE LAST *
1102 inser fcb undlab it.place ;
1103 * NOW GIVE THIS RESOLVED LIST *
1104 * AT FREE LIST *
1105 undlab it.succ := chnix ;
1106 chnix := fdebchain ;
1107 $OPTIONS compile = trace $
1108 IF stattrace > low THEN
1109 BEGIN
1110 write mpcogout '@@@ FIN INSERUNDLAB @@@ WITH CHNIX:' chnix : 6 ; nextline ;
1111 END ;
1112 $OPTIONS compile = true $
1113 1 : * COMES HERE IF ERROR407 *
1114 END * INSERUNDLAB * ;
1115
1116
1117
1118 $OPTIONS page $
1119
1120 * *********************************************************FCT RECADRE****** *
1121
1122 FUNCTION recadre fnumber fmod : integer : integer ;
1123
1124 * C RETURNS THE FIRST FMOD-MULTIPLE OF FNUMBER C *
1125 * E ERRORS DETECTED
1126 350 : RECADRE CALLED WITH FMOD <=0
1127 E *
1128 VAR
1129 lmod : integer ;
1130 BEGIN
1131 $OPTIONS compile = security $
1132 IF fmod <= 0 THEN
1133 error 350 ELSE
1134 BEGIN
1135 $OPTIONS compile = true $
1136 lmod := fnumber MOD fmod ;
1137 IF lmod = 0 THEN
1138 recadre := fnumber ELSE
1139 recadre := fnumber + fmod - lmod ;
1140 $OPTIONS compile = security $
1141 END ;
1142 $OPTIONS compile = true $
1143 END * RECADRE * ;
1144
1145
1146
1147 $OPTIONS page $
1148
1149 * ***********************************************SRCHREC********************** *
1150
1151 PROCEDURE srchrec fbegsearch : ctp ; EXTERNAL ; * THIS PROCEDURE HAS BEEN OPTIMIZED *
1152
1153
1154 OOPROCEDURE DEF SRCHREC FBEGSEARCH:CTP ;
1155
1156 CC*C SEARCHS A BOX WITH NAME= AVAL . RETURNS CTPTR = NIL OR FOUND BOX
1157 SEARCH BEGINS IN CONTEXTTABLE AT FBEGSEARCH AND STOPS AT NIL
1158 C*
1159 BBLABEL
1160 1 ; * EXIT WHILE FOR EFFICIENCY*
1161 GGBEGIN
1162 CTPTR := FBEGSEARCH;
1163 WHILE CTPTR # NIL DO
1164 IF CTPTR@.NAME = AVAL THEN
1165 GOTO 1 ELSE
1166 CTPTR := CTPTR@.NXTEL;
1167 111: * CTPTR HERE NIL OR OK *
1168 DDEND *SRCHREC* ;
1169
1170
1171
1172 $OPTIONS page $
1173
1174 * ***********************************************SEARCH*********************** *
1175
1176 PROCEDURE search ; EXTERNAL ; * THIS PROCEDURE HAS BEEN OPTIMIZED *
1177
1178
1179 OOPROCEDURE DEF SEARCH;
1180
1181 CC*C THE ARRAY 'DISPLAY' FROM 0 TO TOP CONTAINS EACH LEVEL'S LIST'S
1182 BEGINNING.
1183 THIS PROC SEARCHS A BOX WITH NAME 'AVAL'
1184 RETURNS CTPTR = NIL OR FOUND BOX
1185 DISX = INDEX IN DISPLAY WHERE BOX WAS FOUND
1186 CAN BE 0 => PREDEF OR NOT FOUND
1187 C*
1188 BBLABEL
1189 1; * EXIT LOOP FOR EFFICIENCY *
1190 RRVAR
1191 I:INTEGER ;
1192 GGBEGIN
1193 FOR I:= TOP DOWNTO 0 DO
1194 BEGIN
1195 CTPTR := DISPLAYI.FNAME; * BEGINNING OF LIST *
1196 WHILE CTPTR # NIL DO
1197 IF CTPTR@.NAME = AVAL THEN
1198 BEGIN
1199 DISX :=I; GOTO 1;
1200 END ELSE
1201 CTPTR := CTPTR@.NXTEL;
1202 END;*FOR I *
1203 DISX := 0;
1204 111: * HERE CTPTR AND DISX OK FOR CALLER *
1205 DDEND *SEARCH *;
1206
1207
1208
1209 $OPTIONS page $
1210
1211 * *************************************CREALFABOX***************************** *
1212
1213 PROCEDURE crealfabox VAR fkonstbox : ctp ;
1214
1215 * C .BUFVAL IS LOADED FOR 1 TO LONGSTRING WITH THE STRING VALUE
1216 .THIS PROC CREATES THE BOXES ASSOCIATED WITH THIS VALUE
1217 AND ASSIGNS FKONSTBOX@.ALFADEB AND FKONSTBOX@.ALFALONG
1218 C *
1219 * E ERRORS DETECTED
1220 HEAPERROR
1221 E *
1222 VAR
1223 localfpt, nxtal : alfapt ;
1224 nboxes, it, j, longlast, debbuf : integer ;
1225
1226
1227 * ***********************************************PRINTALFABOX < CREALFABOX**** *
1228
1229 $OPTIONS compile = trace $
1230 PROCEDURE printalfabox ptalfabox : alfapt ;
1231
1232 * C USED IN CONDITIONAL COMPILATION TO PRINT THE CONTENT OF
1233 AN ALFABOX TYPE=ALFAVALUE. PTALFABOX POINTS THE BOX C *
1234 VAR
1235 it : integer ;
1236 BEGIN
1237 nextline ; write mpcogout boxheader ; nextline ;
1238 IF ptalfabox = NIL THEN
1239 BEGIN
1240 write mpcogout '* ALFABOX REQUESTED IS NIL. TRACE STOPS' ; nextline ;
1241 END ELSE
1242 BEGIN
1243 write mpcogout '* ALFABOX FOLLOWING IS AT @' ord ptalfabox ; nextline ;
1244 WITH ptalfabox@ DO
1245 BEGIN
1246 write mpcogout
1247 '* NEXTVAL IS : ' ord nextval ' USED SIZE IS ' longfill : 4 ;
1248 nextline ;
1249 write mpcogout '* ALFAVAL IS : @' ;
1250 FOR it := 1 TO longfill DO write mpcogout alfaval it ;
1251 write mpcogout '@' ;
1252 nextline ;
1253 END ; * WITH PTALFABOX@ *
1254 END ; * PTALFABOX # NIL *
1255 write mpcogout boxheader ; nextline ; nextline ;
1256 END * PRINTALFABOX * ;
1257 $OPTIONS compile = true $
1258
1259
1260 BEGIN * CREALFABOX *
1261 $OPTIONS compile = trace $
1262 IF decltrace > none THEN
1263 BEGIN
1264 write mpcogout '@@@ DEBUT CREALFABOX @@@ ' 'V. FKONSTBOX ' ord fkonstbox ;
1265 nextline ;
1266 END ;
1267 $OPTIONS compile = true $
1268 nboxes := longstring DIV longalfbox ; * NB. OF FULL BOXES *
1269 longlast := longstring MOD longalfbox ; * LENGTH OF LAST BOX OR ZERO *
1270 nxtal := NIL ;
1271 debbuf := 0 ;
1272 FOR it := 0 TO nboxes - 1 DO * FOR FULL BOXES *
1273 BEGIN
1274 new localfpt ; IF localfpt = NIL THEN heaperror ; * EXIT COMP *
1275 IF nxtal = NIL THEN
1276 fkonstbox@.alfadeb := localfpt ELSE nxtal@.nextval := localfpt ;
1277 nxtal := localfpt ;
1278 WITH localfpt@ DO
1279 BEGIN nextval := NIL ;
1280 FOR j := 1 TO longalfbox DO
1281 alfaval j := bufval debbuf + j ;
1282 debbuf := debbuf + longalfbox ;
1283 longfill := longalfbox ;
1284 END ;
1285 $OPTIONS compile = trace $
1286 IF decltrace > none THEN
1287 BEGIN
1288 write mpcogout ' ALFA BOX CREATED AT ' ord localfpt ; nextline ;
1289 IF decltrace = high THEN
1290 printalfabox localfpt ;
1291 END ;
1292 $OPTIONS compile = true $
1293 END ; * FOR IT *
1294 fkonstbox@.alfalong := longstring ;
1295 IF longlast # 0 THEN * FILL LAST BOX *
1296 BEGIN
1297 new localfpt ; IF localfpt = NIL THEN heaperror ; * EXIT COMP *
1298 IF nxtal = NIL THEN
1299 fkonstbox@.alfadeb := localfpt ELSE nxtal@.nextval := localfpt ;
1300 WITH localfpt@ DO
1301 BEGIN
1302 nextval := NIL ; longfill := longlast ;
1303 FOR j := 1 TO longlast DO
1304 alfaval j := bufval debbuf + j ;
1305 END * WITH * ;
1306 $OPTIONS compile = trace $
1307 IF decltrace > none THEN
1308 BEGIN
1309 write mpcogout ' ALFA BOX CREATED AT ' ord localfpt ; nextline ;
1310 IF decltrace = high THEN
1311 printalfabox localfpt ;
1312 END ;
1313 $OPTIONS compile = true $
1314 END ; * LONGLAST #0 *
1315 $OPTIONS compile = trace $
1316 IF decltrace > low THEN
1317 BEGIN
1318 IF decltrace = high THEN
1319 BEGIN
1320 write mpcogout ' STRING TO BE GENERATED ON ' longstring : 3 ' CHARS WAS' ;
1321 nextline ;
1322 FOR it := 1 TO longstring DO write mpcogout bufval it ; nextline ;
1323 END ;
1324 write mpcogout ' @@@ FIN CREALFABOX @@@' ; nextline ;
1325 END ;
1326 $OPTIONS compile = true $
1327 END * CREALFABOX * ;
1328
1329
1330 $OPTIONS page $
1331
1332 * *******************************************************************PRINTERR* *
1333
1334 PROCEDURE printerr ;
1335
1336 * C AFTER COMPILATION OF EACH PASCAL SOURCE LINE THIS PROCEDURE IS CALLED
1337 IN ORDER TO FLAG THE COLUMNS WHERE ISARE ERRORS
1338 ERRINX POINTS THE LAST ENTRY USED IN ERRLIST WHERE NUMBER AND POSITION OF
1339 EACH ERROR IS KEPT C *
1340 VAR
1341 it, errdeb, errmax, errptr, errnumb : integer ;
1342 BEGIN * PRINTERR *
1343 errptr := 1 ; * POINTS THE NEXT ERROR *
1344 * TO BE PROCESSED *
1345 errmax := 0 ; * POINTS THE LAST COLUMN *
1346 * REACHED ON A LINE *
1347 * WRITES TWO LAST LINES *
1348 IF lastlig <> prevlig OR lastfile <> prevfile THEN
1349 IF prevfile = 0 THEN writeln mpcogerr ' ' prevlig : 5 ' ' bufold
1350 ELSE writeln mpcogerr prevfile : 3 ' ' prevlig : 5 ' ' bufold ;
1351 IF filetoprint = 0 THEN writeln mpcogerr ' ' linetoprint : 5 ' ' bufnew
1352 ELSE writeln mpcogerr filetoprint : 3 ' ' linetoprint : 5 ' ' bufnew ;
1353 lastfile := filetoprint ; lastlig := linetoprint ;
1354 WHILE errptr <= errinx DO
1355 BEGIN
1356 errmax := errmax + lgprint ;
1357 IF errlist errptr.pos <= errmax THEN
1358 BEGIN
1359 IF chcnt <= lgprint THEN
1360 BEGIN write mpcogout '*********' ;
1361 write mpcogerr '*********' ;
1362 END ELSE
1363 BEGIN write mpcogout '***' errmax DIV lgprint : 3 '***' ;
1364 write mpcogerr '***' errmax DIV lgprint : 3 '***' ;
1365 END ;
1366 errdeb := errptr ; * FIRST ERROR ON THE LINE PRINTED *
1367 FOR it := errmax - lgprint TO errmax DO
1368 IF errptr <= errinx THEN
1369 BEGIN
1370 IF errlist errptr.pos = it THEN
1371 BEGIN
1372 write mpcogout '"' ; write mpcogerr '"' ;
1373 errptr := errptr + 1 ;
1374 END ELSE
1375 BEGIN write mpcogout ' ' ; write mpcogerr ' ' ;
1376 END ;
1377 END ELSE
1378 BEGIN write mpcogout ' ' ; write mpcogerr ' ' ;
1379 END ;
1380 nextline ; writeln mpcogerr ;
1381 END ; * ERRORS ON THE LINE *
1382 END ; * LOOP ON THE LINES *
1383 write mpcogout ' ERRORS NR :' ;
1384 write mpcogerr ' ERRORS NR :' ;
1385 FOR it := 1 TO errinx DO
1386 BEGIN
1387 write mpcogout errlist it.nmr : 4 ;
1388 write mpcogerr errlist it.nmr : 4
1389 END ;
1390 nextline ; writeln mpcogerr ;
1391 FOR it := 1 TO errinx DO
1392
1393 BEGIN
1394 errnumb := errlist it.nmr ;
1395 IF NOT errnumb MOD maxset IN erredited errnumb DIV maxset THEN
1396 BEGIN
1397 prterrmeans mpcogerr errnumb ; writeln mpcogerr ;
1398 erredited errnumb DIV maxset := erredited errnumb DIV maxset +
1399 errnumb MOD maxset ;
1400 END
1401 END ;
1402 writeln mpcogerr ;
1403 errinx := 0 ;
1404 pos1 := 0 ;
1405 END * PRINTERR * ;
1406
1407
1408 $OPTIONS page $
1409
1410 * ***********************************************NEXTCH*********************** *
1411
1412 PROCEDURE nextch ;
1413
1414 * C .GIVES TO INSYMBOL THE NEXT RELEVANT CHARACTER OF SOURCE.
1415 .AT EOLN PRINTS LAST LINE
1416 .AT EOF EXITS COMPIL.
1417 C *
1418 * E ERRORS DETECTED
1419 18: ' EXPECTED
1420 22: EOF ON FILE INPUT =SOURCE
1421 257: SOURCE LINE IS TOO LONG
1422 E *
1423 LABEL
1424 1, 2 ; * EXIT OF LOOP FOR CH#' ' *
1425 VAR
1426 caract : char ;
1427 it, startit, chprint, index, ll : integer ;
1428 listingline : PACKED ARRAY 1..maxsliceline OF char ;
1429 ch1 : char ;
1430 liststatus : boolean ;
1431 BEGIN * NEXTCH *
1432 2 :
1433 IF beginline THEN BEGIN
1434 beginline := false ;
1435 IF incomment OR skipcode THEN sourcectx := '*' ELSE sourcectx := ' '
1436 END ;
1437 IF eoln mpcogin THEN * END OF CURRENT LINE *
1438 IF NOT eof mpcogin THEN
1439 BEGIN
1440 IF listyes OR errinx > 0 THEN * L+ OR ERRORS ON LINE *
1441 BEGIN * PRINTS THIS LINE *
1442 liststatus := listyes ; listyes := true ;
1443 IF instring AND envstandard <> stdextend THEN
1444 BEGIN error 18 ; instring := false ; END ;
1445 * PRINTS FILE NO LINE NO *
1446 IF filetoprint = 0 THEN ll := swrite listingline 1 ' ' linetoprint : 5 sourcectx
1447 ELSE ll := swrite listingline 1 filetoprint : 3 ' ' linetoprint : 5 sourcectx ;
1448 * NOW PRINTS SOURCE . *
1449 * 'LGPRINT' CHARS ON A LINE *
1450 * SEVERAL LINES ALLOWED *
1451 startit := 2 ; it := 1 ; chprint := 0 ;
1452 WHILE it <= chcnt DO
1453 BEGIN
1454 caract := symbline it ;
1455 IF caract = ' ' THEN * TAB *
1456 chprint := chprint + 10 DIV 10 * 10
1457 ELSE
1458 chprint := chprint + 1 ;
1459 IF chprint >= lgprint THEN
1460 BEGIN
1461 ll := swrite listingline ll symbline : 2 + it - startit : startit ;
1462 startit := it + 2 ;
1463 write mpcogout listingline : ll - 1 ;
1464 nextline ;
1465 ll := swrite listingline 1 ' ' ;
1466 chprint := 0 ;
1467 END ;
1468 it := it + 1 ;
1469 END ;
1470 IF chprint <> 0 THEN
1471 ll := swrite listingline ll symbline : 1 + it - startit : startit ;
1472 write mpcogout listingline : ll - 1 ;
1473 nextline ;
1474 IF errinx > 0 THEN printerr ;
1475 listyes := liststatus ;
1476 END * LISTING * ;
1477 bufold := bufnew ; bufnew := ' ' ;
1478 chcnt := -1 ; * SYMBLINE0 = SPACE DUMMY *
1479 * DUE TO EOLN *
1480 beginline := true ;
1481 prevfile := filetoprint ;
1482 prevlig := linetoprint ;
1483 column := -1 ;
1484 liglues := liglues + 1 ; * LINES' COUNTER *
1485 * AT BEGINNING OF NEXT PRINTED LINE *
1486 err257 := false ; * TO AVOID SEVERAL ERROR257 *
1487 * ON THE SAME LINE *
1488 filetoprint := sourcenbr ;
1489 linetoprint := liglues ;
1490 END * EOLN * ;
1491 IF eof mpcogin THEN
1492 IF sourcenbr = 0 THEN
1493 BEGIN
1494 IF compencours THEN error 22 ;
1495 GOTO 100 ; * GOTO END OF COMPILER *
1496 END
1497 ELSE
1498 BEGIN
1499 endsource ; * END OF INCLUDE FILE *
1500 GOTO 2 ;
1501 END ;
1502 * HERE VITAL PART *
1503 * ==> ASSIGNS CH FOR INSYMBOL *
1504 REPEAT
1505 ch1 := ch ;
1506 read mpcogin ch ; * SPACE RETURNED IF EOLNMPCOGIN *
1507 sourceindex := sourceindex + 1 ;
1508 IF chcnt < maxlinepascal THEN
1509 BEGIN
1510 chcnt := chcnt + 1 ;
1511 symbline chcnt := ch ; IF chcnt < maxsliceline THEN bufnew chcnt := ch ;
1512 IF ch = ' ' THEN * TAB *
1513 BEGIN
1514 IF column = -1 THEN column := 0 ;
1515 column := column + 10 DIV 10 * 10
1516 END
1517 ELSE column := column + 1 ;
1518 END ELSE
1519 IF NOT err257 THEN
1520 BEGIN error 257 ;
1521 err257 := true ;
1522 END ;
1523 IF ch # ' ' OR ch1 # ' ' THEN GOTO 1 ; * EXIT REPEAT *
1524 UNTIL eoln mpcogin OR instring OR eof mpcogin ;
1525 1 :
1526 IF NOT instring THEN ch := chr majmin ord ch ;
1527 END * NEXTCH * ;
1528
1529
1530 $OPTIONS page $
1531
1532 * ***********************************************TRACELEVEL******************* *
1533
1534 PROCEDURE tracelevel VAR whichtrace : levtrace ; charfound : char ;
1535
1536 * C A TRACE COMMAND WAS FOUND; THE CHAR GIVING WANTED LEVEL ALSO.
1537 C *
1538 * E ERRORS DETECTED
1539 25: INVALID TRACE OPTIONS IN COMPILER PARMLIST
1540 E *
1541 BEGIN
1542 whichtrace := none ; * DEFAULT *
1543 IF charfound = '0' THEN whichtrace := none ELSE
1544 IF charfound = '1' THEN whichtrace := low ELSE
1545 IF charfound = '2' THEN whichtrace := medium ELSE
1546 IF charfound = '3' THEN whichtrace := high ELSE
1547 error 25 ;
1548 anytrace := decltrace ;
1549 IF anytrace < stattrace THEN anytrace := stattrace ;
1550 IF anytrace < genetrace THEN anytrace := genetrace ;
1551 END * TRACELEVEL * ;
1552
1553
1554 $OPTIONS page $
1555
1556 PROCEDURE traiteinclude ; FORWARD ;
1557 PROCEDURE traiteoptions ; FORWARD ;
1558
1559 * *******************************************************************INSYMBOL* *
1560
1561 PROCEDURE insymbol ;
1562
1563 * C .ASSIGNS A CODE NOCL TO EACH ITEM
1564 .RETURNS VALUE IN IVALRVALBUFVAL
1565 .SKIPS COMMENT AND COMPIL. COND.
1566 .DECODE OPTIONS
1567
1568 INSYMBOL'S OUTPUT SUMMARY
1569
1570 *NO*CL*****ITEM***SYNONYMS*******OUTPUTS*******||||**NO**CL***ITEM************
1571
1572 . 1 LG ID. AVAL 21 BEGIN
1573 . 2 1 CST. INT IVAL 22 END
1574 . 2 . REAL RVAL 23 IF
1575 . 3 . ALFA BUFVAL LONGCHAINE 24 THEN
1576 . 4 . CHAR IVAL 25 ELSE
1577 . 26 CASE
1578 . 5 1 NOT 27 OF
1579 28 REPEAT
1580 . 6 1 * 29 UNTIL
1581 . 2 / 30 WHILE
1582 . 3 AND 31 DO
1583 . 4 DIV 32 FOR
1584 . 5 MOD 33 1 TO
1585 . 2 DOWNTO
1586 . 7 1 +
1587 . 2 - 35 GOTO
1588 . 3 OR 36 NIL
1589 37 TYPE
1590 . 8 1 < 38 1 ARRAY
1591 . 2 <= 2 RECORD
1592 . 3 >= 3 FILE
1593 . 4 > 4 CLASS
1594 . 5 <> # 5 SET
1595 . 6 = 39 ...SEE CHAR..
1596 . 7 IN 40 LABEL
1597 . 41 CONST
1598 . 42 PACKED
1599 . 9 43 VAR
1600 . 10 44 FUNCTION
1601 . 11 . 45 PROCEDURE
1602 . 12 ] . 46 .... CF SKIP ...
1603 . 55 $ 47 VALUE
1604 . 56 $include
1605 . 15 48 WITH
1606 . 16 ; 49 ...SEE CHAR..
1607 . 17 . 50 PROGRAM
1608 . 18 @ ^
1609 . 19 :
1610 . 20 :=
1611 . 39 ..
1612 . 49 ->
1613 C *)
1614 * E
1615 32 OCTAL NUMBER IS NOT STANDARD
1616 33 HEXADECIMALBINARY NUMBER IS NOT STANDARD
1617 70 OBSOLETE CONDITIONNAL COMPILATION MECHANISM
1618 200 CHARACTER NOT ALLOWED IN PASCAL TEXT
1619 201 ERROR IN REAL CONSTANT DIGIT EXPECTED
1620 202 ERROR IN EXPONENT OF REAL CONSTANT
1621 203 INTEGER CONSTANT OUT OF RANGE
1622 204 ILLEGAL DIGIT IN OCTAL CONSTANT
1623 205 EXPONENT OUT OF RANGE
1624 206 DECIMAL CONSTANT IS TOO LONG
1625 207 OCTAL CONSTANT IS TOO LONG
1626 208 ILLEGAL NESTING OF / AND /
1627 209 CHARACTERS' STRING IS TOO LONG
1628 210 HEXADECIMAL VALUE IS TOO LONG
1629 211 ILLEGAL DIGIT IN HEXADECIMAL CONSTANT
1630 212 ERROR IN COMPILATION'S OPTIONS
1631 215 Too many digits
1632 216 Only 0 ou 1 allowed
1633 217 REAL > MAXREAL
1634 218 REAL < MINREAL
1635 219 TOO MANY PRECISION DIGITS FOR A REAL
1636 220 Empty string not allowed
1637 222
1638 223 Invalid number separator
1639 224 REFERENCE TO THIS IDENTIFIER IS NOT ALLOWED HERE.
1640 E *
1641 LABEL 1 * BEGINNING OF INSYMBOL *
1642 3 * EXIT WHEN KEY-WORD IS FOUND *
1643 4
1644 5 ; * COMMENT *
1645 VAR
1646 it k scale exp valhex : integer ;
1647 sign combraces option fin : boolean ;
1648 locvalue : integer ;
1649 locsomme : integer ;
1650 ch1 : char ;
1651 nbrstring : numberstring ;
1652
1653 BEGIN * INSYMBOL *
1654 IF building_from_schema.on THEN
1655 WITH building_from_schema DO
1656 BEGIN
1657 WITH current_token^ DO
1658 CASE kind OF
1659 symbol_token : BEGIN no := tno ; cl := tcl END ;
1660 name_token : BEGIN aval := taval ; no := 1 END ;
1661 int_const_token : BEGIN no := 2 ; cl := 1 ; ival := t_int_value END ;
1662 real_const_token : BEGIN no := 2 ; cl := 2 ; rval := t_real_value END ;
1663 char_const_token : BEGIN no := 2 ; cl := 4 ; ival := ord t_char_value END ;
1664 END ;
1665 current_token := current_token^.next ;
1666 IF current_token = NIL THEN on := false ;
1667 END
1668 ELSE
1669 BEGIN
1670 1 : IF dpoint THEN * INTEGER.. AT LAST CALL * * .. *
1671 BEGIN
1672 dpoint := false ; no := 39 ;
1673 nextch ;
1674 END ELSE
1675 BEGIN * NOT DPOINT *
1676 4 :
1677 WHILE ch = ' ' DO nextch ; * CH IS CHECKED BY NEXTCH *
1678 symbolindex := sourceindex ;
1679 symbolline := liglues ;
1680 symbolfile := sourcenbr ;
1681 IF ch IN 'a'..'z' '$' THEN
1682 BEGIN
1683 IF ch = '$' THEN
1684 IF envstandard = stdpure THEN
1685 BEGIN
1686 error 200 ;
1687 nextch ;
1688 IF NOT ch IN 'a'..'z' THEN GOTO 4
1689 END ;
1690 k := 0 ; aval := blank ;
1691 IF envstandard <> stdextend THEN
1692 REPEAT
1693 IF k < maxident THEN
1694 BEGIN
1695 k := k + 1 ; aval k := ch ;
1696 END ;
1697 nextch ;
1698 UNTIL NOT ch IN 'a'..'z' '0'..'9'
1699 ELSE
1700 REPEAT
1701 IF k < maxident THEN
1702 BEGIN
1703 k := k + 1 ; aval k := ch ;
1704 END ;
1705 nextch ;
1706 UNTIL NOT ch IN 'a'..'z' '0'..'9' '_' ; * UNDERSCORE IS ALLOWED IN NO STANDARD *
1707 * KEY-WORDS *
1708 IF k <= maxkeylength THEN
1709 FOR it := wl1 k TO wl2 k DO * KEY-WORD *
1710 IF aval = wd it THEN
1711 BEGIN
1712 no := wno it ; cl := wcl it ; GOTO 3 ; * EXIT LOOP KEY-WORD FOUND *
1713 END ;
1714 no := 1 ; cl := k ;
1715 IF check_id THEN
1716 IF aval = forbidden_id THEN error 224
1717 ELSE
1718 BEGIN
1719 IF forbidden_id_list^.next = NIL THEN
1720 BEGIN
1721 new forbidden_id_list^.next ;
1722 WITH forbidden_id_list^.next^ DO
1723 BEGIN
1724 previous := forbidden_id_list ;
1725 next := NIL
1726 END
1727 END ;
1728 forbidden_id_list := forbidden_id_list^.next ;
1729 forbidden_id_list^.name := aval ;
1730 END ;
1731 * if aval1 = '$' then error200 ; *
1732 3 :
1733 IF no = 56 THEN * $include founded *
1734 BEGIN
1735 traiteinclude ;
1736 GOTO 1
1737 END ;
1738 IF no = 57 THEN
1739
1740 IF NOT skipcode THEN
1741 BEGIN
1742 traiteoptions ;
1743 GOTO 1 ;
1744 END ;
1745 END * letter * ELSE
1746 IF ch IN digits THEN
1747 BEGIN * NUMBER *
1748 no := 2 ; cl := 1 ;
1749 it := 1 ; ival := 0 ; nbrstring := '+0000000000000000000' ;
1750 WHILE ch = '0' DO nextch ; * SKIP LEADING ZEROES *
1751 WHILE ch IN digits DO
1752 BEGIN
1753 it := it + 1 ;
1754 IF it <= maxdigitsinteger THEN
1755 nbrstring it := ch ;
1756 nextch
1757 END ;
1758 IF ch IN letters THEN
1759 IF ch <> 'E' THEN
1760 IF ch <> 'e' THEN
1761 error 223 ;
1762 IF it > maxdigitsinteger OR
1763 it = maxdigitsinteger AND nbrstring > maxintegerstring
1764 THEN
1765 BEGIN
1766 error 203 ;
1767 it := 1
1768 END
1769 ELSE
1770 FOR k := 2 TO it DO
1771 ival := ival * 10 + ord nbrstring k - ord '0' ;
1772 exp := it - 1 ;
1773
1774 IF ch = '.' THEN
1775 BEGIN
1776 nextch ;
1777 IF ch = '.' THEN dpoint := true ELSE
1778 IF ch = ')' THEN ch := '' ELSE
1779 BEGIN
1780 rval := ival ; cl := 2 ; * REAL *
1781 IF NOT ch IN digits THEN error 201 ELSE
1782 BEGIN
1783 IF it = 1 THEN
1784 WHILE ch = '0' DO
1785 BEGIN
1786 exp := exp - 1 ;
1787 nextch
1788 END ;
1789 WHILE ch IN digits DO
1790 BEGIN
1791 it := it + 1 ;
1792 IF it <= maxdigitsreal THEN nbrstring it := ch ;
1793 nextch
1794 END ;
1795 IF it > maxdigitsreal THEN warning 219
1796 END
1797 END
1798 END * ch = '.' * ;
1799
1800 IF ch = 'e' THEN
1801 BEGIN
1802 nextch ;
1803 rval := ival ; cl := 2 ; scale := exp ; exp := 0 ; * REAL *
1804 sign := false ;
1805 IF ch = '+' THEN nextch
1806 ELSE
1807 IF ch = '-' THEN
1808 BEGIN
1809 nextch ; sign := true ;
1810 END ;
1811 IF NOT ch IN digits THEN error 201
1812 ELSE
1813 REPEAT
1814 IF exp < maxexpon THEN
1815 exp := exp * 10 + ord ch - ord '0' ;
1816 nextch
1817 UNTIL NOT ch IN digits ;
1818 IF sign THEN exp := scale - exp
1819 ELSE exp := scale + exp ;
1820 END * CH = 'E' * ;
1821
1822 IF cl = 2 THEN * CHECK BOUNDS AND CONVERT REAL *
1823 IF it = 1 THEN rval := 0 * MANTISSA IS ZERO *
1824 ELSE
1825 IF exp > maxexp
1826 OR exp = maxexp AND nbrstring > maxrealstring THEN error 217
1827 ELSE
1828 IF exp < minexp
1829 OR exp = minexp AND nbrstring < minrealstring THEN error 218
1830 ELSE
1831 BEGIN
1832 exp := exp - 19 ;
1833 convertreal nbrstring exp rval
1834 END ;
1835
1836 END * CH IN DIGITS * ELSE
1837 BEGIN * SPECIAL CHARACTER *
1838 IF ch = '''' THEN * ALFA OR CHAR *
1839 BEGIN
1840 no := 2 ; longchaine := 0 ; instring := true ;
1841 REPEAT
1842 IF eoln mpcogin THEN
1843 BEGIN
1844 IF envstandard <> stdextend THEN error 231 ;
1845 nextch ; ch := chr 10 ; * ASCII NEW-LINE *
1846 END ELSE
1847 nextch ;
1848 IF ch = '''' THEN * ' *
1849 BEGIN
1850 instring := false ; * TO OBTAIN A PASCAL CHAR *
1851 nextch ;
1852 instring := ch = '''' ;
1853 END ELSE
1854 IF ch = chr 92 THEN
1855 IF envstandard = stdsol THEN
1856 BEGIN
1857 nextch ;
1858 IF ch IN 'N' 'n' 'Z' 'z' 'T' 't' 'R' 'r' 'V' 'A'..'F' 'a'..'f'
1859 '0'..'9' THEN
1860 BEGIN
1861 CASE ch OF
1862 'N' 'n' : ch := chr 10 ; * ASCII NEWLINE *
1863 'Z' 'z' : ch := chr 0 ;
1864 'T' 't' : ch := chr 9 ; * HORIZONTAL TABULATION *
1865 'R' 'r' : ch := chr 13 ; * CARRIAGE RETURN *
1866 'V' : ch := chr 92 ; * ASCII ANTISLASH *
1867 '0' '1' '2' '3' '4' '5' '6' '7' '8' '9'
1868 'A' 'B' 'C' 'D' 'E' 'F'
1869 'a' 'b' 'c' 'd' 'e' 'f' : BEGIN * HEXADECIMAL DIGIT *
1870 locvalue := 0 ;
1871 IF ch IN '0'..'9' THEN
1872 locvalue := ord ch - ord '0' ELSE
1873 IF ch IN 'A'..'F' THEN
1874 locvalue := ord ch - ord 'A' + 10 ELSE
1875 locvalue := ord ch - ord 'a' + 10 ;
1876 locsomme := locvalue * 16 ; * FIRST DIGIT HEXA *
1877 nextch ;
1878 IF ch IN '0'..'9' THEN
1879 locvalue := ord ch - ord '0' ELSE
1880 IF ch IN 'A'..'F' THEN
1881 locvalue := ord ch - ord 'A' + 10 ELSE
1882 locvalue := ord ch - ord 'a' + 10 ;
1883 locsomme := locsomme + locvalue ;
1884
1885 IF locsomme <= maxchar THEN
1886 ch := chr locsomme ELSE
1887 error 303 ;
1888
1889 END * HEXADECIMAL DIGIT * ;
1890 END * case CH * ;
1891 END ;
1892 END * chr 92 * ;
1893 IF instring THEN
1894 BEGIN
1895 longchaine := longchaine + 1 ;
1896 IF longchaine <= maxval THEN bufval longchaine := ch ;
1897 END ;
1898 UNTIL NOT instring ;
1899 IF envstandard <> stdextend THEN
1900 IF longchaine = 0 THEN
1901 error 220 ;
1902 IF ch = 'x' THEN * HEXA * * HEXADECIMAL *
1903 BEGIN
1904 IF envstandard = stdpure THEN
1905 error 33 ;
1906 nextch ;
1907 cl := 1 ; * CODE FOR INTEGER *
1908 ival := 0 ;
1909 IF longchaine > maxhexdi THEN error 210 ELSE
1910 FOR it := 1 TO longchaine DO
1911 BEGIN
1912 IF bufval it IN digits
1913 THEN valhex := ord bufval it - ord '0'
1914 ELSE
1915
1916 IF bufval it IN 'A'..'F' THEN
1917 valhex := ord bufval it - ord 'A' + 10 ELSE
1918 IF bufval it IN 'a'..'f' THEN
1919 valhex := ord bufval it - ord 'a' + 10 ELSE
1920 BEGIN
1921 error 211 ; valhex := 0 ;
1922 END ;
1923 append_ ival 4 valhex ;
1924 END ;
1925 END * HEXA * ELSE
1926
1927 IF ch = 'o' THEN * octal number *
1928 BEGIN
1929 IF envstandard = stdpure THEN
1930 error 32 ;
1931 nextch ; cl := 1 ; * integer * ival := 0 ; no := 2 ;
1932 IF longchaine > maxdig + 1 THEN error 207 ELSE
1933 FOR it := 1 TO longchaine DO
1934 BEGIN
1935 valhex := ord bufval it - ord '0' ;
1936 IF NOT valhex IN 0..7 THEN
1937 BEGIN error 204 ; valhex := 0 ;
1938 END ;
1939 append_ ival 3 valhex ;
1940 END * for it * ;
1941 END * octal number * ELSE
1942 IF ch = 'b' THEN * binary *
1943 BEGIN
1944 nextch ; cl := 1 ; * integer * ; ival := 0 ; no := 2 ;
1945 IF envstandard = stdpure THEN
1946 error 33 ;
1947 IF longchaine > bitsinword THEN error 215 ELSE
1948 FOR it := 1 TO longchaine DO
1949 BEGIN
1950 valhex := ord bufval it - ord '0' ;
1951 IF NOT valhex IN 0..1 THEN
1952 BEGIN error 216 ; valhex := 0 ;
1953 END ;
1954 append_ ival 1 valhex ;
1955 END ; * FOR IT *
1956 END ELSE
1957 IF longchaine = 1 THEN * CHAR * * CHAR *
1958 BEGIN
1959 cl := 4 ; ival := ord bufval 1 ;
1960 END * CHAR * ELSE * STRING *
1961 BEGIN * ALFA *
1962 cl := 3 ;
1963 IF longchaine > maxval THEN
1964 BEGIN
1965 error 209 ; longchaine := maxval ;
1966 END ;
1967 END ; * ALFA *
1968 IF longchaine >= longpad THEN longpad := longchaine ELSE
1969 REPEAT * PADDING WITH SPACES *
1970 bufval longpad := ' ' ; longpad := longpad - 1 ;
1971 UNTIL longpad = longchaine ;
1972 END * ALFA OR CHAR * ELSE
1973 BEGIN * OTHER CHARS *
1974 no := symno ord ch ; * SINGLE CHAR *
1975 cl := symcl ord ch ;
1976 ival := 0 ;
1977 IF NOT eof mpcogin AND sourcenbr = 0 THEN
1978 BEGIN
1979 ch1 := ch ;
1980 nextch ;
1981 * TEST FOR DOUBLE CHARS *
1982 IF ch1 = ':' THEN
1983 BEGIN
1984 IF ch = '=' THEN * := *
1985 BEGIN
1986 no := 20 ; nextch ;
1987 END ;
1988 END ELSE
1989 IF ch1 = '.' THEN
1990 BEGIN
1991 IF ch = '.' THEN * .. *
1992 BEGIN
1993 no := 39 ; nextch ;
1994 END ELSE
1995 IF ch = '' THEN * . *
1996 BEGIN
1997 no := 12 ; nextch ;
1998 END ;
1999 END ELSE
2000 IF ch1 = '-' THEN
2001 BEGIN
2002 IF envstandard = stdextend THEN
2003 IF ch = '>' THEN * CRISS EXTENSION *
2004 BEGIN
2005 no := 49 ; cl := 0 ; nextch ;
2006 END ;
2007 END ELSE
2008 IF ch1 = '<' THEN
2009 BEGIN
2010 IF ch = '=' THEN * <= *
2011 BEGIN * NO=8 *
2012 cl := 2 ; nextch ;
2013 END ELSE
2014 IF ch = '>' THEN * <> *
2015 BEGIN
2016 cl := 5 ; nextch ;
2017 END ;
2018 END ELSE
2019 IF ch1 = '>' THEN
2020 BEGIN
2021 IF ch = '=' THEN * >= *
2022 BEGIN * NO=8 *
2023 cl := 3 ; nextch ;
2024 END ;
2025 END ELSE
2026 IF ch1 = '/' THEN
2027 BEGIN
2028 IF ch = '') THEN * NS * * / *)
2029 BEGIN
2030 error 70 ;
2031 nextch ;
2032 GOTO 1 ; * FOLLOWING MECHANISM IS OBSOLETE AND SKIPPED *
2033 IF envstandard <> stdextend THEN error 70 ;
2034 nextch ;
2035 IF nbccond = 0 THEN error 208
2036 ELSE nbccond := nbccond - 1 ;
2037 GOTO 1 ; * BEGINNING OF INSYMBOL *
2038 END ;
2039 END ELSE
2040 IF ch1 = '' THEN
2041 BEGIN
2042 IF ch = '.' THEN
2043 BEGIN * . *
2044 no := 11 ; nextch ;
2045 END ELSE
2046 IF ch = '*' THEN
2047 BEGIN * * *
2048 nextch ;
2049 combraces := false ;
2050 incomment := true ;
2051 END ;
2052 END ELSE
2053 IF ch1 = '' THEN * COMMENT WITH BRACE *
2054 BEGIN
2055 combraces := true ;
2056 * NEXTCH HAS BEEN DONE *
2057 5 : incomment := true ;
2058 END ; * COMMENT *
2059 END ; * OTHER CHARS *
2060 END * NOT EOFMPCOGIN *
2061 END ; * SPECIAL CHARS *
2062 END ; * NOT DPOINT *
2063
2064 IF incomment THEN
2065 BEGIN
2066 IF envstandard = stdpure THEN
2067 REPEAT
2068 WHILE NOT ch IN '}' '*' DO nextch ;
2069 fin := ch = '' ;
2070 IF NOT fin THEN
2071 BEGIN
2072 nextch ; fin := ch = ''
2073 END
2074 UNTIL fin
2075 ELSE
2076 IF combraces THEN * COMMENT WITH BRACES *
2077 WHILE ch <> '}' DO nextch
2078 ELSE
2079 REPEAT
2080 WHILE ch <> '*' DO nextch ;
2081 nextch ; fin := ch = '' ;
2082 UNTIL fin ;
2083 incomment := false ;
2084 nextch ;
2085 GOTO 1 ; * RESTART INSYMBOL *
2086 END ;
2087 END ;
2088
2089 $OPTIONS compile = trace $
2090 IF anytrace > low THEN
2091 BEGIN
2092 write mpcogout ' @@@ RETOUR INSYMBOL @@@ WITH NOCL' no : 4 cl : 4 ; nextline ;
2093 END ;
2094 $OPTIONS compile = true $
2095 END * INSYMBOL * ;
2096
2097
2098 $OPTIONS page $
2099
2100 PROCEDURE skip nosymb : integer ; FORWARD ;
2101 PROCEDURE skipextd nosymb : setofno ; FORWARD ;
2102
2103 * *************************************************** TRAITEINCLUDE ******************** *
2104
2105 PROCEDURE traiteinclude ;
2106
2107 * c CALLED BY INSYMBOL WHEN $INCLUDE DIRECTIVE HAS BEEN ENCOUNTERED C *
2108
2109 * E
2110 35 : MAX LENGTH FOR EXTERNAL IS 168 CHARS
2111 38 : '' OR '$' EXPECTED
2112 39 : STRING OR '*' EXPECTED
2113 40 : '$' EXPECTED
2114 41 : THIS STRING CANNOT BE > 32 CHARS E *
2115
2116 LABEL
2117 10 ; * EXIT ON ERROR *
2118
2119 VAR
2120 filename : externid ; * NAME OF INCLUDE FILE *
2121 stringdeb stringfin : alfaid ; * OPTIONAL BEGIN AND END STRINGS *
2122 it ldeb lfin : integer ;
2123
2124 BEGIN * TRAITEINCLUDE *
2125 $OPTIONS compile = trace $
2126 IF anytrace > low THEN
2127 BEGIN
2128 write mpcogout ' @@@ DEBUT TRAITEINCLUDE @@@' ; nextline ;
2129 END ;
2130 $OPTIONS compile = true $
2131 insymbol ; * FILENAME STRING *
2132 IF NOT no = 2 AND cl = 3 THEN
2133 BEGIN
2134 error 19 ;
2135 skip 55 ;
2136 GOTO 10
2137 END ;
2138 IF longchaine > maxexternname THEN
2139 BEGIN
2140 error 35 ;
2141 longchaine := maxexternname
2142 END ;
2143 filename := ' ' ;
2144 FOR it := 1 TO longchaine DO
2145 filename it := bufval it ;
2146 stringdeb := ' ' ;
2147 stringfin := ' ' ;
2148 * CHECK FOR OPTIONNAL STRINGS *
2149 WHILE ch = ' ' DO nextch ;
2150 IF ch = '$' THEN
2151 BEGIN
2152 stringdeb := '* ' ; ldeb := 1 ;
2153 stringfin := '* ' ; lfin := 1
2154 END
2155 ELSE
2156 BEGIN
2157 insymbol ;
2158 IF no <> 15 THEN
2159 BEGIN
2160 error 38 ;
2161 skip 55 ;
2162 GOTO 10
2163 END ;
2164 insymbol ; * '*' OR STRING EXPECTED *
2165 IF no = 6 AND cl = 1 THEN * '*' *
2166 BEGIN
2167 stringdeb := '* ' ;
2168 ldeb := 1
2169 END
2170 ELSE
2171 BEGIN
2172 IF NOT no = 2 AND cl = 3 THEN
2173 BEGIN
2174 error 39 ;
2175 skip 55 ;
2176 GOTO 10
2177 END ;
2178 IF longchaine > maxident THEN
2179 BEGIN
2180 error 41 ;
2181 longchaine := maxident
2182 END ;
2183 FOR it := 1 TO longchaine DO
2184 stringdeb it := bufval it ;
2185 ldeb := longchaine ;
2186 END ;
2187 WHILE ch = ' ' DO nextch ;
2188 IF ch = '$' THEN
2189 BEGIN
2190 stringfin := '* ' ;
2191 lfin := 1
2192 END
2193 ELSE
2194 BEGIN
2195 insymbol ;
2196 IF no <> 15 THEN
2197 BEGIN
2198 error 38 ;
2199 skip 55 ;
2200 GOTO 10
2201 END ;
2202 insymbol ; * '*' OR STRING EXPECTED *
2203 IF no = 6 AND cl = 1 THEN * '*' *
2204 BEGIN
2205 stringfin := '* ' ;
2206 lfin := 1
2207 END
2208 ELSE
2209 BEGIN
2210 IF NOT no = 2 AND cl = 3 THEN
2211 BEGIN
2212 error 39 ;
2213 skip 55 ;
2214 GOTO 10
2215 END ;
2216 IF longchaine > maxident THEN
2217 BEGIN
2218 error 41 ;
2219 longchaine := maxident
2220 END ;
2221 FOR it := 1 TO longchaine DO
2222 stringfin it := bufval it ;
2223 lfin := longchaine ;
2224 END ;
2225 WHILE ch = ' ' DO nextch ;
2226 IF ch <> '$' THEN
2227 BEGIN
2228 error 40 ;
2229 skip 55 ;
2230 GOTO 10
2231 END
2232 END
2233 END ;
2234 beginsource filename stringdeb ldeb stringfin lfin ; * BEGIN INCLUDE FILE *
2235 reset mpcogin ;
2236 nextch ;
2237 10 :
2238 $OPTIONS compile = trace $
2239 IF anytrace > low THEN
2240 BEGIN
2241 write mpcogout ' @@@ FIN TRAITEINCLUDE @@@' ; nextline ;
2242 END ;
2243 $OPTIONS compile = true $
2244 END * TRAITEINCLUDE * ;
2245
2246
2247 $OPTIONS page $
2248
2249 * ***************************************** TRAITEOPTIONS ************************************** *
2250
2251 PROCEDURE traiteoptions ;
2252
2253 * C CALLED BY INSYMBOL WHEN "$OPTIONS" DIRECTIVE IS ENCOUNTERED C *
2254
2255 * E ERRORS DETECTED ARE :
2256
2257 47 : OPTION IDENTIFIER EXPECTED
2258 16 : "=" EXPECTED
2259 50 : "$" OR ";" EXPECTED
2260 49 : "+" OR "-" EXPECTED
2261 34 : CONDITION IDENTIFIER EXPECTED
2262 35 : "" OR ";" OR "$" EXPECTED
2263 48 : UNKNOWN OPTION
2264 15 : INTEGER EXPECTED
2265
2266 E *
2267
2268 LABEL
2269 1 3 4 5 10 ;
2270
2271 VAR
2272 ch : char ;
2273 flag : boolean ;
2274 work : condaddr ;
2275
2276 * ************************************************* SKIPOPTION < TRAITEOPTIONS ************************* *
2277
2278 PROCEDURE skipoption errno : integer ;
2279
2280 BEGIN * SKIPOPTION *
2281 error errno ;
2282 IF no = 55 THEN GOTO 10 ;
2283 IF no = 16 THEN GOTO 1 ;
2284 skipextd 16 55 ;
2285 IF no = 55 THEN GOTO 10
2286 ELSE GOTO 1 ;
2287 END * SKIPOPTION * ;
2288
2289 * ************************************************ CHECKPLUSMINUS < TRAITEOPTIONS ********************** *
2290
2291 FUNCTION checkplusminus : boolean ;
2292
2293 BEGIN * CHECKPLUSMINUS *
2294 insymbol ;
2295 checkplusminus := false ;
2296 IF no = 7 AND cl = 1 THEN checkplusminus := true
2297 ELSE IF NOT no = 7 AND cl = 2 THEN skipoption 49 ;
2298 END * CHECKPLUSMINUS * ;
2299
2300 * ******************************************* FINDCOND < TRAITEOPTIONS ******************** *
2301
2302 PROCEDURE findcond ;
2303
2304 LABEL 5 ;
2305
2306 BEGIN
2307 work := firstcond ;
2308 5 :
2309 IF work <> NIL THEN
2310 IF work^.condname <> aval THEN
2311 BEGIN
2312 work := work^.nextcond ;
2313 GOTO 5 ;
2314 END ;
2315 END ; * findcond *
2316
2317 * ****************************** CHECKVALUE < TRAITEOPTIONS ******************* *
2318
2319 FUNCTION checkvalue : boolean ;
2320
2321 VAR
2322 invert : boolean ;
2323 BEGIN
2324 insymbol ;
2325 IF no <> 1 THEN
2326 IF NOT no = 5 AND cl = 1 THEN skipoption 314
2327 ELSE
2328 BEGIN
2329 invert := true ;
2330 insymbol ;
2331 IF no <> 1 THEN skipoption 316
2332 END
2333 ELSE invert := false ;
2334 IF aval = 'true' THEN checkvalue := true
2335 ELSE IF aval = 'false' THEN checkvalue := false
2336 ELSE BEGIN
2337 findcond ;
2338 IF work = NIL THEN skipoption 315 ;
2339 checkvalue := work^.active ;
2340 END ;
2341 IF invert THEN checkvalue := NOT checkvalue ;
2342 END * CHECKVALUE * ;
2343
2344 * ******************************* CREATECOND < TRAITEOPTIONS ***************************** *
2345
2346 PROCEDURE createcond ;
2347
2348 BEGIN
2349 new work ;
2350 IF work = NIL THEN heaperror ;
2351 WITH work^ DO
2352 BEGIN
2353 nextcond := firstcond ;
2354 condname := aval ;
2355 setinargs := false ;
2356 active := false ;
2357 activated := false ;
2358 END ;
2359 firstcond := work ;
2360
2361 END * CREATECOND * ;
2362
2363 BEGIN * TRAITEOPTION *
2364
2365 $OPTIONS compile = trace $
2366 IF anytrace > low THEN
2367 BEGIN
2368 write mpcogout ' @@@ DEBUT TRAITEOPTIONS @@@' ; nextline ;
2369 END ;
2370 $OPTIONS compile = true $
2371
2372 1 :
2373 insymbol ;
2374 IF no <> 1 THEN skipoption 47 ;
2375 ch := aval 1 ;
2376 IF NOT ch IN 'w' 'l' 't' 'e' 'c' 'p' 'd' 's' THEN skipoption 48 ;
2377 CASE ch OF
2378 'w' : BEGIN
2379 IF cl <> 3 THEN skipoption 48 ;
2380 IF NOT aval 2 IN 'd' 's' 'g' THEN skipoption 48 ;
2381 IF NOT aval 3 IN '0'..'3' THEN skipoption 48 ;
2382 CASE aval 2 OF
2383 'd' : IF NOT wdsetinargs THEN tracelevel decltrace aval 3 ;
2384 's' : IF NOT wssetinargs THEN tracelevel stattrace aval 3 ;
2385 'g' : IF NOT wgsetinargs THEN BEGIN
2386 tracelevel genetrace aval 3 ;
2387 outcode := writecode OR genetrace > none ;
2388 END ;
2389 END * CASE * ;
2390 insymbol ;
2391 END ;
2392 'l' : IF aval = 'l ' THEN
2393 BEGIN
2394 flag := checkplusminus ;
2395 IF NOT skipcode THEN
2396 BEGIN
2397 listyes := flag ;
2398 writecode := writecode AND listyes ;
2399 outcode := writecode OR genetrace > none ;
2400 END ;
2401 insymbol ;
2402 END
2403 ELSE
2404 IF aval = 'll' THEN
2405 BEGIN
2406 insymbol ;
2407 IF NOT no = 8 AND cl = 6 THEN skipoption 16 ;
2408 insymbol ;
2409 IF NOT no = 2 AND cl = 1 THEN skipoption 15 ;
2410 * WARNING : LL INEFFECTIVE *
2411 warning 222 ;
2412 insymbol ;
2413 END
2414 ELSE IF aval = 'listing' THEN
2415 BEGIN
2416 insymbol ;
2417 IF NOT no = 8 AND cl = 6 THEN skipoption 16 ;
2418 listyes := checkvalue ;
2419 writecode := writecode AND listyes ;
2420 outcode := writecode OR genetrace > none ;
2421 insymbol
2422 END
2423 ELSE skipoption 48 ;
2424 't' : IF aval = 't ' THEN
2425 BEGIN
2426 flag := checkplusminus ;
2427 IF NOT skipcode AND NOT tsetinargs THEN
2428 BEGIN
2429 divcheck := flag ;
2430 asscheck := divcheck ;
2431 inxcheck := divcheck ;
2432 END ;
2433 insymbol ;
2434 END
2435 ELSE skipoption 48 ;
2436 'p' : IF aval = 'page' THEN
2437 BEGIN
2438 IF NOT skipcode THEN skippage := true ;
2439 insymbol ;
2440 END
2441 ELSE IF aval = 'p ' THEN
2442 BEGIN
2443 flag := checkplusminus ;
2444 * WARNING : P INEFFECTIVE *
2445 warning 222 ;
2446 insymbol ;
2447 END
2448 ELSE skipoption 48 ;
2449 'e' : IF aval = 'ec' THEN
2450 BEGIN
2451 flag := checkplusminus ;
2452 * WARNING : EC INEFFECTIVE *
2453 warning 222 ;
2454 insymbol ;
2455 END
2456 ELSE skipoption 48 ;
2457 'c' : IF aval = 'cond' THEN
2458 BEGIN
2459 insymbol ;
2460 IF NOT no = 8 AND cl = 6 THEN skipoption 16 ;
2461 3 :
2462 insymbol ;
2463 IF no <> 1 THEN
2464 IF NOT no IN wnoset THEN skipoption 34
2465 ELSE
2466 IF no = 6 AND NOT cl IN 3 4 5
2467 OR no = 7 AND cl <> 3
2468 OR no = 8 AND cl <> 7 THEN skipoption 34 ;
2469 findcond ;
2470 IF work = NIL THEN
2471 createcond ;
2472 flag := checkplusminus ;
2473 WITH work^ DO
2474 IF NOT setinargs THEN active := flag ;
2475 insymbol ;
2476 IF NOT no IN 15 16 55 THEN skipoption 35 ;
2477 IF no = 15 THEN GOTO 3 ;
2478 END
2479 ELSE IF aval = 'cc' THEN
2480 BEGIN
2481 insymbol ;
2482 IF NOT no = 8 AND cl = 6 THEN skipoption 16 ;
2483 4 :
2484 insymbol ;
2485 IF no <> 1 THEN
2486 IF NOT no IN wnoset THEN skipoption 34
2487 ELSE
2488 IF no = 6 AND NOT cl IN 3 4 5
2489 OR no = 7 AND cl <> 3
2490 OR no = 8 AND cl <> 7 THEN skipoption 34 ;
2491 findcond ;
2492 IF work = NIL THEN
2493 createcond ;
2494 work^.activated := checkplusminus ;
2495 insymbol ;
2496 IF NOT no IN 15 16 55 THEN skipoption 35 ;
2497 IF no = 15 THEN GOTO 4 ;
2498 work := firstcond ;
2499 skipcode := false ;
2500 WHILE work <> NIL DO
2501 BEGIN
2502 skipcode := skipcode OR NOT work^.active AND work^.activated ;
2503 work := work^.nextcond ;
2504 END ;
2505 END
2506 ELSE IF aval = 'compile' THEN
2507 BEGIN
2508 insymbol ;
2509 IF NOT no = 8 AND cl = 6 THEN skipoption 16 ;
2510 skipcode := NOT checkvalue ;
2511 insymbol ;
2512 END
2513 ELSE skipoption 48 ;
2514 's' : IF aval = 'switch' THEN
2515 BEGIN
2516 5 :
2517 insymbol ;
2518 IF no <> 1 THEN skipoption 316 ;
2519 findcond ;
2520 IF work = NIL THEN createcond ;
2521 insymbol ;
2522 IF no = 20 THEN * := *
2523 BEGIN
2524 flag := checkvalue ;
2525 insymbol ;
2526 END
2527 ELSE flag := false ; * default *
2528 WITH work^ DO
2529 IF NOT setinargs THEN active := flag ;
2530 IF NOT no IN 15 16 55 THEN skipoption 36 ;
2531 IF no = 15 THEN GOTO 5 ;
2532 END
2533 ELSE skipoption 48 ;
2534 'd' : IF aval = 'debug' THEN
2535 BEGIN
2536 insymbol ; * = *
2537 IF NOT no = 8 AND cl = 6 THEN skipoption 16 ;
2538 flag := checkvalue ;
2539 IF NOT tsetinargs THEN
2540 BEGIN
2541 divcheck := flag ;
2542 asscheck := divcheck ;
2543 inxcheck := divcheck ;
2544 END ;
2545
2546 insymbol ;
2547 END
2548 ELSE skipoption 48 ;
2549 END * CASE * ;
2550 IF no = 16 THEN GOTO 1 ;
2551 IF no <> 55 THEN skipoption 50 ;
2552 10 :
2553 IF skipcode THEN
2554 BEGIN
2555 REPEAT
2556 insymbol ;
2557 UNTIL no = 57 ;
2558 GOTO 1 ;
2559 END ;
2560
2561 $OPTIONS compile = trace $
2562 IF anytrace > low THEN
2563 BEGIN
2564 write mpcogout ' @@@ FIN TRAITEOPTIONS @@@' ; nextline ;
2565 END ;
2566 $OPTIONS compile = true $
2567
2568 END * TRAITEOPTION * ;
2569
2570
2571 $OPTIONS page $
2572
2573 * **************************** STATEMENT BEGINS **************************** *
2574
2575 PROCEDURE statement_begins genp : boolean ;
2576
2577 BEGIN
2578 IF ic <> startic THEN
2579 BEGIN
2580 sttplace := ic ;
2581 IF genp THEN
2582 IF profile THEN genprofileref
2583 ELSE IF longprofile THEN genlongprofileref ;
2584 END ;
2585 sttindex := symbolindex ;
2586 sttline := symbolline ;
2587 sttfile := symbolfile ;
2588 startic := ic ;
2589 end_statement := false ;
2590 END * STATEMENT BEGINS * ;
2591
2592 $OPTIONS page $
2593
2594 * ****************************** STATEMENT ENDS **************************** *
2595
2596 PROCEDURE statement_ends sttlength : integer ;
2597
2598 VAR
2599 locic : integer ;
2600
2601 BEGIN
2602 IF NOT end_statement THEN
2603 IF ic <> startic THEN
2604 BEGIN
2605 statnbr := statnbr + 1 ;
2606 WITH mapptr^statnbr DO
2607 BEGIN
2608 IF oldline = sttline
2609 AND oldic <> ic
2610 AND oldfile = sttfile
2611 AND oldindex <> sttindex THEN
2612 sttinline := sttinline + 1
2613 ELSE
2614 BEGIN
2615 sttinline := 1 ;
2616 oldfile := sttfile ;
2617 oldline := sttline ;
2618 END ;
2619 oldic := ic ;
2620 oldindex := sttindex ;
2621 word1 := sttfile * twoto10 + sttline DIV twoto4 ;
2622 locic := sttplace DIV bytesinword ;
2623 insert_ locic 18 word1 ;
2624 word2 := sttinline * twoto27 + sttindex * twoto9 + sttlength MOD 256 ;
2625 insert_ sttline MOD twoto4 32 word2 ;
2626 END ;
2627 end_statement := true ;
2628 END ;
2629 END * STATEMENT ENDS * ;
2630 $OPTIONS page $
2631
2632 * *************************************************** NAMEISREF ************************ *
2633
2634 PROCEDURE nameisref box : ctp ; fil lin : integer ;
2635
2636 * C FILLS REF STRUCTURE WHEN NAME IS REFERENCED C *
2637
2638 VAR
2639 refbox : refptr ;
2640
2641 BEGIN
2642 IF NOT building_from_schema.on THEN
2643 WITH box^ DO
2644 BEGIN
2645 IF klass = vars THEN visrefincode := NOT declarationpart
2646 ELSE IF klass = proc THEN pisrefincode := NOT declarationpart AND NOT procisactive ;
2647 refbox := references ;
2648 IF refbox <> NIL THEN BEGIN
2649 IF refbox^.refnbr = maxref THEN BEGIN
2650 new refbox ;
2651 WITH refbox^ DO
2652 BEGIN
2653 nextref := references ;
2654 references := refbox ;
2655 refnbr := 1
2656 END ;
2657 END
2658 ELSE
2659 WITH refbox^ DO
2660 refnbr := refnbr + 1 ;
2661 WITH refbox^ DO
2662 WITH refs refnbr DO BEGIN
2663 filen := fil ;
2664 linen := lin ;
2665 IF environt = code AND NOT declarationpart THEN sttmapind := statnbr * 2
2666 ELSE IF lin < 0 THEN sttmapind := -1
2667 ELSE sttmapind := -2 ;
2668 END ;
2669 END ;
2670 END ;
2671
2672 END * NAMEISREF * ;
2673
2674 $OPTIONS page $
2675
2676 * ***********************************************SKIP************************* *
2677
2678 PROCEDURE skip ;
2679
2680 * C THIS PROCEDURE IS USED FOR ERROR'S RECOVERY MECHANISM.
2681 SKIPS ALL IRRELEVANT SYMBOLS DEFINED IN ERRCL
2682 STOPS ON BEGSYMBOL ENDSYMBOL OR SPECIFIED 'NOSYMB'
2683 C *
2684 BEGIN
2685 $OPTIONS compile = trace $
2686 IF anytrace > none THEN
2687 BEGIN
2688 write mpcogout ' @@@ DEBUT SKIP @@@ WITH NOSYMB= ' nosymb : 4 ; nextline ;
2689 END ;
2690 $OPTIONS compile = true $
2691 WHILE errcl no = irrelsy AND nosymb # no AND NOT eof mpcogin DO
2692 IF no = 38 AND cl = 2 * RECORD * THEN
2693 BEGIN
2694 REPEAT
2695 insymbol ; skip 46 ; * NON ASSIGNED VALUE *
2696 UNTIL NOT no IN 16 26 ; * ; CASE *
2697 IF no = 22 * END * THEN
2698 insymbol ;
2699 END ELSE
2700 insymbol ;
2701 $OPTIONS compile = trace $
2702 IF anytrace > low THEN
2703 BEGIN
2704 write mpcogout ' @@@ FIN SKIP @@@ ' ; nextline ;
2705 END ;
2706 $OPTIONS compile = true $
2707 END * SKIP * ;
2708
2709 $OPTIONS page $
2710
2711 * *********************************************** SKIPEXTD *
2712
2713 PROCEDURE skipextd ;
2714
2715 * C THIS PROCEDURE IS USED FOR ERROR'S RECOVERY MECHANISM.
2716 SKIPS ALL IRRELEVANT SYMBOLS DEFINED IN ERRCL
2717 STOPS ON BEGSYMBOL ENDSYMBOL OR SPECIFIED 'NOSYMB'S
2718 C *
2719 VAR
2720 it : integer ;
2721
2722 BEGIN * SKIPEXTD *
2723 $OPTIONS compile = trace $
2724 IF anytrace > none THEN
2725 BEGIN
2726 write mpcogout ' @@@ DEBUT SKIPEXTD @@@ WITH NOSYMB= ' ;
2727 FOR it := minno TO maxno DO
2728 IF it IN nosymb THEN
2729 write mpcogout it : 4 ;
2730 nextline ;
2731 END ;
2732 $OPTIONS compile = true $
2733 WHILE errcl no = irrelsy AND NOT no IN nosymb DO
2734 IF no = 38 AND cl = 2 * RECORD * THEN
2735 BEGIN
2736 REPEAT
2737 insymbol ; skip 46 ; * NON ASSIGNED VALUE *
2738 UNTIL NOT no IN 16 26 ; * ; CASE *
2739 IF no = 22 * END * THEN
2740 insymbol ;
2741 END ELSE
2742 insymbol ;
2743 $OPTIONS compile = trace $
2744 IF anytrace > low THEN
2745 BEGIN
2746 write mpcogout ' @@@ FIN SKIPEXTD @@@ with NO' no : 4 ; nextline ;
2747 END ;
2748 $OPTIONS compile = true $
2749 END * SKIPEXTD * ;
2750
2751 $OPTIONS page $
2752
2753 * *********************************************** SKIPTOCHAPTER *** *
2754
2755 PROCEDURE skiptochapter ;
2756
2757 * C THIS PROCEDURE IS USED FOR ERROR'S RECOVERY MECHANISM.
2758 SKIPS ALL IRRELEVANT SYMBOLS
2759 STOPS ON PROGRAM $RENAME $IMPORT $EXPORT LABEL CONST
2760 TYPE VAR $VALUE PROCEDURE FUNCTION BEGIN
2761 C *
2762 BEGIN * SKIPTOCHAPTER *
2763 $OPTIONS compile = trace $
2764 IF anytrace > none THEN
2765 BEGIN
2766 write mpcogout ' @@@ DEBUT SKIPTOCHAPTER @@@ ' ; nextline ;
2767 END ;
2768 $OPTIONS compile = true $
2769 WHILE NOT no IN 50 51 52 53 40 41 37 43 54 44 45 21 DO
2770 insymbol ;
2771 $OPTIONS compile = trace $
2772 IF anytrace > low THEN
2773 BEGIN
2774 write mpcogout ' @@@ FIN SKIPTOCHAPTER @@@ ' ; nextline ;
2775 END ;
2776 $OPTIONS compile = true $
2777 END * SKIPTOCHAPTER * ;
2778
2779
2780 $OPTIONS page $
2781
2782 * ***********************************************INCONST********************** *
2783
2784 PROCEDURE inconst VAR code : integer ; VAR restype : ctp ; fnxt : ctp ; expression_allowed : boolean ;
2785
2786 * C THIS PROCEDURE IS CALLED IN ORDER TO ANALYSE A CONSTANTE
2787 .CODE IS A CODE FOR THE CONSTANTE
2788 1 VALUE IN "CONINT" 5:SCALAR
2789 2 VALUE IN "CONREEL" 0:ERROR
2790 3 VALUE IN "BUFVAL" WITH LENGTH "LONGSTRING"
2791 4 VALUE IN "CONINT" CHARPTR
2792 .RESTYPE TYPE OF CONSTANTE
2793 .FNXT IS CTP BEGINNING OF SEARCH IN CONTEXTTABLE C *
2794 * E 50 ERROR IN CONSTANT
2795 60 OR NOT ALLOWED AS MONADIC OPERATOR
2796 103 IDENTIFIER IS NOT OF APPROPRIATE CLASS
2797 104 IDENTIFIER NOT DECLARED
2798 144 : ILLEGAL TYPE OF EXPRESSION
2799 225 : THIS EXPRESSION CANNOT BE EVALUATED HERE : IT NEEDS CODE GENERATION
2800 105 SIGN NOT ALLOWED E *
2801 VAR
2802 sign isno7 : boolean ;
2803 savectptr : ctp ;
2804 it jt : integer ;
2805 curbox : alfapt ;
2806 whattrace : levtrace ;
2807 BEGIN
2808 $OPTIONS compile = trace $
2809 IF decltrace > stattrace THEN whattrace := decltrace ELSE
2810 whattrace := stattrace ;
2811 IF whattrace > none THEN
2812 BEGIN
2813 write mpcogout ' @@@ DEBUT INCONST @@@ FNXT IS ' ord fnxt ; nextline ;
2814 IF whattrace = high THEN
2815 BEGIN
2816 write mpcogout ' GLOBALS NOCLIVALRVAL ARE ' no : 4 cl : 4 ival rval ;
2817 nextline ;
2818 END ;
2819 END ;
2820 $OPTIONS compile = true $
2821 restype := NIL ; * DEFAULT = ERROR *
2822 IF expression_allowed AND envstandard = stdextend THEN
2823 BEGIN
2824 illegal_generation := false ;
2825 initattrvarbl gattr ; freeallregisters ;
2826 expression ;
2827 IF illegal_generation THEN error 225 ;
2828 WITH gattr DO
2829 IF NOT kind IN sval chain OR typtr = NIL THEN
2830 BEGIN
2831 IF NOT illegal_generation AND typtr <> NIL THEN error 225 ;
2832 restype := NIL ; conint := 0
2833 END
2834 ELSE
2835 IF kind = sval THEN
2836 BEGIN
2837 IF typtr = intptr OR
2838 typtr^.form = scalar OR
2839 typtr = charptr THEN
2840 BEGIN
2841 restype := typtr ; conint := val
2842 END ELSE
2843 IF typtr = realptr THEN
2844 BEGIN
2845 restype := realptr ; conreel := rsval
2846 END ELSE
2847 BEGIN
2848 error 144 ;
2849 restype := NIL ; conint := 0
2850 END
2851 END ELSE
2852 BEGIN
2853 restype := alfaptr ;
2854 longstring := 0 ;
2855 IF alfactp <> NIL THEN
2856 WITH alfactp^ DO
2857 BEGIN
2858 curbox := alfadeb ; longstring := 0 ;
2859 FOR it := 1 TO alfalong DIV longalfbox DO
2860 BEGIN
2861 FOR jt := 1 TO longalfbox DO
2862 BEGIN
2863 bufval longstring + jt := curbox^.alfaval jt ;
2864 END ;
2865 longstring := longstring + longalfbox ;
2866 curbox := curbox^.nextval ;
2867 END ;
2868 FOR it := 1 TO alfalong MOD longalfbox DO
2869 BEGIN
2870 longstring := longstring + 1 ;
2871 bufval longstring := curbox^.alfaval it ;
2872 END ;
2873 END
2874 END
2875 END
2876 ELSE
2877 BEGIN * NOT EXPRESSION *
2878 IF no = 7 * + - OR * THEN
2879 BEGIN
2880 sign := cl = 2 ;
2881 IF cl = 3 THEN error 60 ;
2882 isno7 := true ;
2883 insymbol ;
2884 END ELSE
2885 BEGIN
2886 sign := false ;
2887 isno7 := false ;
2888 END ;
2889 IF no = 2 THEN * EXPLICIT CONST *
2890 BEGIN
2891 IF cl > 2 AND isno7 THEN error 105 ;
2892 CASE cl OF
2893 1 : BEGIN
2894 restype := intptr ;
2895 IF sign THEN conint := -ival ELSE conint := ival ;
2896 END ;
2897 2 : BEGIN
2898 restype := realptr ;
2899 IF sign THEN conreel := -rval ELSE conreel := rval ;
2900 END ;
2901 3 : BEGIN
2902 restype := alfaptr ;
2903 longstring := longchaine ;
2904 END ;
2905 4 : BEGIN
2906 restype := charptr ;
2907 conint := ival ;
2908 END ;
2909 END * CASE * ;
2910 insymbol ;
2911 END * NO=2 * ELSE
2912 IF no = 1 * CONSTANT IDENTIFIER * THEN
2913 BEGIN
2914 savectptr := ctptr ;
2915 srchrec fnxt ;
2916 IF ctptr = NIL THEN search ;
2917 IF ctptr = NIL THEN error 104 ELSE
2918 BEGIN
2919 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
2920 WITH ctptr@ DO
2921 BEGIN * IDENTIFIER FOUND IN CONTEXTABLE *
2922 IF klass # konst THEN error 103 ELSE
2923 BEGIN
2924 restype := contype ;
2925 IF restype = intptr THEN
2926 IF sign THEN conint := -values ELSE conint := values
2927 ELSE
2928 IF restype = realptr THEN
2929 IF sign THEN conreel := -valreel ELSE conreel := valreel
2930 ELSE
2931 BEGIN * CHARSCALAR OR ALFA CONST *
2932 IF isno7 THEN error 105 ;
2933 IF restype = alfaptr THEN
2934 BEGIN
2935 curbox := alfadeb ; longstring := 0 ;
2936 FOR it := 1 TO alfalong DIV longalfbox DO
2937 BEGIN
2938 FOR jt := 1 TO longalfbox DO
2939 BEGIN
2940 bufval longstring + jt := curbox@.alfaval jt ;
2941 END ;
2942 longstring := longstring + longalfbox ;
2943 curbox := curbox@.nextval ;
2944 END ;
2945 FOR it := 1 TO alfalong MOD longalfbox DO
2946 BEGIN
2947 longstring := longstring + 1 ;
2948 bufval longstring := curbox@.alfaval it ;
2949 END ;
2950 END * ALFA * ELSE * CHAR OR SCALAR *
2951 conint := values ;
2952 END ; * CHARSCALAR OR ALFA *
2953 END ; * KONST *
2954 END ; * WITH CTPTR *
2955 END ;
2956 ctptr := savectptr ; * RESTORE CTPTR *
2957 insymbol ;
2958 END * IDENTIFIER * ELSE
2959 error 50 ;
2960 END * NOT EXPRESSION * ;
2961 IF restype = NIL THEN code := 0 ELSE
2962 IF restype = intptr THEN code := 1 ELSE
2963 IF restype = realptr THEN code := 2 ELSE
2964 IF restype = alfaptr THEN code := 3 ELSE
2965 IF restype = charptr THEN code := 4 ELSE
2966 code := 5 ;
2967 $OPTIONS compile = trace $
2968 IF whattrace > low THEN
2969 BEGIN
2970 IF whattrace = high THEN
2971 BEGIN
2972 write mpcogout 'GLOBALS CONINTCONREEL LONGSTRING ARE' conint conreel
2973 longstring ; nextline ;
2974 END ;
2975 write mpcogout ' @@@ FIN INCONST @@@ WITH V.CODEV.RESTYPE = ' code : 3
2976 ord restype ; nextline ;
2977 END ;
2978 $OPTIONS compile = true $
2979 END * INCONST * ;
2980
2981
2982
2983
2984
2985 $OPTIONS page $
2986
2987 * ***********************************************CARTEEXEC ******************* *
2988
2989 PROCEDURE carteexec ;
2990
2991 * C MUST BE CALLED AFTER INITIALISE ; BEFORE FIRST INSYMBOL;
2992 SCANS $PARM IN ORDER TO
2993 ASSIGN TRACE'S VARIABLES
2994 STANDARD
2995 NOTRACE
2996 SYMBTABL
2997 XREFNEED C *
2998 CONST
2999 count = 100 ;
3000 VAR
3001 lfound : boolean ;
3002 lch : char ;
3003 lastread : integer ;
3004 parmlist : PACKED ARRAY 1..count OF char ;
3005
3006
3007 * *************************************SCANPARM < CARTEEXEC ****************** *
3008
3009 PROCEDURE scanparm fstring : alfa ; flong : integer ; VAR strisfound : boolean ;
3010 VAR nextchar : char ;
3011
3012 * C SCANS IN PARMLIST ON 'FSTRING' ON'FLONG' CHARS;
3013 IF FOUND RETURNS 'STRISFOUND ' TRUE AND THE NEXTCHAR
3014 IF NOT RETURNS FALSE
3015 C *
3016 LABEL
3017 1 ; * EXIT LOOP FOR *
3018 VAR
3019 i j : integer ;
3020 lalf : alfa ;
3021 BEGIN
3022 * DEFAULT VALUES *
3023 strisfound := false ; nextchar := ' ' ;
3024 lalf := blank ;
3025 FOR i := 0 TO count - flong DO
3026 BEGIN
3027 FOR j := 1 TO flong DO
3028 lalf j := parmlist i + j - 1 ;
3029 IF lalf = fstring THEN
3030 BEGIN
3031 strisfound := true ;
3032 IF i <= count - flong THEN
3033 BEGIN lastread := i + flong ;
3034 nextchar := parmlist lastread ;
3035 END ;
3036 GOTO 1 ; * EXIT LOOPS *
3037 END ;
3038 END ;
3039 1 : * EXIT LOOP FOR *
3040 END * SCANPARM * ;
3041
3042
3043 BEGIN * CARTEEXEC *
3044 checks := true ;
3045 argv 1 parmlist ;
3046 scanparm 'FAST ' 4 lfound lch ;
3047 IF lfound THEN fastoperator := true ;
3048 scanparm 'PRCODE ' 6 lfound lch ;
3049 IF lfound THEN codelist := true ;
3050 scanparm 'REFS ' 4 lfound lch ;
3051 IF lfound THEN symbolmap := true ;
3052 scanparm 'LIST ' 4 lfound lch ;
3053 IF lfound THEN
3054 BEGIN
3055 listyes := true ;
3056 symbolmap := true ;
3057 symbol_listing := true ;
3058 mapswitch := true
3059 END ;
3060 scanparm 'SKIPCODE' 8 lfound lch ;
3061 IF lfound THEN
3062 skipcode := true ; * CONDITIONAL COMPILATION *
3063 scanparm 'NOCHECKS' 8 lfound lch ;
3064 IF lfound THEN
3065 BEGIN
3066 checks := false ;
3067 tsetinargs := true ;
3068 END ;
3069 scanparm 'NOSTAND ' 7 lfound lch ;
3070 IF lfound THEN
3071 envstandard := stdextend ;
3072 scanparm 'STDSOL' 6 lfound lch ;
3073 IF lfound THEN
3074 BEGIN
3075 envstandard := stdsol ;
3076 END ;
3077 scanparm 'STRACE= ' 7 lfound lch ;
3078 IF lfound THEN
3079 BEGIN
3080 tracelevel stattrace lch ;
3081 wssetinargs := true ;
3082 END ;
3083 scanparm 'DTRACE= ' 7 lfound lch ;
3084 IF lfound THEN
3085 BEGIN
3086 tracelevel decltrace lch ;
3087 wdsetinargs := true ;
3088 END ;
3089 scanparm 'INTER' 5 lfound lch ;
3090 IF lfound THEN
3091 interactive := true ;
3092 scanparm 'NOIOW' 5 lfound lch ;
3093 IF lfound THEN
3094 iowarnings := false ;
3095 scanparm 'GTRACE= ' 7 lfound lch ;
3096 IF lfound THEN
3097 BEGIN
3098 tracelevel genetrace lch ;
3099 wgsetinargs := true ;
3100 END ;
3101 scanparm 'FRENC' 5 lfound lch ;
3102 IF lfound THEN
3103 BEGIN
3104 pascalfrench := true ;
3105 wd := wdf ; wno := wnof ; wcl := wclf ; wl1 := wl1f ; wl2 := wl2f ;
3106 usednames := usednamesf ;
3107 END ELSE
3108 BEGIN
3109 pascalfrench := false ;
3110 wd := wda ; wno := wnoa ; wcl := wcla ; wl1 := wl1a ; wl2 := wl2a ;
3111 usednames := usednamesa ;
3112 END ;
3113 scanparm 'TABLE ' 5 lfound lch ;
3114 IF lfound THEN
3115 BEGIN
3116 symbtabl := true ;
3117 mapswitch := true
3118 END ;
3119 scanparm 'BRIEFTB ' 7 lfound ch ;
3120 IF lfound THEN
3121 BEGIN
3122 brieftable := true ;
3123 mapswitch := true
3124 END ;
3125 scanparm 'LONGPROF' 8 lfound ch ;
3126 IF lfound THEN
3127 BEGIN
3128 longprofile := true ;
3129 mapswitch := true
3130 END ;
3131 scanparm 'PROFILE ' 7 lfound ch ;
3132 IF lfound THEN
3133 BEGIN
3134 profile := true ;
3135 mapswitch := true
3136 END ;
3137 scanparm 'BRIEFMAP' 8 lfound ch ;
3138 IF lfound THEN
3139 BEGIN
3140 listyes := true ;
3141 mapswitch := true
3142 END ;
3143 scanparm 'LP ' 2 lfound lch ;
3144 IF lfound THEN
3145 BEGIN * 2 DIGITS COMING NOW *
3146 pagelength := ord lch - ord '0' * 10 ;
3147 pagelength := pagelength + ord parmlist lastread + 1 - ord '0' ;
3148 END ;
3149 scanparm 'XREF ' 4 lfound lch ;
3150 IF lfound THEN
3151 xrefneed := true ;
3152 outcode := writecode OR genetrace > none ;
3153 $OPTIONS compile = trace $
3154 IF decltrace > none THEN
3155 BEGIN
3156 write mpcogout 'SKIPCODESTATTRACEDECLTRACEGENETRACESYMBTABLXREF'
3157 skipcode ord stattrace ord decltrace ord genetrace
3158 symbtabl xrefneed ;
3159 nextline
3160 END ;
3161 $OPTIONS compile = true $
3162 END * CARTEEXEC * ;
3163
3164 $OPTIONS page $
3165
3166 * ********************************************************** VERIFCOHERENCE ** *
3167
3168 $OPTIONS compile = security $
3169 PROCEDURE verifcoherence ;
3170
3171 * C
3172 On verifie que les relations qui doivent exister entre les constantes
3173 se maintiennent de VERSION en VERSION.
3174 C *
3175
3176 * E ERRORS DETECTED
3177 439 Premier groupe
3178 440 Second "
3179 441 Troisieme "
3180 E *
3181 BEGIN
3182 IF confdimsize <> confdimw * bytesinword OR
3183 eofb <> eofw * bytesinword OR
3184 eolnb <> eolnw * bytesinword OR
3185 lgparm <> lgparm1 + 1 THEN error 439 ;
3186 IF maxset + 1 <> setrange OR
3187 maxchar > maxset OR
3188 maxerrnum <> 3 * setrange - 1 OR
3189 maxpage <> maxerrnum OR
3190 maxerpg + 1 < maxpage DIV setrange THEN error 440 ;
3191 IF bitsforset <> bytesforset * bitsinbyte OR
3192 bytesforset <> wordsforset * bytesinword OR
3193 wordsforset <> bornesupset + 1 THEN error 441 ;
3194
3195 END ;
3196
3197 $OPTIONS compile = true $
3198
3199 $OPTIONS page $
3200
3201 * *************************************COMPILER'S MAIN*********************** *
3202
3203 BEGIN * MAIN *
3204 listyes := false ;
3205 new fichinter ; IF fichinter = NIL THEN heaperror ;
3206 rewrite mpcogout ;
3207 initialise ;
3208 carteexec ;
3209 IF mapswitch THEN BEGIN
3210 getmapptr mapptr ;
3211 getprofptr profptr ;
3212 IF profile THEN profilewordcount := phl ;
3213 IF longprofile THEN profilewordcount := lphl ;
3214 END ;
3215 * IF symbtabl THEN * lkc := lkc + 2 * bytesinword ;
3216 IF listyes THEN
3217 BEGIN
3218 listhead ;
3219 pageno := pageno + 1 ;
3220 iligne := 9 ;
3221 nextline ;
3222 END ;
3223 asscheck := checks ; divcheck := checks ; inxcheck := checks ;
3224 IF eof mpcogin THEN
3225 BEGIN
3226 error 22 ; GOTO 100 ;
3227 END ELSE nextch ;
3228 $OPTIONS compile = security $
3229 verifcoherence ;
3230 $OPTIONS compile = true $
3231 progdecl ; * BEFORE CALL OF INITCLASS *
3232 initclasse ;
3233 * display0.fname := next; In INITCLASSE *
3234
3235 lc := xc ;
3236 WITH display 1 DO
3237 BEGIN
3238 fname := NIL ; occur := block ;
3239 END ;
3240 top := 1 ;
3241 level := 0 ;
3242 create_dummyclass_box pt blank ;
3243 next := NIL ;
3244 IF inputflag # NIL THEN
3245 BEGIN
3246 create_vars_box inputctp usednames 1 ;
3247 WITH inputctp^ DO
3248 BEGIN
3249 vtype := textfilectp ; vkind := imported ; vlevel := 0 ;
3250 vaddr := -1 ; vptextitem := inputflag ;
3251 visused := true ; vfilelocation := standardfile ; visset := true ;
3252 deffile := inputflag^.extrfile1 ; defline := inputflag^.extrline1 ;
3253 IF symbolmap THEN
3254 IF inputflag^.extrline2 <> 0 THEN
3255 nameisref inputctp inputflag^.extrfile2 inputflag^.extrline2 ;
3256 END ;
3257 next := inputctp ; filtop := filtop + 1 ;
3258 inputflag^.extdecl := inputctp ;
3259 filpts filtop := inputctp ;
3260 END * INPUTFLAG * ;
3261 IF outputflag # NIL THEN
3262 BEGIN
3263 create_vars_box outputctp usednames 2 ;
3264 WITH outputctp^ DO
3265 BEGIN
3266 vtype := textfilectp ; vkind := imported ; vlevel := 0 ;
3267 vaddr := -1 ; vptextitem := outputflag ;
3268 visused := true ; vfilelocation := standardfile ;
3269 deffile := outputflag^.extrfile1 ; defline := outputflag^.extrline1 ;
3270 IF symbolmap THEN
3271 IF outputflag^.extrline2 <> 0 THEN
3272 nameisref outputctp outputflag^.extrfile2 outputflag^.extrline2 ;
3273 END ;
3274 next := outputctp ; filtop := filtop + 1 ;
3275 outputflag^.extdecl := outputctp ;
3276 filpts filtop := outputctp ;
3277 END * OUTPUTFLAG * ;
3278 IF errorflag # NIL THEN
3279 BEGIN
3280 create_vars_box errorctp usednames 3 ;
3281 WITH errorctp^ DO
3282 BEGIN
3283 vtype := textfilectp ; vkind := imported ; vlevel := 0 ;
3284 vaddr := -1 ; vptextitem := errorflag ;
3285 visused := true ; vfilelocation := standardfile ;
3286 deffile := errorflag^.extrfile1 ; defline := errorflag^.extrline1 ;
3287 IF symbolmap THEN
3288 IF errorflag^.extrline2 <> 0 THEN
3289 nameisref errorctp errorflag^.extrfile2 errorflag^.extrline2 ;
3290 END ;
3291 next := errorctp ; filtop := filtop + 1 ;
3292 errorflag^.extdecl := errorctp ;
3293 filpts filtop := errorctp ;
3294 END * ERRORFLAG * ;
3295
3296
3297
3298 new programnode procblock ; * ROOTNODE *
3299 currentnode := programnode ;
3300 WITH programnode^ DO BEGIN
3301 father := NIL ;
3302 brother := NIL ;
3303 son := NIL ;
3304 nextproc := NIL ;
3305 blockbox := NIL ;
3306 codebegin := 0 ;
3307 codeend := 0 ;
3308 structureplace := 0 ;
3309 first := NIL ;
3310 firstlabel := NIL ;
3311 blocktp := procblock ;
3312 hdrlin := hdrline ;
3313 hdrfil := hdrfile ;
3314 hdrlen := hdrlength ;
3315 hdrind := hdrindex ;
3316 END ;
3317
3318 * *********************************
3319 * *
3320
3321 body NIL pt ;
3322 IF no # 17 THEN error 24 ;
3323
3324 * *
3325 ********************************* *
3326
3327 compencours := false ;
3328 REPEAT
3329 nextch ;
3330 UNTIL compencours ; * ARTIFICIAL EXIT VIA *
3331 * GOTO 100 IN NEXTCH *
3332 100 : * END OF COMPILATION *
3333 IF mapswitch THEN
3334 statement_ends 0 ;
3335 wkextpt := externallistheader ;
3336 err149 := false ;
3337 WHILE wkextpt <> NIL DO
3338 BEGIN
3339
3340 IF wkextpt^.extdecl = NIL THEN
3341 IF wkextpt^.extitemtype IN extnotresolved remanentfile THEN
3342 BEGIN
3343 IF NOT err149 THEN
3344 BEGIN
3345 err149 := true ;
3346 error 149 ; printerr ;
3347 END ;
3348 IF listyes THEN write mpcogout ' NOT REDEFINED EXTERNAL NAMES :'
3349 wkextpt^.extname : maxident + 1 ; nextline ;
3350 writeln mpcogerr ' NOT REDEFINED EXTERNAL NAMES :'
3351 wkextpt^.extname : maxident + 1 ;
3352 END ;
3353 wkextpt := wkextpt^.extnext ;
3354 END ;
3355 IF programnode <> NIL THEN
3356 programnode^.codeend := statnbr * 2 ;
3357 IF nbccond # 0 THEN error 208 ;
3358 IF errinx > 0 THEN
3359 printerr ;
3360 statistiques ;
3361 linkswordcount := lkc DIV bytesinword ;
3362 IF mapswitch THEN BEGIN * END STATEMENT MAP *
3363 statnbr := statnbr + 1 ;
3364 WITH mapptr^statnbr DO
3365 BEGIN
3366 word1 := twoto18 - 1 ;
3367 insert_ ic DIV bytesinword 18 word1 ;
3368 word2 := 0 ;
3369 insert_ -1 27 word2 ;
3370 END ;
3371 IF profile THEN BEGIN
3372 insert_ statnbr - 1 * 2 18 profptr^profilewordcount ;
3373 profilewordcount := profilewordcount + pclength
3374 END ;
3375 END ;
3376 IF errtotal = 0 THEN buildobject ;
3377 IF errtotal <> 0 THEN
3378 BEGIN
3379 IF mapswitch THEN
3380 displaysources ;
3381 IF symbol_listing THEN
3382 IF programnode <> NIL THEN displaysymbols ;
3383 END ;
3384 reset fichinter ;
3385 stop errtotal ; * RETURN CODE #0 IF COMP ERRORS *
3386 END * END OF MAIN PROGRAM FOR PASCAL COMPILER ********************* *.