1 * *************************************************************************
2 * *
3 * Copyright c 1980 by Centre Interuniversitaire de Calcul de Grenoble *
4 * and Institut National de Recherche en Informatique et Automatique *
5 * *
6 ************************************************************************* *
7
8
9
10
11 * HISTORY COMMENTS:
12 1 change86-09-11JMAthane, approve86-09-11MCR7521,
13 audit86-09-15JPFauche, install86-11-12MR12.0-1212:
14 Release 8.03 for MR12
15 END HISTORY COMMENTS *)
16
17
18 $OPTIONS switch trace := true $
19 PROGRAM expr ;
20
21 $IMPORT
22 * IMPORTED PROCEDURES *
23 'RACINE pascal' :
24 crealfabox,
25 error,
26 insymbol,
27 nameisref,
28 nextline,
29 skip,
30 warning ;
31 'GENERE pascal' :
32 enterreftosymbol,
33 gendesca,
34 gendescb,
35 geneism,
36 genstand,
37 inser ;
38 'CONTEXTTABLE pascal' :
39 checkminmax,
40 compatbin,
41 conformantdim,
42 create_konst_box,
43 findminmax,
44 warningminmax ;
45 'MODATTR pascal' :
46 convreal,
47 easyvar,
48 freeattr,
49 initattrvarbl,
50 is_possible_string,
51 isstring,
52 lvalvarbl,
53 printattr,
54 varissimple ;
55 'MODVARIABLE pascal ' :
56 init_desc_address,
57 passparams,
58 variable ;
59
60 'STATE pascal' :
61 addressvar,
62 calcvarient,
63 checkbnds,
64 choicerarq,
65 entercst,
66 enterlcst,
67 enterllcst,
68 enterundlab,
69 freebloc,
70 gencheckmultover,
71 gencstecode,
72 genexceptcode,
73 inbounds,
74 loadadr,
75 loadbase,
76 newbloc,
77 oldnewstor,
78 raisused,
79 regenere,
80 sauvereg,
81 transfer,
82 variab ;
83 'GENOPER pascal' :
84 check_dynamic_string_length,
85 genandor,
86 gencompare,
87 genconcat,
88 gendivmod,
89 genopadd,
90 genopdivi,
91 genopmult,
92 genoppw,
93 genopsub,
94 genptcomp,
95 gen_string_comp,
96 gen_string_position,
97 gen_substring,
98 genstcomp ;
99 'optimized_procedures alm' :
100 search,
101 srchrec ;
102 * IMPORTED VARIABLES *
103 'RACINE pascal' :
104 alfaptr,
105 boolptr,
106 charptr,
107 cl,
108 ctptr,
109 declarationpart,
110 envstandard,
111 exportablecode,
112 interactive,
113 intptr,
114 ival,
115 lamptr,
116 level,
117 longchaine,
118 longstring,
119 mpcogout,
120 next,
121 nilptr,
122 no,
123 pascalfrench,
124 pnumptr,
125 realptr,
126 rval,
127 string_ptr,
128 symbolfile,
129 symbolline,
130 symbolmap,
131 textfilectp,
132 undecptr ;
133 'DECLARE pascal' :
134 lkc,
135 nextalf ;
136 'GENERE pascal' :
137 cb,
138 indfich,
139 mfari1,
140 mfari2,
141 usednameaddr ;
142 'STATE pascal' :
143 arrayboundsctp,
144 asscheck,
145 currentbloc,
146 currentpr,
147 divcheck,
148 gattr,
149 inputctp,
150 inxcheck,
151 linktomain,
152 linktomainplace,
153 maxinxused,
154 maxprused,
155 modif,
156 nulpw,
157 opaq,
158 prinst,
159 psrsize,
160 stattrace,
161 workformaths,
162 workformathsplacew $
163
164 $EXPORT
165 expression $
166
167
168
169 $OPTIONS page $
170
171
172 $INCLUDE 'CONSTTYPE' $
173
174 $OPTIONS page $
175
176 VAR
177
178 * REDEFINE IMPORTED VARIABLES *
179 * FROM RACINE *
180 declarationpart : boolean ;
181 next : ctp ;
182 longstring : integer ;
183 mpcogout : text ; nilptr : ctp ;
184 cl : integer ;
185 envstandard : stdkind ;
186 lamptr : ctp ;
187 longchaine : integer ;
188 no : integer ;
189 pascalfrench : boolean ;
190 pnumptr : ctp ;
191 realptr : ctp ;
192 rval : real ;
193 string_ptr : ctp ;
194 symbolfile : integer ;
195 symbolline : integer ;
196 symbolmap : boolean ;
197 ctptr : ctp ;
198 intptr : ctp ;
199 textfilectp : ctp ;
200 undecptr : ctp ;
201 ival : integer ;
202 alfaptr : ctp ;
203 boolptr : ctp ;
204 charptr : ctp ;
205 level : levrange ;
206 exportablecode : boolean ;
207 interactive : boolean ;
208
209
210 * FROM GENERE *
211 cb : integer ;
212 indfich : integer ;
213 mfari1 : zari ;
214 mfari2 : zari ;
215 usednameaddr : ctp ;
216
217
218 * FROM DECLARE *
219 nextalf : ctp ;
220 lkc : integer ;
221
222
223 * FROM STATE *
224 arrayboundsctp : ctp ;
225 divcheck : boolean ;
226 inxcheck : boolean ;
227 asscheck : boolean ;
228 gattr : attr ;
229 currentbloc : regpt ;
230 inputctp : ctp ;
231 maxprused : preg ;
232 maxinxused : register ;
233 nulpw : setarray ;
234 stattrace : levtrace ;
235 psrsize : integer ;
236 linktomain : boolean ;
237 linktomainplace : integer ;
238 opaq : ARRAY typeofop ra..reaq OF istand ; * GIVES INST. WITH AQAQEAQ *
239 prinst : ARRAY typepr pr1..pr6 OF istand ;
240 currentpr : preg ;
241 modif : ARRAY nxreg..rq OF tag ;
242 workformaths : boolean ;
243 workformathsplacew : integer ;
244
245
246 $OPTIONS page $
247
248 * REDEFINE IMPORTED PROCEDURES *
249 * FROM GENERE *
250 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
251 PROCEDURE geneism fcode : ieism ; ffield : integer ; fbits : zptr ; EXTERNAL ;
252 PROCEDURE gendesca fareg : preg ; fadr fcn : integer ; fta : lgcar ;
253 fn : integer ; frlgth : mreg ; EXTERNAL ;
254 PROCEDURE gendescb fareg : preg ; fadr fc fb : integer ; fn : integer ;
255 frlgth : mreg ; EXTERNAL ;
256 PROCEDURE inser fcb : integer ; fplace : integer ; EXTERNAL ;
257 FUNCTION enterreftosymbol ctplace : ctp : integer ; EXTERNAL ;
258
259
260 * FROM RACINE *
261 PROCEDURE error errno : integer ; EXTERNAL ;
262 PROCEDURE insymbol ; EXTERNAL ;
263 PROCEDURE nameisref p : ctp ; f l : integer ; EXTERNAL ;
264 PROCEDURE nextline ; EXTERNAL ;
265 PROCEDURE crealfabox VAR fkonstbox : ctp ; EXTERNAL ;
266 PROCEDURE srchrec VAR first : ctp ; EXTERNAL ;
267 PROCEDURE search ; EXTERNAL ;
268 PROCEDURE skip symbcode : integer ; EXTERNAL ;
269 PROCEDURE warning fno : integer ; EXTERNAL ;
270
271
272
273 * IMPORTED PROCEDURES FROM CONTEXTTABLE *
274
275 PROCEDURE checkminmax fvalu : integer ; fctp : ctp ; ferrnum : integer ; EXTERNAL ;
276 PROCEDURE compatbin typleft typright : ctp ; VAR fgeneric : ctp ; EXTERNAL ;
277 FUNCTION conformantdim ff : ctp : boolean ; EXTERNAL ;
278 PROCEDURE create_konst_box VAR fvbox : ctp ; fname : alfaid ; ftypofconst : consttype ; EXTERNAL ;
279 PROCEDURE findminmax fctp : ctp ; VAR fmin fmax : integer ; EXTERNAL ;
280 PROCEDURE warningminmax fvalu : integer ; fctp : ctp ; ferrnum : integer ; EXTERNAL ;
281
282 * FROM STATE *
283 PROCEDURE choicerarq ; EXTERNAL ;
284 PROCEDURE enterlcst VAR fval : setarray ; VAR fboxpt : lcstpt ; EXTERNAL ;
285 PROCEDURE enterllcst VAR fval : setarray ; VAR fboxpt : llcstpt ; EXTERNAL ;
286 PROCEDURE enterundlab VAR fundinx : integer ; EXTERNAL ;
287 PROCEDURE transfer VAR fattr : attr ; inwhat : destination ; EXTERNAL ;
288 PROCEDURE newbloc freg : register ; EXTERNAL ;
289 PROCEDURE entercst fval : integer ; VAR fboxpt : wcstpt ; EXTERNAL ;
290 FUNCTION oldnewstor incrinbytes : integer : integer ; EXTERNAL ;
291 FUNCTION raisused : boolean ; EXTERNAL ;
292 PROCEDURE freebloc VAR fbtofree : regpt ; EXTERNAL ;
293 PROCEDURE loadadr VAR fattr : attr ; wantedpr : preg ; EXTERNAL ;
294 FUNCTION inbounds fval fmin fmax : integer : boolean ; EXTERNAL ;
295 PROCEDURE regenere oldbloc : regpt ; EXTERNAL ;
296 PROCEDURE calcvarient VAR fattr : attr ; VAR fbase : preg ; VAR fdisp : integer ;
297 VAR ftag : tag ; EXTERNAL ;
298 PROCEDURE gencompare VAR fattr : attr ; fcl : integer ; generic : ctp ; EXTERNAL ;
299 PROCEDURE genconcat VAR fattr : attr ; EXTERNAL ;
300 PROCEDURE genptcomp VAR fattr : attr ; fcl : integer ; EXTERNAL ;
301 PROCEDURE gen_string_comp VAR fattr : attr ; fcl : integer ; EXTERNAL ;
302 PROCEDURE gen_string_position VAR fattr : attr ; EXTERNAL ;
303 PROCEDURE gen_substring VAR string_attr disp_attr len_attr : attr ; EXTERNAL ;
304 PROCEDURE genstcomp VAR fattr : attr ; fcl : integer ; EXTERNAL ;
305 PROCEDURE sauvereg freg : register ; fload : boolean ; EXTERNAL ;
306 PROCEDURE gencstecode farg : integer ; finst : istand ; EXTERNAL ;
307 PROCEDURE checkbnds errcode : integer ; freg : register ; fctp : ctp ; EXTERNAL ;
308 PROCEDURE genopadd VAR fattr : attr ; generic : ctp ; EXTERNAL ;
309 PROCEDURE genopsub VAR fattr : attr ; generic : ctp ; EXTERNAL ;
310 PROCEDURE genoppw VAR fattr : attr ; fno fcl : integer ; EXTERNAL ;
311 PROCEDURE check_dynamic_string_length VAR fattr : attr ; EXTERNAL ;
312 PROCEDURE genandor VAR fattr : attr ; fno : integer ; EXTERNAL ;
313 PROCEDURE gencheckmultover ; EXTERNAL ;
314 PROCEDURE addressvar fctp : ctp ; VAR fattr : attr ; modif : boolean ; EXTERNAL ;
315 PROCEDURE genopmult VAR fattr : attr ; generic : ctp ; EXTERNAL ;
316 PROCEDURE genopdivi VAR fattr : attr ; EXTERNAL ;
317 PROCEDURE gendivmod VAR fattr : attr ; fcl : integer ; EXTERNAL ;
318 PROCEDURE genexceptcode ferrcode : integer ; freg : register ; EXTERNAL ;
319 PROCEDURE loadbase flev : integer ; EXTERNAL ;
320 PROCEDURE variab fvarset : boolean ; EXTERNAL ;
321
322
323 * FROM MODATTR *
324
325 FUNCTION easyvar VAR fattr : attr : boolean ; EXTERNAL ;
326 FUNCTION is_possible_string VAR fattr : attr : boolean ; EXTERNAL ;
327 FUNCTION isstring VAR fattr : attr : boolean ; EXTERNAL ;
328 FUNCTION varissimple VAR fattr : attr : boolean ; EXTERNAL ;
329 PROCEDURE convreal VAR fattr : attr ; EXTERNAL ;
330 PROCEDURE freeattr VAR fattr : attr ; EXTERNAL ;
331 PROCEDURE initattrvarbl VAR fattr : attr ; EXTERNAL ;
332 PROCEDURE lvalvarbl VAR fattr : attr ; EXTERNAL ;
333 PROCEDURE printattr VAR fattr : attr ; EXTERNAL ;
334
335 * FROM MODVARIABLE *
336
337 PROCEDURE init_desc_address fctp : ctp ; VAR fattr : attr ; EXTERNAL ;
338 PROCEDURE passparams fctplace : integer ; EXTERNAL ;
339 PROCEDURE variable fvarset : boolean ; EXTERNAL ;
340
341
342 * ************************ FORWARD ******************************* *
343 PROCEDURE expression ; FORWARD ;
344
345
346
347 $OPTIONS page $
348
349
350 * ***************************************** COMPAREIR ******** *
351
352 PROCEDURE compareir ;
353
354 * C Compilation of CCSUBARR -1 <
355 0 =
356 1 >
357 C *
358
359 LABEL
360 10 ; * Exit procedure *
361
362 VAR
363 erro, errt, errl : boolean ;
364 typelem : ctp ;
365 easyo, easyt, easyl : boolean ;
366 baseo, baset : preg ;
367 dplmtow, dplmttw, dplmtob, dplmttb : integer ;
368 temp1, temp2, temp3, temp4 : integer ;
369 basebloco, basebloct : regpt ;
370 longop : integer ;
371 longreg : register ;
372
373 BEGIN * COMPAREIR *
374
375 $OPTIONS cc = trace + $
376 IF stattrace > none THEN
377 BEGIN
378 write mpcogout '@@@ debut COMPAREIR @@@ ' ;
379 nextline ;
380 END ;
381 $OPTIONS cc = trace - $
382 erro := true ; errt := true ; errl := true ;
383 basebloco := NIL ; basebloct := NIL ;
384 * ORIGIN ANALYSIS *
385 insymbol ;
386 variab false ;
387 WITH gattr DO
388 IF typtr <> NIL THEN
389 BEGIN
390 erro := false ;
391
392 IF varissimple gattr THEN
393 BEGIN
394 easyo := true ; baseo := basereg ; dplmtow := dplmt DIV bytesinword ;
395 dplmtob := dplmt MOD bytesinword ;
396 END * varissimple * ELSE
397 BEGIN * not easy *
398 easyo := false ; dplmtow := 0 ; dplmtob := 0 ;
399 loadadr gattr nreg ;
400 baseo := currentpr ; basebloco := currentbloc ;
401 END * not easy * ;
402 END * TYPTR not nil for origin * ;
403 IF no <> 15 THEN
404 BEGIN
405 error 20 ; skip 46 ; GOTO 10 ;
406 END ;
407
408 * TARGET *
409 insymbol ;
410 variab true ;
411 WITH gattr DO
412 IF typtr <> NIL THEN
413 BEGIN
414 errt := false ;
415 IF varissimple gattr THEN
416 BEGIN
417 easyt := true ; baset := basereg ; dplmttw := dplmt DIV bytesinword ;
418 dplmttb := dplmt MOD bytesinword ;
419 END ELSE
420 BEGIN * not easy *
421 easyt := false ; dplmttw := 0 ; dplmttb := 0 ;
422 loadadr gattr nreg ;
423 baset := currentpr ; basebloct := currentbloc ;
424 END * not easy * ;
425 END * TYPTR not nil for target * ;
426 IF no <> 15 * * THEN
427 BEGIN
428 error 20 ; skip 46 ; GOTO 10 ;
429 END ;
430 * THIRD PARAMETER *
431 insymbol ;
432 expression ;
433 WITH gattr DO
434 IF typtr <> NIL THEN
435 BEGIN
436 IF typtr^.form <> numeric THEN error 15 ELSE
437 BEGIN * NUMERIC *
438 errl := false ;
439 IF kind = sval THEN
440 BEGIN
441 easyl := true ; longop := val ;
442 END * SVAL * ELSE
443 BEGIN * NOT SVAL *
444 easyl := false ;
445 IF kind <> lval THEN
446 transfer gattr inacc ;
447 longreg := gattr.ldreg ;
448 END * NOT SVAL * ;
449
450 END ; * NUMERIC *
451 END * typtr not nil for third paramater * ;
452 IF NOT erro OR errt OR errl THEN
453 BEGIN
454 IF NOT easyo THEN regenere basebloco ;
455 IF NOT easyt THEN regenere basebloct ;
456 IF easyl THEN
457 BEGIN
458 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
459 geneism icmpc ord ' ' p0t0r0 ;
460 gendesca baseo dplmtow dplmtob l9 longop tn ;
461 gendesca baset dplmttw dplmttb l9 longop tn ;
462 END * EASYL * ELSE
463 BEGIN * register loaded with length *
464 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
465 geneism icmpc ord ' ' p0t0r0 ;
466 gendesca baseo dplmtow dplmtob l9 0 modif longreg ;
467 gendesca baset dplmttw dplmttb l9 0 modif longreg ;
468 END * not easy * ;
469 freebloc basebloco ; freebloc basebloct ;
470 IF NOT easyl THEN freebloc gattr.ldregbloc ;
471 *
472 After CMPC INDICATOR ZERO ON MEANS EQUAL
473 INDICATOR CARRY ON MEANS >=
474 *
475
476 temp3 := indfich ; genstand nreg 0 itnz tic ;
477 genstand nreg 0 ilda tdl ;
478 temp4 := indfich ; genstand nreg 0 itra tic ;
479 inser cb temp3 ;
480 * ICI ZERO OFF *
481 temp1 := indfich ; genstand nreg 0 itrc tic ;
482 gencstecode -1 ilda ; * Carry off *
483 temp2 := indfich ; genstand nreg 0 itra tic ;
484 inser cb temp1 ;
485 genstand nreg 1 ilda tdl ;
486 inser cb temp4 ; inser cb temp2 ;
487 END ;
488 IF no <> 10 THEN
489 BEGIN
490 error 4 ; skip 46 ;
491 END ;
492 10 : * EXIT IF ERRORS *
493 $OPTIONS cc = trace + $
494 IF stattrace > low THEN
495 BEGIN
496 write mpcogout '@@@ fin COMPAREIR @@@ with NOCL ' no : 4 cl : 4 ;
497 nextline ;
498 END ;
499 $OPTIONS cc = trace - $
500
501 END * COMPAREIR * ;
502
503 $OPTIONS page $
504
505 * ******************************** PREDEFFUNCT ***************************** *
506
507 PROCEDURE predeffunct ;
508
509 * C This procedure is called only one time in FACTOR for generation and
510 analysis of predefined functions.
511 Before the call The first INSYMBOL following the name of the function
512 has alresdy been made.
513 CTPTR points the box found in CONTEXTTABLE.This box represents
514
515 a PROC PREDEFPROC true PROCTYPE <> REALPTR
516
517 As output GATTR describes the resulting expression
518 GATTR.TYPTR nil if error
519 the code for function is generated
520 C *
521 * E ERRORS DETECTED
522 4 "" expected
523 9 "" expected
524 44 Extension used is SOL but is not yet implemented
525 73 Extension used is neither SOL neither Standard.
526 75 Extension used is SOL but not Standard.
527 125 Illegal argument for predefined function
528 175 INPUT used and not present in program header
529 190 Text file expected
530 303 Value out of bounds
531
532 E *
533
534 CONST
535 stringiostringaddrplacew = 0 ;
536 stringiomaxlplacew = 2 ;
537 stringioindexplacew = 3 ;
538 stringiovalplacew = 4 ;
539 stringiolongplacew = 6 ;
540 stringioscaleplacew = 7 ;
541 stringiosizeplacew = 7 ;
542 stringiosubindexplacew = 8 ;
543 stringiostackptrplacew = 10 ;
544 stringioworksizew = 12 ;
545 VAR
546 catfonct : integer ;
547 isopbrack : boolean ;
548 lattr : attr ;
549 lmax : integer ;
550 lmin : integer ;
551 locerr : integer ;
552 operplace : integer ;
553 typofarg : ctp ;
554 lbase : preg ;
555 locskip : integer ;
556 locexit : integer ;
557 totransfer : boolean ;
558 lstor : istand ;
559 lerr : boolean ;
560 ltag : tag ;
561 dummy_bool : boolean ;
562 lbloc : regpt ; l_val : integer ;
563 ldisp : integer ;
564 string_attr, disp_attr, len_attr : attr ;
565 linst : istand ;
566 locop : integer ;
567 lreg : register ;
568
569
570 * ************************************ SWRITEIR < PREDEFFUNCTION ******************************* *
571
572 PROCEDURE swriteir ;
573
574 * COMPILES CALL TO SOL PREDEFINED FUNCTION SWRITE
575 C *
576 * E ERRORS DETECTED
577 4: "" EXPECTED
578 9: "" EXPECTED
579 15: INTEGER EXPECTED
580 19: STRING VARIABLE EXPECTED
581 20: "" EXPECTED
582 144: ILLEGAL TYPE OF EXPRESSION
583 191: SCALING FACTOR ONLY FOR REAL
584 E *
585 LABEL
586 100,
587 1 * EXIT PROC * ;
588
589 VAR
590
591 deflength : integer ;
592 hardlength : boolean ;
593 ddisp : integer ;
594 locreg : preg ;
595 locbox : regpt ;
596 errintype : boolean ;
597 exprismade : boolean ;
598 finloop : boolean ;
599 lengthst : integer ;
600 linst : istand ;
601 typecode : integer ;
602 sattr : attr ;
603 aisknown : boolean ;
604 acont : integer ;
605 workplacew : integer ;
606
607 BEGIN * SWRITEIR *
608 $OPTIONS compile = trace $
609 IF stattrace > none THEN
610 BEGIN
611 write mpcogout '^^^ DEBUT SWRITEIR ^^^ ' ;
612 nextline ;
613 END ;
614 $OPTIONS compile = true $
615 typecode := 0 ;
616 locbox := NIL ;
617 workplacew := oldnewstor stringioworksizew * bytesinword DIV bytesinword ;
618 * "" ALLREADY READ IN PREDEFFUNCT *
619 insymbol ;
620 IF no <> 1 THEN
621 BEGIN
622 error 19 ;
623 skip 15 ;
624 END
625 ELSE
626 BEGIN
627 variab true ; * TARGET STRING *
628 IF isstring gattr THEN
629 IF conformantdim gattr.typtr THEN
630 BEGIN
631 init_desc_address gattr.nameaddr gattr ;
632 regenere gattr.basebloc ;
633 genstand pr6 workplacew + stringiostringaddrplacew prinst spri gattr.basereg tn ;
634 * COMPUTE SIZE NOW *
635 sauvereg ra false ;
636
637 regenere gattr.descbloc ;
638 ddisp := 0 ;
639 genstand gattr.descreg ddisp + 1 ilda tn ; * MAX *
640 genstand gattr.descreg ddisp isba tn ; * - MIN *
641 genstand nreg 1 iada tdl ; * +1 *
642 freeattr gattr ;
643 genstand pr6 workplacew + stringiomaxlplacew ista tn ;
644 END ELSE
645 BEGIN
646 loadadr gattr pr3 ;
647 genstand pr6 workplacew + stringiostringaddrplacew ispri3 tn ;
648 sauvereg ra false ;
649 gencstecode gattr.typtr^.size ilda ;
650 genstand pr6 workplacew + stringiomaxlplacew ista tn ;
651 END
652 ELSE
653 error 19 ;
654 END ;
655 IF no <> 15 THEN * "" *
656 BEGIN error 20 ; skip 15 END
657 ELSE insymbol ;
658 expression ; * PLACE IN STRING *
659 WITH gattr DO
660 BEGIN
661 IF typtr <> NIL THEN
662 IF typtr^.form <> numeric THEN
663 BEGIN
664 error 15 ; skip 15
665 END
666 ELSE
667 BEGIN
668 choicerarq ;
669 linst := opaq stor ldreg ;
670 freebloc gattr.ldregbloc ;
671 genstand pr6 workplacew + stringioindexplacew linst tn ;
672 END ;
673 END ;
674 IF no <> 15 THEN * "" *
675 BEGIN error 20 ; skip 15 END
676 ELSE insymbol ;
677 REPEAT * LOOP ON EXPRESSIONS TO BE WRITTEN *
678 expression ;
679 WITH gattr DO
680 IF typtr <> NIL THEN
681 BEGIN
682 IF typtr^.father_schema = string_ptr THEN
683 BEGIN
684 typecode := 256 ;
685 loadadr gattr pr3 ;
686 freeattr gattr ;
687 genstand pr3 0 ilda tn ;
688 genstand pr6 workplacew + stringiosizeplacew ista tn ;
689 genstand pr3 1 iepp3 tn ;
690 genstand pr6 workplacew + stringiovalplacew ispri3 tn ;
691 hardlength := true ;
692 GOTO 100 ;
693 END
694 ELSE
695 BEGIN
696 linst := inop ;
697 IF typtr^.form <= pointer THEN
698 BEGIN
699 choicerarq ;
700 linst := opaq stor ldreg ;
701 freebloc gattr.ldregbloc ;
702 END * <=POINTER * ELSE
703 IF typtr^.form < files THEN
704 BEGIN
705 IF NOT conformantdim gattr.typtr THEN
706 BEGIN
707 loadadr gattr pr3 ;
708 linst := ispri3 ;
709 END ELSE
710 BEGIN
711 init_desc_address gattr.nameaddr gattr ;
712 regenere gattr.basebloc ;
713 locbox := gattr.descbloc ;
714 linst := prinst spri gattr.basereg ;
715 sattr := gattr ;
716 freebloc sattr.basebloc ;
717 END ;
718 END ;
719 IF linst <> inop THEN
720 BEGIN
721 genstand pr6 workplacew + stringiovalplacew linst tn ;
722 END ;
723 END ;
724 errintype := false ;
725 hardlength := false ;
726 * SELECT TYPECODE *
727 * LENGTH FOR EACH TYPE *
728 CASE typtr^.form OF
729 reel : BEGIN
730 typecode := 8 ; deflength := deflreal ;
731 END * REEL * ;
732 numeric : BEGIN
733 typecode := 4 ; deflength := deflnum ;
734 END * NUMERIC * ;
735 scalar : BEGIN IF typtr^.subrng THEN typtr := typtr^.typset ;
736 IF typtr = boolptr THEN
737 BEGIN typecode := 2 ; deflength := deflbool ;
738 END ELSE
739 IF typtr = charptr THEN
740 BEGIN typecode := 1 ; deflength := deflchar ;
741 END ELSE
742 IF envstandard <> stdextend THEN
743 BEGIN
744 errintype := true ;
745 END
746 ELSE
747 BEGIN
748 typecode := 128 ; deflength := maxident ;
749 genstand nreg enterreftosymbol typtr ilda tdl ;
750 genstand pr6 workplacew + stringioscaleplacew ista tn ;
751 END
752 END * SCALAR * ;
753 pointer records power :
754 errintype := true ;
755 files : errintype := true ;
756 arrays :
757 BEGIN
758 IF isstring gattr THEN
759 BEGIN
760 typecode := 32 ; hardlength := false ;
761 IF typtr = alfaptr THEN
762 lengthst := alfactp^.alfalong ELSE
763 IF typtr^.conformant THEN
764 hardlength := true ELSE
765 lengthst := typtr^.size ;
766 deflength := lengthst ;
767 END ELSE
768 errintype := true ;
769 END ;
770 END * CASE TYPTR^.FORM * ;
771 IF errintype THEN
772 BEGIN error 144 ; typecode := 4 ; deflength := deflnum ;
773 END ;
774 END * TYPTR <> nil WITH GATTR *
775 ELSE sattr := gattr ;
776 aisknown := false ;
777 100 :
778 IF no = 19 * : * THEN
779 BEGIN
780 insymbol ; expression ;
781 IF gattr.typtr <> NIL THEN
782 IF gattr.typtr^.form <> numeric THEN error 15 ELSE
783 BEGIN
784 transfer gattr inacc ;
785 freebloc gattr.ldregbloc ;
786 hardlength := false ;
787 freebloc locbox ;
788 END ;
789 END ELSE
790 IF sattr.typtr <> NIL THEN
791 IF NOT hardlength THEN
792 BEGIN
793 aisknown := true ;
794 acont := deflength ;
795 gencstecode deflength ilda ;
796 IF typecode = 2 AND NOT pascalfrench THEN
797 BEGIN
798 genstand pr6 workplacew + stringiovalplacew iszn tn ;
799 genstand nreg 2 itnz tic ;
800 genstand nreg 1 iada tdl ; * LENGTH + 1 if "FALSE" *
801 END
802 END ELSE
803 IF typecode <> 256 THEN
804 BEGIN
805 regenere sattr.descbloc ;
806 locbox := NIL ;
807 * COMPUTE SIZE NOW *
808
809 ddisp := 0 ;
810 genstand sattr.descreg ddisp + 1 ilda tn ; * MAX *
811 genstand sattr.descreg ddisp isba tn ; * - MIN *
812 genstand nreg 1 iada tdl ; * +1 *
813 freebloc sattr.descbloc ;
814 END ;
815 * STORE LENGTH *
816 genstand pr6 workplacew + stringiolongplacew ista tn ;
817 IF no = 19 * : * THEN
818 BEGIN
819 IF NOT typecode IN 8 32 256 * REAL OR STRING * THEN error 191 ;
820 typecode := typecode * 2 ;
821 aisknown := false ;
822 insymbol ; expression ;
823 IF gattr.typtr <> NIL THEN
824 IF gattr.typtr^.form <> numeric THEN error 15 ELSE
825 BEGIN
826 transfer gattr inacc ;
827 freebloc gattr.ldregbloc ;
828 IF typecode = 16 THEN
829 genstand pr6 workplacew + stringioscaleplacew ista tn
830 ELSE
831 genstand pr6 workplacew + stringiosubindexplacew ista tn ;
832 END ;
833 END ;
834 IF NOT hardlength THEN
835 BEGIN
836 IF typecode IN 32 64 * CHAINE * THEN
837 BEGIN
838 IF NOT aisknown AND acont = lengthst THEN
839 BEGIN
840 gencstecode lengthst ilda ;
841 aisknown := true ; acont := lengthst ;
842 END ;
843 genstand pr6 workplacew + stringiosizeplacew ista tn ;
844 END ;
845
846 END ELSE
847 IF typecode <> 256 AND typecode <> 512 THEN
848 BEGIN
849 genstand pr6 workplacew + stringiosizeplacew ista tn ;
850 END ;
851 sauvereg pr1 false ;
852 genstand pr6 workplacew iepp1 tn ;
853 CASE typecode OF
854 0 : ;
855 1 : genstand pr0 swritecharplace itsp3 tn ;
856 2 : genstand pr0 swritebooleanplace itsp3 tn ;
857 4 : genstand pr0 swriteintegerplace itsp3 tn ;
858 8 : genstand pr0 swriterealeplace itsp3 tn ;
859 16 : genstand pr0 swriterealdplace itsp3 tn ;
860 32 256 : genstand pr0 swritestringplace itsp3 tn ;
861 64 512 : genstand pr0 swritesubstringplace itsp3 tn ;
862 128 : genstand pr0 swriteenumplace itsp3 tn ;
863 END ;
864 * IS LOOP ENDED OR NOT *
865 finloop := true ;
866 IF no <> 10 * * THEN
867 IF no = 15 * * THEN
868 BEGIN
869 insymbol ; finloop := false ;
870 END ELSE
871 BEGIN
872 error 20 ; skip 15 ;
873 insymbol ; finloop := false ;
874 END ;
875 UNTIL finloop ;
876 * LOAD RA WITH INDEX . READY FOR PREDEFFUNCT *
877 genstand pr6 workplacew + stringioindexplacew ilda tn ;
878 1 : * EXIT PROCEDURE *
879 $OPTIONS compile = trace $
880 IF stattrace > low THEN
881 BEGIN
882 write mpcogout '^^^ FIN SWRITEIR ^^^ WITH NO :' no : 4 ; nextline ;
883 END ;
884 $OPTIONS compile = true $
885 END * SWRITEIR * ;
886
887
888 * ************************************ SREADIR < PREDEFFUNCTION ******************************** *
889
890 PROCEDURE sreadir ;
891
892 * C COMPILES CALL TO SOL PREDEFINED FUNCTION SREAD
893 * E ERRORS DETECTED
894 4: "" EXPECTED
895 9: "" EXPECTED
896 15 : NUMERIC TYPE EXPECTED
897 19: STRING VARIABLE EXPECTED
898 20: "" EXPECTED
899 153: TYPE ERROR IN READ
900 E *
901 LABEL
902 1 ; * EXIT OF PROCEDURE *
903 VAR
904
905 finloop : boolean ;
906 lattr : attr ;
907 lerr : boolean ;
908 workplacew : integer ;
909 loctype : ctp ;
910 typecode : integer ;
911 locic : integer ;
912 ddisp : integer ;
913
914
915 BEGIN * SREADIR *
916 $OPTIONS compile = trace $
917 IF stattrace > none THEN
918 BEGIN
919 write mpcogout '^^^ DEBUT SREADIR ^^^ ' ;
920 nextline ;
921 END ;
922 $OPTIONS compile = true $
923 typecode := 0 ;
924 workplacew := oldnewstor stringioworksizew * bytesinword DIV bytesinword ;
925 * "" ALLREADY READ IN PREDEFFUNCT *
926 insymbol ;
927 IF no <> 1 THEN
928 BEGIN
929 error 19 ;
930 skip 15 ;
931 END
932 ELSE
933 BEGIN
934 variab false ; * TARGET STRING *
935 IF isstring gattr THEN
936 IF conformantdim gattr.typtr THEN
937 BEGIN
938 init_desc_address gattr.nameaddr gattr ;
939 regenere gattr.basebloc ;
940 genstand pr6 workplacew + stringiostringaddrplacew prinst spri gattr.basereg tn ;
941 * COMPUTE SIZE NOW *
942 sauvereg ra false ;
943 regenere gattr.descbloc ;
944 ddisp := 0 ;
945 genstand gattr.descreg ddisp + 1 ilda tn ; * MAX *
946 genstand gattr.descreg ddisp isba tn ; * - MIN *
947 genstand nreg 1 iada tdl ; * +1 *
948 freeattr gattr ;
949 genstand pr6 workplacew + stringiomaxlplacew ista tn ;
950 END ELSE
951 BEGIN
952 BEGIN
953 loadadr gattr pr3 ;
954 genstand pr6 workplacew + stringiostringaddrplacew ispri3 tn ;
955 sauvereg ra false ;
956 gencstecode gattr.typtr^.size ilda ;
957 genstand pr6 workplacew + stringiomaxlplacew ista tn ;
958 END
959 END
960 ELSE
961 error 19 ;
962 END ;
963 IF no <> 15 THEN
964 BEGIN error 20 ; skip 15 END
965 ELSE insymbol ;
966 expression ; * PLACE IN STRING *
967 WITH gattr DO
968 BEGIN
969 IF typtr <> NIL THEN
970 IF typtr^.form <> numeric THEN
971 BEGIN
972 error 15 ; skip 15
973 END
974 ELSE
975 BEGIN
976 choicerarq ;
977 linst := opaq stor ldreg ;
978 freebloc gattr.ldregbloc ;
979 genstand pr6 workplacew + stringioindexplacew linst tn ;
980 END ;
981 END ;
982 IF no <> 15 THEN
983 BEGIN error 20 ; skip 15 END
984 ELSE insymbol ;
985 REPEAT
986 variab true ; * VARIABLE IS SET HERE *
987 WITH gattr DO
988 IF typtr <> NIL THEN
989 BEGIN
990 lerr := false ;
991 IF typtr^.form = scalar THEN
992 BEGIN
993 IF typtr^.subrng THEN loctype := typtr^.typset ELSE
994 loctype := typtr ;
995 IF loctype <> charptr THEN
996 lerr := true ELSE
997 typecode := 1 ;
998 END * SCALAR * ELSE
999 IF typtr^.form = numeric THEN
1000 typecode := 4 ELSE
1001 IF typtr = realptr THEN
1002 typecode := 8 ELSE
1003 lerr := true ;
1004 IF lerr THEN
1005 error 153 ELSE
1006 BEGIN
1007 * SAVE LOADED REGISTERS *
1008 IF basereg <= maxprused THEN sauvereg basereg false ;
1009 IF inxreg <> nxreg THEN sauvereg inxreg false ;
1010 lattr := gattr ;
1011 * NOW CALL OPERATOR *
1012 genstand pr6 workplacew iepp1 tn ;
1013 CASE typecode OF
1014 0 : ;
1015 1 : genstand pr0 sreadcharplace itsp3 tn ;
1016 4 : genstand pr0 sreadintegerplace itsp3 tn ;
1017 8 : genstand pr0 sreadrealplace itsp3 tn ;
1018 END ;
1019 * Genere skip if error detected *
1020 genstand pr6 workplacew + stringioindexplacew iszn tn ;
1021 locic := indfich ;
1022 genstand nreg 0 itmi tic ;
1023 * NOW ACC IS LOADED *
1024 * WITH GATTR *
1025 kind := lval ;
1026 IF typtr = realptr THEN
1027 ldreg := reaq ELSE
1028 ldreg := ra ;
1029 newbloc ldreg ; ldregbloc := currentbloc ;
1030 IF asscheck THEN
1031 IF typtr <> realptr THEN
1032 checkbnds asserrcode ra typtr ;
1033 transfer lattr out ; * ASSIGNS *
1034 inser cb locic ;
1035 END * NOT LERR * ;
1036 END * TYPTR <> nilWITH GATTR * ;
1037 * IS LOOP ENDED OR NOT *
1038 finloop := true ;
1039 IF no <> 10 * * THEN
1040 IF no = 15 THEN
1041 BEGIN
1042 insymbol ; finloop := false ;
1043 END ELSE
1044 BEGIN
1045 error 20 ; skip 15 ;
1046 insymbol ; finloop := false ;
1047 END ;
1048 UNTIL finloop ;
1049 * LOAD RA WITH INDEX . READY FOR PREDEFFUNCT *
1050 genstand pr6 workplacew + stringioindexplacew ilda tn ;
1051 1 : * EXIT PROCEDURE *
1052 $OPTIONS compile = trace $
1053 IF stattrace > low THEN
1054 BEGIN
1055 write mpcogout '^^^ FIN SREADIR ^^^ WITH NO:' no : 4 ; nextline ;
1056 END ;
1057 $OPTIONS compile = true $
1058 END * SREADIR * ;
1059
1060 BEGIN * PREDEFFUNCT *
1061
1062 $OPTIONS compile = trace $
1063 IF stattrace > none THEN
1064 BEGIN
1065 write mpcogout '^^^ Debut DE PREDEFFUNCT ^^^ avec NO =' no : 4 ;
1066 nextline ;
1067 END ;
1068 $OPTIONS compile = true $
1069
1070
1071 catfonct := ctptr^.segsize ;
1072 isopbrack := no = 9 ; * Before call NO and CTPTR set in FACTOR *
1073 CASE ctptr^.ploc OF
1074 instdpure :
1075 BEGIN
1076 IF NOT isopbrack THEN
1077 BEGIN
1078 IF NOT catfonct IN 3 4 * EOFEOLN * THEN
1079 BEGIN gattr.typtr := NIL ; error 9 ;
1080 END ELSE
1081 IF inputctp <> NIL THEN
1082 addressvar inputctp gattr false ELSE
1083 BEGIN gattr.typtr := NIL ; error 175 ;
1084 END ;
1085 END * NO <> 9 * ELSE
1086 BEGIN
1087 insymbol ; expression ;
1088 END ;
1089
1090 typofarg := gattr.typtr ;
1091 WITH gattr DO
1092 IF typofarg <> NIL THEN
1093 CASE catfonct OF
1094 0 : * ODD *
1095 BEGIN
1096 IF typofarg^.form <> numeric THEN
1097 error 125 ELSE
1098 BEGIN
1099 IF kind = sval THEN
1100 BEGIN
1101 IF odd val THEN
1102 transf := 4 ELSE transf := 5 ;
1103 accbool := false ; accbloc := NIL ;
1104 kind := lcond ;
1105 END ELSE
1106 BEGIN
1107 transfer gattr inacc ;
1108 genstand nreg 1 iana tdl ;
1109 * BOOLEAN IS IN RA *
1110 accbloc := ldregbloc ; accbool := true ;
1111 transf := 3 ; kind := lcond ;
1112 END * not SVAL * ;
1113 END * NO ERROR * ;
1114 typtr := boolptr ;
1115 END * ODD * ;
1116 1 : * ORD *
1117 BEGIN
1118 IF typofarg^.form = scalar THEN
1119 BEGIN
1120 totransfer := false ;
1121 IF kind = lcond THEN totransfer := true ELSE
1122 IF kind = varbl THEN
1123 IF NOT easyvar gattr THEN totransfer := true ;
1124 IF totransfer THEN
1125 choicerarq ;
1126 typtr := intptr ;
1127 END * SCALAR * ELSE
1128 IF typofarg^.form = pointer THEN
1129 BEGIN
1130 IF envstandard <> stdextend THEN error 125 ;
1131 transfer gattr inacc ; * RAQ =FULL ITS *
1132 freebloc ldregbloc ;
1133 newbloc rq ;
1134 ldreg := rq ; ldregbloc := currentbloc ;
1135 genstand nreg bitsinhword iqrl tn ;
1136 * SHIFT WORD OFFSET *
1137 typtr := intptr ;
1138 END * POINTER * ELSE
1139 IF typtr^.form <> numeric THEN
1140 BEGIN error 125 ; gattr.typtr := NIL ;
1141 END ;
1142 END * ORD * ;
1143 2 : * CHR *
1144 BEGIN
1145 IF typofarg^.form <> numeric THEN error 125 ELSE
1146 IF kind = sval THEN
1147 warningminmax val charptr 303 ELSE
1148 IF asscheck THEN
1149 BEGIN
1150 choicerarq ;
1151 checkbnds chrerrcode ldreg charptr ;
1152 END ;
1153 typtr := charptr ;
1154 END * CHR * ;
1155 3 4 : * EOFEOLN *
1156 BEGIN
1157 IF typofarg^.form <> files THEN
1158 BEGIN
1159 typtr := NIL ; error 125 ;
1160 END ELSE
1161 BEGIN
1162 IF interactive THEN
1163 IF typofarg = textfilectp THEN
1164 BEGIN
1165 sauvereg pr5 false ;
1166 loadadr gattr pr5 ;
1167 newbloc pr5 ;
1168 WITH gattr DO
1169 BEGIN
1170 vlev := level ;
1171 basereg := pr5 ;
1172 basebloc := currentbloc ;
1173 dplmt := 0 ;
1174 inxreg := nxreg ;
1175 inxmem := 0 ;
1176 inxmemrw := true ;
1177 access := pointee ;
1178 itsdplmt := 0 ;
1179 END ;
1180 IF catfonct = 3 THEN
1181 genstand pr0 checkbeforeeofplace itsp3 tn
1182 ELSE
1183 genstand pr0 checkbeforeeolnplace itsp3 tn ;
1184 END ;
1185 IF catfonct = 3 * EOF * THEN
1186 BEGIN
1187 dplmt := dplmt + eofb ;
1188 END * EOF * ELSE
1189 BEGIN * EOLN *
1190 dplmt := dplmt + eolnb ;
1191 IF typofarg <> textfilectp THEN error 190 ;
1192 END ;
1193 typtr := boolptr ;
1194 IF asscheck THEN
1195 BEGIN
1196 transfer gattr inacc ;
1197 checkbnds eofeolnerrcode gattr.ldreg boolptr ;
1198 IF gattr.ldreg = rq THEN
1199 genstand nreg 0 iorq tdl ELSE
1200 genstand nreg 0 iora tdl ;
1201 * RESET BOOLEAN INDICATORS *
1202 END ;
1203 END * FILES * ;
1204 END * EOFEOLN * ;
1205 5 : * ABS *
1206 BEGIN
1207 IF typofarg^.form > numeric THEN
1208 BEGIN error 125 ; gattr.typtr := NIL ;
1209 END ELSE
1210 BEGIN * REEL NUMERIC *
1211 IF typofarg = realptr THEN
1212 BEGIN
1213 linst := ifneg ;
1214 END ELSE
1215 BEGIN
1216 linst := ineg ;
1217 END ;
1218 transfer gattr inacc ;
1219 locskip := indfich ; genstand nreg 0 itpl tic ;
1220 genstand nreg 0 linst tn ;
1221 inser cb locskip ;
1222 IF typofarg <> realptr THEN
1223 typtr := intptr ;
1224 END * NO TYPE ERROR * ;
1225 END * ABS * ;
1226 6 7 : * TRUNCROUND *
1227 BEGIN
1228 IF typofarg <> realptr THEN
1229 BEGIN
1230 typtr := NIL ; error 125 ;
1231 END ELSE
1232 BEGIN
1233 transfer gattr inacc ;
1234 IF catfonct = 6 * TRUNC * THEN
1235 operplace := truncplace ELSE
1236 operplace := roundplace ;
1237 genstand pr0 operplace itsp3 tn ; * RESULT IN RA *
1238 freebloc ldregbloc ;
1239 newbloc ra ;
1240 ldregbloc := currentbloc ;
1241 ldreg := ra ;
1242 typtr := intptr ;
1243 END ;
1244 END * TRUNCROUND * ;
1245 8 9 : * PREDSUCC *
1246 BEGIN
1247 IF NOT typofarg^.form IN numeric scalar THEN
1248 BEGIN error 125 ; gattr.typtr := NIL ;
1249 END ELSE
1250 BEGIN
1251 IF catfonct = 8 * PRED * THEN
1252 BEGIN
1253 linst := isba ;
1254 IF kind = sval THEN
1255 BEGIN
1256 IF val = -maxint - 1 THEN error 303 ELSE
1257 val := val - 1 ;
1258 END ;
1259 END * PRED * ELSE
1260 BEGIN * SUCC *
1261 linst := iada ;
1262 IF kind = sval THEN
1263 IF val = maxint THEN error 303 ELSE
1264 val := val + 1 ;
1265 END * SUCC * ;
1266 IF kind = sval THEN
1267 checkminmax val typofarg 303 ELSE
1268 BEGIN
1269 transfer gattr inacc ;
1270 IF asscheck THEN
1271 BEGIN
1272 findminmax typofarg lmin lmax ;
1273 IF catfonct = 8 * PRED * THEN
1274 BEGIN
1275 lmin := lmin + 1 ; locerr := prderrcode ;
1276 END ELSE
1277 BEGIN
1278 lmax := lmax - 1 ; locerr := sucerrcode ;
1279 END ;
1280 gencstecode lmin icmpa ;
1281 locskip := indfich ;
1282 genstand nreg 0 itmi tic ;
1283 gencstecode lmax icmpa ;
1284 locexit := indfich ;
1285 genstand nreg 0 itmoz tic ;
1286 inser cb locskip ;
1287 genexceptcode locerr ra ;
1288 inser cb locexit ;
1289 END ;
1290 genstand nreg 1 linst tdl ;
1291 END * not SVAL * ;
1292 END * NO TYPERR * ;
1293 END * PREDSUCC * ;
1294 10 : * SQR *
1295 IF typofarg^.form > numeric THEN
1296 BEGIN error 125 ; gattr.typtr := NIL ;
1297 END ELSE
1298 BEGIN
1299 lattr := gattr ;
1300 IF typofarg = realptr THEN
1301 BEGIN
1302 linst := idfmp ; lstor := idfst ;
1303 transfer gattr inacc ;
1304 END ELSE
1305 BEGIN
1306 linst := impy ; lstor := istq ;
1307 transfer gattr inq ;
1308 sauvereg ra false ;
1309 typofarg := intptr ;
1310 END ;
1311 IF NOT varissimple gattr THEN
1312 BEGIN
1313 genstand pr6 evareaw lstor tn ;
1314 genstand pr6 evareaw linst tn ;
1315 END * not EASY * ELSE
1316 BEGIN
1317 calcvarient lattr lbase ldisp ltag ;
1318 WITH lattr DO
1319 IF kind = varbl THEN usednameaddr := nameaddr ;
1320 genstand lbase ldisp linst ltag ;
1321 END ;
1322 IF linst = impy THEN
1323 IF asscheck THEN gencheckmultover ;
1324 typtr := typofarg ;
1325 END * NO ERROR IN SQR * ;
1326 END * CASE CATFONCT * ;
1327 END * INSTDPURE * ;
1328 instdsol :
1329 BEGIN
1330 IF NOT isopbrack THEN
1331 BEGIN
1332 IF NOT catfonct IN 0 1 2 6 * FSIZEFPOSFLLENGTHARGC * THEN
1333 BEGIN gattr.typtr := NIL ; error 9 ;
1334 END ELSE
1335 IF catfonct IN 6 THEN
1336 BEGIN
1337 gattr.typtr := intptr ;
1338 END ELSE
1339 IF inputctp <> NIL THEN
1340 addressvar inputctp gattr false ELSE
1341 BEGIN gattr.typtr := NIL ; error 175 ;
1342 END ;
1343 END * NO <> 9 * ELSE
1344 IF NOT catfonct IN 4 5 THEN
1345 BEGIN
1346 insymbol ; expression ;
1347 END ;
1348
1349 IF envstandard = stdpure THEN
1350 error 75 ;
1351 typofarg := gattr.typtr ;
1352 WITH gattr DO
1353 IF typofarg <> NIL THEN
1354 CASE catfonct OF
1355 0 1 2 : * FSIZEFPOSFLLENTGH *
1356 BEGIN
1357 IF typofarg^.form <> files THEN
1358 error 125 ELSE
1359 BEGIN
1360 IF catfonct = 0 * FSIZE * THEN
1361 BEGIN
1362 dplmt := dplmt + fsizeb ;
1363 END * FSIZE * ELSE
1364 IF catfonct = 1 * FPOS * THEN
1365 BEGIN
1366 dplmt := dplmt + fposb ;
1367 END * FPOS * ELSE
1368 BEGIN * FLLENGTH *
1369 dplmt := dplmt + fllengthb ;
1370 IF typofarg <> textfilectp THEN error 190 ;
1371 END ;
1372 END * FILES * ;
1373 typtr := intptr ;
1374 END * FSIZEFPOSFLLENGTH * ;
1375 3 : * FSTATUS *
1376 BEGIN
1377 error 44 ;
1378 typtr := intptr ;
1379 END * FSTATUS * ;
1380 4 5 : * SREAD SWRITE *
1381 BEGIN
1382 FOR lreg := pr1 TO maxprused DO sauvereg lreg false ;
1383 FOR lreg := x0 TO maxinxused DO sauvereg lreg false ;
1384 FOR lreg := ra TO reaq DO sauvereg lreg false ;
1385 IF catfonct = 4 THEN sreadir ELSE swriteir ;
1386 kind := lval ;
1387 newbloc ra ;
1388 ldregbloc := currentbloc ;
1389 psrsize := 0 ;
1390 ldreg := ra ;
1391 typtr := intptr ;
1392 END * SREADSWRITE * ;
1393 6 : * ARGC *
1394 BEGIN
1395 IF level = 0 THEN
1396 locop := argcshortplace ELSE
1397 BEGIN
1398 IF NOT exportablecode THEN
1399 BEGIN
1400 loadbase 0 ;
1401 IF currentpr <> pr1 THEN
1402 genstand currentpr 0 iepp1 tn ;
1403 * PR1 points MAIN stack frame *
1404 freebloc currentbloc ;
1405 locop := argcplace ;
1406 END ELSE
1407 BEGIN
1408 IF NOT linktomain THEN
1409 BEGIN
1410 linktomainplace := lkc ;
1411 lkc := lkc + bytesindword ;
1412 linktomain := true ;
1413 END ;
1414 genstand prlink linktomainplace DIV bytesinword iepp1 tny ;
1415 * PR1 points MAIN entry point *
1416 locop := argcextplace ;
1417 END * EXPORTABLE * ;
1418
1419 END ; * OPERATOR SELECTION *
1420
1421 genstand pr0 locop itsp3 tn ;
1422
1423 * At return RA is loaded with the number of arguments *
1424 WITH gattr DO
1425 BEGIN
1426 kind := lval ;
1427 newbloc ra ;
1428 ldregbloc := currentbloc ; ldreg := ra ;
1429 typtr := intptr ;
1430 END ;
1431 END * ARGC * ;
1432 END * CASE CATFONCT * ;
1433 END * INSTDSOL * ;
1434 instdextend :
1435 BEGIN
1436 IF NOT isopbrack THEN
1437 BEGIN
1438 IF catfonct <> 0 * CLOCK * THEN
1439 BEGIN error 9 ; gattr.typtr := NIL ;
1440 END ELSE
1441 gattr.typtr := realptr ;
1442 END * NO <> 9 * ELSE
1443 BEGIN
1444 IF NOT catfonct = 2 THEN
1445 BEGIN
1446 insymbol ; expression ;
1447 END ;
1448 END ;
1449
1450 IF envstandard <> stdextend THEN
1451 error 73 ;
1452 typofarg := gattr.typtr ;
1453 WITH gattr DO
1454 IF typofarg <> NIL THEN
1455 CASE catfonct OF
1456 0 : * CLOCK *
1457 WITH gattr DO
1458 BEGIN
1459 typtr := realptr ; kind := lval ;
1460 ldreg := reaq ; sauvereg reaq true ;
1461 ldregbloc := currentbloc ;
1462 genstand pr0 clockopplace itsp3 tn ;
1463 * NOW FLOAT REGISTER IS LOADED *
1464 * WITH NUMBER OF MICSEC *
1465 END * with GATTR CLOCK * ;
1466 1 : * CVPTRINT *
1467 BEGIN
1468 IF typofarg^.form = pointer THEN
1469 BEGIN
1470 transfer gattr inacc ; * RAQ =FULL ITS *
1471 freebloc ldregbloc ;
1472 newbloc rq ; ldreg := rq ;
1473 ldregbloc := currentbloc ;
1474 genstand nreg bitsinhword iqrl tn ;
1475 * SHIFT WORD OFFSET *
1476 typtr := intptr ;
1477 END * POINTER * ELSE
1478 BEGIN error 125 ; gattr.typtr := NIL ;
1479 END ;
1480 END * CVPTRINT * ;
1481 2 : * CCSUBARR *
1482 WITH gattr DO
1483 BEGIN
1484 FOR lreg := pr1 TO maxprused DO sauvereg lreg false ;
1485 FOR lreg := x0 TO maxinxused DO sauvereg lreg false ;
1486 FOR lreg := ra TO reaq DO sauvereg lreg false ;
1487 compareir ;
1488 kind := lval ;
1489 newbloc ra ;
1490 ldregbloc := currentbloc ;
1491 psrsize := 0 ;
1492 ldreg := ra ;
1493 typtr := intptr ;
1494 END * with GATTR CCSUBARR * ;
1495 3 : * LENGTH *
1496 BEGIN
1497 IF NOT is_possible_string gattr OR typtr = NIL THEN
1498 BEGIN
1499 error 274 ; freeattr gattr ;
1500 kind := sval ; val := 0 ;
1501 END
1502 ELSE BEGIN
1503 IF typtr = charptr THEN
1504 BEGIN
1505 freeattr gattr ;
1506 kind := sval ; val := 1 ;
1507 END ELSE
1508 IF isstring gattr THEN
1509 IF conformantdim typtr THEN
1510 BEGIN
1511 init_desc_address nameaddr gattr ;
1512 regenere descbloc ;
1513 sauvereg rq true ; lbloc := currentbloc ;
1514 genstand descreg 1 ildq tn ;
1515 genstand descreg 0 isbq tn ;
1516 genstand nreg 1 iadq tdl ;
1517 freebloc descbloc ;
1518 freeattr gattr ;
1519 ldreg := rq ; ldregbloc := lbloc ;
1520 kind := lval ;
1521 END
1522 ELSE
1523 BEGIN
1524 IF kind = chain THEN
1525 l_val := alfactp^.alfalong
1526 ELSE
1527 l_val := typtr^.size ;
1528 freeattr gattr ;
1529 kind := sval ; val := l_val ;
1530 END
1531 ELSE IF typtr^.father_schema = string_ptr THEN
1532 BEGIN
1533 END ;
1534 END ;
1535 typtr := intptr ;
1536 END ;
1537 4 : * MAXLENGTH *
1538 BEGIN
1539 IF NOT gattr.kind = varbl THEN error 275 ;
1540 IF NOT gattr.typtr^.father_schema = string_ptr THEN error 275 ; * STRING VARIABLE EXPECTED *
1541 typofarg := gattr.typtr ;
1542 freeattr gattr ;
1543 WITH gattr DO
1544 BEGIN
1545 typtr := intptr ;
1546 IF typofarg^.actual_parameter_list = NIL THEN
1547 WITH gattr DO
1548 BEGIN
1549 kind := sval ; val := 0 ;
1550 END
1551 ELSE
1552 WITH typofarg^.actual_parameter_list^ DO
1553 IF klass = konst THEN
1554 WITH gattr DO
1555 BEGIN
1556 kind := sval ; val := values ;
1557 END
1558 ELSE addressvar actual_parameter_list gattr false ;
1559 END ;
1560 END ;
1561 5 : * POSITION *
1562 BEGIN
1563 lerr := false ;
1564 IF NOT is_possible_string gattr THEN
1565 BEGIN error 274 ; lerr := true END ;
1566 IF no <> 15 THEN
1567 BEGIN error 20 ; lerr := true END
1568 ELSE insymbol ;
1569 lattr := gattr ;
1570 expression ;
1571 IF NOT is_possible_string gattr THEN
1572 BEGIN error 274 ; lerr := true END ;
1573 IF NOT lerr THEN gen_string_position lattr
1574 ELSE BEGIN
1575 freeattr gattr ; freeattr lattr ;
1576 WITH gattr DO
1577 BEGIN
1578 typtr := intptr ; kind := sval ; val := 0 ;
1579 END ;
1580 END ;
1581 END ;
1582 6 : * SUBSTR *
1583 BEGIN
1584 lerr := false ;
1585 IF NOT is_possible_string gattr THEN
1586 BEGIN error 274 ; lerr := true END ;
1587 string_attr := gattr ;
1588 IF no <> 15 THEN
1589 BEGIN error 20 ; lerr := true END
1590 ELSE insymbol ;
1591 expression ;
1592 IF gattr.typtr = NIL THEN lerr := true
1593 ELSE IF gattr.typtr^.form <> numeric THEN
1594 BEGIN
1595 lerr := true ; error 15
1596 END ;
1597 disp_attr := gattr ;
1598 IF no <> 15 THEN
1599 BEGIN error 20 ; lerr := true END
1600 ELSE insymbol ;
1601 expression ;
1602 IF gattr.typtr = NIL THEN lerr := true
1603 ELSE IF gattr.typtr^.form <> numeric THEN
1604 BEGIN
1605 lerr := true ; error 15
1606 END ;
1607 len_attr := gattr ;
1608 IF NOT lerr THEN gen_substring string_attr disp_attr len_attr
1609 ELSE BEGIN
1610 freeattr string_attr ; freeattr disp_attr ; freeattr len_attr ;
1611 WITH gattr DO
1612 BEGIN
1613 typtr := charptr ; kind := sval ; val := ord ' ' ;
1614 END ;
1615 END ;
1616 END ;
1617 END * CASE CATFONCT * ;
1618 END * INSTDEXTEND * ;
1619 END * case CTPTR^.PLOC * ;
1620
1621 IF isopbrack THEN
1622 IF no = 10 * * THEN
1623 insymbol ELSE
1624 BEGIN error 4 ; gattr.typtr := NIL ;
1625 END ;
1626
1627 $OPTIONS compile = trace $
1628 IF stattrace > low THEN
1629 BEGIN
1630 write mpcogout '^^^ Fin de PREDEFFUNCT ^^^ avec CATFONCT=' catfonct : 6 ;
1631 nextline ;
1632 END ;
1633 $OPTIONS compile = true $
1634
1635 END * PREDEFFUNCT * ;
1636
1637 $OPTIONS page $
1638
1639 * ************************************ ELEMENT ********************** *
1640
1641 PROCEDURE element VAR fattr : attr ; VAR fvsetelctp : ctp ; VAR fvlpsval : setarray ; VAR fvmax fvmin : integer ; VAR fmaxallow : integer ;
1642
1643 * C .ANALYSES OF AN ELEMENT IN A SET EXPRESSION ..... ...
1644 * EITHER X
1645 * EITHER X..Y
1646 .CONSTANT PART IS COMPUTED IN FVLPSVAL
1647 .AS RESULT .FATTR <---------- LVAL IN RAQ or PSR
1648 SVAL 8 or MAX
1649 . FVMAX IS MAX CSTE FOUND if KIND IS SVAL
1650 . FVMIN same for minimum value
1651 . FVSETELCTP POINTS GENERIC TYPE OF ELEMENTS
1652 .FMAXALLOW PROPAGATES FROM CALL TO CALL MAX VALUE FOR ELEMENT
1653 C *
1654 * E ERRORS DETECTED
1655 1: SCALAR or NUMERIC EXPECTED
1656 102: LOW BOUND MUST not EXCEED HIGH BOUND
1657 129: TYPE CONFLICT
1658 305: SET ELEMENT OUT OF BOUNDS
1659 E *
1660 LABEL
1661 1 ;
1662 VAR
1663 generic : ctp ;
1664 infattr : attr ;
1665 infissval : boolean ;
1666 infval : integer ;
1667 it : integer ;
1668 ldisp : integer ;
1669 lerr : boolean ;
1670 locexit : integer ;
1671 lload : istand ;
1672 ltag : tag ;
1673 stag : tag ;
1674 stpospr : register ;
1675 toloadq : boolean ;
1676
1677 * ************************************ INITPSR < ELEMENT ************* *
1678 PROCEDURE initpsr ;
1679 BEGIN * INITPSR *
1680 IF fattr.kind = sval THEN
1681 BEGIN
1682 * FIRST ITEM VARIABLE *
1683 sauvereg psr true ;
1684 fattr.kind := lval ; fattr.ldreg := psr ; fattr.ldregbloc := currentbloc ;
1685 IF fmaxallow >= bitsindword THEN
1686 psrsize := bytesforset ELSE psrsize := bytesindword ;
1687 * INIT ZONE with "000...0" *
1688 mfari1 := a0r0i0 ; mfari2 := a1r0i0 ;
1689 geneism imlr 0 * PADDING * p0t0r0 ;
1690 gendesca nreg 0 0 l9 0 tn ;
1691 gendesca pr6 psrdepw 0 l9 bytesforset tn ;
1692 END * INIT PSR * ELSE
1693 regenere fattr.ldregbloc ;
1694 END * INITPSR * ;
1695
1696 BEGIN * ELEMENT *
1697 lerr := true ;
1698 1 : expression ;
1699 IF gattr.typtr = NIL THEN
1700 BEGIN
1701 IF no IN 15 39 THEN * .. *
1702 BEGIN
1703 insymbol ; GOTO 1 ;
1704 END ;
1705 END ;
1706 IF gattr.typtr <> NIL THEN
1707 IF fvsetelctp = NIL THEN
1708 BEGIN * FIRST ITEM WITHOUT ERROR *
1709 WITH gattr.typtr^ DO
1710 IF form = numeric THEN
1711 BEGIN
1712 fvsetelctp := intptr ; fmaxallow := bitsforset - 1 ; lerr := false ;
1713 END * NUMERIC * ELSE
1714 IF form = scalar THEN
1715 BEGIN
1716 IF subrng THEN
1717 fvsetelctp := typset ELSE
1718 fvsetelctp := gattr.typtr ;
1719 fmaxallow := fvsetelctp^.fconst^.values ; lerr := false ;
1720 END ELSE
1721 error 1 ;
1722 END * FIRST ITEM * ELSE
1723 BEGIN
1724 compatbin fvsetelctp gattr.typtr generic ;
1725 IF generic = NIL OR generic = realptr THEN
1726 error 129 ELSE lerr := false ;
1727 END ; * end ALSO for GATTR.TYPTR <> nil *
1728 arrayboundsctp^.nmin := 0 ; arrayboundsctp^.nmax := fmaxallow ;
1729 IF fvsetelctp <> NIL AND NOT lerr THEN
1730 BEGIN
1731 WITH gattr DO
1732 IF kind = sval THEN
1733 BEGIN
1734 infissval := true ; infval := 0 ;
1735 IF val < 0 OR val > fmaxallow THEN
1736 error 305 ELSE
1737 BEGIN infval := val ;
1738 IF val < fvmin THEN fvmin := val ;
1739 END ;
1740 END ELSE
1741 BEGIN
1742 infissval := false ;
1743 transfer gattr inq ;
1744 infattr := gattr ;
1745 END * not SVAL with GATTR * ;
1746 IF no <> 39 * .. * THEN
1747 BEGIN
1748 IF infissval THEN
1749 BEGIN
1750 insert_ 1 bitsinword - 1 - infval MOD bitsinword
1751 fvlpsval infval DIV bitsinword ;
1752 IF infval > fvmax THEN fvmax := infval ;
1753 END * SVAL * ELSE
1754 BEGIN * LVAL *
1755 initpsr ;
1756 IF inxcheck THEN
1757 checkbnds seterrcode rq arrayboundsctp ;
1758 sauvereg ra false ;
1759 genstand nreg bitsinword idiv tdl ; * RA BIT DISP RQ WORD DISP *
1760 genstand nreg 0 ieax7 tal ;
1761 genstand nreg -twoto17 ilda tdu ; * 10000.... 00 *
1762 genstand nreg 0 iarl tx7 ; genstand pr6 psrdepw iorsa tql ;
1763 freebloc infattr.ldregbloc ;
1764 END * LVAL * ;
1765 END * NO <> 39 .. * ELSE
1766 BEGIN * NO=39 *
1767 insymbol ; expression ;
1768 WITH gattr DO
1769 IF typtr <> NIL THEN
1770 BEGIN
1771 compatbin fvsetelctp typtr generic ;
1772 IF generic = NIL OR generic = realptr THEN
1773 error 129 ELSE
1774 BEGIN
1775 IF infissval THEN
1776 BEGIN
1777 IF kind = sval THEN
1778 BEGIN * CST1..CST2 *
1779 IF val < infval THEN
1780 warning 102 ELSE
1781 BEGIN
1782 IF val < 0 OR val > fmaxallow THEN error 305 ELSE
1783 FOR it := infval TO val DO
1784 insert_ 1 bitsinword - 1 - it MOD bitsinword
1785 fvlpsval it DIV bitsinword ;
1786 IF val > fvmax THEN
1787 IF val <= fmaxallow THEN fvmax := val ;
1788 END ;
1789 END * CST1..CST2 * ELSE
1790 BEGIN * CST1..EXP2 *
1791 IF kind <> lval THEN
1792 transfer gattr inacc ;
1793 IF ldreg = ra THEN
1794 BEGIN
1795 ltag := tal ; stag := tql ; stpospr := rq ; lload := ildq ;
1796 END ELSE
1797 BEGIN
1798 ltag := tql ; stag := tal ; stpospr := ra ; lload := ilda ;
1799 END ;
1800 IF inxcheck THEN
1801 checkbnds seterrcode ldreg arrayboundsctp ;
1802 IF infval = 0 THEN
1803 genstand nreg 1 opaq add ldreg tdl
1804 ELSE
1805 genstand nreg infval - 1 opaq sub ldreg tdl ;
1806 * LDREG NOW IS LENGTH IN BITS *
1807 locexit := indfich ; genstand nreg 0 itmoz tic ;
1808 * NO OP if LENGTH <=0 *
1809 sauvereg stpospr false ;
1810 genstand nreg infval lload tdl ; * STARTING BIT *
1811 initpsr ;
1812 genstand pr6 psrdepw iepp3 tn ;
1813 genstand pr3 0 iabd stag ;
1814 mfari1 := a0r0i0 ; * DUMMY * mfari2 := a1r1i0 ; * TARGET *
1815 geneism icsl 15 * 1111=MOVE 1 * p1t0r0 ;
1816 gendescb nreg 0 0 0 0 tn ;
1817 gendescb pr3 0 0 0 0 ltag ;
1818 inser cb locexit ;
1819 freebloc ldregbloc ;
1820 END * CST1..EXP2 * ;
1821 END * INFISSVAL * ELSE
1822 BEGIN * INF IS or WAS IN RQ *
1823 initpsr ;
1824 transfer gattr inacc ;
1825 IF inxcheck THEN
1826 checkbnds seterrcode ra arrayboundsctp ;
1827 IF infattr.ldregbloc^.saveplace = 0 THEN
1828 BEGIN
1829 toloadq := false ; sauvereg rq false ;
1830 END ELSE
1831 toloadq := true ;
1832 ldisp := infattr.ldregbloc^.saveplace DIV bytesinword ;
1833 genstand pr6 ldisp isba tn ;
1834 genstand nreg 1 iada tdl ; * LENGTH = SUP-INF+1 *
1835 locexit := indfich ; genstand nreg 0 itmoz tic ;
1836 IF toloadq THEN
1837 genstand pr6 ldisp ildq tn ; * STARTING BIT *
1838 mfari1 := a0r0i0 ; mfari2 := a1r1i0 ;
1839 genstand pr6 psrdepw iepp3 tn ;
1840 genstand pr3 0 iabd tql ;
1841 geneism icsl 15 * BOLR=IIII =MOVE 1 * p1t0r0 ;
1842 gendescb nreg 0 0 0 0 tn ;
1843 gendescb pr3 0 0 0 0 tal ;
1844 inser cb locexit ;
1845 freebloc ldregbloc ;
1846 freebloc infattr.ldregbloc ;
1847 END * INF WAS IN RQ * ;
1848 END * NO ERROR * ;
1849 END * TYPTR <> nil with GATTR * ;
1850 END * NO=39 * ;
1851 END * OK for FVSETELCTP LERR * ELSE
1852 IF NOT no IN 15 12 * ] * THEN
1853 insymbol ;
1854 END * ELEMENT * ;
1855
1856 * PAGE *
1857 * *********************************** FACTOR ********************************* *
1858
1859 PROCEDURE factor ;
1860
1861 * C .BUILD A GATTR FOR SEVERAL ITEMS
1862 .FOLLOWING CASES
1863 IDENT KONST ==> GATTR
1864 VARSFIELD==> VARIABLE
1865 PROC ==> GATTR
1866 PASSPARAMS
1867 CONST ==> GATTR
1868 nil ==> "
1869 not FACTOR "
1870 EXPRESSION EXPRESSION
1871 EXPR EXPR* "
1872 C *
1873 * E ERRORS DETECTED
1874 4: "" EXPECTED
1875 9: "" EXPECTED
1876 12: "]" EXPECTED
1877 58: ILLEGAL BEGINNING SYMBOL FOR A FACTOR
1878 73 Extension used is neither SOL neither Standard.
1879 103: IDENTIFIER IS not OF APPROPRIATE CLASS
1880 104: UNDECLARED ID.
1881 125: ILLEGAL ARGUMENT TYPE FOR A STANDARD FUNCTION
1882 135: TYPE OF OPERAND MUST BE BOOLEAN
1883 187: procedure USED AS A FUNCTION
1884 E *
1885 VAR
1886 catfonct : integer ;
1887 equal : boolean ;
1888 it : integer ;
1889 lattr : attr ;
1890 lretpt : lcstpt ;
1891 llretpt : llcstpt ;
1892 lmaxallow : integer ;
1893 lmaxcst : integer ;
1894 lmincst : integer ;
1895 longop : integer ;
1896 lp : ctp ;
1897 lpsval : setarray ;
1898 lreg : register ;
1899 ltemp : integer ;
1900 $OPTIONS compile = trace $
1901 newattr : boolean ;
1902 $OPTIONS compile = true $
1903 setelctp : ctp ;
1904 wretpt : wcstpt ;
1905
1906 * *********************************** FACTERR < FACTOR *************** *
1907
1908 PROCEDURE facterr errnum : integer ;
1909 BEGIN
1910 error errnum ; gattr.typtr := NIL ;
1911 END * FACTERR * ;
1912
1913
1914
1915 BEGIN * FACTOR *
1916 $OPTIONS compile = trace $
1917 newattr := true ;
1918 IF stattrace > none THEN
1919 BEGIN
1920 write mpcogout '^^^ DEBUT FACTOR ^^^ with NO:' no : 4 ; nextline ;
1921 END ;
1922 $OPTIONS compile = true $
1923 IF no = 1 * IDENTIFIER * THEN
1924 BEGIN
1925 IF declarationpart THEN
1926 BEGIN
1927 srchrec next ;
1928 IF ctptr = NIL THEN search
1929 END
1930 ELSE
1931 search ;
1932 IF ctptr = NIL THEN
1933 BEGIN
1934 error 104 ; ctptr := undecptr ;
1935 END * nil * ;
1936 CASE ctptr^.klass OF
1937 schema, types :
1938 BEGIN
1939 IF symbolmap THEN
1940 nameisref ctptr symbolfile symbolline ;
1941 error 103 ; gattr.typtr := NIL ; insymbol ;
1942 END * TYPES * ;
1943 konst :
1944 BEGIN
1945 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1946 WITH gattr, ctptr^ DO
1947 BEGIN
1948 typtr := contype ;
1949 IF typtr = alfaptr THEN
1950 BEGIN * CHAIN CONSTANT *
1951 kind := chain ; alfactp := ctptr ;
1952 IF NOT declarationpart AND succ = ctptr THEN
1953 BEGIN * not YET USED *
1954 succ := nextalf ; nextalf := ctptr ;
1955 END * not YET USED * ;
1956 END * CHAIN * ELSE
1957 BEGIN
1958 kind := sval ;
1959 IF typtr = realptr THEN
1960 rsval := valreel ELSE
1961 val := values ;
1962 END * not ALFAPTR * ;
1963 insymbol ;
1964 END * with GATTR........ * ;
1965 END * KONST * ;
1966 vars, field :
1967 BEGIN
1968 variable false ;
1969 IF gattr.typtr <> NIL THEN
1970 IF asscheck THEN
1971 IF gattr.typtr^.father_schema = string_ptr THEN
1972 IF gattr.typtr^.actual_parameter_list <> NIL THEN
1973 check_dynamic_string_length gattr ;
1974 $OPTIONS compile = trace $
1975 newattr := false ;
1976 $OPTIONS compile = true $
1977 END * VARSFIELD * ;
1978 proc : BEGIN
1979 IF symbolmap THEN
1980 nameisref ctptr symbolfile symbolline ;
1981 insymbol ;
1982 IF ctptr^.proctype = NIL THEN
1983 gattr.typtr := NIL ELSE
1984 IF ctptr^.proctype = ctptr THEN
1985 facterr 187 ELSE
1986 WITH ctptr^ DO
1987 IF predefproc THEN
1988
1989 * PREDEFINED FUNCTIONS AND SCIENTIFIC SUBROUTINES *************** *
1990 BEGIN
1991 IF proctype <> realptr THEN
1992 BEGIN
1993 * REALPTR AS PROCTYPE FOR SCIENTIFIC *
1994 * NILPTR FOR OTHERS *
1995
1996 predeffunct ;
1997
1998 END * PROCTYPE <> REALPTR =PREDEFINED FUNCTIONS * ELSE
1999 BEGIN * SCIENTIFIC FUNCTIONS *
2000 IF no <> 9 * "" * THEN
2001 facterr 9 ELSE
2002 BEGIN
2003 catfonct := segsize ;
2004 IF catfonct = log10switch THEN
2005 IF envstandard <> stdextend THEN
2006 error 73 ;
2007 insymbol ; expression ;
2008 IF gattr.typtr <> NIL THEN
2009 IF gattr.typtr^.form > numeric THEN
2010 error 125 ELSE
2011 BEGIN
2012 IF gattr.typtr^.form = numeric THEN
2013 convreal gattr ;
2014 transfer gattr inacc ;
2015 IF NOT workformaths THEN
2016 BEGIN
2017 workformathsplacew := oldnewstor mathworksizew * bytesinword DIV bytesinword ;
2018 workformaths := true ;
2019 END ;
2020 sauvereg pr2 false ;
2021 genstand pr6 workformathsplacew iepp2 tn ;
2022 genstand pr0 scientplace + catfonct itsp3 tn ;
2023 END ;
2024 gattr.typtr := realptr ;
2025 IF no = 10 THEN * *
2026 insymbol ELSE
2027 facterr 4 ;
2028 END * NO WAS 9 * ;
2029 END * SCIENTIFIC SUBROUTINE *
2030 END * PREDEFPROC * ELSE
2031 BEGIN * PROGRAMMER FUNCTION *
2032 ltemp := oldnewstor bytesindword ;
2033 WITH lattr DO
2034 BEGIN
2035 typtr := proctype ;
2036 IF NOT exportablecode AND prockind < formal THEN
2037 BEGIN
2038 kind := lval ;
2039 IF typtr = realptr THEN
2040 BEGIN
2041 ldreg := reaq ;
2042 END ELSE
2043 IF typtr^.form = pointer THEN
2044 BEGIN
2045 ldreg := raq ;
2046 END ELSE
2047 BEGIN
2048 ldreg := ra ;
2049 END ;
2050 * LDREGBLOC LATER AFTER PASSPARAMS *
2051 END * PASCAL * ELSE
2052 BEGIN * not PASCAL *
2053 initattrvarbl lattr ;
2054 dplmt := ltemp ;
2055 END * not PASCAL * ;
2056 END * with LATTR * ;
2057 * SAVE ALL PREVIOUS LOADED REGISTERS *
2058 FOR lreg := pr1 TO maxprused DO sauvereg lreg false ;
2059 FOR lreg := x0 TO maxinxused DO sauvereg lreg false ;
2060 FOR lreg := ra TO reaq DO sauvereg lreg false ;
2061 * ****************************** *
2062 passparams ltemp ;
2063 * ***************************** *
2064 * RETURN CODE *
2065 * LOAD RARAQ OR REAQ *
2066 * AND ASSIGNS PRG|LTEMP *
2067 WITH lattr DO
2068 IF kind = lval THEN
2069 BEGIN * PASC FUNCTION LOCAL *
2070 newbloc ldreg ;
2071 ldregbloc := currentbloc ;
2072 END ;
2073 gattr := lattr ;
2074 END * PROGRAMMER FUNCTION with CTPTR^ *
2075 END * PROC * ;
2076 END * CASE CTPTR^.KLASS * ;
2077 END * NO=1 IDENTIFIER * ELSE
2078 IF no = 2 * EXPLICIT CONSTANT * THEN
2079 BEGIN
2080 WITH gattr DO
2081 CASE cl OF
2082 1 : * INTEGER *
2083 BEGIN kind := sval ; typtr := intptr ; val := ival ;
2084 END * 1 * ;
2085 2 : * REAL *
2086 BEGIN kind := sval ; typtr := realptr ; rsval := rval ;
2087 END * 2 * ;
2088 3 : * ALFA *
2089 BEGIN kind := chain ; typtr := alfaptr ;
2090 longstring := longchaine ;
2091 create_konst_box lp blank alfaconst ;
2092 lp^.contype := alfaptr ;
2093 IF NOT declarationpart THEN
2094 BEGIN
2095 lp^.succ := nextalf ;
2096 nextalf := lp ;
2097 END ;
2098 crealfabox lp ;
2099 alfactp := lp ;
2100 END * 3 * ;
2101 4 : * CHAR *
2102 BEGIN
2103 kind := sval ; typtr := charptr ; val := ival ;
2104 END * 4 * ;
2105 END * CASE CLwith GATTR * ;
2106 insymbol ;
2107 END * NO=2 * ELSE
2108 IF no = 36 * nil * THEN
2109 BEGIN
2110 WITH gattr DO
2111 BEGIN
2112 kind := sval ; typtr := nilptr ; val := 0 ; * DUMMY HERE NILLEFTNILRIGHT *
2113 IF symbolmap THEN nameisref nilptr symbolfile symbolline ;
2114 END ;
2115 insymbol ;
2116 END * NO=36 * ELSE
2117 IF no = 9 * * THEN
2118 BEGIN
2119 insymbol ; expression ;
2120 $OPTIONS compile = trace $
2121 newattr := false ;
2122 $OPTIONS compile = true $
2123 IF no = 10 * * THEN
2124 insymbol ELSE
2125 facterr 4 ;
2126 END * NO= 9 * ELSE
2127 IF no = 5 * not * THEN
2128 BEGIN
2129 insymbol ; factor ;
2130 WITH gattr DO
2131 IF typtr <> boolptr THEN
2132 facterr 135 ELSE
2133 BEGIN
2134 CASE kind OF
2135 lcond : CASE transf OF
2136 1 : BEGIN transf := 9 ; freebloc accbloc ; accbool := false ;
2137 END ;
2138 2 : transf := 6 ;
2139 3 : transf := 13 ;
2140 4 : transf := 5 ;
2141 5 : transf := 4 ;
2142 6 : transf := 2 ;
2143 7 : transf := 9 ;
2144 8 : transf := 10 ;
2145 9 : transf := 7 ;
2146 10 : transf := 8 ;
2147 11 : transf := 12 ;
2148 12 : transf := 11 ;
2149 13 : transf := 3 ;
2150 14 : transf := 15 ;
2151 15 : transf := 14 ;
2152 END * CASE TRANSF LCOND * ;
2153 sval : val := ord true - ord val ;
2154 varbl, lval :
2155 BEGIN
2156 IF kind <> lval THEN
2157 IF raisused THEN transfer gattr inq ELSE
2158 transfer gattr inacc ;
2159 WITH gattr DO
2160 BEGIN
2161 accbloc := ldregbloc ; kind := lcond ; accbool := true ;
2162 IF accbloc^.sregister = ra THEN transf := 13 ELSE
2163 transf := 15 ;
2164 END ;
2165 END ;
2166 END * CASE KIND * ;
2167 END * NO ERRORwith GATTR * ;
2168 END * NO=5 not * ELSE
2169 IF no = 11 * *) THEN
2170 BEGIN * SET EXPRESSION *
2171 insymbol ;
2172 IF no = 12 * ] * THEN
2173 BEGIN
2174 * EMPTY SET *
2175 WITH gattr DO
2176 BEGIN
2177 typtr := lamptr ; kind := sval ;
2178 longv := bytesforset ; valpw := nulpw ;
2179 END ;
2180 insymbol ;
2181 END * EMPTY * ELSE
2182 BEGIN * not EMPTY. *
2183 * BUILT IN LATTR BY SUCCESSIVE *
2184 * CALLS OF ELEMENT *
2185 WITH lattr DO
2186 BEGIN
2187 typtr := NIL ; * FLAG NO ERROR *
2188 kind := sval ; longv := bytesforset ; valpw := nulpw ;
2189 END * INIT LATTR * ;
2190 lmaxcst := 0 ; lmincst := maxset ; lmaxallow := 0 ;
2191 lpsval := nulpw ;
2192 setelctp := NIL ;
2193 element lattr setelctp lpsval lmaxcst lmincst lmaxallow ;
2194 WHILE no = 15 * ; * DO
2195 BEGIN
2196 insymbol ; element lattr setelctp lpsval lmaxcst lmincst lmaxallow ;
2197 END ;
2198 WITH lattr DO
2199 BEGIN
2200 IF kind = sval THEN
2201 BEGIN
2202 valpw := lpsval ; val := lmaxcst * 1000 + lmincst ;
2203 IF lmaxcst < bitsindword THEN
2204 longv := bytesindword ;
2205 END * SVAL SET * ELSE
2206 BEGIN * LVAL *
2207 * TWO PARTS: *
2208 * LPSVAL COMPUTED PART BY COMPILER *
2209 * PSR RUN-COMPUTED *
2210 equal := true ;
2211 FOR it := 0 TO bornesupset DO
2212 IF lpsval it <> nulpw it THEN equal := false ;
2213 IF NOT equal THEN
2214 BEGIN
2215 IF lmaxcst < bitsinword THEN
2216 BEGIN
2217 entercst lpsval 0 wretpt ;
2218 enterundlab wretpt^.cstplace ;
2219 END ELSE
2220 IF lmaxcst < bitsindword THEN
2221 BEGIN
2222 enterlcst lpsval lretpt ;
2223 enterundlab lretpt^.lplace ;
2224 END ELSE
2225 BEGIN
2226 enterllcst lpsval llretpt ;
2227 enterundlab llretpt^.llplace ;
2228 END ;
2229 longop := lmaxcst + 1 ;
2230 genstand nreg 0 iepp3 tic ;
2231 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
2232 geneism icsl 7 * 0111=OR * p0t0r0 ;
2233 gendescb pr3 0 0 0 longop tn ;
2234 gendescb pr6 psrdepw 0 0 longop tn ;
2235 END * <> NULPW * ;
2236 END * LVAL * ;
2237 * SETELCTP POINTS THE *
2238 * TYPE OF ELEMENTS *
2239 IF setelctp = intptr THEN
2240 typtr := pnumptr ELSE
2241 IF setelctp <> NIL THEN
2242 typtr := setelctp^.sptcstepw ;
2243 END * with LATTR * ;
2244 gattr := lattr ;
2245 IF no = 12 * ] * THEN
2246 insymbol ELSE
2247 facterr 12 ;
2248 END * not EMPTY * ;
2249 END * NO=11 SET EXPR * ELSE
2250 facterr 58 ;
2251 $OPTIONS compile = trace $
2252 IF stattrace > low THEN
2253 BEGIN
2254 IF stattrace = high THEN
2255 IF newattr THEN
2256 BEGIN
2257 write mpcogout '* GATTR BUILT IN FACTOR IS:' ; nextline ;
2258 printattr gattr ;
2259 END ;
2260 write mpcogout '^^^ FIN FACTOR with NO' no : 4 ; nextline ;
2261 END ;
2262 $OPTIONS compile = true $
2263 END * FACTOR * ;
2264
2265 $OPTIONS page $
2266
2267 * ********************************** TERM ********************************** *
2268
2269 PROCEDURE term ;
2270
2271 * C . COMPILES A TERM ::= <FACTOR> <MULT-OD> <FACTOR>*
2272 . MULT-OP ARE CODED NO=6 CL= 12345
2273 CL=1 * REELNUMERIC SET INTERSECTION
2274 CL=2 / REELNUMERIC GIVES A REAL
2275 CL=3 AND BOOLEAN
2276 CL=4 DIV NUMERIC
2277 CL=5 MOD NUMERIC
2278 C *
2279 * E ERRORS DETECTED
2280 129: OPERANDS TYPE CONFLICT
2281 134: ILLEGAL OPERAND TYPE
2282 E *
2283
2284 VAR
2285
2286 loczerodiv : integer ;
2287 lmopcl : integer ;
2288 $OPTIONS compile = trace $
2289 newattr : boolean ;
2290 $OPTIONS compile = true $
2291 lattr : attr ;
2292 generic : ctp ;
2293 ljump : istand ;
2294 BEGIN * TERM *
2295 $OPTIONS compile = trace $
2296 newattr := false ;
2297 IF stattrace > none THEN
2298 BEGIN
2299 write mpcogout '^^^ DEBUT TERM ^^^' ; nextline ;
2300 END ;
2301 $OPTIONS compile = true $
2302 factor ;
2303 WHILE no = 6 DO
2304 BEGIN * MULT. OPERATOR * * * / AND DIV MOD *
2305 lmopcl := cl ;
2306 WITH gattr DO
2307 IF typtr <> NIL * LEFT OPERAND * THEN
2308 IF lmopcl = 2 * / * AND typtr^.form = numeric THEN
2309 BEGIN
2310 convreal gattr * LVAL EAQ OR RSVAL *
2311 END ELSE
2312 CASE kind OF
2313 varbl : IF NOT easyvar gattr THEN
2314 transfer gattr inacc ;
2315 sval lval : ;
2316 chain : BEGIN error 134 ; gattr.typtr := NIL ;
2317 END ;
2318 lcond : choicerarq ;
2319 END * CASE WITH GATTR do * ;
2320 lattr := gattr ;
2321 $OPTIONS compile = trace $
2322 newattr := true ;
2323 $OPTIONS compile = true $
2324 insymbol ;
2325 factor ;
2326 IF lattr.typtr <> NIL AND gattr.typtr <> NIL THEN
2327 BEGIN
2328 compatbin lattr.typtr gattr.typtr generic ;
2329 IF generic = NIL THEN error 129 ELSE
2330 IF generic^.form <> power THEN
2331 BEGIN
2332 CASE lmopcl OF
2333 1 * * * : IF generic^.form > numeric THEN
2334 error 134 ELSE
2335 genopmult lattr generic ;
2336 2 * / * : * GENERIC IS REAL *
2337 WITH gattr DO
2338 BEGIN
2339 IF typtr <> realptr THEN convreal gattr ;
2340 IF divcheck THEN
2341 IF kind <> sval THEN
2342 BEGIN
2343 transfer gattr inacc ;
2344 loczerodiv := indfich ; genstand nreg 0 itnz tic ;
2345 * SKIP if NOT ZERO ON *
2346 genexceptcode diverrcode reaq ;
2347 inser cb loczerodiv ;
2348 END ;
2349 genopdivi lattr ;
2350 END * WITH GATTR * ;
2351 3 * AND * : IF generic <> boolptr THEN error 134 ELSE
2352 genandor lattr 6 ; * NO=6 ==> AND *
2353 4 5 * DIVMOD * :
2354 IF generic^.form <> numeric THEN error 134 ELSE
2355 WITH gattr DO
2356 BEGIN
2357 IF divcheck THEN
2358 IF kind <> sval THEN
2359 BEGIN
2360 transfer gattr inq ;
2361 IF lmopcl = 4 * DIV * THEN ljump := itnz ELSE
2362 ljump := itpnz ;
2363 loczerodiv := indfich ; genstand nreg 0 ljump tic ;
2364 * SKIP if ZERO OFF *
2365 genexceptcode diverrcode rq ;
2366 inser cb loczerodiv ;
2367 END ;
2368 gendivmod lattr lmopcl ;
2369 END ;
2370 END * CASE LMOPCL * ;
2371 gattr.typtr := generic ;
2372 END * <> SET * ELSE
2373 BEGIN
2374 IF lmopcl <> 1 THEN error 134 ELSE
2375 genoppw lattr 6 1 ;
2376 gattr.typtr := generic ;
2377 END * SET GENERIC <> NIL * ;
2378 END * LATTR <> NIL GATTR <> NIL * ;
2379 END * while NO=6 * ;
2380 $OPTIONS compile = trace $
2381 IF stattrace > low THEN
2382 BEGIN
2383 IF stattrace = high AND newattr THEN
2384 printattr gattr ;
2385 write mpcogout '^^^ FIN TERM ^^^ WITH NOCL:' no : 4 cl : 4 ; nextline ;
2386 END ;
2387 $OPTIONS compile = true $
2388 END * TERM * ;
2389
2390 $OPTIONS page $
2391
2392 * ********************************* SIMPLEEXP ***************************** *
2393
2394 PROCEDURE simpleexp ;
2395
2396 * C COMPILES A SIMPLE-EXPRESSION ::=
2397 +/- <TERM> <+-OR> <TERM>*
2398 NO=7 CL=1 + REALNUMERIC SET UNION
2399 CL=2 - REALNUMERIC SET DifFER
2400 CL=3 OR BOOLEAN
2401 C *
2402 * E ERRORS DETECTED
2403 60: OR MONADIC NOT ALLOWED
2404 129: TYPE CONFLICT
2405 134: ILLEGAL TYPE OF OPERAND
2406 135: BOOLEAN OPERAND EXPECTED
2407 303: VALUE OUT OF RANGE
2408 E *
2409 VAR
2410 minus plus
2411 $OPTIONS compile = trace $ newattr
2412 $OPTIONS compile = true $
2413 : boolean ;
2414 ldisp ladopcl : integer ;
2415 lbase : preg ;
2416 ltag : tag ;
2417 lattr : attr ;
2418 generic : ctp ;
2419 BEGIN * SIMPLEEXP *
2420 $OPTIONS compile = trace $
2421 newattr := false ;
2422 IF stattrace > none THEN
2423 BEGIN
2424 write mpcogout '^^^ DEBUT SIMPLEEXP ^^^' ; nextline ;
2425 END ;
2426 $OPTIONS compile = true $
2427 * TEST FOR MONADIC OPERATOR *
2428 minus := false ; plus := false ;
2429 IF no = 7 * + - OR * THEN
2430 BEGIN
2431 IF cl = 2 * - * THEN
2432 minus := true ELSE
2433 IF cl = 3 * OR * THEN error 60 ELSE plus := true ;
2434 insymbol ;
2435 END ;
2436 * ************************** *
2437 term ;
2438 * *************************** *
2439 IF plus THEN
2440 BEGIN IF gattr.typtr <> NIL THEN
2441 IF gattr.typtr^.form > numeric THEN
2442 error 134
2443 END ELSE
2444 IF minus THEN
2445 WITH gattr DO
2446 IF typtr <> NIL THEN
2447 IF typtr^.form > numeric THEN
2448 error 134 ELSE
2449 BEGIN
2450 $OPTIONS compile = trace $
2451 newattr := true ;
2452 $OPTIONS compile = true $
2453 CASE kind OF
2454 sval : IF typtr = realptr THEN
2455 rsval := -rsval ELSE
2456 IF val <> -maxint - 1 THEN
2457 val := -val ELSE
2458 error 303 ;
2459 lval : BEGIN transfer gattr inacc ;
2460 genstand nreg 0 opaq neg ldreg tn ;
2461 END ;
2462 varbl : IF easyvar gattr AND typtr <> realptr THEN
2463 BEGIN
2464 calcvarient gattr lbase ldisp ltag ;
2465 sauvereg ra true ;
2466 usednameaddr := nameaddr ;
2467 genstand lbase ldisp ilca ltag ;
2468 kind := lval ; ldreg := ra ; ldregbloc := currentbloc ;
2469 END * EASY * ELSE
2470 BEGIN transfer gattr inacc ;
2471 genstand nreg 0 opaq neg ldreg tn ;
2472 END * NOT EASY VARBL * ;
2473 END * CASE KIND * ;
2474 END * MINUS * ;
2475 WHILE no = 7 DO
2476 BEGIN * CL=1 + CL=2 - CL=3 OR *
2477 $OPTIONS compile = trace $
2478 newattr := true ;
2479 $OPTIONS compile = true $
2480 ladopcl := cl ;
2481 WITH gattr DO
2482 IF typtr <> NIL THEN
2483 IF typtr^.father_schema <> string_ptr THEN
2484 IF typtr^.form = power AND ladopcl = 2 THEN
2485 transfer gattr inpsr ELSE
2486 CASE kind OF
2487 sval lval : ;
2488 chain : IF envstandard <> stdextend THEN
2489 BEGIN
2490 error 134 ; gattr.typtr := NIL ;
2491 END ;
2492 varbl : IF NOT easyvar gattr THEN
2493 transfer gattr inacc ;
2494 lcond : choicerarq ;
2495 END * CASE KIND * ;
2496 lattr := gattr ;
2497 * ************************** *
2498 insymbol ;
2499 term ;
2500 * **************************** *
2501 IF lattr.typtr <> NIL AND gattr.typtr <> NIL THEN
2502 BEGIN
2503 compatbin lattr.typtr gattr.typtr generic ;
2504 IF envstandard = stdextend
2505 AND is_possible_string gattr AND is_possible_string lattr AND ladopcl = 1 THEN
2506 genconcat lattr ELSE
2507 IF generic = NIL THEN error 129 ELSE BEGIN
2508 IF generic^.form <> power THEN
2509 CASE ladopcl OF
2510 1 : * + * IF generic^.form > numeric THEN error 134 ELSE
2511 genopadd lattr generic ;
2512 2 : * - * IF generic^.form > numeric THEN error 134 ELSE
2513 genopsub lattr generic ;
2514 3 : * OR * IF generic <> boolptr THEN error 135 ELSE
2515 genandor lattr 7 * OR * ;
2516 END * CASE LADOPCL <> POWER * ELSE
2517 BEGIN * POWER *
2518 IF ladopcl = 3 THEN error 134 ELSE
2519 genoppw lattr 7 ladopcl ;
2520 END * POWER * ;
2521 gattr.typtr := generic ;
2522 END * GENERIC <> nil * ;
2523 END * NOT nil * ;
2524 END * WHILE NO=7 * ;
2525 $OPTIONS compile = trace $
2526 IF stattrace > low THEN
2527 BEGIN
2528 IF stattrace = high AND newattr THEN
2529 printattr gattr ;
2530 write mpcogout '^^^ FIN SIMPLEEXP ^^^ WITH NOCL' no : 4 cl : 4 ; nextline ;
2531 END ;
2532 $OPTIONS compile = true $
2533 END * SIMPLEEXP * ;
2534
2535 $OPTIONS page $
2536
2537 * *********************************** EXPRESSION **************************** *
2538
2539 PROCEDURE expression ;
2540
2541 * C . COMPILES <SIMPLEEXP> <RELAT> <SIMPLEEXP>
2542 . NO=8 CL=1 <
2543 2 <=
2544 3 >=
2545 4 >
2546 5 <>
2547 6 =
2548 7 IN
2549 . AS OUPUT A GATTR LCOND IS PRODUCED
2550 C *
2551 * E ERRORS DETECTED
2552 108: FILES/CLASS NOT ALLOWED
2553 129: TYPE CONFLICT
2554 134: ILLEGAL TYPE OF OPERAND
2555 E *
2556 VAR
2557
2558 bitselect : integer ;
2559 generic : ctp ;
2560 lattr : attr ;
2561 lbase : preg ;
2562 lcomp : istand ;
2563 ldisp : integer ;
2564 lerr : boolean ;
2565 llretpt : llcstpt ;
2566 lmax : integer ;
2567 lmin : integer ;
2568 locmax : integer ;
2569 locmin : integer ;
2570 locskip : integer ;
2571 lreopcl : integer ;
2572 lres : boolean ;
2573 lretpt : lcstpt ;
2574 ltag : tag ;
2575 $OPTIONS compile = trace $
2576 newattr : boolean ;
2577 $OPTIONS compile = true $
2578 tofind : integer ;
2579 totest : integer ;
2580
2581 * ****************************************** EERROR < EXPRESSION ********* *
2582
2583 PROCEDURE eerror errnum : integer ;
2584 BEGIN
2585 * DUMMY VALUE *
2586 gattr.typtr := boolptr ; gattr.kind := sval ; gattr.val := 0 * false * ;
2587 error errnum ;
2588 END * EERROR * ;
2589
2590 BEGIN * EXPRESSION *
2591 $OPTIONS compile = trace $
2592 newattr := false ;
2593 IF stattrace > none THEN
2594 BEGIN
2595 write mpcogout '^^^ DEBUT EXPRESSION ^^^' ; nextline ;
2596 END ;
2597 $OPTIONS compile = true $
2598 * ************************ *
2599 simpleexp ;
2600 * ************************ *
2601 IF no = 8 * RELATIONAL OPERATOR * THEN
2602 BEGIN
2603 lreopcl := cl ; * < <= >= > <> = IN *
2604 WITH gattr DO * LEFT OPERAND *
2605 IF typtr <> NIL THEN
2606 BEGIN * NO ERROR *
2607 IF typtr^.form < power THEN
2608 BEGIN
2609 CASE kind OF
2610 lval sval : ;
2611 lcond : choicerarq ;
2612 varbl : IF NOT easyvar gattr THEN transfer gattr inacc ;
2613 END * CASE KIND * ;
2614 END * < POWER * ELSE
2615 IF typtr^.form = power THEN
2616 BEGIN
2617 IF lreopcl IN 2 3 THEN
2618 transfer gattr inpsr ELSE
2619 CASE kind OF
2620 varbl : IF NOT easyvar gattr THEN transfer gattr inacc ;
2621 sval lval : ;
2622 END * case KIND * ;
2623 END * = POWER * ELSE
2624 IF typtr^.form < files THEN
2625 BEGIN * ARRAYS RECORDS *
2626 IF kind = varbl THEN
2627 IF NOT varissimple gattr THEN
2628 BEGIN
2629 loadadr gattr nreg ;
2630 basereg := currentpr ; basebloc := currentbloc ;
2631 dplmt := 0 ; itsdplmt := 0 ;
2632 inxreg := nxreg ; inxbloc := NIL ; inxmem := 0 ;
2633 inxmemrw := true ; pckd := false ;
2634 access := pointee ;
2635 END ;
2636 END * ARRAYSRECORDS * ELSE
2637 error 134 ;
2638 END * TYPTR <> nil with GATTR * ;
2639 lattr := gattr ;
2640 * ******************* *
2641 insymbol ;
2642 simpleexp ;
2643 * ********************** *
2644 IF gattr.typtr <> NIL AND lattr.typtr <> NIL THEN
2645 BEGIN
2646 IF lreopcl <> 7 THEN
2647 BEGIN * OPERATORS < ... = *
2648 compatbin lattr.typtr gattr.typtr generic ;
2649 IF generic = NIL THEN
2650 IF envstandard = stdextend
2651 AND is_possible_string lattr AND is_possible_string gattr THEN
2652 gen_string_comp lattr lreopcl ELSE
2653 eerror 129 ELSE
2654 CASE generic^.form OF
2655 reel numeric scalar : gencompare lattr lreopcl generic ;
2656 pointer :
2657 BEGIN
2658 IF envstandard <> stdextend THEN
2659 IF lreopcl <= 4 THEN eerror 134 ;
2660 genptcomp lattr lreopcl ;
2661 END ;
2662 records :
2663 IF envstandard = stdextend AND
2664 is_possible_string lattr AND is_possible_string gattr THEN
2665 gen_string_comp lattr lreopcl ELSE
2666 BEGIN
2667 IF envstandard <> stdextend OR lreopcl <= 4 THEN eerror 134 ;
2668 genstcomp lattr lreopcl ;
2669 END ;
2670 arrays :
2671 BEGIN
2672 lerr := true ;
2673 IF isstring lattr THEN
2674 IF isstring gattr THEN
2675 lerr := false ;
2676 IF envstandard = stdextend THEN
2677 IF lreopcl > 4 THEN
2678 lerr := false ;
2679 IF lerr THEN
2680 eerror 134 ELSE
2681 genstcomp lattr lreopcl ;
2682 END * ARRAYS * ;
2683 power :
2684 BEGIN
2685 IF lreopcl IN 2 3 5 6 THEN
2686 genoppw lattr 8 * NO * lreopcl ELSE
2687 eerror 134 ;
2688 END ;
2689 files aliastype : eerror 108 ;
2690 END * GENERIC^.FORM * ;
2691 END * LREOPCL <> 7 * ELSE
2692 BEGIN * OPERATOR IN *
2693 lerr := true ;
2694 IF gattr.typtr^.form = power THEN
2695 IF lattr.typtr^.form <= scalar THEN
2696 BEGIN
2697 compatbin lattr.typtr gattr.typtr^.elset generic ;
2698 IF generic <> NIL THEN
2699 IF generic <> realptr THEN
2700 lerr := false ;
2701 END ;
2702 IF lerr THEN
2703 eerror 129 ELSE
2704 * OK FOR TYPES. LET'S GO *
2705
2706 * LATTR MAY BE *
2707 * SVAL *
2708 * VARBL EASY TO ADRESS *
2709 * LVAL IN RA OR RQ . SAVED OR NOT *
2710 * GATTR MAY BE *
2711 * SVAL 8 OR MAX *
2712 * LVAL RAQ PSR *
2713 * VARBL ANY SIZE *
2714 WITH gattr DO
2715 BEGIN
2716 findminmax typtr^.elset lmin lmax ;
2717 IF lattr.kind = sval THEN
2718 BEGIN
2719 IF kind = sval THEN
2720 BEGIN * COMPILER KNOWN *
2721 IF inbounds lattr.val 0 maxset THEN
2722 BEGIN
2723 totest := valpw lattr.val DIV bitsinword ;
2724 tofind := lattr.val MOD bitsinword ;
2725 append_ totest tofind 0 ;
2726 lres := totest < 0 ;
2727 END ELSE
2728 lres := false ;
2729 * GATTR *
2730 IF lres THEN
2731 transf := 4 * true * ELSE
2732 transf := 5 * false * ;
2733 accbloc := NIL ; accbool := false ;
2734 END * GATTR SVAL * ELSE
2735 BEGIN
2736 IF inbounds lattr.val lmin lmax THEN
2737 BEGIN
2738 IF kind = lval THEN
2739 BEGIN
2740 * RAQ ==> SHifT PSR ==> VARBL *
2741 IF ldreg = raq THEN
2742 BEGIN
2743 genstand nreg lattr.val ills tn ;
2744 * NEGATIVE ON=true *
2745 freebloc ldregbloc ; newbloc ra ;
2746 transf := 1 ;
2747 accbloc := currentbloc ; accbool := true ;
2748 END * RAQ * ELSE
2749 lvalvarbl gattr ;
2750 END * GATTR WAS LVAL * ;
2751 IF kind = varbl THEN
2752 BEGIN * INCLUDES OLD PSR *
2753 * MODIFY DPLMT TO *
2754 * POINT THE RIGHT BYTE *
2755 dplmt := dplmt + lattr.val DIV bitsinbyte ;
2756 bitselect := lattr.val MOD bitsinbyte ;
2757 loadadr gattr pr3 ;
2758 mfari1 := a0r0i0 ; mfari2 := a1r0i0 ;
2759 geneism icmpb 0 p1t0r0 ; * FILL BIT 1 *
2760 gendescb nreg 0 0 0 0 tn ; * DUMMY *
2761 usednameaddr := nameaddr ;
2762 gendescb pr3 0 0 bitselect 1 tn ;
2763 * ONE BIT OPERAND *
2764 * ZERO ON <==> true *
2765 transf := 2 ; accbool := false ; accbloc := NIL ;
2766 END * KIND=VARBL * ;
2767 END * INBOUNDS * ELSE
2768 BEGIN * false *
2769 freeattr gattr ;
2770 transf := 5 ;
2771 accbool := false ; accbloc := NIL ;
2772 END * false * ;
2773 END * GATTR NOT SVAL * ;
2774 END * LATTR.SVAL * ELSE
2775 BEGIN
2776 IF kind = lval THEN * GATTR IN AQ OR PSR *
2777 BEGIN
2778 IF ldreg = raq THEN
2779 BEGIN
2780 IF lattr.kind = lval THEN
2781 lvalvarbl lattr ;
2782 calcvarient lattr lbase ldisp ltag ;
2783 WITH lattr DO
2784 IF kind = varbl THEN usednameaddr := nameaddr ;
2785 genstand lbase ldisp ilxl7 ltag ;
2786 * X7 = VALUE TO TEST IN AQ *
2787 * FIRST CHECK MIN MAX then SHifT *
2788 genstand nreg lmin icmpx7 tdu ;
2789 locmin := indfich ; genstand nreg 0 itmi tic ;
2790 * SKIP if < *
2791 genstand nreg lmax icmpx7 tdu ;
2792 locmax := indfich ; genstand nreg 0 itpnz tic ;
2793 * SKIP if > *
2794 genstand nreg 0 ills tx7 ; * NOW SHifT *
2795 * true == NEGATIVE ON *
2796 locskip := indfich ; genstand nreg 0 itra tic ;
2797 inser cb locmin ;
2798 inser cb locmax ;
2799 genstand nreg ord false ilda tdl ;
2800 inser cb locskip ;
2801 freebloc ldregbloc ; newbloc ra ; transf := 1 ;
2802 accbool := true ; accbloc := currentbloc ; * LCOND LATER *
2803 END * LDREG=RAQ * ELSE
2804 lvalvarbl gattr ;
2805 END * KIND=LVAL * ;
2806 IF kind <> lval THEN
2807 BEGIN
2808 IF kind = sval THEN
2809 BEGIN
2810 IF longv = bytesindword THEN
2811 BEGIN
2812 enterlcst valpw lretpt ;
2813 IF lmax > bitsindword - 1 THEN lmax := bitsindword - 1 ;
2814 enterundlab lretpt^.lplace ;
2815 END ELSE
2816 BEGIN * LONG SET *
2817 enterllcst valpw llretpt ;
2818 enterundlab llretpt^.llplace ;
2819 END * LONGSET * ;
2820 genstand nreg 0 iepp3 tic ;
2821 END * SVAL * ELSE
2822 loadadr gattr pr3 ;
2823 IF lattr.kind = lval THEN
2824 regenere lattr.ldregbloc ELSE
2825 transfer lattr inacc ;
2826 * NOW RA OR RQ LOADED *
2827 lcomp := opaq cmp lattr.ldreg ;
2828 genstand nreg lmin lcomp tdl ;
2829 locmin := indfich ;
2830 genstand nreg 0 itmi tic ; * SKIP if < *
2831 genstand nreg lmax lcomp tdl ;
2832 locmax := indfich ;
2833 genstand nreg 0 itpnz tic ; * SKIP if > *
2834 * ADD BIT DISP AT PR3 *
2835 genstand pr3 0 iabd modif lattr.ldreg ;
2836 mfari1 := a0r0i0 ; mfari2 := a1r0i0 ;
2837 geneism icmpb 0 p1t0r0 ; * FILL BIT TO 1 *
2838 gendescb nreg 0 0 0 0 tn ; * DUMMY *
2839 IF kind = varbl THEN usednameaddr := nameaddr ;
2840 gendescb pr3 0 0 0 1 tn ; * ONE BIT OPER *
2841 * ZERO ON true *
2842 inser cb locmin ; * HERE ZERO OFF if SKIP OR false *
2843 inser cb locmax ;
2844 freebloc lattr.ldregbloc ;
2845 accbool := false ; accbloc := NIL ; transf := 2 ;
2846 END * GATTR.KIND <> LVAL * ;
2847 END * LATTR NOT SVAL * ;
2848 gattr.kind := lcond ;
2849 END * with GATTRNO ERROR129 * ;
2850 END * LREOPCL=7 * ;
2851 gattr.typtr := boolptr ;
2852 END * NOT nil FOR GATTRLATTR * ;
2853 $OPTIONS compile = trace $
2854 newattr := true ;
2855 $OPTIONS compile = true $
2856 END * NO=8 RELATIONAL OPERATOR * ;
2857 $OPTIONS compile = trace $
2858 IF stattrace > low THEN
2859 BEGIN
2860 IF stattrace = high AND newattr THEN
2861 printattr gattr ;
2862 write mpcogout '^^^ FIN EXPRESSION with NOCL ' no : 4 cl : 4 ; nextline ;
2863 END ;
2864 $OPTIONS compile = true $
2865 END * EXPRESSION * ;
2866
2867 BEGIN
2868 END. * Fin du module d ' analyse des expressions *