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 PROGRAM contexttable ;
19
20 $OPTIONS switch trace := true ; switch security := true ; t + $
21
22
23 $IMPORT
24 'RACINE pascal' :
25 alfaptr,
26 anytrace,
27 boxheader,
28 charptr,
29 intptr,
30 lamptr,
31 level,
32 mpcogout,
33 next,
34 nilptr,
35 pnumptr,
36 realptr,
37 symbolfile,
38 symbolline,
39 top ;
40 'RACINE pascal ' :
41 error,
42 nextline,
43 warning ;
44 'DECLARE pascal ' :
45 analyzing_schema,
46 decltrace,
47 tabform,
48 tabkinds,
49 tabklass,
50 tabkonst,
51 tabpdef ;
52 'UNIQUE pascal' :
53 heaperror ;
54 'STATE pascal' :
55 stattrace ;
56 $
57
58
59 $EXPORT
60 add_schema_token,
61 areconformeq,
62 boundary,
63 bytesneeded,
64 checkminmax,
65 compatbin,
66 conformantdim,
67 create_vars_box,
68 create_types_box,
69 create_proc_box,
70 create_field_box,
71 create_konst_box,
72 create_schema_box,
73 create_tagfield_box,
74 create_dummyclass_box,
75 existfileintype,
76 findminmax,
77 legalconfarrsubstitution,
78 packedsize,
79 packedcadre,
80 printrec,
81 warningminmax
82
83 $
84 $INCLUDE 'CONSTTYPE' $
85
86 $OPTIONS page $
87
88 VAR
89
90 * REDEFINE IMPORTED VARIABLES FROM "RACINE" *
91
92 alfaptr : ctp ;
93 anytrace : levtrace ;
94 boxheader : PACKED ARRAY 1..120 OF char ;
95 charptr : ctp ;
96 intptr : ctp ;
97 lamptr : ctp ;
98 level : levrange ;
99 mpcogout : text ;
100 next : ctp ;
101 nilptr : ctp ;
102 pnumptr : ctp ;
103 realptr : ctp ;
104 symbolfile : integer ;
105 symbolline : integer ;
106 top : integer ;
107
108
109 * REDEFINE IMPORTED VARIABLES FROM "DECLARE" *
110
111
112 analyzing_schema : schema_status ;
113 decltrace : levtrace ;
114 tabform : ARRAY typform OF alfa ;
115 tabkinds : ARRAY idkinds OF alfa ;
116 tabklass : ARRAY idklass OF alfa ;
117 tabkonst : ARRAY consttype OF alfa ;
118 tabpdef : ARRAY idprocdef OF alfa ;
119
120 * REDEFINE IMPORTED VARIABLES FROM "STATE" *
121
122
123 stattrace : levtrace ;
124
125
126 * REDEFINE IMPORTED PROCEDURES FROM "UNIQUE" *
127
128 PROCEDURE heaperror ; EXTERNAL ;
129
130
131 * REDEFINE IMPORTED PROCEDURES FROM "RACINE" *
132
133 PROCEDURE error errno : integer ; EXTERNAL ;
134 PROCEDURE nextline ; EXTERNAL ;
135 PROCEDURE warning ferrnum : integer ; EXTERNAL ;
136
137
138
139
140 * ******************************************* ADD_FORMAT_TOKEN ****************************** *
141
142 PROCEDURE add_schema_token kind : schema_token_kind ;
143
144 VAR
145 localftp : ftp ;
146 BEGIN
147 new localftp ;
148 IF localftp = NIL THEN heaperror ;
149 localftp^.kind := kind ;
150 WITH localftp^ DO
151 CASE kind OF
152 symbol_token :
153 BEGIN
154 tno := 0 ; tcl := 0
155 END ;
156 name_token :
157 taval := blank ;
158 int_const_token :
159 t_int_value := 0 ;
160 char_const_token :
161 t_char_value := ' ' ;
162 real_const_token :
163 t_real_value := 0 ;
164 END ;
165 localftp^.next := NIL ;
166 IF analyzing_schema.schema_ptr^.token_list = NIL THEN
167 analyzing_schema.schema_ptr^.token_list := localftp
168 ELSE analyzing_schema.current_token^.next := localftp ;
169 analyzing_schema.current_token := localftp ;
170 END ;
171
172 $OPTIONS page $
173 $OPTIONS page $
174 PROCEDURE initcommonpart fvbox : ctp ; fname : alfaid ;
175
176 * C Cette procedure initialise les champs communs a toutes les boites
177 CONTEXTTABLE.
178 C *
179
180 BEGIN * INITCOMMONPART *
181
182 WITH fvbox^ DO
183 BEGIN
184 name := fname ;
185 alfathread := NIL ;
186 symbolplace := packednil ;
187 symbtablerefs := 0 ;
188
189
190 IF name = blank THEN
191 BEGIN
192 nxtel := NIL ; deffile := 0 ; defline := 0 ; references := NIL ;
193 END * NAME = BLANK * ELSE
194 BEGIN
195 nxtel := next ; * Common default *
196 deffile := symbolfile ; defline := symbolline ;
197 new references ; IF references = NIL THEN heaperror ;
198 WITH references^ DO
199 BEGIN
200 refnbr := 0 ; nextref := NIL ;
201 END ;
202 END ;
203 END * with FVBOX * ;
204 END * INITCOMMONPART * ;
205
206
207 $OPTIONS page $
208
209 * ********************************* CREATE_VARS_BOX ********* *
210
211 PROCEDURE create_vars_box VAR fvbox : ctp ; fname : alfaid ;
212
213 * C Cette procedure est la seule autorisee a creer un enregistrement
214 de CONTEXTTABLE correspondant a la classe VARS.
215 En sortie elle renvoie le pointeur FVBOX .
216 En cas de saturation du tas on appelle HEAPERROR qui arrete la
217 compilation.
218 C *
219
220 BEGIN * CREATE_VARS_BOX *
221
222 new fvbox vars ;
223 IF fvbox = NIL THEN heaperror ;
224 WITH fvbox ^ DO
225 BEGIN
226 initcommonpart fvbox fname ;
227 klass := vars ;
228 vtype := NIL ;
229 vkind := actual ;
230 vfilelocation := notafile ;
231 vaddr := 0 ;
232 vdispl := 0 ; vdescaddr := 0 ;
233 vlevel := level ;
234 visused := false ;
235 visset := false ;
236 visreadonly := false ;
237 visrefincode := false ;
238 varparam := false ;
239 vptextitem := NIL ;
240 END ;
241
242 END * CREATE_VARS_BOX * ;
243
244 $OPTIONS page $
245 * ********************************* CREATE_SCHEMA_BOX ********* *
246
247 PROCEDURE create_schema_box VAR fvbox : ctp ; fname : alfaid ;
248
249 * C Cette procedure est la seule autorisee a creer un enregistrement
250 de CONTEXTTABLE correspondant a la classe SCHEMA.
251 En sortie elle renvoie le pointeur FVBOX .
252 En cas de saturation du tas on appelle HEAPERROR qui arrete la
253 compilation.
254 C *
255
256 BEGIN * CREATE_SCHEMA_BOX *
257
258 new fvbox schema ;
259 IF fvbox = NIL THEN heaperror ;
260 WITH fvbox ^ DO
261 BEGIN
262 initcommonpart fvbox fname ;
263 klass := schema ;
264 top_for_schema := top ;
265 next_for_schema := next ;
266 formal_parameter_list := NIL ;
267 parameter_count := 0 ;
268 token_list := NIL
269 END ;
270
271 END * CREATE_SCHEMA_BOX * ;
272
273 $OPTIONS page $
274
275
276 * ********************************* CREATE_TYPES_BOX ********* *
277
278 PROCEDURE create_types_box VAR fvbox : ctp ; fname : alfaid ;
279 fform : typform ; fbool : boolean ;
280
281 * C Cette procedure est la seule autorisee a creer un enregistrement
282 de CONTEXTTABLE correspondant a la classe TYPES.
283 En sortie elle renvoie le pointeur FVBOX .
284 En cas de saturation du tas on appelle HEAPERROR qui arrete la
285 compilation.
286 FFORM identifie le sous-type.
287 FBOOL n'est utilise que pour SCALAR ARRAYS.
288 C *
289
290 BEGIN * CREATE_TYPES_BOX *
291
292 new fvbox types ;
293 IF fvbox = NIL THEN heaperror ;
294 WITH fvbox ^ DO
295 BEGIN
296 initcommonpart fvbox fname ;
297 klass := types ;
298 size := 0 ;
299 cadrage := 0 ;
300 pack := false ;
301 tlevel := level ;
302 form := fform ;
303 father_schema := NIL ;
304 actual_parameter_list := NIL ;
305
306 CASE form OF
307 reel : BEGIN
308 END ;
309 numeric : BEGIN
310 npksize := 0 ;
311 nmin := 0 ;
312 nmax := 0 ;
313 END ;
314 scalar : BEGIN
315 spksize := 0 ;
316 subrng := fbool ;
317 CASE subrng OF
318 false : BEGIN
319 fconst := NIL ;
320 sptcstepw := NIL ;
321 END ;
322 true : BEGIN
323 smin := 0 ;
324 smax := 0 ;
325 typset := NIL ;
326 END ;
327 END ;
328 END ;
329 pointer : BEGIN
330 ptpksize := 0 ;
331 domain := NIL ;
332 eltype := NIL ;
333 END ;
334 power : BEGIN
335 ppksize := 0 ;
336 setlength := 0 ;
337 elset := NIL ;
338 END ;
339 arrays : BEGIN
340 aeltype := NIL ;
341 inxtype := NIL ;
342 conformant := fbool ;
343 CASE conformant OF
344 false : BEGIN
345 lo := 0 ;
346 hi := 0 ;
347 opt2 := 0 ;
348 subsize := 0 ;
349 END ;
350 true : BEGIN
351 ptlow := NIL ;
352 father_schema := NIL ;
353 actual_parameter_list := NIL ;
354 desc_vector_references := -1 ;
355 END ;
356 END * case CONFORMANT * ;
357 END ;
358 records : BEGIN
359 recvar := NIL ;
360 fstfld := NIL ;
361 END ;
362 files : BEGIN
363 feltype := NIL ;
364 END ;
365 aliastype : BEGIN
366 realtype := NIL ;
367 END ;
368 END * case FORM * ;
369 END ;
370
371 END * CREATE_TYPES_BOX * ;
372
373 $OPTIONS page $
374
375 * ********************************* CREATE_PROC_BOX ********* *
376
377 PROCEDURE create_proc_box VAR fvbox : ctp ; fname : alfaid ;
378
379 * C Cette procedure est la seule autorisee a creer un enregistrement
380 de CONTEXTTABLE correspondant a la classe PROC.
381 En sortie elle renvoie le pointeur FVBOX .
382 En cas de saturation du tas on appelle HEAPERROR qui arrete la
383 compilation.
384 C *
385
386 BEGIN * CREATE_PROC_BOX *
387
388 new fvbox proc ;
389 IF fvbox = NIL THEN heaperror ;
390 WITH fvbox ^ DO
391 BEGIN
392 initcommonpart fvbox fname ;
393 klass := proc ;
394 proctype := NIL ;
395 formals := NIL ;
396 prockind := actual ;
397 proclevel := level ;
398 procaddr := 0 ;
399 segsize := 0 ;
400 nbparproc := 0 ;
401 locincode := 0 ;
402 procisassigned := false ;
403 predefproc := false ;
404 procinscope := true ;
405 phasdescriptor := false ;
406 ploc := notpredef ;
407 procextitem := NIL ;
408 procdef := standdef ;
409 ptypesymbolplace := packednil ;
410 pisrefincode := false ;
411 procisactive := false ;
412 pwantdescs := false ;
413 pdescsaddrplace := 0 ;
414 pextcalltrapinfoplace := 0 ;
415 pwantspl1descriptors := false ;
416 END ;
417
418 END * CREATE_PROC_BOX * ;
419
420 $OPTIONS page $
421
422 * ********************************* CREATE_FIELD_BOX ********* *
423
424 PROCEDURE create_field_box VAR fvbox : ctp ; fname : alfaid ;
425
426 * C Cette procedure est la seule autorisee a creer un enregistrement
427 de CONTEXTTABLE correspondant a la classe FIELD.
428 En sortie elle renvoie le pointeur FVBOX .
429 En cas de saturation du tas on appelle HEAPERROR qui arrete la
430 compilation.
431 C *
432
433 BEGIN * CREATE_FIELD_BOX *
434
435 new fvbox field ;
436 IF fvbox = NIL THEN heaperror ;
437 WITH fvbox ^ DO
438 BEGIN
439 initcommonpart fvbox fname ;
440 klass := field ;
441 fldtype := NIL ;
442 fldaddr := 0 ;
443 bytwidth := 0 ;
444 END ;
445
446 END * CREATE_FIELD_BOX * ;
447
448 $OPTIONS page $
449
450 * ********************************* CREATE_KONST_BOX ********* *
451
452 PROCEDURE create_konst_box VAR fvbox : ctp ; fname : alfaid ;
453 ftypofconst : consttype ;
454
455 * C Cette procedure est la seule autorisee a creer un enregistrement
456 de CONTEXTTABLE correspondant a la classe KONST.
457 En sortie elle renvoie le pointeur FVBOX .
458 En cas de saturation du tas on appelle HEAPERROR qui arrete la
459 compilation.
460 FTYPOFCONST identifie la sous-classe de constante.
461 C *
462
463 BEGIN * CREATE_KONST_BOX *
464
465 new fvbox konst ;
466 IF fvbox = NIL THEN heaperror ;
467 WITH fvbox ^ DO
468 BEGIN
469 initcommonpart fvbox fname ;
470 klass := konst ;
471 succ := NIL ;
472 contype := NIL ;
473 typofconst := ftypofconst ;
474
475 CASE typofconst OF
476 wordconst : BEGIN
477 values := 0 ;
478 END ;
479 dwordconst : BEGIN
480 valreel := 0 ;
481 END ;
482 alfaconst : BEGIN
483 alfadeb := NIL ;
484 alfalong := 0 ;
485 alfalevel := level ;
486 unddeb := 0 ;
487 END ;
488 END * case TYPOFCONST * ;
489 END ;
490
491 END * CREATE_KONST_BOX * ;
492
493 $OPTIONS page $
494
495 * ********************************* CREATE_TAGFIELD_BOX ********* *
496
497 PROCEDURE create_tagfield_box VAR fvbox : ctp ; fname : alfaid ; ftagval : boolean ;
498
499 * C Cette procedure est la seule autorisee a creer un enregistrement
500 de CONTEXTTABLE correspondant a la classe TAGFIELD.
501 En sortie elle renvoie le pointeur FVBOX .
502 En cas de saturation du tas on appelle HEAPERROR qui arrete la
503 compilation.
504 FTAGVAL permet la discrimination de champs.
505 C *
506
507 BEGIN * CREATE_TAGFIELD_BOX *
508
509 new fvbox tagfield ;
510 IF fvbox = NIL THEN heaperror ;
511 WITH fvbox ^ DO
512 BEGIN
513 initcommonpart fvbox fname ;
514 klass := tagfield ;
515 casesize := 0 ;
516 variants := NIL ;
517 tagval := ftagval ;
518
519 CASE tagval OF
520 false : BEGIN
521 casetype := NIL ;
522 selectorfield := NIL ;
523 END ;
524 true : BEGIN
525 caseval := 0 ;
526 firstfield := NIL ;
527 END ;
528 END * case TAGVAL * ;
529
530 END * with * ;
531
532 END * CREATE_TAGFIELD_BOX * ;
533
534 $OPTIONS page $
535
536 * ********************************* CREATE_DUMMYCLASS_BOX ********* *
537
538 PROCEDURE create_dummyclass_box VAR fvbox : ctp ; fname : alfaid ;
539
540 * C Cette procedure est la seule autorisee a creer un enregistrement
541 de CONTEXTTABLE correspondant a la classe DUMMYCLASS.
542 En sortie elle renvoie le pointeur FVBOX .
543 En cas de saturation du tas on appelle HEAPERROR qui arrete la
544 compilation.
545 C *
546
547 BEGIN * CREATE_DUMMYCLASS_BOX *
548
549 new fvbox dummyclass ;
550 IF fvbox = NIL THEN heaperror ;
551 WITH fvbox ^ DO
552 BEGIN
553 initcommonpart fvbox fname ;
554 klass := dummyclass ;
555 END ;
556
557 END * CREATE_DUMMYCLASS_BOX * ;
558
559 $OPTIONS page $
560
561 * *************************************PRINTREC******************************* *
562
563 PROCEDURE printrec ptbox : ctp ;
564
565 * C .CALLED IN ORDER TO WRITE ON LISTING THE CONTENT OF THE BOX POINTED BY
566 "PTBOX".
567 .THE VALUE OF DECLTRACE GIVES THE LEVEL OF INFORMATIONS TO BE
568 WRITTEN
569 C *
570
571
572 * ***********************************************CRACHEPROC < PRINTREC******** *
573
574 PROCEDURE cracheproc ;
575
576 BEGIN nextline ;
577 WITH ptbox@ DO
578 IF decltrace = high THEN
579 BEGIN
580 write mpcogout '* PROCTYPE FORMALS AT @ ' ord proctype ord formals
581 ' PROCKIND IS ' tabkinds prockind ' PROCLEVEL IS' proclevel : 4 ;
582 nextline ;
583 write mpcogout '* PROCADDRSEGSIZE ARE ' procaddr : 5 segsize ' PROCDEF IS '
584 tabpdef procdef ' POCISASSIGNED IS ' procisassigned : 5
585 ' PROCINSCOPE IS ' procinscope ;
586 nextline ;
587 write mpcogout '* NBPARPROCPREDEFPROC ARE : ' nbparproc : 5 predefproc : 5 ;
588 write mpcogout ' PROCEXTITEM is at^' ord procextitem ;
589 write mpcogout ' PISREFINCODE is:' pisrefincode ;
590 write mpcogout ' PHASDESCRIPTOR = ' phasdescriptor ;
591 nextline ;
592 END ;
593 END * CRACHEPROC * ;
594
595
596 * *************************************CRACHEFIELD < PRINTREC *********** *
597
598 PROCEDURE crachefield ;
599 BEGIN nextline ;
600 WITH ptbox@ DO
601 IF decltrace = high THEN
602 BEGIN
603 write mpcogout '* FLDTYPE IS AT @ ' ord fldtype ' FLDADDRBYTWIDTH ARE'
604 fldaddr : 5 bytwidth : 5 ;
605 nextline ;
606 END ;
607 END ; * CRACHEFIELD *
608
609
610 * *************************************CRACHEVARS < PRINTREC *********** *
611
612 PROCEDURE crachevars ;
613 BEGIN
614 nextline ;
615 WITH ptbox@ DO
616 IF decltrace = high THEN
617 BEGIN
618 write mpcogout '* VTYPE IS AT @ ' ord vtype ' VKIND IS ' tabkinds vkind
619 ' VADDRVLEVELVPTEXTITEM ARE : ' vaddr vlevel : 4 ord vptextitem ;
620 nextline ;
621 write mpcogout '* ordVFILELOCATION is:' ord vfilelocation
622 ' VISREFINCODE is :' visrefincode ;
623 write mpcogout ' VDISPL and VDESCADDR are :' vdispl : 8 vdescaddr : 8 ;
624 nextline ;
625 write mpcogout '* VISUSEDVISSETVISREADONLY ARE :' visused : 5 visset : 5
626 visreadonly : 5 ' VARPARAM IS : ' varparam : 5 ;
627 nextline ;
628 END ;
629 END ; * CRACHEVARS *
630
631
632 * *************************************CRACHEKONST < PRINTREC *********** *
633
634 PROCEDURE crachekonst ;
635
636 BEGIN
637 WITH ptbox@ DO
638 IF decltrace = medium THEN
639 BEGIN
640 write mpcogout ' TYPOFCONST IS ' tabkonst typofconst ; nextline ;
641 END ELSE
642 BEGIN
643 nextline ;
644 write mpcogout
645 '* SUCC CONTYPE ARE AT@ ' ord succ ord contype ' TYPOFCONST IS'
646 tabkonst typofconst : 9 ;
647 nextline ;
648 IF typofconst = wordconst THEN
649 write mpcogout '* VALUES IS: ' values ELSE
650 IF typofconst = dwordconst THEN
651 write mpcogout '* VALREEL IS: ' valreel ELSE
652 write mpcogout
653 '* ALFADEB IS AT @ ' ord alfadeb ' ALFALONGALFALEVELUNDDEB '
654 alfalong : 4 alfalevel : 4 unddeb : 4 ;
655 nextline ;
656 END ;
657 END ; * CRACHEKONST *
658
659
660 * *************************************CRACHETAGFIELD < PRINTREC *********** *
661 PROCEDURE crachetagfield ;
662
663 BEGIN
664 WITH ptbox@ DO
665 IF decltrace = medium THEN
666 BEGIN
667 write mpcogout '* TAGVAL IS: ' tagval : 5 ; nextline ;
668 END ELSE
669 BEGIN
670 nextline ;
671 write mpcogout
672 '* CASESIZE IS:' casesize : 5 ' VARIANTS IS AT@ ' ord variants
673 ' TAGVAL IS: ' tagval : 5 ; nextline ;
674 IF tagval THEN
675 write mpcogout '* CASEVAL IS:' caseval ELSE
676 write mpcogout '* CASETYPE IS AT @' ord casetype ;
677 nextline ;
678 END ;
679 END ; * CRACHETAGFIELD *
680
681
682 * *************************************CRACHETYPES < PRINTREC *********** *
683 PROCEDURE crachetypes ;
684
685 BEGIN
686 WITH ptbox@ DO
687 IF decltrace = medium THEN
688 BEGIN
689 write mpcogout ' FORM IS : ' tabform form ;
690 IF form = scalar THEN
691 write mpcogout ' SUBRNG IS ' subrng : 5 ELSE
692 IF form = arrays THEN
693 write mpcogout ' CONFORMANT IS ' conformant : 5 ;
694 nextline ;
695 END ELSE
696 BEGIN nextline ;
697 write mpcogout
698 '* SIZECADRAGE ARE : ' size cadrage : 4 ' PACK IS ' pack : 5
699 ' FORM IS : ' tabform form ;
700 nextline ;
701 CASE form OF
702 reel : ;
703 numeric : BEGIN
704 write mpcogout '* NPKSIZENMIN AND NMAX ARE: ' npksize nmin nmax ;
705 nextline ;
706 END ;
707 scalar : BEGIN
708 write mpcogout '* SPKSIZE IS: ' spksize ' SUBRNG IS: ' subrng : 5 ;
709 nextline ;
710 IF subrng THEN
711 write mpcogout
712 '* SMINSMAX ARE :' smin smax ' TYPSET IS AT @' ord typset
713 ELSE
714 write mpcogout
715 '* FCONSTSPTCSTEPW ARE AT @' ord fconst ord sptcstepw ;
716 nextline ;
717 END ;
718 pointer : BEGIN
719 write mpcogout
720 '* PTPKSIZE IS:' ptpksize : 4
721 ' DOMAINELTYPE ARE AT @' ord domain ord eltype ;
722 nextline ;
723 END ;
724 power : BEGIN
725 write mpcogout
726 '* PPKSIZE IS: ' ppksize : 4 ' ELSET IS AT @' ord elset ;
727 nextline ;
728 END ;
729 arrays : BEGIN
730 write mpcogout '* AELTYPEINXTYPE ARE AT @' ord aeltype ord inxtype
731 ' CONFORMANT IS :' conformant : 5 ;
732 nextline ;
733 IF conformant THEN
734 BEGIN
735
736 END ELSE
737 write mpcogout '* LOHIOPT2SUBSIZE ARE :' lo hi opt2 subsize ;
738 nextline ;
739 END ;
740 records : BEGIN
741 write mpcogout '*RECVARFSTFLD ARE AT@' ord recvar ord fstfld ;
742 nextline ;
743 END ;
744 files : BEGIN
745 write mpcogout
746 '* FELTYPE IS AT @' ord feltype ;
747 nextline ;
748 END ;
749 aliastype : BEGIN
750 write mpcogout '* REALTYPE IS AT @' ord realtype ; nextline ;
751 END ;
752 END * CASE FORM * ;
753 END * DECLTRACE=HIGH * ;
754 END * CRACHETYPE * ;
755
756
757 BEGIN * PRINTREC *
758 IF decltrace > low THEN
759 BEGIN
760 nextline ; write mpcogout boxheader ; nextline ;
761 IF ptbox = NIL THEN
762 BEGIN
763 write mpcogout '* BOX REQUESTED IS NIL . TRACE STOPS ' ; nextline ;
764 END ELSE
765 WITH ptbox@ DO
766 BEGIN
767 write mpcogout '* BOX FOLLOWING HERE IS AT @' ord ptbox ; nextline ;
768 write mpcogout '* NAME IS : ' name ' NXTEL IS AT @' ord nxtel
769 ' KLASS IS : ' tabklass klass ;
770 CASE klass OF
771 types : crachetypes ;
772 konst : crachekonst ;
773 proc : cracheproc ;
774 vars : crachevars ;
775 field : crachefield ;
776 tagfield : crachetagfield ;
777 dummyclass : nextline ;
778 END * CASE KLASS * ;
779 END ;
780 write mpcogout boxheader ; nextline ;
781 nextline ;
782 END * DECLTRACE > LOW * ;
783 END ; * PRINTREC *
784
785
786 $OPTIONS page $
787
788 * ******************************************** FCT. EXISTFILEINTYPE *
789
790 FUNCTION existfileintype ptontype : ctp : boolean ;
791
792 * C returns TRUE if the type pointed by PTONTYPE may be a complex type
793 is a file type or a type containing a file as element
794 returns FALSE otherwise
795 C *
796
797 VAR
798 locexist : boolean ;
799
800 BEGIN * EXISTFILEINTYPE *
801 $OPTIONS compile = trace $
802 IF decltrace > none THEN
803 BEGIN
804 write mpcogout ' @@@ Debut de EXISTFILEINTYPE @@@ avec ^'
805 ord ptontype ; nextline ;
806 END ;
807 $OPTIONS compile = true $
808
809 * THIS IS A VERY POOR SIMULATION OF THE DEFINITIVE FUNCTION *
810
811 locexist := ptontype^.form = files ;
812 existfileintype := locexist ;
813 $OPTIONS compile = trace $
814 IF decltrace = high THEN
815 BEGIN
816 write mpcogout ' @@@ Fin de EXISTFILEINTYPE @@@ avec valeur='
817 locexist ; nextline ;
818 END ;
819 $OPTIONS compile = true $
820
821 END * EXISTFILEINTYPE * ;
822
823 $OPTIONS page $
824
825 * *********************************************************FCT. BOUNDARY****** *
826
827 FUNCTION boundary objform : typform ; ispack : boolean ; pcksize : integer : integer ;
828
829 * C GIVES FOR AN OBJECT ITS BOUNDARY IN MEMORY IN BYTES C *
830 * E ERRORS DETECTED
831 353 COMPILER'S CONTROL BOUNDARY OBJFORM=ALIASTYPE
832 354 COMPILER'S CONTROL BOUNDARY BAD ARGUMENT E *
833 VAR
834 lbound : integer ;
835 BEGIN
836 lbound := bytesinword ; * DEFAULT AND MOST COMMON VALUE *
837 IF ispack THEN
838 * PACKED OBJECT *
839 CASE objform OF
840 reel : lbound := bytesindword ;
841 numeric, scalar : lbound := pcksize ;
842 pointer : * LBOUND := BYTESINWORD * ;
843 power : IF pcksize <= bytesindword THEN lbound := pcksize ELSE
844 lbound := bytesindword ;
845 arrays, records, files : error 354 ; * COMPILER'S FAULT *
846 aliastype : error 353 ; * COMPILER'S FAULT *
847 END * CASEPACKED *
848 ELSE
849 * UNPACKED OBJECT *
850 CASE objform OF
851 reel, pointer : lbound := bytesindword ;
852 numeric, scalar : * LBOUND:=BYTESINWORD * ;
853 power : lbound := bytesindword ;
854 arrays, records : * LBOUND:=BYTESINWORD * ;
855 files : lbound := bytesindword ;
856 aliastype : error 353 ; * COMPILER'S FAULT *
857 END * CASEUNPACKED * ;
858 boundary := lbound ;
859 END * BOUNDARY * ;
860
861
862 $OPTIONS page $
863
864 * *************************************FCT.BYTESNEEDED************************ *
865
866 FUNCTION bytesneeded objform : typform ; highest : integer ;
867 ispack : boolean : integer ;
868
869 * C FOR EACH TYPE THIS FUNCTION RETURNS THE SIZE NEEDED IN BYTES
870 THIS VALUE DEPENDS ON THE BOOLEAN ISPACK.
871 WHEN THIS BOOLEAN IS TRUE HIGHEST GIVES THE MAXIMUM VALUE OF THE OBJECT
872 THEN IT IS POSSIBLE TO FIND THE OPTIMAL SIZE C *
873 * E ERRORS DETECTED
874 351 COMPILER'S CONTROL BYTESNEEDED OBSFORM=ALIASTYPE
875 352 COMPILER'S CONTROL BYTESNEEDED BAD ARGUMENT E *
876 VAR i : integer ;
877 BEGIN i := bytesinword ; * DEFAULT VALUE *
878 IF NOT ispack THEN
879 * NOT PACKED ENVIRONMENT *
880 CASE objform OF
881 reel, pointer : i := bytesindword ;
882 numeric, scalar : * DEFAULT * ;
883 power : IF highest <= bitsindword - 1 THEN i := bytesindword ELSE
884 i := bytesforset ;
885 arrays, records : i := 0 ; * PRELIMINARY SIZE *
886 files : i := fsbpointersize ;
887 aliastype : error 351 ; * COMPILER'S CONTROL *
888 END * CASE NOT ISPACK *
889 ELSE
890 * PACKED ENVIRONMENT *
891 CASE objform OF
892 reel : i := bytesindword ;
893 numeric : IF highest <= ntwotobyte THEN i := 1 * ONE BYTE * ELSE
894 IF highest <= ntwotohword THEN i := bytesinhword ELSE
895 i := bytesinword ;
896 scalar : IF highest <= stwotobyte THEN i := 1 * ONE BYTE * ELSE
897 i := bytesinhword ;
898 pointer : i := bytesinword ;
899 power : IF highest <= bitsinbyte - 1 THEN i := 1 * ONE BYTE * ELSE
900 IF highest <= bitsinhword - 1 THEN i := bytesinhword ELSE
901 IF highest <= bitsinword - 1 THEN i := bytesinword ELSE
902 IF highest <= bitsindword - 1 THEN i := bytesindword ELSE
903 i := bytesforset ;
904 arrays, records, files : error 352 ; * NO MEANINGS IN PACKED *
905 aliastype : error 351 ; * COMPILER'S CONTROL *
906 END * CASE PACKED ENV * ;
907 bytesneeded := i ;
908 END * BYTESNEEDED * ;
909
910
911 $OPTIONS page $
912
913 * *********************************************************PACKEDSIZE********* *
914
915 FUNCTION packedsize ftype : ctp : integer ;
916
917 * C GIVES THE PACKED SIZE FOR A GIVEN TYPE FTYPE C *
918 * E 379 COMPILER'S CONTROL PACKEDSIZE E *
919 VAR
920 lsize : integer ;
921 BEGIN
922 lsize := 0 ;
923 $OPTIONS compile = security $
924 IF ftype = NIL THEN error 379 ELSE
925 IF ftype@.klass # types THEN error 379 ELSE
926 $OPTIONS compile = true $
927 WITH ftype@ DO
928 IF pack THEN lsize := size ELSE
929 CASE form OF
930 numeric : lsize := npksize ;
931 pointer : lsize := ptpksize ;
932 power : lsize := ppksize ;
933 scalar : lsize := spksize ;
934 aliastype, arrays, files, records, reel : lsize := size ;
935 END * CASE * ;
936 packedsize := lsize ;
937 END * PACKEDSIZE * ;
938
939 $OPTIONS page $
940
941 * *********************************************************PACKEDCADRE********* *
942
943 FUNCTION packedcadre ftype : ctp : integer ;
944
945 * C GIVES THE PACKED CADRE FOR A GIVEN TYPE FTYPE C *
946 * E 379 COMPILER'S CONTROL PACKEDCADRE E *
947 VAR
948 lcadre : integer ;
949 BEGIN
950 lcadre := 0 ;
951 $OPTIONS compile = security $
952 IF ftype = NIL THEN error 379 ELSE
953 IF ftype@.klass # types THEN error 379 ELSE
954 $OPTIONS compile = true $
955 WITH ftype@ DO
956 IF pack THEN lcadre := cadrage ELSE
957 CASE form OF
958 numeric : BEGIN
959 lcadre := npksize ;
960 END ;
961 pointer : lcadre := ptpksize ;
962 power : lcadre := ppksize ;
963 scalar : lcadre := spksize ;
964 aliastype, arrays, files, records, reel : lcadre := cadrage ;
965 END * CASE * ;
966 packedcadre := lcadre ;
967 $OPTIONS compile = trace $
968 IF decltrace = high THEN
969 BEGIN
970 write mpcogout '@@@ Fin de PACKED CADRE @@@ sur FTYPE^'
971 ord ftype ' valeur retournee =' lcadre : 6 ;
972 nextline ;
973 END ;
974 $OPTIONS compile = true $
975 END * PACKEDCADRE * ;
976
977 $OPTIONS page $
978
979 * ************************************ COMPATBIN ***************************** *
980
981 PROCEDURE compatbin typleft typright : ctp ; VAR fgeneric : ctp ;
982
983 * C GIVEN TWO CTP TYPES THIS PROCEDURE RETURNS NIL IF POINTER ARE NOT
984 COMPATIBLE.
985 IF THEY ARE COMPATIBLES RETURNS GENERIC TYPE
986 C *
987 VAR
988 locgen : ctp ;
989 BEGIN * COMPATBIN *
990 $OPTIONS compile = trace $
991 IF anytrace > none THEN
992 BEGIN
993 write mpcogout '@@@ DEBUT COMPATBIN @@@ WITH TYPLEFTTYPRIGHT AT @' ord typleft
994 ord typright ; nextline ;
995 END ;
996 $OPTIONS compile = true $
997 fgeneric := NIL ; * DEFAULT OVERRIDEN *
998 * ONLY IF COMPATIBLE TYPES *
999 IF typleft # NIL THEN * LEFT NIL *
1000 IF typright # NIL THEN * RIGHT NIL *
1001 IF typleft = typright THEN * SAME TYPE *
1002 fgeneric := typleft ELSE
1003 CASE typleft@.form OF
1004 reel : IF typright@.form = numeric THEN fgeneric := realptr ;
1005 numeric :
1006 IF typright = realptr THEN fgeneric := realptr ELSE
1007 IF typright@.form = numeric THEN fgeneric := intptr ;
1008 scalar :
1009 IF typright@.form = scalar THEN
1010 IF NOT typleft@.subrng THEN
1011 BEGIN
1012 IF typright@.subrng THEN
1013 BEGIN
1014 IF typright@.typset = typleft THEN fgeneric := typleft ;
1015 END
1016 END * LEFT NOT SUBRNG * ELSE
1017 BEGIN * SUBRNG *
1018 IF typright@.subrng THEN
1019 BEGIN
1020 IF typright@.typset = typleft@.typset
1021 THEN fgeneric := typleft@.typset ;
1022 END ELSE
1023 IF typleft@.typset = typright THEN fgeneric := typright ;
1024 END * LEFT SUBRNG * ;
1025 pointer : IF typright@.form = pointer THEN
1026 IF typleft = nilptr THEN
1027 fgeneric := typright ELSE
1028 IF typright = nilptr THEN
1029 fgeneric := typleft ;
1030 power : IF typright@.form = power THEN
1031 IF typleft = lamptr THEN fgeneric := typright ELSE
1032 IF typright = lamptr THEN fgeneric := typleft ELSE
1033 BEGIN
1034 compatbin typleft@.elset typright@.elset locgen ;
1035 IF locgen # NIL THEN
1036 IF locgen@.form = numeric THEN
1037 fgeneric := pnumptr ELSE
1038 IF locgen@.subrng THEN
1039 fgeneric := locgen@.typset@.sptcstepw ELSE
1040 fgeneric := locgen@.sptcstepw ;
1041 END ;
1042 arrays : IF typright@.form = arrays THEN
1043 IF typleft@.pack THEN
1044 IF typright@.pack THEN
1045 IF typleft@.aeltype = charptr THEN
1046 IF typright@.aeltype = charptr THEN
1047 BEGIN
1048 IF typright = alfaptr THEN
1049 BEGIN
1050 IF typleft@.lo = 1 THEN
1051 IF typleft@.inxtype@.form = numeric THEN
1052 fgeneric := typleft
1053 END ELSE
1054 IF typleft = alfaptr THEN
1055 BEGIN
1056 IF typright@.lo = 1 THEN
1057 IF typright@.inxtype@.form = numeric THEN
1058 fgeneric := typright
1059 END ELSE
1060 BEGIN
1061 IF typright@.inxtype = typleft@.inxtype THEN
1062 IF typleft@.inxtype@.form = numeric THEN
1063 IF typleft@.size = typright@.size THEN
1064 fgeneric := typleft ;
1065 END ;
1066 END * 2 PACKED ARRAYS OF CHARS * ;
1067 records, files : ;
1068 END * CASE TYPLEFT@.FORM * ;
1069 $OPTIONS compile = trace $
1070 IF anytrace > low THEN
1071 BEGIN
1072 write mpcogout '@@@ FIN COMPATBIN @@@ WITH GENERIC AT @' ord fgeneric ;
1073 nextline ;
1074 END ;
1075 $OPTIONS compile = true $
1076 END * COMPATBIN * ;
1077
1078 $OPTIONS page $
1079
1080 * *************************************WARNINGMINMAX**************************** *
1081
1082 PROCEDURE warningminmax fvalue : integer ; fctp : ctp ; ferrnum : integer ;
1083
1084 * C CALLED EACH TIME THE COMPILER IS ABLE TO FIND IF 'FVALUE' IS A CONSTANT
1085 COMPATIBLE WITH THE DECLARED BOUNDS OF 'FCTP' C *
1086 * E Errors detected
1087 COMPILER'S CONTROL
1088 384 : FCTP IS NIL
1089 385 : TYPES NOT OF A GOOD FORM
1090 386 : FCONST IS NIL E *
1091 VAR
1092 lerr : boolean ;
1093 BEGIN
1094 $OPTIONS compile = security $
1095 IF fctp = NIL THEN error 384 ELSE
1096 IF fctp@.klass # types THEN error 385 ELSE
1097 IF NOT fctp@.form IN numeric scalar THEN error 385 ELSE
1098 $OPTIONS compile = true $
1099 WITH fctp@ DO
1100 BEGIN
1101 * NUMERIC *
1102 IF form = numeric THEN lerr := fvalue > nmax OR fvalue < nmin ELSE
1103 * SCALAR *
1104 IF subrng THEN lerr := fvalue > smax OR fvalue < smin ELSE
1105 BEGIN
1106 $OPTIONS compile = security $
1107 IF fconst = NIL THEN
1108 BEGIN
1109 error 386 ; lerr := false ;
1110 END ELSE
1111 $OPTIONS compile = true $
1112 lerr := fvalue > fconst@.values OR fvalue < 0 ;
1113 END ;
1114 IF lerr THEN
1115 warning ferrnum ;
1116 END * WITH * ;
1117 END * WARNINGMINMAX * ;
1118
1119 $OPTIONS page $
1120
1121 * *************************************CHECKMINMAX**************************** *
1122
1123 PROCEDURE checkminmax fvalue : integer ; fctp : ctp ; ferrnum : integer ;
1124
1125 * C CALLED EACH TIME THE COMPILER IS ABLE TO FIND IF 'FVALUE' IS A CONSTANT
1126 COMPATIBLE WITH THE DECLARED BOUNDS OF 'FCTP' C *
1127 * E ERRORS DETECTED
1128 VIA FERRNUM
1129 301 : CASE VARIANT OUT OF BOUNDS
1130 302 : INDEX OUT OF BOUNDS
1131 303 : VALUE ASSIGNED OUT OF BOUNDS
1132 304 : CASE LABEL OUT OF BOUNDS
1133 305 : VALUE IN A SET OUT OF BOUNDS
1134 COMPILER'S CONTROL
1135 384 : FCTP IS NIL
1136 385 : TYPES NOT OF A GOOD FORM
1137 386 : FCONST IS NIL E *
1138 VAR
1139 lerr : boolean ;
1140 BEGIN
1141 $OPTIONS compile = trace $
1142 IF decltrace > none THEN
1143 BEGIN
1144 write mpcogout ' @@@ DEBUT CHEKMINMAX @@@' ' FVALUEFCTPFERRNUM :' fvalue
1145 ord fctp ferrnum ;
1146 nextline ;
1147 END ;
1148 $OPTIONS compile = true $
1149 $OPTIONS compile = security $
1150 IF fctp = NIL THEN error 384 ELSE
1151 IF fctp@.klass # types THEN error 385 ELSE
1152 IF NOT fctp@.form IN numeric scalar THEN error 385 ELSE
1153 $OPTIONS compile = true $
1154 WITH fctp@ DO
1155 BEGIN
1156 * NUMERIC *
1157 IF form = numeric THEN lerr := fvalue > nmax OR fvalue < nmin ELSE
1158 * SCALAR *
1159 IF subrng THEN lerr := fvalue > smax OR fvalue < smin ELSE
1160 BEGIN
1161 $OPTIONS compile = security $
1162 IF fconst = NIL THEN
1163 BEGIN
1164 error 386 ; lerr := false ;
1165 END ELSE
1166 $OPTIONS compile = true $
1167 lerr := fvalue > fconst@.values OR fvalue < 0 ;
1168 END ;
1169 IF lerr THEN
1170 error ferrnum ;
1171 END * WITH * ;
1172 $OPTIONS compile = trace $
1173 IF decltrace > low THEN
1174 BEGIN
1175 write mpcogout ' @@@ FIN CHECKMINMAX' ; nextline ;
1176 END ;
1177 $OPTIONS compile = true $
1178 END * CHECKMINMAX * ;
1179
1180 $OPTIONS page $
1181
1182 * ************************************ FINDMINMAX **************************** *
1183
1184 PROCEDURE findminmax fctp : ctp ; VAR fmin fmax : integer ;
1185
1186 * C GIVEN A POINTER FCTP NOT NIL ON A SCALAR OR NUMERIC TYPETHIS PROC.
1187 RETURNS THE BOUNDS ALLOWED IN "FMIN" AND "FMAX
1188 C *
1189 * E ERRORS DETECTED
1190 423 FCTP NIL
1191 424 KLASS # TYPES
1192 437 FORM # NUMERICSCALAR
1193 E *
1194 BEGIN * FINDMINMAX *
1195 $OPTIONS compile = trace $
1196 IF stattrace > none THEN
1197 BEGIN
1198 write mpcogout '@@@ DEBUT FINDMINMAX @@@ FOR CTP AT @' ord fctp ; nextline ;
1199 END ;
1200 $OPTIONS compile = true $
1201 fmin := 0 ; fmax := 0 ; * IF ERRORS *
1202 $OPTIONS compile = security $
1203 IF fctp = NIL THEN error 423 ELSE
1204 IF fctp@.klass # types THEN error 424 ELSE
1205 IF NOT fctp@.form IN numeric scalar THEN error 437 ELSE
1206 $OPTIONS compile = true $
1207 WITH fctp@ DO
1208 IF form = numeric THEN
1209 BEGIN
1210 fmin := nmin ; fmax := nmax ;
1211 END ELSE
1212 * SCALAR *
1213 IF subrng THEN
1214 BEGIN
1215 fmin := smin ; fmax := smax ;
1216 END ELSE
1217 BEGIN
1218 fmin := 0 ; fmax := fconst@.values ;
1219 END ;
1220 $OPTIONS compile = trace $
1221 IF stattrace > low THEN
1222 BEGIN
1223 write mpcogout '@@@ FIN FINDMINMAX @@@ WITH FMINFMAX' fmin fmax ; nextline ;
1224 END ;
1225 $OPTIONS compile = true $
1226 END * FINDMINMAX * ;
1227
1228 $OPTIONS page $
1229
1230 * ****************************** ARECONFORMEQ ******************* *
1231
1232 FUNCTION areconformeq fp1 fp2 : ctp : boolean ;
1233
1234 * C
1235 Tool of PASSPARAMS
1236 if two types denoted by a pointer on their descriptive box are not
1237 identical perhaps are they congruent conformant arrays types
1238 C *
1239
1240 VAR
1241 locbool : boolean ;
1242
1243 BEGIN * ARECONFORMEQ *
1244 $OPTIONS compile = trace $
1245 IF stattrace > none THEN
1246 BEGIN
1247 write mpcogout '@@@ Debut de ARECONFORMEQ @@@ avec '
1248 ' FP1 en ^' ord fp1 ' FP2 en ^' ord fp2 ;
1249 nextline ;
1250 END ;
1251 $OPTIONS compile = true $
1252 locbool := false ;
1253 IF fp1^.form = arrays THEN
1254 IF fp1^.conformant THEN
1255 IF fp2^.form = arrays THEN
1256 IF fp2^.conformant THEN
1257 IF fp1^.inxtype = fp2^.inxtype THEN * ISO 7185 6.6.3.6 3 *
1258 IF fp1^.pack = fp2^.pack THEN
1259 IF fp1^.aeltype = fp2^.aeltype THEN
1260 locbool := true ELSE
1261 IF fp1^.aeltype <> NIL AND fp2^.aeltype <> NIL THEN
1262 locbool := areconformeq fp1^.aeltype fp2^.aeltype ;
1263
1264 areconformeq := locbool ;
1265
1266 $OPTIONS compile = trace $
1267 IF stattrace > low THEN
1268 BEGIN
1269 write mpcogout '@@@ Fin de ARECONFORMEQ @@@ avec valeur='
1270 locbool ;
1271 nextline ;
1272 END ;
1273 $OPTIONS compile = true $
1274 END * ARECONFORMEQ * ;
1275
1276 $OPTIONS page $
1277
1278 * ******************************** LEGALCONFARRSUBSTITUTION ************* *
1279
1280 FUNCTION legalconfarrsubstitution ffound fdecl : ctp : boolean ;
1281 VAR
1282 locbool : boolean ;
1283 lmin, lmax : integer ;
1284 generic : ctp ;
1285
1286 BEGIN * LEGALCONFARRSUBSTITUTION *
1287 locbool := false ;
1288
1289 IF ffound <> NIL AND fdecl <> NIL THEN
1290 IF ffound^.klass = types AND fdecl^.klass = types THEN
1291 IF ffound^.form = arrays AND fdecl^.form = arrays THEN
1292 IF ffound^.pack = fdecl^.pack THEN
1293 BEGIN
1294 compatbin ffound^.inxtype fdecl^.inxtype generic ;
1295 IF generic <> NIL THEN
1296 BEGIN
1297 findminmax fdecl^.inxtype lmin lmax ;
1298 IF ffound^.conformant THEN
1299 BEGIN
1300 locbool := areconformeq ffound fdecl ;
1301 END * FOUND CONFORMANT * ELSE
1302 BEGIN
1303 IF ffound^.lo >= lmin THEN
1304 IF ffound^.hi <= lmax THEN
1305 IF ffound^.aeltype = fdecl^.aeltype THEN
1306 locbool := true ELSE
1307 BEGIN
1308 IF ffound^.aeltype^.form = arrays THEN
1309 IF fdecl^.aeltype^.form = arrays THEN
1310 locbool := legalconfarrsubstitution ffound^.aeltype fdecl^.aeltype ;
1311 END ;
1312
1313 END * FOUND NOT CONFORMANT * ;
1314 END * GENERIC <> nil * ;
1315 END * Can be equivalent * ;
1316 legalconfarrsubstitution := locbool ;
1317
1318 $OPTIONS compile = trace $
1319 IF stattrace = high THEN
1320 BEGIN
1321 write mpcogout '@@@ Fin de LEGALCONFARRSUBSTITUTION avec valeur retournee=' locbool ;
1322 nextline ;
1323 END ;
1324 $OPTIONS compile = true $
1325 END * LEGALCONFARRSUBSTITUTION * ;
1326
1327 $OPTIONS page $
1328
1329 * **************************** CONFORMANTDIM ************************ *
1330
1331 FUNCTION conformantdim ffound : ctp : boolean ;
1332
1333 VAR
1334 locbool : boolean ;
1335
1336 BEGIN * CONFORMANTDIM *
1337 locbool := false ;
1338
1339 IF ffound <> NIL THEN
1340 IF ffound^.klass = types THEN
1341 IF ffound^.father_schema <> NIL THEN
1342 locbool := ffound^.actual_parameter_list = NIL
1343 ELSE IF ffound^.form = arrays THEN
1344 IF ffound^.conformant THEN
1345 locbool := true ;
1346 conformantdim := locbool ;
1347
1348 $OPTIONS compile = trace $
1349 IF stattrace = high THEN
1350 BEGIN
1351 write mpcogout '@@@ Fin de CONFORMANTDIM avec valeur retournee=' locbool ;
1352 nextline ;
1353 END ;
1354 $OPTIONS compile = true $
1355 END * CONFORMANTDIM * ;
1356
1357
1358 BEGIN
1359 END.