1 * *************************************************************************
2 * *
3 * Copyright c 1980 by Centre Interuniversitaire de Calcul de Grenoble *
4 * and Institut National de Recherche en Informatique et Automatique *
5 * *
6 ************************************************************************* *
7
8
9
10
11 * HISTORY COMMENTS:
12 1 change86-09-11JMAthane, approve86-09-11MCR7521,
13 audit86-09-15JPFauche, install86-11-12MR12.0-1212:
14 Release 8.03 for MR12
15 END HISTORY COMMENTS *)
16
17
18 $OPTIONS page $
19
20 $OPTIONS switch trace := true ; switch security := true ; t + $
21 PROGRAM unique ;
22
23 $IMPORT
24 * IMPORTED CONSTANTS *
25 'pascal_constants_$max_real alm' : maxreal ;
26 'pascal_constants_$min_real_pos alm' : minreal ;
27 * IMPORTED PROCEDURES *
28 'RACINE pascal' :
29 error,
30 initracine,
31 insymbol,
32 nextline,
33 nextpage,
34 recadre,
35 returnstop,
36 skip,
37 statement_begins ;
38 'DECLARE pascal' :
39 checkexternalitem,
40 createexternalbox,
41 initdeclare ;
42 'GENERE pascal' :
43 initgen,
44 longint ;
45 'STATE pascal' :
46 initstate ;
47 'CONTEXTTABLE pascal' :
48 add_schema_token,
49 boundary,
50 bytesneeded,
51 create_konst_box,
52 create_proc_box,
53 create_vars_box,
54 create_schema_box,
55 create_types_box ;
56 * IMPORTED VARIABLES *
57 'RACINE pascal' :
58 alfaptr,
59 aval,
60 boolptr,
61 ch8flag,
62 charptr,
63 display,
64 errorflag,
65 errorsfound,
66 errtotal,
67 inputflag,
68 intptr,
69 lamptr,
70 listyes,
71 mapswitch,
72 maxstring_ptr,
73 mpcogout,
74 next,
75 nilptr,
76 no,
77 outputflag,
78 pageserrors,
79 pascalfrench,
80 pnumptr,
81 progname,
82 programnode,
83 realptr,
84 string_ptr,
85 symbolfile,
86 symbolindex,
87 symbolline,
88 textfilectp,
89 top,
90 undecptr,
91 usednames,
92 version ;
93 'DECLARE pascal' :
94 analyzing_schema,
95 decltrace,
96 hdrfile,
97 hdrindex,
98 hdrlength,
99 hdrline,
100 firstlabbox $
101
102 $EXPORT
103 displaysymbols,
104 heaperror,
105 initclasse,
106 initialise,
107 progdecl,
108 prterrmeans,
109 statistiques $
110
111
112
113
114
115 $OPTIONS page $
116
117 $INCLUDE 'CONSTTYPE' $
118
119
120
121 $OPTIONS page $
122
123 VAR
124 * IMPORTED CONSTANTS *
125 minreal, maxreal : real ;
126 * IMPORTED FROM RACINE *
127 alfaptr : ctp ;
128 aval : alfaid ;
129 boolptr : ctp ;
130 ch8flag : boolean ;
131 charptr : ctp ;
132 display : ARRAY 0..displimit OF recidscope ;
133 errorflag : ptexternalitem ;
134 errorsfound : ARRAY 0..maxerpg OF SET OF 0..maxset ;
135 errtotal : integer ;
136 inputflag : ptexternalitem ;
137 intptr : ctp ;
138 lamptr : ctp ;
139 listyes : boolean ;
140 mapswitch : boolean ;
141 maxstring_ptr : ctp ;
142 mpcogout : text ;
143 next : ctp ;
144 nilptr : ctp ;
145 no : integer ;
146 outputflag : ptexternalitem ;
147 pageserrors : ARRAY 0..maxerpg OF SET OF 0..maxset ;
148 pascalfrench : boolean ;
149 pnumptr : ctp ;
150 progname : alfaid ;
151 programnode : blocknodeptr ;
152 realptr : ctp ;
153 string_ptr : ctp ;
154 symbolfile : integer ;
155 symbolindex : integer ;
156 symbolline : integer ;
157 textfilectp : ctp ;
158 top : integer ;
159 undecptr : ctp ;
160 usednames : typusednames ;
161 version : integer ;
162 * IMPORTED FROM DECLARE *
163 analyzing_schema : schema_status ;
164 decltrace : levtrace ;
165 firstlabbox : labelblockptr ;
166 hdrfile : integer ;
167 hdrindex : integer ;
168 hdrlength : integer ;
169 hdrline : integer ;
170
171
172 * EXPORTABLE VARIABLES *
173 * NONE *
174
175
176 * LOCAL VARIABLES *
177 currentnode : blocknodeptr ;
178 firstalfa : ctp ;
179 stdcompilernames : ARRAY 1..2 OF alfaid ;
180 stdextendnames : ARRAY 1..23 OF alfaid ;
181 stdnames,
182 stdnamesa,
183 stdnamesf : ARRAY 1..38 OF alfaid ;
184 stdsolnames,
185 stdsolnamesa,
186 stdsolnamesf : ARRAY 1..30 OF alfaid ;
187 uversion : integer ; * VERSION OF UNIQUE *
188
189
190 $OPTIONS page $
191
192 $VALUE
193 stdcompilernames = 'insert_' 'append_' ;
194 stdextendnames =
195 'maxchar' 3 * ' '
196 'date' 'time' 'mvc' 'alloc' ' '
197 'clock' 'cvptrint' 'ccsubarr' 2 * ' '
198 'log10' 'string' 'maxstring' 'length' 'maxlength' 'position' 'substr' 'insert' 'delete'
199 ;
200 stdnamesa =
201 'real' 'integer' 'maxint' 'boolean' 'false' 'true' 'char' 'text'
202 'get' 'put' 'reset' 'rewrite' 'new' 'dispose' 'read' 'readln' 'write'
203 'writeln' 'page' 'pack' 'unpack'
204 'odd' 'ord' 'chr' 'eof' 'eoln' 'abs' 'trunc' 'round' 'pred' 'succ'
205 'sqr'
206 'sin' 'cos' 'ln' 'exp' 'sqrt' 'arctan'
207 ;
208 stdnamesf =
209 'reel' 'entier' 'entmax' 'booleen' 'faux' 'vrai' 'car' 'texte'
210 'prendre' 'mettre' 'relire' 'recrire' 'creer' 'liberer' 'lire'
211 'lireln' 'ecrire' 'ecrireln' 'page' 'tasser' 'detasser'
212 'impair' 'ord' 'carac' 'fdf' 'fdln' 'abs' 'tronc' 'arrondi' 'pred'
213 'succ' 'carre' 'sin' 'cos' 'ln' 'exp' 'rac2' 'arctan'
214 ;
215 stdsolnamesa =
216 'maxreal' 'minreal' 'setmax' 2 * ' '
217 'fconnect' 'fupdate' 'fget' 'fput' 'fclose' 'fappend' 'freopen'
218 'flush' 'argv' 'stop'
219 4 * ' '
220 'fsize' 'fpos' 'fllength' 'fstatus' 'sread' 'swrite' 'argc' 4 * ' '
221 ;
222 stdsolnamesf =
223 'reelmax' 'precision' 'ensmax' ' ' ' '
224 'connecter' 'fupdate' 'fprendre' 'fmettre' 'fermer' 'allonger'
225 'reouvrir' 'vider' 'arg' 'stop'
226 ' ' ' ' ' ' ' '
227 'taille' 'poscour' 'maxligne' 'etat' 'lirech' 'ecrirech' 'nbarg'
228 4 * ' '
229 $
230
231
232 $OPTIONS page $
233
234 * HEADERS OF THE IMPORTED PROCEDURES *
235 * FROM RACINE *
236 PROCEDURE error errno : integer ; EXTERNAL ;
237 PROCEDURE nextline ; EXTERNAL ;
238 FUNCTION recadre fnumber fmod : integer : integer ; EXTERNAL ;
239 PROCEDURE nextpage ; EXTERNAL ;
240 PROCEDURE skip nosymb : integer ; EXTERNAL ;
241 PROCEDURE insymbol ; EXTERNAL ;
242 PROCEDURE returnstop ; EXTERNAL ;
243 PROCEDURE initracine ; EXTERNAL ;
244 PROCEDURE statement_begins genp : boolean ; EXTERNAL ;
245 * FROM DECLARE *
246 PROCEDURE initdeclare ; EXTERNAL ;
247 PROCEDURE checkexternalitem ai : alfaid ; VAR fpt : ptexternalitem ; EXTERNAL ;
248 PROCEDURE createexternalbox ai : alfaid ; ei : externalitemtype ; id : idkinds ;
249 VAR fpt : ptexternalitem ; EXTERNAL ;
250 * FROM GENERE *
251 PROCEDURE initgen ; EXTERNAL ;
252 FUNCTION longint i : integer : integer ; EXTERNAL ;
253 * FROM STATE *
254 PROCEDURE initstate ; EXTERNAL ;
255
256 * FROM CONTEXTTABLE *
257 FUNCTION bytesneeded objform : typform ; highest : integer ; ispack : boolean : integer ; EXTERNAL ;
258 PROCEDURE add_schema_token kind : schema_token_kind ; EXTERNAL ;
259 FUNCTION boundary objform : typform ; ispack : boolean ; pcksize : integer : integer ; EXTERNAL ;
260 PROCEDURE create_vars_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
261
262 PROCEDURE create_proc_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
263 PROCEDURE create_types_box VAR fvbox : ctp ; fname : alfaid ; fform : typform ; fbool : boolean ; EXTERNAL ;
264 PROCEDURE create_schema_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
265 PROCEDURE create_konst_box VAR fvbox : ctp ; fname : alfaid ; ftypofconst : consttype ; EXTERNAL ;
266
267 $OPTIONS page $
268
269 * *********************************************************HEAPERROR********** *
270
271 PROCEDURE heaperror ;
272
273 * C FUNCTIONS OF THIS PROCEDURE
274 . EMITS AN ERROR HEAP IS FULL
275 . EMITS EXPLICIT MSG ON LISTING
276 . STOPS COMPILATION
277 C *
278 * E ERRORS DETECTED
279 252 : COMPILER'S HEAP FULL.COMPILATION STOPS
280 E *
281 BEGIN
282 error 252 ;
283 nextline ;
284 write mpcogout ' ******** COMPILER''S HEAP IS FULL. COMPILATION STOPS' ;
285 nextline ;
286 returnstop ; * GOTO 100 IN MODULE RACINE *
287 * TO STOP COMPILATION *
288 END * HEAPERROR * ;
289
290
291 $OPTIONS page $
292
293 * ***********************************************INITIALISE******************* *
294
295 PROCEDURE initialise ;
296
297 * C INITIALIZES ALL GLOBALS USED IN COMPILER WHICH MUST BE INITIALIZED C *
298 BEGIN
299 uversion := 3 ;
300 initracine ;
301 initdeclare ;
302 initgen ;
303 initstate ;
304 IF uversion > version THEN version := uversion ;
305 END * INITIALISE * ;
306
307
308 $OPTIONS page $
309
310 * ************************************************* INITSTDPURE ****** *
311
312 PROCEDURE initstdpure ;
313 VAR
314 locpt, lp : ctp ;
315 it : integer ;
316 BEGIN * INITSTDPURE *
317
318 * TYPE OF NIL *
319 create_types_box nilptr blank pointer false ;
320 WITH nilptr ^ DO
321 BEGIN
322 size := bytesneeded pointer 0 false ;
323 cadrage := boundary pointer false 0 ;
324 pack := false ;
325 END ;
326
327 * TYPE REAL *
328 create_types_box realptr stdnames 1 reel false ;
329 WITH realptr ^ DO
330 BEGIN
331 deffile := 0 ; defline := 0 ; next := realptr ;
332 size := bytesneeded reel 0 false ;
333 cadrage := boundary reel false 0 ;
334 pack := false ;
335 END ;
336
337 * TYPE INTEGER *
338 create_types_box intptr stdnames 2 numeric false ;
339 WITH intptr ^ DO
340 BEGIN
341 deffile := 0 ; defline := 0 ; next := intptr ;
342 size := bytesneeded numeric maxint false ;
343 cadrage := boundary numeric false 0 ;
344 pack := false ;
345 npksize := size ;
346 nmax := maxint ; nmin := -maxint ;
347 END ;
348
349 * NUMERIC SUBRANGE SIMULATION OF NUMERIC SETS *
350 create_types_box locpt blank numeric false ;
351 WITH locpt ^ DO
352 BEGIN
353 size := bytesneeded numeric maxset false ;
354 cadrage := boundary numeric false 0 ;
355 pack := false ;
356 npksize := bytesneeded numeric maxset true ;
357 nmax := maxset ;
358 END ;
359
360 * TYPE OF NUMERIC SETS *
361 create_types_box pnumptr blank power false ;
362 WITH pnumptr ^ DO
363 BEGIN
364 size := bytesneeded power maxset false ;
365 cadrage := boundary power false 0 ;
366 pack := false ;
367 ppksize := bytesneeded power setmax true ;
368 setlength := setmax + 1 ;
369 elset := locpt ;
370 END ;
371
372 * CONSTANT MAXINT *
373 create_konst_box locpt stdnames 3 wordconst ;
374 WITH locpt^ DO
375 BEGIN
376 next := locpt ;
377 deffile := 0 ; defline := 0 ;
378 contype := intptr ; values := maxint ;
379 END ;
380
381 * TYPE BOOLEAN *
382 create_types_box boolptr stdnames 4 scalar false ;
383 WITH boolptr^ DO
384 BEGIN
385 next := boolptr ;
386 deffile := 0 ; defline := 0 ;
387 size := bytesneeded scalar 1 false ;
388 cadrage := boundary scalar false 0 ;
389 pack := false ;
390 spksize := bytesneeded scalar 1 true ;
391 END ;
392
393 * CONSTANTS FALSE TRUE *
394 lp := NIL ;
395 FOR it := 0 TO 1 DO
396 BEGIN
397 create_konst_box locpt stdnames 5 + it wordconst ;
398 WITH locpt^ DO
399 BEGIN
400 next := locpt ;
401 deffile := 0 ; defline := 0 ;
402 contype := boolptr ; values := it ; succ := lp ;
403 END ;
404 lp := locpt ;
405 END ;
406 boolptr^.fconst := locpt ;
407
408 * TYPE OF PREDEFINED SET OF BOOLEAN *
409 create_types_box locpt blank power false ;
410 WITH locpt ^ DO
411 BEGIN
412 deffile := 0 ; defline := 0 ;
413 size := bytesneeded power 1 false ;
414 cadrage := boundary power false 0 ;
415 pack := false ;
416 ppksize := bytesneeded power 1 true ;
417 setlength := 2 ;
418 elset := boolptr ;
419 END ;
420 boolptr^.sptcstepw := locpt ;
421
422 * TYPE CHAR *
423 create_types_box charptr stdnames 7 scalar false ;
424 WITH charptr^ DO
425 BEGIN
426 next := charptr ;
427 deffile := 0 ; defline := 0 ;
428 size := bytesneeded scalar maxchar false ;
429 cadrage := boundary scalar false 0 ;
430 pack := false ;
431 spksize := bytesneeded scalar maxchar true ;
432 END ;
433
434 * LAST CONSTANT OF TYPE CHAR *
435 create_konst_box locpt blank wordconst ;
436 WITH locpt ^ DO
437 BEGIN
438 contype := charptr ;
439 IF ch8flag THEN values := maxchar8
440 ELSE values := maxchar ;
441 END ;
442 charptr ^.fconst := locpt ;
443
444 * TYPE OF PREDEFINED SET OF CHAR *
445 create_types_box locpt blank power false ;
446 WITH locpt ^ DO
447 BEGIN
448 deffile := 0 ; defline := 0 ;
449 size := bytesneeded power maxchar false ;
450 cadrage := boundary power false 0 ;
451 pack := false ;
452 ppksize := bytesneeded power maxchar true ;
453 setlength := maxchar + 1 ;
454 elset := charptr ;
455 END ;
456 charptr^.sptcstepw := locpt ;
457
458 * TYPE OF EMPTY SET *
459 create_types_box lamptr blank power false ;
460 WITH lamptr ^ DO
461 BEGIN
462 deffile := 0 ; defline := 0 ;
463 size := bytesneeded power maxset false ;
464 cadrage := boundary power false 0 ;
465 pack := false ;
466 ppksize := bytesneeded power maxset true ;
467 setlength := maxset + 1 ;
468 END ;
469
470 * TYPE OF ALFA CONSTANTS *
471 create_types_box alfaptr blank arrays false ;
472 WITH alfaptr ^ DO
473 BEGIN
474 deffile := 0 ; defline := 0 ;
475 size := 0 ;
476 cadrage := 0 ;
477 pack := true ;
478 aeltype := charptr ; inxtype := intptr ;
479 subsize := bytesneeded scalar maxchar true ;
480 END ;
481
482 * TYPE TEXT *
483 create_types_box textfilectp stdnames 8 files false ;
484 WITH textfilectp^ DO
485 BEGIN
486 next := textfilectp ;
487 deffile := 0 ; defline := 0 ;
488 size := fsbpointersize ;
489 cadrage := bytesindword ;
490 pack := false ;
491 feltype := charptr ;
492 END ;
493
494 * PREDEFINED PROCEDURES:
495 get put reset rewrite new dispose read readln write writeln
496 page pack unpack *
497 FOR it := 0 TO 12 DO
498 BEGIN
499 create_proc_box locpt stdnames 9 + it ;
500 WITH locpt^ DO
501 BEGIN
502 next := locpt ;
503 deffile := 0 ; defline := 0 ;
504 proctype := locpt ; proclevel := 0 ; formals := NIL ;
505 segsize := it ;
506 procinscope := false ;
507 predefproc := true ; ploc := instdpure ;
508 END ;
509 END ;
510
511 * PREDEFINED FUNCTIONS *
512 * odd ord chr eof eoln abs trunc round pred succ sqr *
513 FOR it := 0 TO 10 DO
514 BEGIN
515 create_proc_box locpt stdnames 22 + it ;
516 WITH locpt^ DO
517 BEGIN
518 next := locpt ;
519 deffile := 0 ; defline := 0 ;
520 proctype := nilptr ; proclevel := 0 ; formals := NIL ;
521 segsize := it ;
522 procinscope := false ;
523 predefproc := true ; ploc := instdpure ;
524 END ;
525 END ;
526
527 * PREDEFINED SCIENTIFIC FUNCTIONS:
528 sin cos ln exp sqrt arctan *
529 FOR it := 0 TO 5 DO
530 BEGIN
531 create_proc_box locpt stdnames 33 + it ;
532 WITH locpt^ DO
533 BEGIN
534 next := locpt ;
535 deffile := 0 ; defline := 0 ;
536 proctype := realptr ; proclevel := 0 ; formals := NIL ;
537 segsize := it ;
538 procinscope := false ;
539 predefproc := true ; ploc := instdpure ;
540 END ;
541 END ;
542
543 * UNDECLARED VARIABLE associated to undeclared identifiers *
544 create_vars_box undecptr blank ;
545 WITH undecptr^ DO
546 BEGIN
547 visused := true ; visset := true ;
548 END ;
549
550 $OPTIONS compile = trace $
551 IF decltrace > low THEN
552 BEGIN
553 write mpcogout ' @@@ Fin de INITSTDPURE @@@ with NEXT UNDECPTR at^'
554 ord next ord undecptr ;
555 nextline ;
556 END ;
557 $OPTIONS compile = true $
558 END * INITSTDPURE * ;
559
560 $OPTIONS page $
561
562 * *********************************************** INITSTDSOL ************** *
563
564 PROCEDURE initstdsol ;
565
566 VAR
567 it : integer ;
568 locpt : ctp ;
569
570 BEGIN * INITSTDSOL *
571
572 * Constantes MAXREAL and MINREAL *
573 FOR it := 1 TO 2 DO
574 BEGIN
575 create_konst_box locpt stdsolnames it dwordconst ;
576 WITH locpt^ DO
577 BEGIN
578 next := locpt ;
579 deffile := 0 ; defline := 0 ;
580 contype := realptr ;
581 IF it = 1 THEN valreel := maxreal ELSE valreel := minreal ;
582 END ;
583 END ;
584
585 * Constante SOL SETMAX *
586 create_konst_box locpt stdsolnames 3 wordconst ;
587 WITH locpt^ DO
588 BEGIN
589 next := locpt ;
590 deffile := 0 ; defline := 0 ;
591 contype := intptr ; values := setmax ;
592 END ;
593
594 * SOL procedures
595 fconnectfupdatefgetfputfclosefappendfreopenflushargv
596 stop *
597 FOR it := 0 TO 9 DO
598 BEGIN
599 create_proc_box locpt stdsolnames 6 + it ;
600 WITH locpt^ DO
601 BEGIN
602 next := locpt ;
603 deffile := 0 ; defline := 0 ;
604 proctype := locpt ; proclevel := 0 ; formals := NIL ;
605 segsize := it ;
606 procinscope := false ;
607 predefproc := true ; ploc := instdsol ;
608 END ;
609 END ;
610
611 * SOL functions
612 fsize fpos fllength fstatus sread swrite argc *
613 FOR it := 0 TO 6 DO
614 BEGIN
615 create_proc_box locpt stdsolnames 20 + it ;
616 WITH locpt^ DO
617 BEGIN
618 next := locpt ;
619 deffile := 0 ; defline := 0 ;
620 proctype := nilptr ; proclevel := 0 ; formals := NIL ;
621 segsize := it ;
622 procinscope := false ;
623 predefproc := true ; ploc := instdsol ;
624 END ;
625 END ;
626 END * INITSTDSOL * ;
627
628
629 $OPTIONS page $
630
631 * ***************************************** INITSTDCOMPILER ************** *
632
633 PROCEDURE initstdcompiler ;
634
635 VAR
636 it : integer ;
637 locpt : ctp ;
638
639 BEGIN * INITSTDCOMPILER *
640 FOR it := 0 TO 1 DO
641 BEGIN
642 create_proc_box locpt stdcompilernames 1 + it ;
643 WITH locpt^ DO
644 BEGIN
645 next := locpt ;
646 deffile := 0 ; defline := 0 ;
647 proctype := locpt ; proclevel := 0 ; formals := NIL ;
648 segsize := it ;
649 procinscope := false ;
650 predefproc := true ; ploc := instdcompiler ;
651 END ;
652 END ;
653 END * INITSTDCOMPILER * ;
654
655 $OPTIONS page $
656
657 * ***************************************** INITSTDEXTEND *************** *
658
659 PROCEDURE initstdextend ;
660 VAR
661 it : integer ;
662 locpt : ctp ;
663 BEGIN * INITSTDEXTEND *
664
665
666 * CONSTANT MAXCHAR *
667 new locpt konst wordconst ; IF locpt = NIL THEN heaperror ;
668 WITH locpt^ DO
669 BEGIN
670 klass := konst ; typofconst := wordconst ;
671 name := stdextendnames 1 ; nxtel := next ; next := locpt ;
672 alfathread := NIL ; deffile := 0 ; defline := 0 ;
673 new references ; IF references = NIL THEN heaperror ; * Exit compil *
674 WITH references^ DO
675 BEGIN
676 refnbr := 0 ; nextref := NIL ;
677 END ;
678 contype := intptr ; values := maxchar ; succ := NIL ;
679 END ;
680
681
682 * EXTEND PROCEDURES
683 date time mvc alloc
684 *
685 FOR it := 0 TO 3 DO
686 BEGIN
687 create_proc_box locpt stdextendnames 5 + it ;
688 WITH locpt^ DO
689 BEGIN
690 next := locpt ;
691 deffile := 0 ; defline := 0 ;
692 proctype := locpt ; proclevel := 0 ; formals := NIL ;
693 segsize := it ;
694 procinscope := false ;
695 predefproc := true ; ploc := instdextend ;
696 END ;
697 END ;
698
699 * EXTEND FUNCTIONS
700 clock
701 cvptrint ccsubarr *
702 FOR it := 0 TO 2 DO
703 BEGIN
704 create_proc_box locpt stdextendnames 10 + it ;
705 WITH locpt^ DO
706 BEGIN
707 next := locpt ;
708 deffile := 0 ; defline := 0 ;
709 proctype := nilptr ; proclevel := 0 ; formals := nilptr ;
710 segsize := it ;
711 procinscope := false ;
712 predefproc := true ; ploc := instdextend ;
713 END ;
714 END ;
715
716 * Predefined scientific function LOG10 *
717
718 create_proc_box locpt stdextendnames 15 ;
719 WITH locpt^ DO
720 BEGIN
721 next := locpt ;
722 deffile := 0 ; defline := 0 ;
723 proctype := realptr ; proclevel := 0 ;
724 segsize := log10switch ;
725 procinscope := false ;
726 predefproc := true ; ploc := instdextend ;
727 END ;
728
729
730 * PREDEFINED MAXSTRING CONSTANT *
731
732 create_konst_box maxstring_ptr stdextendnames 17 wordconst ;
733 WITH maxstring_ptr^ DO
734 BEGIN
735 deffile := 0 ; defline := 0 ;
736 contype := intptr ; values := wordsinsegment - 1 * bytesinword ;
737 END ;
738 next := maxstring_ptr ;
739
740 * BOX FOR STRING LENGTH RANGE *
741
742 create_types_box locpt blank numeric false ;
743 WITH locpt^ DO
744 BEGIN
745 size := bytesneeded numeric maxstring_ptr^.values false ;
746 cadrage := boundary numeric false 0 ;
747 npksize := size ;
748 nmin := 0 ; nmax := maxstring_ptr^.values ;
749 END ;
750
751 * BOX FOR STRING FORMAT *
752
753 create_schema_box string_ptr stdextendnames 16 ;
754 next := string_ptr ;
755 WITH string_ptr^ DO
756 BEGIN
757 deffile := 0 ; defline := 0 ;
758 parameter_count := 1 ;
759 create_vars_box formal_parameter_list 'maxlength' ;
760 WITH formal_parameter_list^ DO
761 BEGIN
762 vtype := locpt ;
763 vkind := formal ;
764 nxtel := NIL ;
765 END ;
766 END ;
767 WITH analyzing_schema DO
768 BEGIN
769 on := true ;
770 schema_ptr := string_ptr ;
771 current_token := NIL ;
772 add_schema_token symbol_token ;
773 WITH current_token^ DO
774 BEGIN
775 tno := 38 ; tcl := 2 * "RECORD" *
776 END ;
777 add_schema_token name_token ;
778 current_token^.taval := 'length' ;
779 add_schema_token symbol_token ;
780 WITH current_token^ DO
781 current_token^.tno := 19 ; * ":" *
782 add_schema_token int_const_token ; * "0" *
783 add_schema_token symbol_token ;
784 current_token^.tno := 39 ; * ".." *
785 add_schema_token name_token ;
786 current_token^.taval := 'maxlength' ;
787 add_schema_token symbol_token ;
788 current_token^.tno := 16 ; * ";" *
789 add_schema_token name_token ;
790 current_token^.taval := 'character string' ;
791 add_schema_token symbol_token ;
792 current_token^.tno := 19 ; * : *
793 add_schema_token symbol_token ;
794 current_token^.tno := 42 ; * "PACKED" *
795 add_schema_token symbol_token ;
796 WITH current_token^ DO
797 BEGIN
798 tno := 38 ; tcl := 1 * "ARRAY" *
799 END ;
800 add_schema_token symbol_token ;
801 current_token^.tno := 11 ; * "" *)
802 add_schema_token int_const_token ; * "1" *
803 current_token^.t_int_value := 1 ;
804 add_schema_token symbol_token ;
805 current_token^.tno := 39 ; * ".." *
806 add_schema_token name_token ;
807 current_token^.taval := 'maxlength' ;
808 add_schema_token symbol_token ;
809 current_token^.tno := 12 ; * "]" *
810 add_schema_token symbol_token ;
811 current_token^.tno := 27 ; * "OF" *
812 add_schema_token name_token ;
813 current_token^.taval := charptr^.name ;
814 add_schema_token symbol_token ;
815 current_token^.tno := 22 ; * " END" *
816 END ;
817
818 * PREDEFINED STRING FUNCTIONS *
819
820 FOR it := 0 TO 3 DO
821 BEGIN
822 create_proc_box locpt stdextendnames 18 + it ;
823 WITH locpt^ DO
824 BEGIN
825 next := locpt ;
826 deffile := 0 ; defline := 0 ;
827 proctype := nilptr ; proclevel := 0 ; formals := nilptr ;
828 segsize := it + 3 ; * FROM 3 TO 6 *
829 procinscope := false ;
830 predefproc := true ; ploc := instdextend ;
831 END ;
832 END ;
833
834 * PREDEFINED STRING PROCEDURES *
835
836 FOR it := 0 TO 1 DO
837 BEGIN
838 create_proc_box locpt stdextendnames 22 + it ;
839 WITH locpt^ DO
840 BEGIN
841 next := locpt ;
842 deffile := 0 ; defline := 0 ;
843 proctype := locpt ; proclevel := 0 ; formals := NIL ;
844 segsize := it + 3 ; * FROM 3 TO 4 *
845 procinscope := false ;
846 predefproc := true ; ploc := instdextend ;
847 END ;
848 END ;
849
850 END * INITSTDEXTEND * ;
851
852
853
854
855 $OPTIONS page $
856
857 * *************************************** INITCLASSE ************************* *
858
859 PROCEDURE initclasse ;
860
861 * C By successive calls of
862 INITSTDPURE INITSTDCOMPILER
863 INITSTDSOL
864 INITSTDEXTEND
865 all suitable predefined items are created
866 As output of this procedure we have
867 INTPTR REALPTR and so on .......
868 NEXT last created name
869 DISPLAY 0 is initialized
870 C *
871
872 BEGIN * Initclasse *
873 $OPTIONS compile = trace $
874 IF decltrace > none THEN
875 BEGIN
876 write mpcogout '@@@ Debut de INITCLASSE @@@ ' ;
877 nextline ;
878 END ;
879 $OPTIONS compile = true $
880
881 next := NIL ;
882 IF pascalfrench THEN
883 BEGIN
884 stdnames := stdnamesf ; stdsolnames := stdsolnamesf ;
885 END ELSE
886 BEGIN
887 stdnames := stdnamesa ; stdsolnames := stdsolnamesa ;
888 END ;
889
890 initstdpure ;
891 initstdcompiler ;
892 initstdsol ;
893 initstdextend ;
894
895 WITH display 0 DO
896 BEGIN
897 fname := next ; occur := block ;
898 END ;
899
900 $OPTIONS compile = trace $
901 IF decltrace > low THEN
902 BEGIN
903 write mpcogout '@@@ Fin de INITCLASSE @@@ with NEXT at^'
904 ord next ;
905 nextline ;
906 END ;
907 $OPTIONS compile = true $
908 END * Initclasse * ;
909
910 $OPTIONS page $
911
912 * *************************************PROGDECL******************************* *
913
914 PROCEDURE progdecl ;
915
916 * C CALLED IN ORDER TO ANALYZE PROGRAM HEADER.
917 * MAIN PROGRAM
918 * PROGRAM NAME
919 * EXTERNAL LIST
920 C *
921 * E ERRORS DETECTED
922 2: ID. EXPECTED
923 3: 'PROGRAM' EXPECTED
924 4: '' EXPECTED
925 14: ';' EXPECTED
926 20: '' EXPECTED
927 100 : External id declared twice
928 E *)
929 VAR
930 wkextpt : ptexternalitem ;
931 BEGIN * PROGDECL *
932 $OPTIONS compile = trace $
933 IF decltrace > none THEN
934 BEGIN
935 write mpcogout ' @@@ DEBUT PROGDECL @@@ ' ; nextline ;
936 END ;
937 $OPTIONS compile = true $
938 insymbol ;
939 IF mapswitch THEN
940 BEGIN
941 hdrline := symbolline ;
942 hdrfile := symbolfile ;
943 hdrindex := symbolindex ;
944 END ;
945 IF no # 50 * PROGRAM * THEN
946 BEGIN
947 error 3 ; skip 46 ;
948 END ELSE
949 BEGIN
950 insymbol ;
951 IF no # 1 * ID * THEN
952 BEGIN
953 error 2 ; skip 9 ; * SEARCH *
954 END ELSE
955 BEGIN
956 progname := aval ;
957 insymbol ;
958 END ;
959 IF no = 9 * * THEN
960 BEGIN * EXTERNAL LIST *
961 insymbol ;
962 IF no # 1 THEN
963 BEGIN
964 error 2 ; skip 1 ; * SEARCHS NEXT ID *
965 END ;
966 WHILE no = 1 * ID * DO
967 BEGIN
968 checkexternalitem aval wkextpt ;
969 IF wkextpt <> NIL THEN error 100 ELSE
970 BEGIN
971 IF aval = usednames 1 THEN
972 createexternalbox aval requiredfile imported inputflag ELSE
973 IF aval = usednames 3 THEN
974 createexternalbox aval requiredfile imported errorflag ELSE
975 IF aval = usednames 2 THEN
976 createexternalbox aval requiredfile imported outputflag ELSE
977 createexternalbox aval remanentfile actual wkextpt ;
978 END ;
979 insymbol ;
980 IF no = 15 * * THEN
981 BEGIN
982 insymbol ;
983 IF no <> 1 THEN
984 BEGIN
985 error 2 ; skip 1
986 END
987 END ELSE
988 IF no # 10 * * THEN
989 error 20 ;
990 END * WHILE NO=1 * ;
991 IF no = 10 THEN * *
992 insymbol ELSE
993 BEGIN
994 error 4 ; skip 46 ; * SEARCHS ; *
995 END ;
996 END * NO=9 * ;
997 hdrlength := symbolindex - hdrindex ;
998 IF no # 16 * ; * THEN
999 BEGIN
1000 error 14 ; skip 16 ;
1001 END ;
1002 END * NO=50 PROGRAM * ;
1003 IF no = 16 THEN insymbol ;
1004 $OPTIONS compile = trace $
1005 IF decltrace > low THEN
1006 BEGIN
1007 write mpcogout ' @@@ FIN PROGDECL @@@ ' ; nextline ;
1008 END ;
1009 $OPTIONS compile = true $
1010 END * PROGDECL * ;
1011
1012
1013 $OPTIONS page $
1014
1015 * *********************************************************PRTERRMEANS******** *
1016
1017
1018 PROCEDURE prterrmeans VAR filetowr : text ; errornum : integer ;
1019
1020 VAR j i : integer ;
1021
1022 * ***********************************************PR00 < PRTERRMEANS*********** *
1023
1024 PROCEDURE pr00 errnumod : integer ;
1025
1026 * C ERRORS 0 TO 49 NUMBER IS ERRNUMOD C *
1027 BEGIN
1028 CASE errnumod OF
1029 1 : * 1 *
1030 write filetowr 'SCALAR OR NUMERIC EXPECTED' ;
1031 2 : * 2 *
1032 write filetowr 'IDENTIFIER EXPECTED' ;
1033 3 : * 3 *
1034 IF pascalfrench THEN
1035 write filetowr '''PROGRAMME'' EXPECTED'
1036 ELSE
1037 write filetowr '''PROGRAM'' EXPECTED' ;
1038 4 : * 4 *
1039 write filetowr ''''' EXPECTED') ;
1040 5 : * 5 *
1041 write filetowr '''..'' EXPECTED' ;
1042 6 : * 6 *
1043 write filetowr 'BOOLEAN EXPRESSION EXPECTED' ;
1044 7 : * 7 *
1045 write filetowr ''':'' EXPECTED' ;
1046 8 : * 8 *
1047 IF pascalfrench THEN
1048 write filetowr '''DE'' EXPECTED'
1049 ELSE
1050 write filetowr '''OF'' EXPECTED' ;
1051 9 : * 9 *
1052 write filetowr ''''' EXPECTED' ;
1053 10 : * 10 *
1054 write filetowr 'ERROR IN TYPE DECLARATION' ;
1055 11 : * 11 *
1056 write filetowr ''''' EXPECTED') ;
1057 12 : * 12 *
1058 write filetowr ''']'' EXPECTED' ;
1059 13 : * 13 *
1060 IF pascalfrench THEN
1061 write filetowr '''FIN'' EXPECTED'
1062 ELSE
1063 write filetowr '''END'' EXPECTED' ;
1064 14 : * 14 *
1065 write filetowr ''';'' EXPECTED' ;
1066 15 : * 15 *
1067 write filetowr 'INTEGER EXPECTED' ;
1068 16 : * 16 *
1069 write filetowr '''='' EXPECTED' ;
1070 17 : * 17 *
1071 IF pascalfrench THEN
1072 write filetowr '''DEBUT'' EXPECTED'
1073 ELSE
1074 write filetowr '''BEGIN'' EXPECTED' ;
1075 18 : * 18 *
1076 write filetowr ''' EXPECTED' ;
1077 19 : * 19 *
1078 write filetowr '"PACKED ARRAY OF CHAR" CHARACTER STRING EXPECTED' ;
1079 20 : * 20 *
1080 write filetowr ''''' EXPECTED' ;
1081 21 : * 21 *
1082 write filetowr 'ILLEGAL SHIFT COUNT' ;
1083 22 : * 22 *
1084 write filetowr 'END_OF_FILE ON INPUT FILE' ;
1085 23 : * 23 *
1086 write filetowr '"CASE LABEL" EXPECTED' ;
1087 24 : * 24 *
1088 write filetowr '''.'' EXPECTED' ;
1089 25 : * 25 *
1090 write filetowr 'INVALID TRACE OPTION IN PARAMETERS'' LIST' ;
1091 26 : * 26 *
1092 write filetowr 'PACKED ITEM NOT ALLOWED HERE' ;
1093 27 : * 27 *
1094 write filetowr 'TYPE IDENTIFIER ENCOUNTERED IN TYPE DECLARATION' ;
1095 28 : * 28 *
1096 write filetowr 'PREDEFINED PROC OR FUNCT NOT ALLOWED HERE ' ;
1097 29 : * 29 *
1098 write filetowr 'SAME LENGTH STRINGS EXPECTED HERE' ;
1099 30 : * 30 *
1100 write filetowr 'AT LEAST A DUMMY BLOC EXPECTED ' ;
1101 31 : * 31 *
1102 write filetowr 'MAIN NOT ALLOWED IN SEPARATE PROGRAM ' ;
1103 32 : * 32 *
1104 write filetowr 'OCTAL NUMBER NOT ALLOWED IN STANDARD' ;
1105 33 : * 33 *
1106 write filetowr 'HEXADECIMALBINARY NUMBER NOT ALLOWED IN STANDARD ' ;
1107 34 : * 34 *
1108 write filetowr 'CONDITION IDENTIFIER EXPECTED' ;
1109 35 : * 35 *
1110 write filetowr ''''' OR '';'' OR ''$'' EXPECTED' ;
1111 36 : * 36 *
1112 write filetowr ''''' '':='' '';'' OR ''$'' EXPECTED' ;
1113 37 :
1114 write filetowr 'SUPPLIED MULTICS IDENTIFICATION STRING ERRONEOUS' ; * 37 *
1115 38 : * 38 *
1116 write filetowr ''''' or ''$'' EXPECTED' ;
1117 39 : * 39 *
1118 write filetowr 'STRING OR ''*'' EXPECTED' ;
1119 40 : * 40 *
1120 write filetowr '''$'' EXPECTED' ;
1121 41 : * 41 *
1122 write filetowr 'THIS STRING CANNOT BE > 32 CHARS' ;
1123 42 :
1124 write filetowr 'SOL PROCEDURE IS NOT STANDARD ' ;
1125 44 :
1126 write filetowr 'SOL PROCEDURE IS NOT YET IMPLEMENTED ' ;
1127 45 :
1128 write filetowr 'EXTENDED PASCAL IS NOT STANDARD ' ;
1129 46 :
1130 write filetowr 'ARRAY OF FILE NOT YET READY ' ;
1131 47 : * 47 *
1132 write filetowr 'OPTION IDENTIFIER EXPECTED' ;
1133 48 : * 48 *
1134 write filetowr 'UNKNOWN OPTION' ;
1135 49 : * 49 *
1136 write filetowr '''+'' OR ''-'' EXTECTED' ;
1137 END ; * CASE *
1138 END * PR00 * ;
1139
1140 * ***********************************************PR01 < PRTERRMEANS*********** *
1141
1142 PROCEDURE pr01 errnumod : integer ;
1143
1144 * C ERRORS 50 TO 99 NUMBER IS 50+ERRNUMOD C *
1145 BEGIN
1146 CASE errnumod OF
1147 0 : * 50 *
1148 write filetowr 'ERROR IN CONSTANT' ;
1149 1 : * 51 *
1150 write filetowr ''':='' EXPECTED' ;
1151 2 : * 52 *
1152 IF pascalfrench THEN
1153 write filetowr '''ALORS'' EXPECTED'
1154 ELSE
1155 write filetowr '''THEN'' EXPECTED' ;
1156 3 : * 53 *
1157 IF pascalfrench THEN
1158 write filetowr '''JUSQUE'' EXPECTED'
1159 ELSE
1160 write filetowr '''UNTIL'' EXPECTED' ;
1161 4 : * 54 *
1162 IF pascalfrench THEN
1163 write filetowr '''FAIRE'' EXPECTED'
1164 ELSE
1165 write filetowr '''DO'' EXPECTED' ;
1166 5 : * 55 *
1167 IF pascalfrench THEN
1168 write filetowr '''HAUT/BAS'' EXPECTED'
1169 ELSE
1170 write filetowr '''TO/DOWNTO'' EXPECTED' ;
1171 6 : * 56 *
1172 write filetowr ' TYPE IDENTIFIER OR CONFORMANT ARRAY SCHEMA EXPECTED' ;
1173 7 : * 57 *
1174 write filetowr ' CONFORMANT ARRAY SCHEMA EXPECTED ' ;
1175 8 : * 58 *
1176 write filetowr 'ILLEGAL BEGINNING SYMBOL FOR A FACTOR' ;
1177 9 : * 59 *
1178 write filetowr 'AN IDENTIFIER CANNOT BE MORE THAN 32 CHARS LONG.' ;
1179 10 : * 60 *
1180 IF pascalfrench THEN
1181 write filetowr '''OU'' NOT ALLOWED AS MONADIC OPERATOR'
1182 ELSE
1183 write filetowr '''OR'' NOT ALLOWED AS MONADIC OPERATOR' ;
1184 11 : * 61 *
1185 write filetowr 'ILLEGAL FIRST SYMBOL IN A STATEMENT' ;
1186 12 : * 62 *
1187 write filetowr 'POINTED TYPE NOT DEFINED ' ;
1188 14 : * 64 *
1189 write filetowr ''''' OR '''' EXPECTED IN VALUE LIST') ;
1190 15 : * 65 *
1191 write filetowr 'VALUE PART ALLOWED AT GLOBAL LEVEL ONLY' ;
1192 16 : * 66 *
1193 write filetowr 'ILLEGAL OPERATION FOR THIS TYPE OF FILE' ;
1194 17 : * 67 *
1195 write filetowr '''$'' OR '';'' EXPECTED.' ;
1196 18 : * 68 *
1197 write filetowr 'RESET POINTER NOT ALLOWED IN STANDARD MODE' ;
1198 19 : * 69 *
1199 write filetowr 'VALUE PART NOT ALLOWED STANDARD' ;
1200 20 : * 70 *
1201 write filetowr 'THIS CONDITIONAL COMPILATION MECHANISM IS OBSOLETE' ;
1202 21 : * 71 *
1203 write filetowr 'PACK ATTRIBUTE ALLOWED ONLY FOR LAST DIMENSIONS' ;
1204 23 : * 73 *
1205 write filetowr 'EXTENSION USED IS NOT SOL AND NOT STANDARD' ;
1206 24 : * 74 *
1207 write filetowr 'STRING OR PACKED ARRAY OF 8 CHARS EXPECTED ' ;
1208 25 : * 75 *
1209 write filetowr 'EXTENSION USED IS SOL BUT NOT STANDARD' ;
1210 26 : * 76 *
1211 write filetowr '$ EXPECTED ' ;
1212 27 : * 77 *
1213 IF pascalfrench THEN
1214 write filetowr '$IMPORTE MUST BE AT GLOBAL LEVEL AFTER PROGRAM HEADER'
1215 ELSE
1216 write filetowr '$IMPORT MUST BE AT GLOBAL LEVEL AFTER PROGRAM HEADER' ;
1217 28 : * 78 *
1218 IF pascalfrench THEN
1219 write filetowr '$IMPORTE AND $EXPORTE ONLY SOL FEATURES'
1220 ELSE
1221 write filetowr '$IMPORT AND $EXPORT ONLY SOL FEATURES' ;
1222 29 : * 79 *
1223 IF pascalfrench THEN
1224 write filetowr '$EXPORTE ONLY ALLOWED AT MAIN LEVEL.' ELSE
1225 write filetowr '$EXPORT ONLY ALLOWED AT MAIN LEVEL.' ;
1226 30 : * 80 *
1227 write filetowr 'EXPORTED ITEM CANNOT HAVE SAME NAME THAN PROGRAM.' ;
1228 36 : * 86 *
1229 write filetowr 'FUNCTION CANNOT BE ASSIGNED HERE ' ;
1230 37 : * 87 *
1231 write filetowr 'THIS PROCEDURE MUST OCCUR IN EXTERNAL LIST' ;
1232 38 : * 88 *
1233 write filetowr 'INVALID DIRECTIVE' ;
1234 43 : * 93 *
1235 write filetowr 'UNRESOLVED FORWARD TYPE DEFINITION' ;
1236 46 : * 96 *
1237 write filetowr 'ILLEGAL POINTED ITEM' ;
1238 47 : * 97 *
1239 write filetowr 'POINTER ON A VARIABLE MUST POINT A CLASS' ;
1240 48 : * 98 *
1241 IF NOT pascalfrench THEN
1242 write filetowr '''PACKED'' NOT ALLOWED HERE'
1243 ELSE
1244 write filetowr '''PAQUET'' NOT ALLOWED HERE' ;
1245 49 : * 99 *
1246 write filetowr 'ILLEGAL FIRST ITEM FOR A SIMPLE TYPE' ;
1247 END ; * CASE *
1248 END * PR01 * ;
1249
1250 * ***********************************************PR02 < PRTERRMEANS*********** *
1251
1252 PROCEDURE pr02 errnumod : integer ;
1253
1254 * C ERRORS 100 TO 149 NUMBER IS 100+ERRNUMOD C *
1255 BEGIN
1256 CASE errnumod OF
1257 0 : * 100 *
1258 write filetowr 'EXTERNAL ITEM HAS YET BEEN USED' ;
1259 1 : * 101 *
1260 write filetowr 'IDENTIFIER DECLARED TWICE' ;
1261 2 : * 102 *
1262 write filetowr 'HIGH BOUND MUST NOT BE LOWER THAN LOW BOUND' ;
1263 3 : * 103 *
1264 write filetowr 'IDENTIFIER IS NOT OF APPROPRIATE CLASS' ;
1265 4 : * 104 *
1266 write filetowr 'IDENTIFIER NOT DECLARED' ;
1267 5 : * 105 *
1268 write filetowr 'SIGN NOT ALLOWED HERE' ;
1269 6 : * 106 *
1270 write filetowr 'INTEGER TYPE NOT ALLOWED HERE' ;
1271 7 : * 107 *
1272 write filetowr 'ERROR IN THE SELECTOR OF A RECORD' ;
1273 8 : * 108 *
1274 write filetowr 'FILE NOT ALLOWED HERE' ;
1275 9 : * 109 *
1276 write filetowr 'TYPE MUST NOT BE REAL' ;
1277 10 : * 110 *
1278 write filetowr 'ERROR IN THE TYPE IDENTIFIER OF A TAG FIELD' ;
1279 11 : * 111 *
1280 write filetowr 'TYPE INCOMPATIBLE WITH THE TYPE OF THE TAG FIELD' ;
1281 12 : * 112 *
1282 write filetowr 'TOO LARGE ARRAY .MAX SIZE IS ONE SEGMENT' ;
1283 13 : * 113 *
1284 write filetowr 'INDEX TYPE MUST BE SCALAR OR NUMERIC' ;
1285 14 : * 114 *
1286 write filetowr 'SUBRANGE TYPE MUST BE SCALAR OR NUMERIC' ;
1287 15 : * 115 *
1288 write filetowr 'BASE TYPE OF A SET MUST BE SCALAR OR NUMERIC' ;
1289 16 : * 116 *
1290 write filetowr 'CONFLICT BETWEEN FIRST DECLARATION AND REDECLARATION FORWARD' ;
1291 17 : * 117 *
1292 write filetowr 'UNDEFINED FORWARD DECLARED PROCEDURE' ;
1293 19 : * *
1294 write filetowr 'REPETITION OF PARAMETERS'' LIST NOT ALLOWED FORWARD DECLARATION' ;
1295 20 : * *
1296 write filetowr 'FUNCTION RESULT TYPE MUST BE SCALARREALSUBRANGE OR POINTER' ;
1297 21 : * 119120121 *
1298 write filetowr 'FILE OR CLASS PARAMETERS MUST BE VAR PARAMETERS' ;
1299 23 : * 123 *
1300 write filetowr 'MISSING RESULT''S TYPE IN FUNCTION DECLARATION' ;
1301 24 : * 124 *
1302 write filetowr 'CONFORMANT ARRAY PARAMETERS MUST BE VAR PARAMETERS' ;
1303 25 : * 125 *
1304 write filetowr 'ERROR IN TYPE OF STANDARD FUNCTION OR PROCEDURE PARAM.' ;
1305 26 : * 126 *
1306 write filetowr 'NUMBER OF PARAMETERS DOES NOT AGREE WITH DECLARATION' ;
1307 27 : * 127 *
1308 write filetowr 'ILLEGAL PARAMETER SUBSTITUTION ' ;
1309 28 : * 128 *
1310 write filetowr 'PARAMETER CONFLICT FOR FORMAL PROCEDURE ' ;
1311 29 : * 129 *
1312 write filetowr 'OPERAND TYPE CONFLICT' ;
1313 30 : * 130 *
1314 write filetowr 'NIL NO MORE ALLOWED IN CONSTANT PART STANDARD' ;
1315 31 : * 131 *
1316 write filetowr 'STRINGS LENGTH CONFLICT ' ;
1317 33 : * 133 *
1318 write filetowr 'ILLEGAL CONFORMANT ARRAY SUBSTITUTION' ;
1319 34 : * 134 *
1320 write filetowr 'ILLEGAL TYPE OF OPERAND' ;
1321 35 : * 135 *
1322 write filetowr 'TYPE OF OPERAND MUST BE BOOLEAN' ;
1323 38 : * 138 *
1324 write filetowr 'TYPE OF THIS VARIABLE IS NOT ARRAY OR RECORD' ;
1325 39 : * 139 *
1326 write filetowr 'INDEX TYPE IS NOT COMPATIBLE WITH ITS DECLARATION' ;
1327 40 : * 140 *
1328 write filetowr 'TYPE OF THIS VARIABLE MUST BE RECORD' ;
1329 41 : * 141 *
1330 write filetowr 'TYPE OF THIS VARIABLE MUST BE FILE OR POINTER' ;
1331 42 : * 142 *
1332 write filetowr 'TYPE OF THIS VARIABLE MUST BE ARRAY' ;
1333 43 : * 143 *
1334 write filetowr 'ELEMENT TYPE ALLOWED IS SCALAR NUMERIC OR POINTER' ;
1335 44 : * 144 *
1336 write filetowr 'ILLEGAL TYPE OF EXPRESSION' ;
1337 45 : * 145 *
1338 write filetowr 'TYPE CONFLICT' ;
1339 46 : * 146 *
1340 write filetowr 'ASSIGNEMENT TO FILE OR CLASS NOT ALLOWED' ;
1341 47 : * 147 *
1342 write filetowr 'TYPE CONFLICT WITH THE CASE SELECTOR' ;
1343 48 : * 148 *
1344 write filetowr 'CASE VECTOR TRANSFER TOO LARGE FOR THIS PROCEDURE' ;
1345 49 : * 149 *
1346 write filetowr 'EXTERNAL IDENT NOT REDEFINED ' ;
1347 END ; * CASE *
1348 END * PR02 * ;
1349
1350 * ***********************************************PR03 < PRTERRMEANS*********** *
1351
1352 PROCEDURE pr03 errnumod : integer ;
1353
1354 * C ERRORS 150 TO 199 NUMBER IS 150+ERRNUMOD C *
1355 BEGIN
1356 CASE errnumod OF
1357 0 : * 150 *
1358 write filetowr 'ASSIGNEMENT TO STANDARD FUNCTION NOT ALLOWED' ;
1359 2 : * 152 *
1360 write filetowr 'NO SUCH FIELD IN THIS RECORD' ;
1361 3 : * 153 *
1362 write filetowr 'ILLEGAL TYPE FOR ITEM READ' ;
1363 5 : * 155 *
1364 write filetowr 'FUNCTION IDENTIFIER HAS NOT BEEN ASSIGNED' ;
1365 6 : * 156 *
1366 write filetowr 'DUPLICATE CASE LABEL' ;
1367 8 : * 158 *
1368 write filetowr 'VARIANT SELECTOR DOES NOT MATCH WITH DECLARATION' ;
1369 9 : * 159 *
1370 write filetowr 'UNPACKED ARRAY EXPECTED' ;
1371 10 : * 160 *
1372 write filetowr 'PACKED ARRAY EXPECTED' ;
1373 11 : * 161 *
1374 write filetowr 'CONFORMANT ARRAY NOT READY Restriction temporary FOR PACK AND UNPACK' ;
1375 12 : * 162 *
1376 write filetowr 'ORIGIN AND TARGET NOT COMPATIBLE' ;
1377 13 : * 163 *
1378 write filetowr 'ELEMENT TOO LARGE' ;
1379 15 : * 165 *
1380 write filetowr 'MULTIDEFINED LABEL' ;
1381 16 : * 166 *
1382 write filetowr 'MULTIDECLARED LABEL' ;
1383 17 : * 167 *
1384 write filetowr 'UNDECLARED LABEL' ;
1385 18 : * 168 *
1386 write filetowr 'UNDEFINED LABELS.SEE MESSAGES LATER' ;
1387 19 : * 169 *
1388 write filetowr 'ERROR IN BASE TYPE OF A SET' ;
1389 25 : * 175 *
1390 IF pascalfrench THEN
1391 write filetowr 'ENTREE USED AND NOT DECLARED'
1392 ELSE
1393 write filetowr 'INPUT USED AND NOT DECLARED' ;
1394 26 : * 176 *
1395 IF pascalfrench THEN
1396 write filetowr 'SORTIE USED AND NOT DECLARED'
1397 ELSE
1398 write filetowr 'OUTPUT USED AND NOT DECLARED' ;
1399 28 : * 178 *
1400 write filetowr 'ALPHANUMERIC STRING IS TOO LONG' ;
1401 29 : * 179 *
1402 write filetowr 'INITIALIZATION LIST IS TOO LONG' ;
1403 30 : * 180 *
1404 write filetowr 'INITIALIZATION OF IMPORTED VARIABLE NOT ALLOWED' ;
1405 31 : * 181 *
1406 write filetowr 'THIS VARIABLE MUST BE AN ARRAY OR A RECORD' ;
1407 32 : * 182 *
1408 write filetowr 'PACKED VARIABLE NOT ALLOWED HERE' ;
1409 33 : * 183 *
1410 write filetowr 'ILLEGAL VARIABLE TYPE IN VALUE PART' ;
1411 34 : * 184 *
1412 write filetowr 'IDENTIFIER MUST BE A VARIABLE VALUE PART' ;
1413 35 : * 185 *
1414 write filetowr 'VARIABLES MUST BE INITIALIZED IN THEIR DECLARATION ORDER' ;
1415 37 : * 187 *
1416 write filetowr 'PROCEDURE USED AS A FUNCTION' ;
1417 40 : * 190 *
1418 write filetowr 'TEXT FILE EXPECTED HERE' ;
1419 41 : * 191 *
1420 write filetowr 'SCALING FACTOR ALLOWED ONLY FOR REAL' ;
1421 44 : * 194 *
1422 write filetowr 'CONTROL VARIABLE MUST BE DECLARED AND USED AT SAME LEV.' ;
1423 45 : * 195 *
1424 write filetowr 'CONTROL VARIABLE MUST BE SCALAR OR NUMERIC' ;
1425 46 : * 196 *
1426 write filetowr 'THIS VARIABLE MUST NOT BE ASSIGNED' ;
1427 47 : * 197 *
1428 write filetowr 'TRUNCATION OF STRING NOT ALLOWED' ;
1429 48 : * 198 *
1430 write filetowr 'OPERATION ALLOWED ONLY ON TEXT FILE' ;
1431 49 : * 199 *
1432 write filetowr 'CONTROL VARIABLE MUST NOT BE FORMAL OR EXTERNAL' ;
1433 END ; * CASE *
1434 END * PR03 * ;
1435
1436 * ***********************************************PR04 < PRTERRMEANS*********** *
1437
1438 PROCEDURE pr04 errnumod : integer ;
1439
1440 * C ERRORS 200 TO 249 NUMBER IS ERRNUMOD+200 C *
1441 BEGIN
1442 CASE errnumod OF
1443 0 : * 200 *
1444 write filetowr 'CHARACTER NOT ALLOWED IN PASCAL TEXT' ;
1445 1 : * 201 *
1446 write filetowr 'ERROR IN A REAL CONSTANT. DIGIT EXPECTED' ;
1447 2 : * 202 *
1448 write filetowr 'ERROR IN THE EXPONENT OF A REAL CONSTANT' ;
1449 3 : * 203 *
1450 write filetowr 'INTEGER CONSTANT OUT OF RANGE' ;
1451 4 : * 204 *
1452 write filetowr 'ILLEGAL DIGIT IN AN OCTAL CONSTANT' ;
1453 5 : * 205 *
1454 write filetowr 'EXPONENT OF A REAL CONSTANT OUT OF RANGE' ;
1455 6 : * 206 *
1456 write filetowr 'DECIMAL CONSTANT IS TOO LONG' ;
1457 7 : * 207 *
1458 write filetowr 'OCTAL CONSTANT IS TOO LONG' ;
1459 8 : * 208 *
1460 write filetowr 'ILLEGAL NESTING OF / AND /' ;
1461 9 : * 209 *
1462 write filetowr 'CHARACTERS'' STRING IS TOO LONG' ;
1463 10 : * 210 *
1464 write filetowr 'HEXADECIMAL STRING IS TOO LONG' ;
1465 11 : * 211 *
1466 write filetowr 'ILLEGAL CHARACTER IN A HEXADECIMAL STRING' ;
1467 12 : * 212 *
1468 write filetowr 'ERROR IN COMPILATION OPTIONS' ;
1469 13 : * 213 *
1470 write filetowr 'STACK FRAME MUST NOT EXCEED 60000 WORDS' ;
1471 14 : * 214 *
1472 write filetowr 'SIZE ALLOWED FOR GLOBALS EXCEEDED' ;
1473 15 : * 215 *
1474 write filetowr 'TOO MANY BINARY DIGITS.MAX IS 36 ' ;
1475 16 : * 216 *
1476 write filetowr 'INVALID BINARY DIGIT. 0 OR 1 EXPECTED ' ;
1477 17 : * 217 *
1478 write filetowr 'REAL CONSTANT CANNOT BE > 1.701411834604692317E+38' ;
1479 18 : * 218 *
1480 write filetowr 'NON NULL REAL CONSTANT CANNOT BE < 1.469367938527859385E-39' ;
1481 19 : * 218 *
1482 write filetowr 'WARNING : MAXIMUM PRECISION FOR A REAL IS 19 DIGITS' ;
1483 20 : * 220 *
1484 write filetowr 'EMPTY STRING NOT ALLOWED ' ;
1485 21 : * 221 *
1486 IF pascalfrench THEN
1487 write filetowr '''SINON'' ALREADY USED IN THIS CASE STATEMENT' ELSE
1488 write filetowr '''ELSE'' ALREADY USED IN THIS CASE STATEMENT' ;
1489 22 : * 222 *
1490 write filetowr 'WARNING : OPTION ACCEPTED BUT INEFFECTIVE.' ;
1491 23 : * 223 *
1492 write filetowr 'ILLEGAL SEPARATOR AFTER NUMBER READ ' ;
1493 24 : * 224 *
1494 write filetowr 'REFERENCE TO THIS IDENTIFIER IS NOT ALLOWED HERE' ;
1495 25 : * 225 *
1496 write filetowr 'THIS EXPRESSION CANNOT BE EVALUATED HERE : IT NEEDS CODE GENERATION' ;
1497 26 : * 226 *
1498 write filetowr 'THIS IDENTIFIER HAS BEEN PREVIOUSLY REFERENCED AT SAME LEVEL' ;
1499 27 : * 227 *
1500 write filetowr 'SOME LABELS DECLARED IN THIS PROCEDURE ARE ILLEGALLY REFERENCED' ;
1501 28 : * 228 *
1502 write filetowr 'INTEGER OVERFLOW IN EXPRESSION' ;
1503 29 : * 229 *
1504 write filetowr 'INTEGER UNDERFLOW IN EXPRESSION' ;
1505 30 : * 230 *
1506 write filetowr 'EFFECTIVE PARAMETER PASSED BY VALUE CANNOT BE A CONFORMANT ARRAY' ;
1507 31 : * 231 *
1508 write filetowr 'CONSTANT CHAIN CANNOT CONTAIN A NEW-LINE' ;
1509 END ; * CASE *
1510 END * PR04 * ;
1511
1512 * ***********************************************PR05 < PRTERRMEANS*********** *
1513
1514 PROCEDURE pr05 errnumod : integer ;
1515
1516 * C ERRORS 250 TO 299 NUMBER IS 250+ERRNUMOD C *
1517 BEGIN
1518 CASE errnumod OF
1519 0 : * 250 *
1520 write filetowr 'TOO MANY NESTED SCOPES OF IDENTIFIERS' ;
1521 1 : * 251 *
1522 write filetowr 'TOO MANY NESTED PROCEDURES ANDOR FUNCTIONS' ;
1523 2 : * 252 *
1524 write filetowr 'COMPILER''S HEAP IS FULL. INCREASE REGION' ;
1525 3 : * 253 *
1526 write filetowr 'CODE FOR THIS PROCEDURE OR VALUE IS TOO LONG' ;
1527 4 : * 254 *
1528 write filetowr 'EXPRESSION TOO COMPLICATED' ;
1529 5 : * 255 *
1530 write filetowr 'TOO MANY ERRORS ON THIS LINE' ;
1531 6 : * 256 *
1532 write filetowr 'FCONNECT IS ONLY ALLOWED ON PERMANENT FILES' ;
1533 7 : * 257 *
1534 write filetowr 'SOURCE LINE IS TOO LONG' ;
1535 8 : * 258 *
1536 write filetowr 'TOO MANY FILES' ;
1537 10 : * 260 *
1538 write filetowr 'STARTING POINT FOR THIS VARIABLE EXCEED IMPLEMENTATION LIMIT' ;
1539 11 : * 261 *
1540 write filetowr 'TOO MANY UNRESOLVED REFERENCES UNDLAB' ;
1541 17 : * 267 *
1542 write filetowr 'TOO MANY LABELS' ;
1543 18 : * 268 *
1544 write filetowr 'TOO MANY FORWARD DEFINED POINTERS' ;
1545 19 : * 269 *
1546 write filetowr 'TOO MANY CLASSES' ;
1547 20 : * 270 *
1548 write filetowr 'NOT YET IMPLEMENTED' ;
1549 21 : * 271 *
1550 write filetowr 'ACTUAL SCHEMA PARAMETER IS OF ILLEGAL TYPE' ;
1551 22 : * 272 *
1552 write filetowr 'ACTUAL SCHEMA PARAMETER IS OUT OF BOUNDS' ;
1553 23 : * 273 *
1554 write filetowr 'TARGET STRING IS TOO SHORT' ;
1555 24 : * 274 *
1556 write filetowr 'STRING EXPRESSION EXPECTED' ;
1557 25 : * 275 *
1558 write filetowr 'STRING VARIABLE REFERENCE EXPECTED' ;
1559 26 : * 276 *
1560 write filetowr 'ERROR IN DELETE : SUBSTRING TO DELETE IS OUT OF STRING BOUNDS.' ;
1561 27 : * 277 *
1562 write filetowr 'ERROR IN DELETE : SUBSTRING TO DELETE HAS NEGATIVE LENGTH' ;
1563 28 : * 278 *
1564 write filetowr 'ERROR IN SUBSTRING : SUBSTRING IS OUT OF STRING BOUNDS' ;
1565 29 : * 279 *
1566 write filetowr 'ERROR IN SUBSTRING : SUBSTRING HAS NEGATIVE LENGTH' ;
1567 30 : * 280 *
1568 write filetowr 'INTEGER EXPRESSION EXPECTED' ;
1569 31 : * 281 *
1570 write filetowr 'THIS PARAMETER MUST BE PASSED BY ADDRESS' ;
1571 END ; * CASE *
1572 END * PR05 * ;
1573
1574 * ***********************************************PR06 < PRTERRMEANS*********** *
1575
1576 PROCEDURE pr06 errnumod : integer ;
1577
1578 * C ERRORS 300 TO 349 NUMBER IS 300+ERRNUMOD C *
1579 BEGIN
1580 CASE errnumod OF
1581 0 : * 300 *
1582 write filetowr 'ZERO DIVIDE CAN BE NOT SUITABLE ' ;
1583 1 : * 301 *
1584 write filetowr 'CASE VARIANT OUT OF BOUNDS' ;
1585 2 : * 302 *
1586 write filetowr 'INDEX OUT OF BOUNDS' ;
1587 3 : * 303 *
1588 write filetowr 'VALUE ASSIGNED OUT OF BOUNDS' ;
1589 4 : * 304 *
1590 write filetowr 'CASE LABEL OUT OF BOUNDS' ;
1591 5 : * 305 *
1592 write filetowr 'VALUE IN A SET OUT OF BOUNDS' ;
1593 6 : * 306 *
1594 write filetowr 'LABEL MUST HAVE AT MOST 4 DIGITS' ;
1595 7 : * 307 *
1596 write filetowr 'ITEMS COMPARED TOO LONG ' ;
1597 8 : * 308 *
1598 write filetowr 'RIGHT ARGUMENT OF DIV IS NULL' ;
1599 9 : * 309 *
1600 write filetowr 'RIGHT ARGUMENT OF MOD IS NEGATIVE OR NULL' ;
1601 10 : * 310 *
1602 write filetowr 'VALUE ALREADY USED IN CASE SELECTOR ' ;
1603 11 : * 311 *
1604 write filetowr 'ALL POSSIBLE CASE VALUES ARE NOT MENTIONED' ;
1605 12 : * 312 *
1606 writeln filetowr 'IMPLEMENTATION RESTRICTION: MAX NUMBER OF POSSIBLE CASE VALUES IS 288.' ;
1607 13 : * 313 *
1608 writeln filetowr 'WARNING : ALL POSSIBLE CASE VALUES ARE NOT MENTIONNED' ;
1609 14 : * 314 *
1610 write filetowr '''TRUE'' ''FALSE'' ''NOT'' OR CONDITIONNAL COMPILATION SWITCH NAME EXPECTED' ;
1611 15 : * 315 *
1612 write filetowr 'CONDITIONNAL COMPILATION SWITCH NOT DEFINED' ;
1613 16 : * 316 *
1614 write filetowr '''TRUE'' ''FALSE'' OR CONDITIONNAL COMPILATION SWITCH NAME EXPECTED' ;
1615 17 : * 317 *
1616 write filetowr ''''' OR '':'' EXPECTED' ;
1617 18 : * 318 *
1618 write filetowr 'PARAMETER PROCEDURE PASSED TO AN EXTERNAL PROCEDURE MUST BE EXPORTABLE' ;
1619 44 : * 344 *
1620 write filetowr 'EXTENDED DISPOSE NOT ALLOWED' ;
1621 45 : * 345 *
1622 write filetowr 'NEW IS LIMITED TO 261094 WORDS' ;
1623 END ; * CASE *
1624 END * PR06 * ;
1625
1626 * ***********************************************PR07 < PRTERRMEANS********** *
1627
1628 PROCEDURE pr07 errnumod : integer ;
1629
1630 * C ERRORS 350 TO 399 NUMBER IS 350+ERRNUMOD C *
1631 BEGIN
1632 CASE errnumod OF
1633 0 : * 350 *
1634 write filetowr 'RECADRE BAD ARGUMENTS' ;
1635 1 : * 351 *
1636 write filetowr 'BYTESNEEDED OBJFORM=ALIASTYPE' ;
1637 2 : * 352 *
1638 write filetowr 'BYTESNEEDED BAD ARGUMENT' ;
1639 3 : * 353 *
1640 write filetowr 'BOUNDARY OBJFORM=ALIASTYPE' ;
1641 4 : * 354 *
1642 write filetowr 'BOUNDARY BAD ARGUMENT' ;
1643 5 : * 355 *
1644 write filetowr 'GENSTAND ILLEGAL SHIFT COUNT' ;
1645 6 : * 356 *
1646 write filetowr 'GENSTAND ILLEGAL OP. CODE WITHOUT POINTER REGISTER' ;
1647 7 : * 357 *
1648 write filetowr 'GENSTAND TAG FIELD INCOMPATIBLE WITH OP. CODE' ;
1649 8 : * 358 *
1650 write filetowr 'GENWITHPR ILLEGAL ADDRESS WITHOUT POINTER REGISTER' ;
1651 9 : * 359 *
1652 write filetowr 'TEMPORARY RESTRICTION: GLOBALS MUST BE < 16384 WORDS ' ;
1653 10 : * 360 *
1654 write filetowr 'GENSTOBC ILLEGAL BYTES'' POSITION FIELD' ;
1655 11 : * 361 *
1656 write filetowr 'GENREPT ILLEGAL TALLY' ;
1657 12 : * 362 *
1658 write filetowr 'GENREPT ILLEGAL TERMINATION CONDITION' ;
1659 13 : * 363 *
1660 write filetowr 'GENREPT ILLEGAL DELTA' ;
1661 14 : * 364 *
1662 write filetowr 'GENREPT BITS 8910 INCOMPATIBLE WITH OP. CODE' ;
1663 15 : * 365 *
1664 write filetowr 'GENIPAIR ILLEGAL SEGMENT NUMBER' ;
1665 16 : * 366 *
1666 write filetowr 'GENIPAIR ILLEGAL SECOND WORD IN AN ITP OR ITS PAIR' ;
1667 17 : * 367 *
1668 write filetowr 'GENEISM ILLEGAL TAG IN AN EIS MODIFICATION FIELD' ;
1669 18 : * 368 *
1670 write filetowr 'GENEISM BITS 0910 INCOMPATIBLE WITH OP. CODE' ;
1671 19 : * 369 *
1672 write filetowr 'GENEISM ILLEGAL FIELD 0-8' ;
1673 20 : * 370 *
1674 write filetowr 'GENINDW ILLEGAL TAG IN AN INDIRECT WORD' ;
1675 21 : * 371 *
1676 write filetowr 'GENINDW USE OF PREG NOT ALLOWED IN AN INDIRECT WORD' ;
1677 22 : * 372 *
1678 write filetowr 'LENGTHCTRL ILLEGAL EIS OPERAND LENGTH' ;
1679 23 : * 373 *
1680 write filetowr 'GENDESCA_B_N ILLEGAL CHARACTERS'' COUNT' ;
1681 24 : * 374 *
1682 write filetowr 'LENGTHCTRL ILLEGAL MODIFIER' ;
1683 25 : * 375 *
1684 write filetowr 'GENDESCB ILLEGAL BITS'' COUNT' ;
1685 26 : * 376 *
1686 write filetowr 'GENDESCN ILLEGAL SCALING FACTOR' ;
1687 27 : * 377 *
1688 write filetowr 'GENINDIT ILLEGAL TALLY OR TAG' ;
1689 29 : * 379 *
1690 write filetowr 'PACKEDSIZE ILLEGAL ITEM' ;
1691 31 : * 381 *
1692 write filetowr 'ERROR ERROR NUMBER IS TOO HIGH' ;
1693 32 : * 382 *
1694 write filetowr 'ERROR PAGE NUMBER IS TOO HIGH' ;
1695 33 : * 383 *
1696 write filetowr 'NEXTPAGE PAGE NUMBER BECOMES TOO HIGH' ;
1697 34 : * 384 *
1698 write filetowr 'CHECKMINMAX FCTP=NIL' ;
1699 35 : * 385 *
1700 write filetowr 'CHECKMINMAX FCTP@.FORM IS BAD' ;
1701 36 : * 386 *
1702 write filetowr 'CHECKMINMAX FCONST=NIL' ;
1703 40 : * 390 *
1704 write filetowr 'LOCAL STACK STORAGE OVERFLOW : CANNOT BE > 16384 WORDS' ;
1705 41 : * 391 *
1706 write filetowr 'ILLEGAL OFFSET IN INSTRUCTION GENERATION. CONTACT MAINTENANCE.' ;
1707 END ; * CASE *
1708 END * PR07 * ;
1709
1710 * ***********************************************PR08 < PRTERRMEANS*********** *
1711
1712 PROCEDURE pr08 errnumod : integer ;
1713
1714 * C ERRORS 400 TO 449 NUMBER IS 400+ERRNUMOD C *
1715 BEGIN
1716 CASE errnumod OF
1717 0 : * 400 *
1718 write filetowr 'LDREGBLOC IS NILTRANSFER OUT' ;
1719 1 : * 401 *
1720 write filetowr 'LCOND IS SAVEDTRANSFER IN' ;
1721 2 : * 402 *
1722 write filetowr 'FORM # NUMERICCONVREAL' ;
1723 3 : * 403 *
1724 write filetowr 'BLOC NOT FOUNDSAUVEREG' ;
1725 4 : * 404 *
1726 write filetowr 'REGISTER ALREADY SAVEDSAUVEREG' ;
1727 5 : * 405 *
1728 write filetowr 'FATTR IS NOT CHAIN OR VARBLLOADADR' ;
1729 6 : * 406 *
1730 write filetowr 'FMIN > FMAX INBOUNDS' ;
1731 7 : * 407 *
1732 write filetowr 'EMPTY STRINGINSERUNDLAB' ;
1733 8 : * 408 *
1734 write filetowr 'FPLACE OUT OF RANGEINSER' ;
1735 9 : * 409 *
1736 write filetowr 'OFFSET TOO LARGEINSER' ;
1737 10 : * 410 *
1738 write filetowr 'INSER ON HALF-WORD # 0 INSER' ;
1739 11 : * 411 *
1740 write filetowr 'TYPTR = NILCONVREAL' ;
1741 12 : * 412 *
1742 write filetowr 'TYPTR = NILCALCVARIANT' ;
1743 13 : * 413 *
1744 write filetowr 'KIND = LVALNOT SAVEDCALCVARIANT' ;
1745 14 : * 414 *
1746 write filetowr 'KIND = CHAIN/LCOND CALCVARANT' ;
1747 16 : * 416 *
1748 write filetowr 'LVAL SAVED TRANSFER IN' ;
1749 17 : * 417 *
1750 write filetowr 'FREEBLOC CALLED WITH DUMMYBLOC' ;
1751 18 : * 418 *
1752 write filetowr 'INCORRECT SOURCE TRANSFER IN' ;
1753 19 : * 419 *
1754 write filetowr 'TYPSEQ=0 GENOPMULT ' ;
1755 20 : * 420 *
1756 write filetowr 'FATTR.KIND # VARBL TRANSFER OUT' ;
1757 21 : * 421 *
1758 write filetowr 'GATTR.KIND # LVAL TRANSFER OUT' ;
1759 22 : * 422 *
1760 write filetowr 'GATTR.KIND CHAIN IN CHOICERARQ' ;
1761 23 : * 423 *
1762 write filetowr 'FCTP = NIL FINDMINMAX' ;
1763 24 : * 424 *
1764 write filetowr 'FCTP@.KLASS # TYPES FINDMINMAX' ;
1765 25 : * 425 *
1766 write filetowr 'FATTR.KIND # LVAL LVALVARBL' ;
1767 26 : * 426 *
1768 write filetowr 'NO BLOC ASSOCIATED TO THE REGISTER LVALVARBL' ;
1769 27 : * 427 *
1770 write filetowr 'OLDBLOC = NIL REGENERE' ;
1771 28 : * 428 *
1772 write filetowr 'REGISTER NOT SAVED AND NOT LOAD REGENERE' ;
1773 29 : * 429 *
1774 write filetowr 'SOME REGISTER BOX NOT FREED FREEALLREGISTER' ;
1775 30 : * 430 *
1776 write filetowr 'TYPTR = NIL EASYVAR' ;
1777 31 : * 431 *
1778 write filetowr 'KIND # VARBL EASYVAR' ;
1779 32 : * 432 *
1780 write filetowr 'TYPSEQ = 0 GENOPADD' ;
1781 33 : * 433 *
1782 write filetowr 'TYPSEQ = 0 GENOPSUB' ;
1783 34 : * 434 *
1784 write filetowr 'TYPSEQ=0 GENCOMPARE' ;
1785 35 : * 435 *
1786 write filetowr 'REGISTER NOT SAVED AND NOT LOADFREEBLOC' ;
1787 36 : * 436 *
1788 write filetowr 'PROCKIND = FORMAL OR IMPORTEDGENPRCEXIT' ;
1789 37 : * 437 *
1790 write filetowr 'FORM NOT NUMERIC OR SCALAR FINDMINMAX' ;
1791 38 : * 438 *
1792 write filetowr 'FCTP = NIL ADDRESSVAR' ;
1793 39 : * 439 *
1794 write filetowr 'VERIF COHERENCE ERREUR PREMIER GROUPE ' ;
1795 40 : * 440 *
1796 write filetowr 'VERIF COHERENCE ERREUR DEUXIEME GROUPE ' ;
1797 41 : * 441 *
1798 write filetowr 'VERIF COHERENCE ERREUR TROISIEME GROUPE' ;
1799 42 : * 442 *
1800 write filetowr 'GENBINAREA FAILED. CONTACT MAINTENANCE' ;
1801 46 : * 446 *
1802 write filetowr ' CHECKEXTERNALITEM COMPILER ERROR ' ;
1803 47 : * 447 *
1804 write filetowr 'EXPORTPARTDECL ERROR ' ;
1805 48 : * 448 *
1806 write filetowr 'EXTERNAL DESCRIPTOR CANNOT BE GENERATED FOR SUCH A PARAMETER' ;
1807 END ; * CASE *
1808 END * PR08 * ;
1809
1810 * ***********************************************PR09 < PRTERRMEANS*********** *
1811 PROCEDURE pr09 errnumod : integer ;
1812
1813 * C ERRORS 450 TO 499 NUMBER IS 450+ERRNUMOD C *
1814 BEGIN
1815 CASE errnumod OF
1816 0 : * DUMMY * ;
1817 END ; * CASE *
1818 END * PR09 * ;
1819
1820 * ***********************************************PR10 < PRTERRMEANS*********** *
1821
1822 PROCEDURE pr10 errnumod : integer ;
1823
1824 * C ERRORS 500 TO 549 NUMBER IS 500+ERRNUMOD C *
1825 BEGIN
1826 CASE errnumod OF
1827 0 : * 500 *
1828 write filetowr 'INTERNAL ERROR Genentrypoint . Exitlabel. CONTACT MAINTENANCE' ;
1829 1 : * 501 *
1830 write filetowr 'INTERNAL ERROR Genentrypoint . Genprolog main. CONTACT MAINTENANCE' ;
1831 2 : * 502 *
1832 write filetowr 'INTERNAL ERROR Genentrypoint . Link to main . CONTACT MAINTENANCE' ;
1833 3 : * 503 *
1834 write filetowr 'INTERNAL ERROR Genentrypoint . Genprocentry . CONTACT MAINTENANCE' ;
1835 4 : * 504 *
1836 write filetowr 'INTERNAL ERROR Genbinarea . Writout . CONTACT MAINTENANCE' ;
1837 5 : * 505 *
1838 write filetowr 'INTERNAL ERROR Genentrypoint . Imported procedure CONTACT MAINTENANCE' ;
1839 6 : * 506 *
1840 write filetowr 'INTERNAL ERROR Link pour export non init Valuedecl CONTACT MAINTENANCE' ;
1841 7 : * 507 *
1842 write filetowr 'INTERNAL ERROR Genbinarea Valuedecl CONTACT MAINTENANCE' ;
1843 8 : * 508 *
1844 write filetowr 'INTERNAL ERROR Genextvariable Exportable Init CONTACT MAINTENANCE' ;
1845 9 : * 509 *
1846 write filetowr 'INTERNAL ERROR Genexportfile Valuedecl CONTACT MAINTENANCE' ;
1847 10 : * 510 *
1848 write filetowr 'INTERNAL ERROR Genentrypoint LINKTOEND CONTACT MAINTENANCE' ;
1849 11 : * 511 *
1850 write filetowr 'ALREADY BUILDING TYPE FROM SHEMA INTERNAL ERROR. PLEASE CONTACT MAINTENANCE' ;
1851 END ; * CASE *
1852 END * PR10 * ;
1853
1854 * ***********************************************PR11 < PRTERRMEANS*********** *
1855
1856 PROCEDURE pr11 errnumod : integer ;
1857
1858 * C ERRORS 550 TO 599 NUMBER IS 550+ERRNUMOD C *
1859 BEGIN
1860 CASE errnumod OF
1861 0 : * DUMMY * ;
1862 END ; * CASE *
1863 END * PR11 * ;
1864
1865 * ***********************************************PR12 < PRTERRMEANS*********** *
1866
1867 PROCEDURE pr12 errnumod : integer ;
1868
1869 * C ERRORS 600 TO 639 NUMBER IS 600+ERRNUMOD C *
1870 BEGIN
1871 CASE errnumod OF
1872 0 : * DUMMY * ;
1873 40 41 42 43 44 45 46 47 48 49 :
1874 write filetowr '*** PR12 ERRNUMOD > 39 ***' ;
1875 END ; * CASE *
1876 END * PR12 * ;
1877
1878 BEGIN * PRTERRMEANS *
1879 write filetowr ' ' errornum : 4 ' : ' ;
1880 i := errornum DIV 50 ; j := errornum MOD 50 ;
1881 CASE i OF
1882 0 : pr00 j ;
1883 1 : pr01 j ;
1884 2 : pr02 j ;
1885 3 : pr03 j ;
1886 4 : pr04 j ;
1887 5 : pr05 j ;
1888 6 : pr06 j ;
1889 7 : pr07 j ;
1890 8 : pr08 j ;
1891 9 : pr09 j ;
1892 10 : pr10 j ;
1893 11 : pr11 j ;
1894 12 : pr12 j ;
1895 END * CASE I * ; * NEXTLINE MADE IN 'STATISTIQUES' *
1896 END * PRTERRMEANS * ;
1897
1898
1899 $OPTIONS page $
1900
1901 * ************************************************* DISPLAYSYMBOLS **************************************** *
1902
1903 PROCEDURE displaysymbols ;
1904
1905 * C CALLED IF LISTYES BY RACINE AT THE END OF COMPILATION
1906 PRINTS SYMBOL MAP ON LISTING OUTPUT C *
1907
1908 CONST
1909 llmax = 126 ;
1910 TYPE
1911 alfalistrange = 0..26 ;
1912 VAR
1913 i : integer ;
1914 tittle : boolean ;
1915 tittlestring : PACKED ARRAY 1..50 OF char ;
1916 p1 p2 refbox : refptr ;
1917 currlabbox : labelblockptr ;
1918 checkunused : boolean ;
1919 lastbox cctp : ctp ; * CURRENT SYMBOL BOX *
1920 n ll it lastit : integer ;
1921 alfalist : ARRAY alfalistrange OF RECORD
1922 firstname lastname : ctp ;
1923 END ;
1924 output_string : PACKED ARRAY 1..200 OF char ;
1925
1926 * ********************************************** PRINTOCT < DISPLAYSYMBOLS ************************ *
1927
1928 PROCEDURE printoct nb : integer ;
1929
1930 VAR
1931 tab : ARRAY 1..7 OF integer ;
1932 j k : integer ;
1933
1934 BEGIN
1935 FOR j := 7 DOWNTO 1 DO
1936 BEGIN
1937 tab j := nb MOD 8 ;
1938 nb := nb DIV 8 ;
1939 END ;
1940 k := 1 ;
1941 WHILE tab k = 0 AND k < 7 DO
1942 k := k + 1 ;
1943 FOR j := k TO 7 DO
1944 ll := swrite output_string ll chr ord '0' + tab j ;
1945 END * PRINTOCT * ;
1946
1947
1948 * ************************************************* SPLIT < DISPLAYSYMBOLS ********************************* *
1949
1950 PROCEDURE split ;
1951
1952 BEGIN
1953 writeln mpcogout output_string : ll - 1 ;
1954 IF checkunused THEN ll := maxident + 9 ELSE ll := maxident + 7 ;
1955 ll := ll + 2 ; * INDENT *
1956 ll := swrite output_string 1 ' ' : ll ;
1957 END * SPLIT * ;
1958
1959
1960 * ************************************************* PRINTREFS < DISPLAYSYMBOLS ************************ *
1961
1962 PROCEDURE printrefs ;
1963
1964 VAR
1965 p1 p2 refbox : refptr ;
1966 i n : integer ;
1967 newl : boolean ;
1968
1969 BEGIN
1970 IF ll >= llmax THEN split ;
1971 newl := false ;
1972 WITH cctp^ DO
1973 BEGIN
1974 IF defline <> 0 THEN BEGIN
1975 ll := swrite output_string ll ' ; DEF: ' ;
1976 IF deffile <> 0 THEN
1977 ll := swrite output_string ll deffile : 1 '-' ;
1978 ll := swrite output_string ll defline : 1 ;
1979 END ;
1980 IF references^.refnbr <> 0 THEN BEGIN
1981 IF ll >= llmax THEN split ;
1982 ll := swrite output_string ll ' ; REF: ' ;
1983 refbox := references ;
1984 p1 := NIL ;
1985 WHILE refbox^.nextref <> NIL DO BEGIN
1986 p2 := refbox^.nextref ;
1987 refbox^.nextref := p1 ;
1988 p1 := refbox ;
1989 refbox := p2 ;
1990 END ;
1991 refbox^.nextref := p1 ;
1992 REPEAT
1993 WITH refbox^ DO
1994 FOR i := 1 TO refnbr DO
1995 WITH refs i DO
1996 BEGIN
1997 IF ll >= llmax THEN split ;
1998 IF filen <> 0 THEN
1999 ll := swrite output_string ll filen : 1 '-' ;
2000 IF linen < 0 THEN
2001 ll := swrite output_string ll -linen : 1 '* '
2002 ELSE
2003 ll := swrite output_string ll linen : 1 ' ' ;
2004 END ;
2005 refbox := refbox^.nextref ;
2006 UNTIL refbox = NIL ;
2007 END ;
2008 writeln mpcogout output_string : ll - 1 ;
2009 END
2010 END * PRINTREFS * ;
2011
2012 * *********************************************** PRINTTYPE < DISPLAYSYMBOLS **************************** *
2013
2014 PROCEDURE printtype cctp : ctp ;
2015
2016 VAR
2017 m i : integer ;
2018
2019 BEGIN
2020 IF ll >= llmax THEN split ;
2021 WITH cctp^ DO BEGIN
2022 IF defline = 0 AND name <> blank THEN * PREDEFINED *
2023 BEGIN
2024 i := 1 ;
2025 WHILE name i <> ' ' DO BEGIN
2026 ll := swrite output_string ll name i ;
2027 i := i + 1 ;
2028 END ;
2029 END
2030 ELSE
2031 IF cctp^.father_schema <> NIL THEN
2032 BEGIN
2033 IF cctp^.father_schema <> NIL THEN
2034 WITH cctp^.father_schema^ DO
2035 BEGIN
2036 i := 1 ;
2037 REPEAT
2038 IF name i <> ' ' THEN
2039 ll := swrite output_string ll name i
2040 ELSE
2041 i := maxident ;
2042 i := i + 1
2043 UNTIL i > maxident ;
2044 END ;
2045 END
2046 ELSE
2047 CASE form OF
2048 reel :
2049 ll := swrite output_string ll 'real' ;
2050 numeric :
2051 ll := swrite output_string ll 'numeric ' nmin : 1 '..' nmax : 1 ;
2052 scalar :
2053 BEGIN
2054 ll := swrite output_string ll 'scalar' ;
2055 IF subrng THEN
2056 ll := swrite output_string ll ' subrange' ;
2057 END ;
2058 pointer :
2059 ll := swrite output_string ll 'pointer' ;
2060 power :
2061 BEGIN
2062 ll := swrite output_string ll 'set of ' ;
2063 IF cctp^.elset <> NIL THEN printtype cctp^.elset ;
2064 ll := swrite output_string ll '' ;
2065 END ;
2066 arrays :
2067 BEGIN
2068 IF conformant THEN
2069 ll := swrite output_string ll 'conformant ' ;
2070 ll := swrite output_string ll 'array of ' ;
2071 IF cctp^.aeltype <> NIL THEN printtype cctp^.aeltype ;
2072 ll := swrite output_string ll '' ;
2073 END ;
2074 records :
2075 ll := swrite output_string ll 'record' ;
2076 files :
2077 ll := swrite output_string ll 'file' ;
2078 aliastype :
2079 IF cctp^.realtype <> NIL THEN printtype cctp^.realtype ;
2080 END ;
2081 END
2082 END * PRINTTYPE * ;
2083
2084 * *********************************************************** PRINTSYMBOL < DISPLAYSYMBOLS ******************* *
2085
2086 PROCEDURE printsymbol ;
2087
2088 VAR
2089 dw bc : integer ;
2090 i : integer ;
2091 bp : blocknodeptr ;
2092 lctp : ctp ;
2093
2094 BEGIN
2095 IF NOT tittle THEN
2096 BEGIN
2097 writeln mpcogout ' ' tittlestring ;
2098 writeln mpcogout ;
2099 tittle := true ;
2100 END ;
2101 WITH cctp^ DO
2102 BEGIN
2103 CASE klass OF
2104 schema :
2105 BEGIN
2106 IF checkunused THEN
2107 ll := swrite output_string 1 name ' * schem ' ELSE
2108 ll := swrite output_string 1 name ' schem ' ;
2109 printrefs ;
2110 END ;
2111 types :
2112 BEGIN
2113 IF checkunused THEN
2114 ll := swrite output_string 1 name ' * type ' ELSE
2115 ll := swrite output_string 1 name ' type ' ;
2116 IF cctp^.pack THEN
2117 IF cctp^.defline <> 0 THEN
2118 ll := swrite output_string ll 'packed ' ;
2119 printtype cctp ;
2120 printrefs ;
2121 END ;
2122 vars :
2123 BEGIN
2124 IF checkunused THEN
2125 ll := swrite output_string 1 name ' * var ' ELSE
2126 ll := swrite output_string 1 name ' var ' ;
2127 CASE vkind OF
2128 actual :
2129 BEGIN
2130 IF vlevel = 0 THEN
2131 ll := swrite output_string ll 'global'
2132 ELSE BEGIN
2133 ll := swrite output_string ll 'local to ' ;
2134 IF nxtel <> NIL THEN
2135 WITH nxtel^ DO
2136 BEGIN
2137 i := 1 ;
2138 REPEAT
2139 IF name i <> ' ' THEN
2140 ll := swrite output_string ll name i
2141 ELSE
2142 i := maxident ;
2143 i := i + 1
2144 UNTIL i > maxident ;
2145 END ;
2146 END ;
2147 ll := swrite output_string ll ' loc:' ;
2148 dw := vaddr DIV bytesinword ;
2149 bc := vaddr MOD bytesinword * bitsinbyte ;
2150 printoct dw ;
2151 IF bc <> 0 THEN
2152 ll := swrite output_string ll '' bc : 1 '' ;
2153 END ;
2154 formal arraybound :
2155 BEGIN
2156 IF varparam THEN
2157 ll := swrite output_string ll 'var ' ;
2158 ll := swrite output_string ll 'parameter of ' ;
2159 IF nxtel <> NIL THEN
2160 WITH nxtel^ DO
2161 BEGIN
2162 i := 1 ;
2163 REPEAT
2164 IF name i <> ' ' THEN
2165 ll := swrite output_string ll name i
2166 ELSE
2167 i := maxident ;
2168 i := i + 1
2169 UNTIL i > maxident ;
2170 END ;
2171 END ;
2172 exportable :
2173 ll := swrite output_string ll 'global exportable' ;
2174 imported :
2175 ll := swrite output_string ll 'global imported' ;
2176 END ;
2177 IF vtype <> NIL THEN BEGIN
2178 IF vtype^.form <> files THEN
2179 BEGIN
2180 ll := swrite output_string ll ' size:' ;
2181 printoct vtype^.size ;
2182 END ;
2183 ll := swrite output_string ll ' ; ' ;
2184 IF vtype^.pack THEN
2185 IF vtype^.defline <> 0 THEN
2186 ll := swrite output_string ll 'packed ' ;
2187 printtype vtype ;
2188 END ;
2189 printrefs ;
2190 END ;
2191 field :
2192 BEGIN
2193 IF checkunused THEN
2194 ll := swrite output_string 1 name ' field disp:' ELSE
2195 ll := swrite output_string 1 name ' field disp:' ;
2196 printoct fldaddr ;
2197 ll := swrite output_string ll ' size:' ;
2198 printoct bytwidth ;
2199 IF fldtype <> NIL THEN BEGIN
2200 ll := swrite output_string ll ' ; ' ;
2201 IF fldtype^.pack THEN
2202 IF fldtype^.defline <> 0 THEN
2203 ll := swrite output_string ll 'packed ' ;
2204 printtype fldtype ;
2205 END ;
2206 printrefs ;
2207 END ;
2208 konst :
2209 BEGIN
2210 IF checkunused THEN
2211 IF typofconst = wordconst AND contype <> NIL THEN
2212 IF contype^.form IN numeric pointer reel THEN
2213 ll := swrite output_string 1 name ' * const '
2214 ELSE ll := swrite output_string 1 name ' const '
2215 ELSE ll := swrite output_string 1 name ' const '
2216 ELSE
2217 ll := swrite output_string 1 name ' const ' ;
2218 CASE typofconst OF
2219 wordconst :
2220 IF contype <> NIL THEN
2221 CASE contype^.form OF
2222 numeric :
2223 ll := swrite output_string ll 'numeric' ;
2224 scalar :
2225 ll := swrite output_string ll 'scalar ord=' values : 1 ;
2226 pointer :
2227 ll := swrite output_string ll 'nil pointer' ;
2228 END ;
2229 dwordconst :
2230 ll := swrite output_string ll 'real' ;
2231 alfaconst :
2232 ll := swrite output_string ll 'alphanumeric ' alfalong : 1 ' chars' ;
2233 END ;
2234 printrefs ;
2235 END ;
2236 proc :
2237 BEGIN
2238 IF checkunused THEN
2239 IF proctype = cctp THEN
2240 ll := swrite output_string 1 name ' * proc '
2241 ELSE ll := swrite output_string 1 name ' * funct '
2242 ELSE
2243 IF proctype = cctp THEN
2244 ll := swrite output_string 1 name ' proc '
2245 ELSE ll := swrite output_string 1 name ' funct ' ;
2246 lctp := nxtel ;
2247 CASE prockind OF
2248 actual :
2249 IF lctp = NIL THEN
2250 ll := swrite output_string ll 'level 0'
2251 ELSE
2252 WITH lctp^ DO
2253 BEGIN
2254 ll := swrite output_string ll 'of ' ;
2255 i := 1 ;
2256 REPEAT
2257 IF name i <> ' ' THEN
2258 ll := swrite output_string ll name i
2259 ELSE
2260 i := maxident ;
2261 i := i + 1
2262 UNTIL i > maxident ;
2263 END ;
2264 formal :
2265 BEGIN
2266 ll := swrite output_string ll 'parameter of ' ;
2267 IF lctp <> NIL THEN
2268 WITH lctp^ DO
2269 BEGIN
2270 i := 1 ;
2271 REPEAT
2272 IF name i <> ' ' THEN
2273 ll := swrite output_string ll name i
2274 ELSE
2275 i := maxident ;
2276 i := i + 1
2277 UNTIL i > maxident ;
2278 END ;
2279 END ;
2280 exportable :
2281 ll := swrite output_string ll 'level 0 exportable' ;
2282 imported :
2283 ll := swrite output_string ll 'level 0 imported' ;
2284 END ;
2285 IF proctype <> cctp THEN
2286 IF proctype <> NIL THEN BEGIN
2287 ll := swrite output_string ll ' ; ' ;
2288 IF proctype = nilptr THEN
2289 ll := swrite output_string ll 'standard'
2290 ELSE
2291 printtype proctype
2292 END ;
2293 printrefs ;
2294 END ;
2295 tagfield dummyclass :
2296 END ;
2297 IF lastbox = NIL THEN firstalfa := alfathread
2298 ELSE lastbox^.alfathread := alfathread ;
2299 END ;
2300 END * PRINTSYMBOL * ;
2301
2302 * ******************************************** SEARCHINTYPE < DISPLAYSYMBOLS ********************************* *
2303
2304 PROCEDURE sortlevel cctp : ctp ; FORWARD ;
2305
2306 PROCEDURE searchintype cctp : ctp ;
2307
2308 BEGIN
2309 WITH cctp^ DO
2310 CASE form OF
2311 records :
2312 sortlevel fstfld ;
2313 arrays :
2314 IF aeltype <> NIL THEN
2315 IF aeltype^.name = blank THEN searchintype aeltype ;
2316 pointer :
2317 IF eltype <> NIL THEN
2318 IF eltype^.name = blank THEN searchintype eltype ;
2319 reel numeric scalar power files aliastype : ;
2320 END * CASE *
2321 END * SEARCHINTYPE * ;
2322
2323 * ****************************************** SORTLEVEL < DISPLAYSYMBOLS ************************************* *
2324
2325 PROCEDURE sortlevel ;
2326
2327 LABEL
2328 100 200 ;
2329
2330 VAR
2331 sctp : ctp ;
2332 index : integer ;
2333 previous next : ctp ;
2334
2335 BEGIN * SORTLEVEL *
2336 WHILE cctp <> NIL DO
2337 BEGIN
2338 WITH cctp^ DO
2339 BEGIN
2340 IF name <> blank AND references <> NIL THEN
2341 BEGIN
2342 IF name 1 = '$' THEN index := 26 ELSE index := ord name 1 - ord 'a' ;
2343 IF index IN 0..26 THEN
2344 WITH alfalist index DO
2345 IF firstname = NIL THEN
2346 BEGIN
2347 firstname := cctp ;
2348 alfathread := NIL ;
2349 lastname := cctp
2350 END
2351 ELSE
2352 BEGIN
2353 previous := NIL ;
2354 next := firstname ;
2355 100 :
2356 IF next = cctp THEN GOTO 200 ; * TO AVOID LOOP IN SYMBOLS THREAD... *
2357 IF next^.name <= name THEN
2358 IF next^.alfathread = NIL THEN
2359 BEGIN
2360 next^.alfathread := cctp ;
2361 cctp^.alfathread := NIL ;
2362 lastname := cctp
2363 END
2364 ELSE
2365 BEGIN
2366 previous := next ;
2367 next := next^.alfathread ;
2368 GOTO 100
2369 END
2370 ELSE
2371 BEGIN
2372 cctp^.alfathread := next ;
2373 IF previous = NIL THEN
2374 firstname := cctp
2375 ELSE
2376 previous^.alfathread := cctp
2377 END
2378 END
2379 END ;
2380 CASE klass OF
2381 types :
2382 searchintype cctp ;
2383 vars :
2384 IF vtype <> NIL THEN
2385 IF vtype^.name = blank THEN searchintype vtype ;
2386 field :
2387 IF fldtype <> NIL THEN
2388 IF fldtype^.name = blank THEN searchintype fldtype ;
2389 proc :
2390 IF proctype <> cctp THEN
2391 IF proctype <> NIL THEN
2392 IF proctype^.name = blank THEN searchintype proctype ;
2393 schema konst tagfield dummyclass :
2394 END ;
2395 END ;
2396 sctp := cctp^.nxtel ;
2397 cctp^.nxtel := currentnode^.blockbox ;
2398 cctp := sctp ;
2399 END ;
2400 200 :
2401 END * SORTLEVEL * ;
2402
2403 * ************************************** SORTALFA<DISPLAYSYMBOLS ************************************* *
2404
2405 PROCEDURE sortalfa ;
2406
2407 BEGIN * SORTALFA *
2408 IF currentnode^.blocktp = procblock THEN
2409 BEGIN
2410 sortlevel currentnode^.first ;
2411 IF currentnode^.son <> NIL THEN
2412 BEGIN
2413 currentnode := currentnode^.son ;
2414 sortalfa ;
2415 currentnode := currentnode^.father ;
2416 END ;
2417 END ;
2418 IF currentnode^.brother <> NIL THEN
2419 BEGIN
2420 currentnode := currentnode^.brother ;
2421 sortalfa ;
2422 END ;
2423 END * SORTALFA * ;
2424
2425 BEGIN * DISPLAYSYMBOLS *
2426 * SORT ALL SYMBOLS *
2427 checkunused := false ;
2428 currentnode := programnode ;
2429 FOR it := 0 TO 26 DO
2430 alfalist it.firstname := NIL ;
2431 sortalfa ;
2432 it := 0 ;
2433 WHILE alfalist it.firstname = NIL AND it <> 26 DO
2434 it := it + 1 ;
2435 firstalfa := alfalist it.firstname ;
2436 lastit := it ;
2437 it := it + 1 ;
2438 WHILE it <> 27 DO
2439 BEGIN
2440 IF alfalist it.firstname <> NIL THEN
2441 BEGIN
2442 alfalist lastit.lastname^.alfathread := alfalist it.firstname ;
2443 lastit := it ;
2444 END ;
2445 it := it + 1 ;
2446 END ;
2447 * EDITION *
2448 tittle := false ;
2449 tittlestring := 'NAMES DECLARED AND REFERENCED' ;
2450 writeln mpcogout ;
2451 cctp := firstalfa ;
2452 lastbox := NIL ;
2453 WHILE cctp <> NIL DO
2454 BEGIN
2455 WITH cctp^ DO
2456 IF klass = vars THEN IF visrefincode OR vkind = arraybound THEN printsymbol ELSE lastbox := cctp
2457 ELSE IF klass = proc THEN IF pisrefincode THEN printsymbol ELSE lastbox := cctp
2458 ELSE IF references^.refnbr <> 0 THEN printsymbol ELSE lastbox := cctp ;
2459 cctp := cctp^.alfathread ;
2460 END ;
2461 IF NOT tittle THEN
2462 writeln mpcogout ' NO ' tittlestring ;
2463
2464 tittle := false ;
2465 tittlestring := 'NAMES DECLARED AND NEVER REFERENCED' ;
2466 writeln mpcogout ;
2467 cctp := firstalfa ;
2468 checkunused := true ;
2469 lastbox := NIL ;
2470 WHILE cctp <> NIL DO
2471 BEGIN
2472 printsymbol ;
2473 cctp := cctp^.alfathread ;
2474 END ;
2475 checkunused := false ;
2476 IF NOT tittle THEN
2477 writeln mpcogout ' NO ' tittlestring ;
2478
2479 tittle := false ;
2480 tittlestring := 'NAMES DECLARED BY DEFAULT' ;
2481 writeln mpcogout ;
2482 FOR it := 0 TO 26 DO
2483 alfalist it.firstname := NIL ;
2484 sortlevel display 0.fname ;
2485 it := 0 ;
2486 WHILE alfalist it.firstname = NIL AND it <> 26 DO
2487 it := it + 1 ;
2488 firstalfa := alfalist it.firstname ;
2489 lastit := it ;
2490 it := it + 1 ;
2491 WHILE it <> 27 DO
2492 BEGIN
2493 IF alfalist it.firstname <> NIL THEN
2494 BEGIN
2495 alfalist lastit.lastname^.alfathread := alfalist it.firstname ;
2496 lastit := it ;
2497 END ;
2498 it := it + 1 ;
2499 END ;
2500 cctp := firstalfa ;
2501 WHILE cctp <> NIL DO
2502 BEGIN
2503 IF cctp^.references^.refnbr <> 0 THEN printsymbol ;
2504 cctp := cctp^.alfathread ;
2505 END ;
2506 IF NOT tittle THEN
2507 writeln mpcogout ' NO ' tittlestring ;
2508 writeln mpcogout ;
2509 IF firstlabbox^.next^.next = NIL THEN
2510 writeln mpcogout ' NO LABELS'
2511 ELSE
2512 BEGIN
2513 writeln mpcogout ' LABELS' ;
2514 writeln mpcogout ;
2515 writeln mpcogout ' BLOCK NAME' ;
2516 currlabbox := firstlabbox^.next ;
2517 REPEAT
2518 WITH currlabbox^ DO
2519 BEGIN
2520 write mpcogout number : 4 ;
2521 IF references^.refnbr = 0 THEN write mpcogout '* '
2522 ELSE write mpcogout ' ' ;
2523 IF procnode = programnode THEN write mpcogout 'main '
2524 ELSE write mpcogout procnode^.blockbox^.name : 32 ;
2525 write mpcogout ' DCL : ' ;
2526 ll := 39 + 6 ;
2527 IF dclfile <> 0 THEN
2528 BEGIN
2529 n := longint dclfile ;
2530 write mpcogout dclfile : n '-' ;
2531 ll := ll + n + 1 ;
2532 END ;
2533 n := longint dclline ;
2534 write mpcogout dclline : n ' ; DEF: ' ;
2535 ll := ll + n + 8 ;
2536 IF deffile <> 0 THEN
2537 BEGIN
2538 n := longint deffile ;
2539 write mpcogout deffile : n '-' ;
2540 ll := ll + n + 1 ;
2541 END ;
2542 n := longint defline ;
2543 write mpcogout defline : n ;
2544 ll := ll + n ;
2545 IF references^.refnbr <> 0 THEN BEGIN
2546 write mpcogout ' ; REF: ' ;
2547 ll := ll + 8 ;
2548 refbox := references ;
2549 p1 := NIL ;
2550 WHILE refbox^.nextref <> NIL DO BEGIN
2551 p2 := refbox^.nextref ;
2552 refbox^.nextref := p1 ;
2553 p1 := refbox ;
2554 refbox := p2 ;
2555 END ;
2556 refbox^.nextref := p1 ;
2557 REPEAT
2558 WITH refbox^ DO
2559 FOR i := 1 TO refnbr DO
2560 WITH refs i DO
2561 BEGIN
2562 IF ll >= llmax THEN
2563 BEGIN
2564 writeln mpcogout ;
2565 write mpcogout ' ' : 41 ;
2566 ll := 40 ;
2567 END ;
2568 IF filen <> 0 THEN BEGIN
2569 n := longint filen ;
2570 write mpcogout filen : n '-' ;
2571 ll := ll + n + 1 ;
2572 END ;
2573 IF linen < 0 THEN
2574 BEGIN
2575 n := longint -linen ;
2576 write mpcogout -linen : n '* '
2577 END ELSE
2578 BEGIN
2579 n := longint linen ;
2580 write mpcogout linen : n ' ' ;
2581 END ;
2582 ll := ll + n + 1 ;
2583 END ;
2584 refbox := refbox^.nextref ;
2585 UNTIL refbox = NIL ;
2586 END ;
2587 END ;
2588 writeln mpcogout ;
2589 currlabbox := currlabbox^.next ;
2590 UNTIL currlabbox^.next = NIL ;
2591 END ;
2592
2593 END * DISPLAYSYMBOLS * ;
2594
2595 $OPTIONS page $
2596
2597 * ***********************************************STATISTIQUES***************** *
2598
2599 PROCEDURE statistiques ;
2600
2601 * C CALLED AT END OF COMPILATION
2602 . PRINTS ERROR'S MEANING
2603 . PRINTS PAGENUMBER WHERE ERRORS WERE FOUND
2604 . PRINTS ERRTOTAL
2605 . ASSIGNS $COND C *
2606 VAR
2607 i j pageocc : integer ;
2608 BEGIN
2609 IF mapswitch THEN
2610 IF errtotal # 0 THEN
2611 BEGIN
2612 nextpage ;
2613 write mpcogout errtotal : 5 ' COMPILATION ERRORS DETECTED' ; nextline ;
2614 nextline ;
2615 pageocc := -1 ; * FLAG FIRST LINE OF PAGE NUMBERS *
2616 FOR i := 0 TO maxerpg DO * LOOP ON ENTRIES *
2617 FOR j := 0 TO maxset DO * LOOP ON ELEMENT IN AN ENTRY *
2618 IF j IN pageserrors i THEN
2619 BEGIN
2620 IF pageocc = -1 THEN
2621 BEGIN write mpcogout 'ERRORS DETECTED IN PAGES :' ; pageocc := 1 ;
2622 END ELSE
2623 IF pageocc = 1 THEN
2624 write mpcogout ' :' ;
2625 write mpcogout i * setrange + j : 5 ; pageocc := pageocc + 1 ;
2626 IF pageocc = 19 THEN
2627 BEGIN
2628 nextline ; pageocc := 1 ;
2629 END ;
2630 END * FOR IJIF * ;
2631 IF pageocc > 1 THEN * LINE NOT EMPTY *
2632 nextline ;
2633 * NOW PRINTS ERROR'S MEANING *
2634 nextline ;
2635 FOR i := 0 TO maxerpg DO
2636 FOR j := 0 TO maxset DO
2637 IF j IN errorsfound i THEN
2638 BEGIN
2639 prterrmeans mpcogout i * setrange + j ;
2640 nextline ;
2641 END ;
2642 END * ERRORS * ELSE
2643 BEGIN
2644 nextpage ;
2645 IF listyes THEN write mpcogout ' NO COMPILATION ERROR ' ; nextline ;
2646 END ;
2647 IF listyes THEN
2648 nextline ;
2649 END * STATISTIQUES * ;
2650
2651 * END OF UNIQUE MODULE ******************************************************* * BEGIN
2652 END.
2653