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 ; switch security := true $
19 PROGRAM procstat ;
20 $IMPORT
21 * IMPORTED PROCEDURES *
22 'RACINE pascal' :
23 error,
24 insymbol,
25 nameisref,
26 nextline,
27 recadre,
28 skip ;
29 'GENOPER pascal' :
30 check_dynamic_string_length,
31 gen_insert,
32 gen_delete ;
33 'GENERE pascal' :
34 gendesca,
35 geneism,
36 genstand,
37 inser ;
38 'EXPR pascal' :
39 expression ;
40 'STATE pascal' :
41 addressvar,
42 calcvarient,
43 checkbnds,
44 choicerarq,
45 freeallregisters,
46 freebloc,
47 gencstecode,
48 loadadr,
49 loadbase,
50 genexceptcode,
51 newbloc,
52 oldnewstor,
53 regenere,
54 sauvereg,
55 transfer,
56 variab ;
57 'MODVARIABLE pascal ' :
58 init_desc_address,
59 variable ;
60 'CONTEXTTABLE pascal ' :
61 checkminmax,
62 compatbin,
63 conformantdim ;
64 'MODATTR pascal' :
65 freeattr,
66 initattrvarbl,
67 isstring,
68 is_possible_string,
69 varissimple ;
70 'optimized_procedures alm' : search ;
71
72 * IMPORTED VARIABLES *
73 'RACINE pascal' :
74 alfaptr,
75 boolptr,
76 charptr,
77 cl,
78 ctptr,
79 envstandard,
80 errcl,
81 exportablecode,
82 ival,
83 level,
84 intptr,
85 mpcogout,
86 no,
87 pascalfrench,
88 realptr,
89 symbolfile,
90 symbolline,
91 string_ptr,
92 symbolmap,
93 textfilectp ;
94 'DECLARE pascal' :
95 getpr4afterstop,
96 lkc ;
97 'GENERE pascal' :
98 cb,
99 indfich,
100 mfari1,
101 mfari2,
102 usednameaddr ;
103 'STATE pascal' :
104 resetused,
105 disposeused,
106 arrayboundsctp,
107 asscheck,
108 currentbloc,
109 currentpr,
110 gattr,
111 inputctp,
112 inxcheck,
113 linktoend,
114 linktoendplace,
115 linktomain,
116 linktomainplace,
117 maxprused,
118 modif,
119 opaq,
120 outputctp,
121 prinst,
122 stattrace$
123
124 $EXPORT
125 argvstat,
126 dateandtime,
127 delete_string,
128 getput,
129 insapp,
130 insert_string,
131 mvcir,
132 newir,
133 pckunpck,
134 readir,
135 stopstat,
136 writeir $
137
138
139
140 $OPTIONS page $
141
142
143 $INCLUDE 'CONSTTYPE' $
144
145 $OPTIONS page $
146
147 VAR
148
149 * REDEFINE IMPORTED VARIABLES *
150 * FROM RACINE *
151 mpcogout : text ;
152 cl : integer ;
153 no : integer ;
154 pascalfrench : boolean ;
155 realptr : ctp ;
156 string_ptr : ctp ;
157 ctptr : ctp ;
158 envstandard : stdkind ;
159 errcl : ARRAY norange OF typofsymb ;
160 textfilectp : ctp ;
161 intptr : ctp ;
162 ival : integer ;
163 alfaptr : ctp ;
164 boolptr : ctp ;
165 charptr : ctp ;
166 exportablecode : boolean ;
167 level : levrange ;
168 symbolmap : boolean ;
169 symbolfile, symbolline : integer ;
170
171 * FROM DECLARE *
172 getpr4afterstop : boolean ;
173 lkc : integer ;
174
175 * FROM GENERE *
176 cb : integer ;
177 indfich : integer ;
178 mfari1 : zari ;
179 mfari2 : zari ;
180 usednameaddr : ctp ;
181
182
183 * FROM STATE *
184 arrayboundsctp : ctp ;
185 resetused : boolean ;
186 disposeused : boolean ;
187 inxcheck : boolean ;
188 asscheck : boolean ;
189 gattr : attr ;
190 currentbloc : regpt ;
191 outputctp : ctp ;
192 inputctp : ctp ;
193 maxprused : preg ;
194 prinst : ARRAY typepr pr1..pr6 OF istand ; * GIVES A PR INSTRUCTION *
195 stattrace : levtrace ;
196 opaq : ARRAY typeofop ra..reaq OF istand ; * GIVES INST. WITH AQAQEAQ *
197 currentpr : preg ;
198 modif : ARRAY nxreg..rq OF tag ;
199 linktomain : boolean ;
200 linktomainplace : integer ;
201 linktoendplace : integer ;
202 linktoend : boolean ;
203
204
205
206
207 $OPTIONS page $
208 * FROM GENOPER *
209 PROCEDURE check_dynamic_string_length VAR fattr : attr ; EXTERNAL ;
210 PROCEDURE gen_insert VAR inserted_attr target_attr disp_attr : attr ; EXTERNAL ;
211 PROCEDURE gen_delete VAR string_attr disp_attr len_attr : attr ; EXTERNAL ;
212 * FROM GENERE *
213 * REDEFINE IMPORTED PROCEDURES *
214 * FROM GENERE *
215 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
216 PROCEDURE geneism fcode : ieism ; ffield : integer ; fbits : zptr ; EXTERNAL ;
217 PROCEDURE gendesca fareg : preg ; fadr fcn : integer ; fta : lgcar ;
218 fn : integer ; frlgth : mreg ; EXTERNAL ;
219 PROCEDURE inser fcb : integer ; fplace : integer ; EXTERNAL ;
220
221
222 * FROM RACINE *
223 PROCEDURE error errno : integer ; EXTERNAL ;
224 PROCEDURE insymbol ; EXTERNAL ;
225 PROCEDURE skip nosym : integer ; EXTERNAL ;
226 PROCEDURE nextline ; EXTERNAL ;
227 PROCEDURE search ; EXTERNAL ;
228 PROCEDURE nameisref box : ctp ; fil lin : integer ; EXTERNAL ;
229 FUNCTION recadre fnum fmod : integer : integer ; EXTERNAL ;
230
231
232 * FROM EXPR *
233 PROCEDURE expression ; EXTERNAL ;
234
235
236 * FROM STATE *
237 PROCEDURE choicerarq ; EXTERNAL ;
238 PROCEDURE transfer VAR fattr : attr ; inwhat : destination ; EXTERNAL ;
239 PROCEDURE newbloc freg : register ; EXTERNAL ;
240 PROCEDURE variab fvarset : boolean ; EXTERNAL ;
241 PROCEDURE loadbase lev : integer ; EXTERNAL ;
242 FUNCTION oldnewstor incrinbytes : integer : integer ; EXTERNAL ;
243 PROCEDURE freebloc VAR fbtofree : regpt ; EXTERNAL ;
244 PROCEDURE genexceptcode ferrcode : integer ; freg : register ; EXTERNAL ;
245 PROCEDURE loadadr VAR fattr : attr ; wantedpr : preg ; EXTERNAL ;
246 PROCEDURE regenere oldbloc : regpt ; EXTERNAL ;
247 PROCEDURE addressvar fctp : ctp ; VAR fattr : attr ; modif : boolean ; EXTERNAL ;
248 PROCEDURE calcvarient VAR fattr : attr ; VAR fbase : preg ; VAR fdisp : integer ;
249 VAR ftag : tag ; EXTERNAL ;
250 PROCEDURE sauvereg freg : register ; fload : boolean ; EXTERNAL ;
251 PROCEDURE gencstecode farg : integer ; finst : istand ; EXTERNAL ;
252 PROCEDURE checkbnds errcode : integer ; freg : register ; fctp : ctp ; EXTERNAL ;
253 PROCEDURE freeallregisters ; EXTERNAL ;
254 * FROM MODVARIABLE *
255 PROCEDURE init_desc_address fctp : ctp ; VAR fattr : attr ; EXTERNAL ;
256
257 PROCEDURE variable fvarset : boolean ; EXTERNAL ;
258
259 * FROM CONTEXTTABLE *
260
261 PROCEDURE compatbin typleft typright : ctp ; VAR fgeneric : ctp ; EXTERNAL ;
262 PROCEDURE checkminmax fvalu : integer ; fctp : ctp ; ferrnum : integer ; EXTERNAL ;
263 FUNCTION conformantdim ff : ctp : boolean ; EXTERNAL ;
264
265 * FROM MODATTR *
266
267 FUNCTION is_possible_string VAR fattr : attr : boolean ; EXTERNAL ;
268 FUNCTION isstring VAR fattr : attr : boolean ; EXTERNAL ;
269 FUNCTION varissimple VAR fattr : attr : boolean ; EXTERNAL ;
270 PROCEDURE freeattr VAR fattr : attr ; EXTERNAL ;
271 PROCEDURE initattrvarbl VAR fattr : attr ; EXTERNAL ;
272
273
274
275 $OPTIONS page $
276
277 * ************************************ WRITEIR ******************************* *
278
279 PROCEDURE writeir typewrite : integer ;
280
281 * C COMPILES THE CALL OF WRITE TYPEWRITE = 0 Standard
282 WRITELN TYPEWRITE = 1 Standard
283 PAGE TYPEWRITE = 2 Standard
284 FLUSH TYPEWRITE = 3 SOL extension
285 if FILE IS OMITTED then OUTPUT ASSUMED
286 C *
287 * E ERRORS DETECTED
288 4: "" EXPECTED
289 9: "" EXPECTED
290 15: INTEGER EXPECTED
291 20: "" EXPECTED
292 144: ILLEGAL TYPE OF EXPRESSION
293 176: OUTPUT USED NOT DECLARED
294 191: SCALING FACTOR ONLY FOR REAL
295 198: OPERATION ALLOWED ONLY FOR TEXT FILE
296 E *
297 LABEL
298 1 * EXIT PROC * ;
299 VAR
300 pr3bloc : regpt ;
301 loc1, loc2 : integer ;
302 lattr : attr ;
303 defaultfile : boolean ;
304 deflength : integer ;
305 errintype : boolean ;
306 exprismade : boolean ;
307 fileonly : boolean ;
308 finloop : boolean ;
309 itisput : boolean ;
310 hardlength : boolean ;
311 locreg : preg ;
312 locbox : regpt ;
313 lengthst : integer ;
314 linst : istand ;
315 locctptr : ctp ;
316 notwrite : boolean ;
317 typecode : integer ;
318 aisknown : boolean ;
319 acont : integer ;
320
321 BEGIN * WRITEIR *
322 $OPTIONS compile = trace $
323 IF stattrace > none THEN
324 BEGIN
325 write mpcogout '^^^ DEBUT WRITEIR ^^^ WITH TYPEWRITE:' typewrite : 4 ;
326 nextline ;
327 END ;
328 $OPTIONS compile = true $
329 fileonly := false ; exprismade := false ;
330 locbox := NIL ;
331 notwrite := typewrite <> 0 ;
332 locctptr := NIL ;
333 IF no <> 9 * * THEN
334 BEGIN
335 IF notwrite THEN
336 BEGIN
337 IF outputctp <> NIL THEN
338 BEGIN
339 usednameaddr := outputctp ;
340 IF symbolmap THEN
341 nameisref outputctp symbolfile symbolline ;
342 genstand prlink outputctp^.vaddr DIV bytesinword iepp3 tny ;
343 genstand pr6 fsbadrw ispri3 tn ;
344 END * <> nil * ELSE
345 BEGIN
346 IF errcl no = endsy THEN error 176 ELSE error 9 ;
347 skip 46 ;
348 GOTO 1 ;
349 END ;
350 END * NOTWRITE * ELSE
351 BEGIN * WRITE *
352 error 9 ; skip 46 ; GOTO 1 ;
353 END ;
354 END * NO <> 9 * ELSE
355 BEGIN * NO=9 *
356 insymbol ;
357 defaultfile := true ;
358 IF no = 1 * ID * THEN
359 BEGIN
360 search ;
361 IF ctptr <> NIL THEN
362 IF ctptr^.klass = vars THEN
363 IF ctptr^.vtype <> NIL THEN
364 IF ctptr^.vtype^.form = files THEN
365 BEGIN
366 locctptr := ctptr ;
367 expression ;
368
369 IF gattr.typtr <> NIL THEN
370 BEGIN
371 IF gattr.typtr^.form = files THEN
372 BEGIN
373 usednameaddr := gattr.nameaddr ;
374 loadadr gattr pr3 ;
375 genstand pr6 fsbadrw ispri3 tn ;
376 defaultfile := false ;
377 IF no = 10 * * THEN
378 BEGIN
379 IF NOT notwrite THEN error 20 ;
380 fileonly := true ;
381 END * ID * ELSE
382 IF no = 15 * * THEN
383 BEGIN
384 IF typewrite >= 2 * PAGE FLUSH * THEN error 4 ;
385 insymbol ;
386 END * 15 * ELSE
387 error 20 ;
388 END * FILES * ELSE
389 BEGIN exprismade := true ; locctptr := NIL ;
390 END
391 END * TYPTR not nil * ELSE
392 BEGIN exprismade := true ; locctptr := NIL ;
393 END ;
394 END * FILE IDENT * ;
395 END * ID * ;
396 IF defaultfile THEN
397 IF outputctp <> NIL THEN
398 BEGIN
399 usednameaddr := outputctp ;
400 IF symbolmap THEN
401 nameisref outputctp symbolfile symbolline ;
402 genstand prlink outputctp^.vaddr DIV bytesinword iepp3 tny ;
403 genstand pr6 fsbadrw ispri3 tn ;
404 END ELSE
405 error 176 ;
406 IF NOT fileonly THEN
407 BEGIN
408 REPEAT * LOOP ON EXPRESSIONS TO BE WRITTEN *
409 lengthst := -1 ;
410 deflength := -1 ;
411 acont := -1 ;
412 IF NOT exprismade THEN
413 BEGIN
414 freeallregisters ; expression ;
415 END ELSE
416 exprismade := false ;
417 WITH gattr DO
418 IF typtr <> NIL THEN
419 BEGIN
420 * CHECK FOR PUT *
421 itisput := false ; linst := inop ;
422 IF NOT notwrite THEN
423 IF locctptr <> NIL THEN
424 IF locctptr^.vtype^.feltype = typtr THEN
425 IF locctptr^.vtype <> textfilectp THEN
426 itisput := true ;
427 IF typtr^.form <= pointer THEN
428 BEGIN
429 choicerarq ;
430 linst := opaq stor ldreg ;
431 freebloc gattr.ldregbloc ;
432 END * <=POINTER * ELSE
433 IF typtr^.form < files THEN
434 BEGIN
435 IF NOT conformantdim gattr.typtr THEN
436 BEGIN
437 loadadr gattr pr3 ;
438 linst := ispri3 ;
439 END ELSE
440 BEGIN
441 locreg := nreg ; locbox := NIL ;
442 init_desc_address gattr.nameaddr gattr ;
443 locreg := gattr.descreg ; locbox := gattr.descbloc ;
444 linst := prinst spri gattr.basereg ;
445 freebloc gattr.basebloc ;
446 END ;
447 END ;
448 errintype := false ;
449 hardlength := false ;
450 aisknown := false ;
451 * SELECT TYPECODE *
452 * LENGTH FOR EACH TYPE *
453 IF typtr^.father_schema = string_ptr THEN
454 BEGIN
455 typecode := 32 ;
456 genstand pr3 0 ilda tn ;
457 aisknown := true ; acont := deflength ;
458 genstand pr3 1 iepp3 tn ;
459 genstand pr6 valplacew ispri3 tn
460 END ELSE
461 BEGIN
462 IF linst <> inop THEN
463 BEGIN
464 genstand pr6 valplacew linst tn ;
465 END ;
466 CASE typtr^.form OF
467 reel : BEGIN
468 typecode := 8 ; deflength := deflreal ;
469 END * REEL * ;
470 numeric : BEGIN
471 typecode := 4 ; deflength := deflnum ;
472 END * NUMERIC * ;
473 scalar : BEGIN IF typtr^.subrng THEN typtr := typtr^.typset ;
474 IF typtr = boolptr THEN
475 BEGIN typecode := 2 ; deflength := deflbool ;
476 END ELSE
477 IF typtr = charptr THEN
478 BEGIN typecode := 1 ; deflength := deflchar ;
479 END ELSE
480 BEGIN
481 IF itisput THEN
482 BEGIN typecode := 4 ; * AS INTEGER *
483 END ELSE
484 errintype := true ;
485 END ;
486 END * SCALAR * ;
487 pointer, records, power :
488 IF itisput THEN
489 typecode := 64 ELSE
490 errintype := true ;
491 files : errintype := true ;
492 arrays :
493 IF itisput THEN
494 typecode := 64 ELSE
495 BEGIN
496 IF isstring gattr THEN
497 BEGIN
498 typecode := 32 ; hardlength := false ;
499 IF typtr = alfaptr THEN
500 lengthst := alfactp^.alfalong ELSE
501 IF typtr^.conformant THEN
502 hardlength := true ELSE
503 lengthst := typtr^.size ;
504 deflength := lengthst ;
505 END ELSE
506 errintype := true ;
507 END ;
508 END * CASE TYPTR^.FORM * ;
509 END ;
510 IF errintype THEN
511 BEGIN error 144 ; typecode := 4 ; deflength := deflnum ;
512 END ;
513 END * TYPTR <> nil WITH GATTR * ;
514 IF itisput THEN
515 BEGIN
516
517 * 6|FSBADRW = ITS ON FSB
518 6|VALPLACW= TWO-WORDS VALUE *
519 genstand nreg typecode ilda tdl ; * CODE FOR VALUE TYPE *
520 genstand pr0 writeseqplace itsp3 tn ; * OPERATOR CALL *
521 END * PUT * ELSE
522 BEGIN * WRITE ON A TEXT FILE *
523 IF locctptr <> NIL THEN
524 IF locctptr^.vtype <> textfilectp THEN error 198 ;
525 IF no = 19 * : * THEN
526 BEGIN
527 insymbol ; expression ;
528 IF hardlength THEN
529 BEGIN
530 hardlength := false ;
531 aisknown := true ;
532 acont := lengthst ;
533 END ;
534 freebloc locbox ;
535 IF gattr.typtr <> NIL THEN
536 IF gattr.typtr^.form <> numeric THEN error 15 ELSE
537 BEGIN
538 transfer gattr inacc ;
539 freebloc gattr.ldregbloc ;
540 END ;
541 END ELSE
542 BEGIN
543 IF NOT hardlength THEN
544 BEGIN
545 IF NOT aisknown THEN
546 BEGIN
547 aisknown := true ;
548 acont := deflength ;
549 gencstecode deflength ilda ;
550 hardlength := false ; freebloc locbox ;
551 END ;
552 IF typecode = 2 AND NOT pascalfrench THEN
553 BEGIN
554 genstand pr6 valplacew iszn tn ;
555 genstand nreg 2 itnz tic ;
556 genstand nreg 1 iada tdl ; * LENGTH + 1 if "FALSE" *
557 END
558 END ELSE
559 BEGIN
560 regenere gattr.descbloc ; ; locbox := NIL ;
561 * COMPUTE SIZE NOW *
562 sauvereg ra false ;
563
564 genstand locreg 1 ilda tn ; * MAX *
565 genstand locreg 0 isba tn ; * - MIN *
566 genstand nreg 1 iada tdl ; * +1 *
567 freeattr gattr ;
568 aisknown := true ; acont := lengthst ;
569 END ;
570 END ;
571 * STORE LENGTH *
572 genstand pr6 longplacew ista tn ;
573 IF no = 19 * : * THEN
574 BEGIN
575 IF typecode <> 8 * REAL * THEN error 191 ;
576 typecode := 16 ;
577 aisknown := false ;
578 freeallregisters ;
579 insymbol ; expression ;
580 IF gattr.typtr <> NIL THEN
581 IF gattr.typtr^.form <> numeric THEN error 15 ELSE
582 BEGIN
583 transfer gattr inacc ;
584 freebloc gattr.ldregbloc ;
585 genstand pr6 scaleplacew ista tn ;
586 END ;
587 END ;
588 IF NOT hardlength THEN
589 BEGIN
590 IF typecode = 32 * CHAINE * THEN
591 BEGIN
592 IF NOT aisknown AND acont = lengthst THEN
593 BEGIN
594 gencstecode lengthst ilda ;
595 aisknown := true ; acont := lengthst ;
596 END ;
597 genstand pr6 longstplacew ista tn ;
598 END ;
599 IF NOT aisknown AND acont = typecode THEN
600 genstand nreg typecode ilda tdl ;
601 END ELSE
602 BEGIN
603 genstand pr6 longstplacew ista tn ;
604 genstand nreg typecode ilda tdl ;
605 END ;
606
607 * PR6| FSBADRW ITS ON FSB
608 PR6| VALPLACEW VALUE OR ITS ON VALUE
609 PR6| LONGPLACEW REQUESTED LENGTH
610 PR6| SCALEPLACEW DIGITS FOR REAL
611 OR
612 LONGSTPLACEW REAL SIZE FOR A STRING
613 RA CODE FOR VALUE TYPE *
614 genstand pr0 writetextplace itsp3 tn ;
615 END * not A PUT * ;
616 * IS LOOP ENDED OR NOT *
617 finloop := true ;
618 IF no = 10 * *) THEN insymbol ELSE
619 IF no = 15 * * THEN
620 BEGIN
621 insymbol ; finloop := false ;
622 END ELSE
623 BEGIN
624 error 20 ; skip 15 ;
625 IF no = 15 * * THEN
626 BEGIN
627 insymbol ; finloop := false ;
628 END ;
629 END ;
630 UNTIL finloop ;
631 END * not FILEONLY * ELSE
632 IF no <> 10 * *) THEN
633 BEGIN
634 error 4 ; skip 46 ;
635 END ELSE
636 insymbol ;
637 END * NO= 9 * ;
638 IF notwrite THEN
639 BEGIN
640 IF locctptr <> NIL THEN
641 IF locctptr^.vtype <> textfilectp THEN
642 error 198 ;
643 IF typewrite = 1 * WRITELN * THEN
644 BEGIN
645 genstand pr0 writelnplace itsp3 tn ;
646 END ELSE
647 IF typewrite = 2 * PAGE * THEN
648 BEGIN
649 genstand pr0 pageplace itsp3 tn ;
650 END ELSE
651 BEGIN
652 genstand pr0 flushplace itsp3 tn ;
653 END ;
654 END ;
655 1 : * EXIT PROCEDURE *
656 $OPTIONS compile = trace $
657 IF stattrace > low THEN
658 BEGIN
659 write mpcogout '^^^ FIN WRITEIR ^^^ WITH NO :' no : 4 ; nextline ;
660 END ;
661 $OPTIONS compile = true $
662 END * WRITEIR * ;
663
664 $OPTIONS page $
665
666 $OPTIONS page $
667
668 * ************************************ READIR ******************************** *
669
670 PROCEDURE readir typeread : integer ;
671
672 * C .CALLED BY STATEMENT FOR STANDARD PROCEDURES - READ TYPEREAD IS 0
673 - READLN TYPEREAD IS 1
674 .ON NOT TEXT FILES READ IS ASSIGN FOLLOWED BY GET
675 .THE FILE "INPUT" CAN BE OMITTED.
676 .READLN CAN BE USED ONLY ON TEXT FILES
677 C *
678 * E ERRORS DETECTED
679 4: "" EXPECTED
680 9: "" EXPECTED
681 20: "" EXPECTED
682 153: TYPE ERROR IN READ
683 175: INPUT USED AND NOT DECLARED
684 198: OPERATION ALLOWED ONLY FOR TEXT FILE
685 E *
686 LABEL
687 1 ; * EXIT OF PROCEDURE *
688 VAR
689
690 defaultfile : boolean ;
691 variabismade : boolean ;
692 fileonly : boolean ;
693 finloop : boolean ;
694 isreadln : boolean ;
695 itisget : boolean ;
696 lattr : attr ;
697 lerr : boolean ;
698 locctptr : ctp ;
699 loctype : ctp ;
700 typecode : integer ;
701
702
703 BEGIN * READIR *
704 $OPTIONS compile = trace $
705 IF stattrace > none THEN
706 BEGIN
707 write mpcogout '^^^ DEBUT READIR ^^^ WITH TYPEREAD :' typeread : 4 ;
708 nextline ;
709 END ;
710 $OPTIONS compile = true $
711 isreadln := typeread = 1 ;
712 locctptr := NIL ;
713 variabismade := false ;
714 fileonly := false ;
715 IF no <> 9 * * THEN
716 BEGIN
717 IF isreadln THEN
718 BEGIN
719 IF inputctp <> NIL THEN
720 BEGIN
721 usednameaddr := inputctp ;
722 IF symbolmap THEN
723 nameisref inputctp symbolfile symbolline ;
724 genstand prlink inputctp^.vaddr DIV bytesinword iepp3 tny ;
725 genstand pr6 fsbadrw ispri3 tn ;
726 END * <> nil * ELSE
727 BEGIN
728 IF errcl no = endsy THEN error 175 ELSE error 9 ;
729 skip 46 ; GOTO 1 ;
730 END * =nil * ;
731 END * READLN * ELSE
732 BEGIN * READ *
733 error 9 ; skip 46 ; GOTO 1 ;
734 END ;
735 END * NO <> 9 * ELSE
736 BEGIN * NO=9 *
737 insymbol ;
738 defaultfile := true ;
739 IF no = 1 * ID * THEN
740 BEGIN
741 search ;
742 IF ctptr <> NIL THEN
743 IF ctptr^.klass = vars THEN
744 IF ctptr^.vtype <> NIL THEN
745 IF ctptr^.vtype^.form = files THEN
746 BEGIN
747 locctptr := ctptr ;
748 freeallregisters ;
749 variable false ;
750 IF gattr.typtr <> NIL THEN
751 IF gattr.typtr^.form = files THEN
752 BEGIN
753 loadadr gattr pr3 ;
754 genstand pr6 fsbadrw ispri3 tn ;
755 defaultfile := false ;
756 IF no = 10 * * THEN
757 BEGIN
758 IF NOT isreadln THEN error 20 ;
759 fileonly := true ;
760 END * NO=10 * ELSE
761 IF no = 15 * * THEN
762 insymbol ELSE
763 error 20 ;
764 END * FILE FOUND * ELSE
765 BEGIN
766 variabismade := true ; locctptr := NIL ;
767 END ELSE
768 BEGIN
769 variabismade := true ; locctptr := NIL ;
770 END
771 END * FILE IDENTIFIER * ;
772 END * NO=1 * ;
773 IF defaultfile THEN
774 IF inputctp <> NIL THEN
775 BEGIN
776 usednameaddr := inputctp ;
777 IF symbolmap THEN
778 nameisref inputctp symbolfile symbolline ;
779 genstand prlink inputctp^.vaddr DIV bytesinword iepp3 tny ;
780 genstand pr6 fsbadrw ispri3 tn ;
781 END ELSE
782 error 175 ;
783 IF NOT fileonly THEN
784 BEGIN
785 REPEAT * LOOP ON READ ITEMS *
786 IF NOT variabismade THEN
787 BEGIN
788 freeallregisters ;
789 variab true ; * VARIABLE IS SET HERE *
790 END ELSE
791 variabismade := false ;
792 WITH gattr DO
793 IF typtr <> NIL THEN
794 BEGIN
795 itisget := false ;
796 IF NOT isreadln THEN
797 IF locctptr <> NIL THEN
798 IF locctptr^.vtype^.feltype = typtr THEN
799 IF locctptr^.vtype <> textfilectp THEN
800 itisget := true ;
801 IF itisget THEN
802 BEGIN
803 loadadr gattr pr1 ;
804 genstand pr0 readseqplace itsp3 tn ;
805 END * GET * ELSE
806 BEGIN * READ ON TEXT FILE *
807 IF locctptr <> NIL THEN
808 IF locctptr^.vtype <> textfilectp THEN error 198 ;
809 lerr := false ;
810 IF typtr^.father_schema = string_ptr THEN
811 BEGIN
812 loadadr gattr pr3 ;
813 genstand pr6 valplacew ispri3 tn ;
814 freeattr gattr ;
815 IF typtr^.actual_parameter_list^.klass <> konst THEN
816 BEGIN
817 addressvar typtr^.actual_parameter_list lattr false ;
818 transfer lattr inacc ;
819 freeattr lattr ;
820 END
821 ELSE gencstecode typtr^.actual_parameter_list^.values ilda ;
822 genstand pr6 longstplacew ista tn ;
823 typecode := 16 ;
824 END ELSE
825 IF typtr^.form = scalar THEN
826 BEGIN
827 IF typtr^.subrng THEN loctype := typtr^.typset ELSE
828 loctype := typtr ;
829 IF loctype <> charptr THEN
830 lerr := true ELSE
831 typecode := 1 ;
832 END * SCALAR * ELSE
833 IF typtr^.form = numeric THEN
834 typecode := 4 ELSE
835 IF typtr = realptr THEN
836 typecode := 8 ELSE
837 lerr := true ;
838 IF lerr THEN
839 error 153 ELSE
840 BEGIN
841 * SAVE LOADED REGISTERS *
842 IF basereg <= maxprused THEN sauvereg basereg false ;
843 IF inxreg <> nxreg THEN sauvereg inxreg false ;
844 lattr := gattr ;
845 * NOW CALL OPERATOR *
846 genstand nreg typecode ilda tdl ;
847 genstand pr0 readtextplace itsp3 tn ;
848 * NOW ACC IS LOADED *
849 * WITH GATTR *
850 IF typecode <> 16 THEN
851 BEGIN
852 kind := lval ;
853 IF typtr = realptr THEN
854 ldreg := reaq ELSE
855 ldreg := ra ;
856 newbloc ldreg ; ldregbloc := currentbloc ;
857 IF asscheck THEN
858 IF typtr <> realptr THEN
859 checkbnds asserrcode ra typtr ;
860 transfer lattr out ; * ASSIGNS *
861 END ;
862 END * NOT LERR * ;
863 END * READ ON TEXT FILE * ;
864 END * TYPTR <> nilWITH GATTR * ;
865 * IS LOOP ENDED OR NOT *
866 finloop := true ;
867 IF no = 10 * *) THEN
868 insymbol ELSE
869 IF no = 15 THEN
870 BEGIN
871 insymbol ; finloop := false ;
872 END ELSE
873 BEGIN
874 error 20 ; skip 15 ;
875 IF no = 15 * * THEN
876 BEGIN
877 insymbol ; finloop := false ;
878 END ;
879 END ;
880 UNTIL finloop ;
881 END * NOT FILEONLY * ELSE
882 IF no <> 10 * *) THEN
883 BEGIN
884 error 4 ; skip 46 ;
885 END ELSE
886 insymbol ;
887 END * NO=9 * ;
888 IF isreadln THEN
889 BEGIN
890 IF locctptr <> NIL THEN
891 IF locctptr^.vtype <> textfilectp THEN
892 error 198 ;
893 genstand pr0 readlnplace itsp3 tn ;
894 END ;
895 1 : * EXIT PROCEDURE *
896 $OPTIONS compile = trace $
897 IF stattrace > low THEN
898 BEGIN
899 write mpcogout '^^^ FIN READIR ^^^ WITH NO:' no : 4 ; nextline ;
900 END ;
901 $OPTIONS compile = true $
902 END * READIR * ;
903
904 $OPTIONS page $
905
906 * ************************************* GETPUT ****************************** *
907
908 PROCEDURE getput typeio : integer ;
909
910 * C COMPILATION OF ALL INPUT/OUTPUT PREDECLARED PROCEDURES
911 . CALLED IN STATEMENT WITH FOLLOWING CODES
912 Codes 0..3 are for standard procedures
913 4..10 are for SOL procedures
914
915 0: GET 4: FCONNECT 8: FCLOSE
916 1:PUT 5: FUPDATE 9: FAPPEND
917 2:RESET 6: FGET 10: FREOPEN
918 3:REWRITE 7: FPUT
919
920 . INCLUDE ALSO RESET FOR A POINTER Extended Pascal only
921 C *
922 * E ERRORS DETECTED
923 4: '' EXPECTED
924 9: '' EXPECTED
925 15: INTEGER EXPECTED
926 19: STRING EXPECTED
927 20: '' EXPECTED
928 66: ILLEGAL OPERATION FOR THIS TYPE OF FILE
929 68: RESET ON POINTER NOT ALLOWED IN STANDARD
930 125: ERROR ON TYPE FOR STANDARD FUNCT/PROC
931 256: FCONNECT autorise que sur fichier permanent
932 E *
933 LABEL
934 10 ; * EXIT PROCEDURE *
935 VAR
936
937 istext : boolean ;
938 loclong : integer ;
939 operdepw : integer ;
940
941 BEGIN * GETPUT *
942 $OPTIONS compile = trace $
943 IF stattrace > none THEN
944 BEGIN
945 write mpcogout '^^^ DEBUT GETPUT ^^^ WITH TYPEIO :' typeio ; nextline ;
946 END ;
947 $OPTIONS compile = true $
948
949 IF no <> 9 * * THEN
950 BEGIN error 9 ; skip 46 ; GOTO 10 ;
951 END ;
952 insymbol ; freeallregisters ;
953 variab true ;
954 IF gattr.typtr <> NIL THEN
955 IF gattr.typtr^.form = files THEN
956 BEGIN
957 usednameaddr := gattr.nameaddr ;
958 loadadr gattr pr3 ;
959 genstand pr6 fsbadrw ispri3 tn ;
960 * FIND NOW SUITABLE OPERATOR *
961 istext := gattr.typtr = textfilectp ;
962 CASE typeio OF
963 0 : * GET *
964 IF istext THEN operdepw := gettextplace ELSE operdepw := getseqplace ;
965 1 : * PUT *
966 IF istext THEN operdepw := puttextplace ELSE operdepw := putseqplace ;
967 2 : * RESET * operdepw := resetplace ;
968 3 : * REWRITE * operdepw := rewriteplace ;
969 4 : * FCONNECT *
970 operdepw := connectplace ;
971 5 : * FUPDATE * IF istext THEN error 66 ELSE operdepw := fupdtplace ;
972 6 : * FGET * IF istext THEN error 66 ELSE operdepw := getdirplace ;
973 7 : * FPUT * IF istext THEN error 66 ELSE operdepw := putdirplace ;
974 8 : * FCLOSE * operdepw := fcloseplace ;
975 9 : * FAPPEND * operdepw := fappendplace ;
976 10 : * FREOPEN * operdepw := freopenplace ;
977 END * case TYPEIO * ;
978 IF typeio IN 4 6 7 THEN
979 BEGIN * FCONNECTFGETFPUT *
980 IF no <> 15 * * THEN
981 BEGIN error 20 ; skip 46 ; GOTO 10 ;
982 END ;
983 freeallregisters ;
984 insymbol ; expression ;
985 IF gattr.typtr <> NIL THEN
986 IF typeio = 4 * FCONNECT * THEN
987 BEGIN
988 IF isstring gattr THEN
989 BEGIN
990 IF gattr.kind = chain THEN * PACKED ARRAY OF CHAR *
991 loclong := gattr.alfactp^.alfalong ELSE
992 loclong := gattr.typtr^.size ;
993 loadadr gattr pr2 ;
994 genstand nreg loclong ilda tdl ;
995 END * STRING *
996 ELSE IF gattr.typtr^.father_schema = string_ptr THEN * VAR STRING *
997 BEGIN
998 loadadr gattr pr2 ;
999 genstand pr2 0 ilda tn ;
1000 genstand pr2 1 iepp2 tn ;
1001 END
1002 ELSE error 19 ;
1003 END * 4 * ELSE
1004 BEGIN * FGETFPUT *
1005 IF gattr.typtr^.form <> numeric THEN
1006 error 15 ELSE
1007 BEGIN
1008 transfer gattr inacc ;
1009 freebloc gattr.ldregbloc ;
1010 END
1011 END ;
1012 END * FCONNECTFGETFPUT * ;
1013 genstand pr0 operdepw itsp3 tn ;
1014 END * FORM=FILES * ELSE
1015 IF gattr.typtr^.form = pointer THEN
1016 BEGIN
1017 IF envstandard <> stdextend THEN error 68 ;
1018 IF typeio = 2 THEN
1019 BEGIN
1020 resetused := true ;
1021 transfer gattr inacc ;
1022 freebloc gattr.ldregbloc ;
1023 genstand pr0 resetheapplace itsp3 tn ;
1024 END ELSE error 125 ;
1025 END * RESET POINTER * ELSE
1026 error 125 ;
1027 IF no <> 10 * * THEN
1028 BEGIN
1029 error 4 ; skip 46 ;
1030 END ELSE
1031 insymbol ;
1032 10 : * EXIT PROCEDURE *
1033 $OPTIONS compile = trace $
1034 IF stattrace > low THEN
1035 BEGIN
1036 write mpcogout '^^^ FIN GETPUT ^^^ WITH NO:' no : 4 ; nextline ;
1037 END ;
1038 $OPTIONS compile = true $
1039 END * GETPUT * ;
1040
1041 $OPTIONS page $
1042
1043 * ************************************ NEWIR ******************************** *
1044
1045 PROCEDURE newir fcode : integer ;
1046
1047 * C .CALLED BY STATEMENT FOR STANDARD PROCEDURE
1048 NEW FCODE IS 0
1049 DISPOSE FCODE IS 1
1050 .GENERATES THE CALL OF PASCAL OPERATORS
1051 C *
1052 * E ERRORS DETECTED
1053 4: '' EXPECTED
1054 9: '' EXPECTED
1055 103: IDENTIFIER IS NOT OF APPROPRIATE CLASS
1056 104: IDENTIFIER NOT DECLARED
1057 107: ERROR IN SELECTOR.
1058 125: ERROR IN TYPE OF ARGUMENT OF STANDARD PROCEDURE
1059 145: TYPE CONFLICT
1060 158: MISSING CORRESPONDING VARIANT DECLARATION
1061 344: Too large item
1062 345: Dispose pas compatible avec extensions
1063 E *
1064
1065 LABEL
1066 10 ; * EXIT PROCEDURE *
1067 VAR
1068
1069 generic : ctp ; * RETURNED BY COMPATBIN *
1070 isnew : boolean ; * TRUE FOR NEW FALSE FOR DISPOSE *
1071 harddispose, ptpack : boolean ;
1072 lattr : attr ; * USED TO ASSIGN POINTER *
1073 * AFTER NEW OPERATOR *
1074 lerr : boolean ;
1075 etendu : boolean ;
1076 savegattr : attr ;
1077 locctp : ctp ;
1078 ltemp, locval, locop : integer ;
1079 linst : istand ;
1080 notfound : boolean ;
1081 pt : ctp ;
1082 sizeofnew : integer ; * SIZE TO BE ALLOCATE IN WORDS *
1083 ltag : tag ;
1084
1085
1086 * ************************************ LSKIPERROR< NEWIR ***************** *
1087
1088 PROCEDURE lskiperror ferrnum : integer ;
1089 BEGIN
1090 error ferrnum ; skip 46 ; GOTO 10 ; * EXIT OF NEWIR *
1091 END * LSKIPERROR * ;
1092
1093 BEGIN * NEWIR *
1094 $OPTIONS compile = trace $
1095 IF stattrace > none THEN
1096 BEGIN
1097 write mpcogout '^^^ DEBUT NEWIR ^^^ with FCODE:' fcode : 4 ; nextline ;
1098 END ;
1099 $OPTIONS compile = true $
1100 isnew := fcode = 0 ; * true FOR STANDARD PROCEDURE "NEW" *
1101 etendu := false ;
1102 IF NOT isnew THEN
1103 disposeused := true ;
1104 IF no <> 9 THEN lskiperror 9 ;
1105 freeallregisters ;
1106 insymbol ; variab true ; * SETTING OF THE VARIABLE *
1107 WITH gattr DO
1108 IF typtr <> NIL THEN
1109 WITH typtr^ DO
1110 BEGIN
1111 IF form <> pointer THEN lskiperror 125 ;
1112 IF eltype = NIL THEN * PREVIOUS ERROR *
1113 BEGIN skip 46 ; GOTO 10 ;
1114 END ;
1115 pt := eltype ;
1116 END * with TYPTR^GATTR * ELSE
1117 BEGIN * ERROR *
1118 skip 46 ; GOTO 10 ;
1119 END ;
1120 * COMPUTE ALLOCATION SIZE *
1121 IF no = 15 * * THEN
1122 BEGIN
1123 pt := pt^.recvar ;
1124 REPEAT
1125 IF pt = NIL THEN lskiperror 158 ;
1126 insymbol ;
1127 IF no = 1 * ID * THEN
1128 BEGIN
1129 search ;
1130 IF ctptr = NIL THEN lskiperror 104 ;
1131 IF ctptr^.klass <> konst THEN lskiperror 103 ;
1132 compatbin pt^.casetype ctptr^.contype generic ;
1133 IF generic = NIL OR generic = realptr THEN lskiperror 145 ;
1134 locval := ctptr^.values ;
1135 END * NO=1 * ELSE
1136 IF no = 2 AND cl IN 1 4 THEN * INTCHAR CSTE *
1137 BEGIN
1138 lerr := true ;
1139 IF cl = 1 * INT * THEN
1140 BEGIN
1141 IF pt^.casetype^.form = numeric THEN lerr := false
1142 END ELSE
1143 WITH pt^ DO
1144 BEGIN
1145 IF casetype^.subrng THEN
1146 BEGIN IF casetype^.typset = charptr THEN lerr := false ;
1147 END ELSE
1148 IF casetype = charptr THEN lerr := false ;
1149 END ;
1150 IF lerr THEN lskiperror 145 ;
1151 locval := ival ;
1152 END ELSE
1153 lskiperror 107 ;
1154 * SEARCHS SELECTOR IN VARIANT LIST *
1155 notfound := true ;
1156 locctp := pt^.variants ;
1157 WHILE locctp <> NIL AND notfound DO
1158 WITH locctp^ DO
1159 IF caseval = locval THEN notfound := false ELSE locctp := nxtel ;
1160 IF notfound THEN lskiperror 158 ;
1161 sizeofnew := locctp^.casesize ;
1162 sizeofnew := recadre sizeofnew bytesinword DIV bytesinword ;
1163 pt := locctp^.variants ;
1164 insymbol ;
1165 UNTIL no <> 15 * * ;
1166 END * NO=15 * ELSE
1167 sizeofnew := recadre pt^.size bytesinword DIV bytesinword ;
1168 IF no = 49 THEN * -> *
1169 BEGIN
1170 IF NOT isnew THEN error 345 ;
1171 * Save all registers *
1172 IF gattr.inxreg <> nxreg THEN sauvereg gattr.inxreg false ;
1173 IF gattr.basereg <= maxprused THEN sauvereg gattr.basereg false ;
1174 savegattr := gattr ;
1175
1176 insymbol ; expression ;
1177 WITH gattr DO
1178 BEGIN
1179 IF typtr = NIL THEN
1180 BEGIN
1181 skip 46 ; GOTO 10 ;
1182 END ELSE
1183 IF typtr^.form <> numeric THEN
1184 lskiperror 15 ELSE
1185 BEGIN
1186 etendu := true ;
1187 transfer gattr inacc ;
1188
1189 * Words now *
1190 genstand nreg 1 isba tdl ; genstand nreg 2 iars tn ;
1191 genstand nreg 1 iada tdl ;
1192
1193 freebloc gattr.ldregbloc ;
1194 gattr := savegattr ;
1195 linst := iada ; ltag := tdl ; locop := newplace ;
1196 END * OK for type * ;
1197 END * With gattr * ;
1198 END * NO=49 * ;
1199 harddispose := false ;
1200 IF NOT isnew THEN
1201 IF NOT varissimple gattr THEN
1202 harddispose := true ;
1203 IF NOT harddispose THEN
1204 BEGIN
1205 IF gattr.inxreg <> nxreg THEN sauvereg gattr.inxreg false ;
1206 IF gattr.basereg <= maxprused THEN sauvereg gattr.basereg false ;
1207 END ; * EASY DISPOSE *
1208 lattr := gattr ;
1209 IF etendu THEN ELSE
1210 IF isnew THEN
1211 BEGIN
1212 linst := ilda ; ltag := tdl ; locop := newplace ;
1213 END ELSE
1214 BEGIN * DISPOSE *
1215 linst := ieax7 ; ltag := tn ; locop := disposeplace ;
1216 IF harddispose THEN
1217 BEGIN
1218 ptpack := gattr.pckd ;
1219 loadadr gattr pr3 ;
1220 genstand pr6 evareaw ispri3 tn ;
1221 * ADDRESS OF ITEM *
1222 sauvereg raq false ;
1223 IF ptpack THEN
1224 BEGIN
1225 genstand pr3 0 ilprp3 tn ;
1226 ltemp := oldnewstor bytesindword DIV bytesinword ;
1227 genstand pr6 ltemp ispri3 tn ;
1228 genstand pr6 ltemp ildaq tn ;
1229 END ELSE
1230 genstand pr3 0 ildaq tn ;
1231 END ELSE
1232 BEGIN
1233 transfer gattr inacc ;
1234 freebloc gattr.ldregbloc ;
1235 END ;
1236 END * DISPOSE * ;
1237 IF sizeofnew <= maxnewsize THEN
1238 genstand nreg sizeofnew linst ltag ELSE
1239 error 344 ;
1240 genstand pr0 locop itsp3 tn ;
1241 * RETURNS "ITS" IN AQ *
1242 * nil FOR DISPOSE *
1243 WITH gattr DO
1244 BEGIN
1245 kind := lval ;
1246 ldreg := raq ; newbloc raq ;
1247 ldregbloc := currentbloc ;
1248 END ;
1249 IF harddispose THEN
1250 BEGIN
1251 genstand pr6 evareaw iepp3 tny ;
1252 genstand pr6 evareaw istaq tn ;
1253 freebloc currentbloc ;
1254 genstand pr6 evareaw iepp1 tny ;
1255 IF ptpack THEN
1256 BEGIN
1257 genstand pr3 0 isprp1 tn ;
1258 END ELSE
1259 BEGIN
1260 genstand pr3 0 ispri1 tn ;
1261 END ;
1262 END ELSE
1263 transfer lattr out ;
1264 IF no <> 10 THEN lskiperror 4 ;
1265 insymbol ;
1266 10 : * EXIT PROC *
1267 $OPTIONS compile = trace $
1268 IF stattrace > low THEN
1269 BEGIN
1270 write mpcogout '^^^ FIN NEWIR ^^^ with NO' no : 4 ; nextline ;
1271 END ;
1272 $OPTIONS compile = true $
1273 END * NEWIR * ;
1274
1275 $OPTIONS page $
1276
1277 * ***************************************** STOPSTAT ***************** *
1278
1279 PROCEDURE stopstat ;
1280
1281 * C Compilation de la procedure predefinie SOL STOP returncode
1282
1283 On appelle un runtime dont les fonction sont les suivantes
1284 . fermeture des fichiers
1285 . retour au systeme et renvoie d'un code d'erreur
1286
1287 C *
1288
1289 * E ERRORS DETECTED
1290 4 : "" expected
1291 9 : "" expected
1292 15 : Numeric type expected
1293
1294 E *
1295
1296 LABEL
1297 10 ; * Exit if error *
1298
1299 CONST
1300 * nd01 *
1301 param2disp = 8 ;
1302 param3disp = 16 ;
1303 param4disp = 20 ;
1304 * nf01 *
1305
1306 VAR
1307 locop : integer ;
1308
1309 BEGIN * STOPSTAT *
1310 $OPTIONS compile = trace $
1311 IF stattrace > none THEN
1312 BEGIN
1313 write mpcogout '@@@ Debut de STOPSTAT @@@' ; nextline ;
1314 END ;
1315 $OPTIONS compile = true $
1316
1317 IF no <> 9 * * THEN
1318 BEGIN
1319 error 9 ; skip 46 ;
1320 GOTO 10 ;
1321 END ;
1322
1323 insymbol ; expression ; * ANALYSIS OF GIVEN RETURNCODE *
1324 IF gattr.typtr <> NIL THEN
1325 BEGIN
1326 IF gattr.typtr^.form <> numeric THEN
1327 error 15 ELSE
1328 BEGIN
1329 transfer gattr inacc ; * Found return code value *
1330 * On stocke la valeur trouvee *
1331 freebloc gattr.ldregbloc ;
1332 IF level = 0 THEN
1333 locop := stopshortplace ELSE
1334 BEGIN
1335 IF NOT exportablecode THEN
1336 BEGIN
1337 loadbase 0 ;
1338 IF currentpr <> pr1 THEN
1339 genstand currentpr 0 iepp1 tn ;
1340 * PR1 points MAIN stack frame *
1341 freebloc currentbloc ;
1342 locop := stopplace ;
1343 END ELSE
1344 BEGIN
1345 IF NOT linktomain THEN
1346 BEGIN
1347 linktomainplace := lkc ;
1348 lkc := lkc + bytesindword ;
1349 linktomain := true ;
1350 END ;
1351 genstand prlink linktomainplace DIV bytesinword iepp1 tny ;
1352 * PR1 points MAIN entry point *
1353 locop := stopextplace ;
1354 END * EXPORTABLE * ;
1355 getpr4afterstop := true ;
1356
1357 END ; * OPERATOR SELECTION *
1358
1359 * Charge PR2 avec adresse sequence de retour du main *
1360 IF NOT linktoend THEN
1361 BEGIN
1362 linktoendplace := lkc ;
1363 lkc := lkc + bytesindword ;
1364 linktoend := true ;
1365 END ;
1366 genstand prlink linktoendplace DIV bytesinword iepp2 tny ;
1367
1368 genstand pr0 locop itsp3 tn ;
1369
1370 END * Numeric found * ;
1371 END * Gattr.typtr <> nil * ;
1372
1373 IF no <> 10 * * THEN
1374 BEGIN
1375 error 4 ; skip 46 ;
1376 END ELSE
1377 insymbol ;
1378
1379 10 : * Error exit *
1380
1381 $OPTIONS compile = trace $
1382 IF stattrace > low THEN
1383 BEGIN
1384 write mpcogout ' @@@ Fin de STOPSTAT @@@ avec NO :' no : 4 ;
1385 nextline ;
1386 END ;
1387 $OPTIONS compile = true $
1388 END * STOPSTAT * ;
1389
1390 $OPTIONS page $
1391
1392 * ***************************************** ARGVSTAT ***************** *
1393
1394 PROCEDURE argvstat ;
1395
1396 * C Compilation de la procedure predefinie SOL ARGV rang string
1397
1398 On appelle un runtime
1399
1400 C *
1401
1402 * E ERRORS DETECTED
1403 4 : "" expected
1404 9 : "" expected
1405 15 : Numeric type expected
1406 19 : String variable expected
1407 20 : "" expected
1408
1409 E *
1410
1411 LABEL
1412 10 ; * Exit if error *
1413
1414 CONST
1415
1416 VAR
1417
1418 is_var_string : boolean ;
1419 string_attr : attr ;
1420 addrplace : integer ;
1421 errinrang : boolean ;
1422 errintarget : boolean ;
1423 rangattr : attr ;
1424 stringbloc : regpt ;
1425 stringpr : register ;
1426 locop : integer ;
1427 BEGIN * ARGVSTAT *
1428 $OPTIONS compile = trace $
1429 IF stattrace > none THEN
1430 BEGIN
1431 write mpcogout '@@@ Debut de ARGVSTAT @@@' ; nextline ;
1432 END ;
1433 $OPTIONS compile = true $
1434
1435 is_var_string := false ;
1436 errinrang := true ; errintarget := true ;
1437
1438
1439 IF no <> 9 * * THEN
1440 BEGIN
1441 error 9 ; skip 46 ;
1442 GOTO 10 ;
1443 END ;
1444
1445 insymbol ; expression ; * ANALYSIS OF GIVEN RANG *
1446 IF gattr.typtr <> NIL THEN
1447 BEGIN
1448 IF gattr.typtr^.form <> numeric THEN
1449 error 15 ELSE
1450 BEGIN
1451 transfer gattr inq ;
1452 rangattr := gattr ;
1453 errinrang := false ;
1454 END * Numeric found * ;
1455 END * Gattr.typtr <> nil * ;
1456
1457 IF no <> 15 * * THEN
1458 BEGIN
1459 IF gattr.typtr <> NIL THEN
1460 error 20 ;
1461 skip 20 ;
1462 IF no <> 15 THEN
1463 BEGIN
1464 IF gattr.typtr = NIL THEN
1465 error 20 ;
1466 skip 46 ; GOTO 10 ;
1467 END ;
1468 END ;
1469
1470 insymbol ;
1471 variab true ;
1472
1473 IF gattr.typtr <> NIL THEN
1474 BEGIN
1475 IF NOT isstring gattr THEN
1476 IF gattr.typtr^.father_schema = string_ptr THEN
1477 BEGIN
1478 IF gattr.typtr^.actual_parameter_list <> NIL THEN
1479 BEGIN
1480 errintarget := false ;
1481 is_var_string := true ;
1482 loadadr gattr nreg ;
1483 stringbloc := currentbloc ;
1484 stringpr := currentpr ;
1485 WITH gattr.typtr^ DO
1486 BEGIN
1487 IF actual_parameter_list^.klass = konst THEN
1488 gencstecode actual_parameter_list^.values ilda
1489 ELSE
1490 BEGIN
1491 addressvar actual_parameter_list string_attr false ;
1492 transfer string_attr inacc ;
1493 freeattr string_attr ;
1494 END ;
1495 END ;
1496 END
1497 END ELSE
1498 error 19 ELSE
1499 BEGIN
1500 loadadr gattr nreg ;
1501 stringbloc := currentbloc ;
1502 stringpr := currentpr ;
1503 gencstecode gattr.typtr^.size ilda ;
1504 errintarget := false ;
1505 END * OK for string * ;
1506 END * GATTR.TYPTR <> nil * ;
1507
1508 * NOW CODE GENERATION *
1509 IF NOT errinrang OR errintarget THEN
1510 BEGIN
1511
1512 regenere rangattr.ldregbloc ; * RQ ok = Rang desire *
1513 freebloc rangattr.ldregbloc ;
1514
1515 * PR1 = TARGET STRING OK *
1516
1517 * RA ok = String long *
1518
1519 * SELECT OPERATOR *
1520 IF level = 0 THEN
1521 locop := argvshortplace ELSE
1522 BEGIN
1523 IF NOT exportablecode THEN
1524 BEGIN
1525 loadbase 0 ;
1526 IF currentpr <> pr2 THEN
1527 genstand currentpr 0 iepp2 tn ;
1528 * PR2 points MAIN stack frame *
1529 regenere stringbloc ;
1530 regenere currentbloc ;
1531 IF stringpr <> pr1 THEN
1532 genstand stringpr 0 iepp1 tn ;
1533 freebloc currentbloc ;
1534 locop := argvplace ;
1535 END ELSE
1536 BEGIN
1537 IF NOT linktomain THEN
1538 BEGIN
1539 linktomainplace := lkc ;
1540 lkc := lkc + bytesindword ;
1541 linktomain := true ;
1542 END ;
1543 genstand prlink linktomainplace DIV bytesinword iepp2 tny ;
1544 * PR2 points MAIN entry point *
1545 locop := argvextplace ;
1546 END * EXPORTABLE * ;
1547
1548 END ; * OPERATOR SELECTion *
1549 freebloc stringbloc ;
1550
1551 IF is_var_string THEN
1552 BEGIN
1553 addrplace := oldnewstor bytesindword DIV bytesinword ;
1554 genstand pr6 addrplace ispri1 tn ;
1555 genstand pr1 1 iepp1 tn ;
1556 END ;
1557
1558 genstand pr0 locop itsp3 tn ;
1559
1560 IF is_var_string THEN
1561 genstand pr6 addrplace ista tny ;
1562
1563 END * no ERROR * ;
1564
1565 IF no <> 10 * * THEN
1566 BEGIN
1567 error 4 ; skip 46 ;
1568 END ELSE
1569 insymbol ;
1570
1571 10 : * Error exit *
1572
1573 $OPTIONS compile = trace $
1574 IF stattrace > low THEN
1575 BEGIN
1576 write mpcogout ' @@@ Fin de ARGVSTAT @@@ avec NO :' no : 4 ;
1577 nextline ;
1578 END ;
1579 $OPTIONS compile = true $
1580 END * ARGVSTAT * ;
1581
1582 $OPTIONS page $
1583
1584 * *********************************************** DATE AND TIME ********** *
1585
1586 PROCEDURE dateandtime whatisit : integer ;
1587
1588 * E ERRORS DETECTED
1589 4 expected
1590 9 expected
1591 74 string or packed array of char with size 8 expected
1592
1593 E *
1594
1595 * C Analysis and code generation for the non-standard predefined procedures
1596 DATE and TIME
1597 0 1 for the parameter WHATISIT
1598
1599 C *
1600
1601 LABEL
1602 10 ; * EXIT IF ERROR *
1603
1604 VAR
1605 string_attr : attr ;
1606 var_string : boolean ;
1607 lerr : boolean ;
1608 lopplace : integer ;
1609 BEGIN * DATE AND TIME *
1610 $OPTIONS compile = trace $
1611 IF stattrace > none THEN
1612 BEGIN
1613 write mpcogout '@@@ DEBUT DATE AND TIME @@@ WHIT PARAM' whatisit : 6 ;
1614 nextline ;
1615 END ;
1616 $OPTIONS compile = true $
1617 IF no # 9 * * THEN
1618 BEGIN
1619 error 9 ; skip 46 ; GOTO 10
1620 END ;
1621 freeallregisters ; insymbol ; variab true ;
1622 WITH gattr DO
1623 IF typtr # NIL THEN
1624 BEGIN
1625 * CHECK PARAMETER TYPE *
1626 lerr := true ;
1627 var_string := false ;
1628 IF isstring gattr THEN
1629 lerr := typtr^.size <> alfaleng
1630 ELSE
1631 IF gattr.typtr^.father_schema = string_ptr THEN
1632 WITH gattr.typtr^ DO
1633 IF actual_parameter_list <> NIL THEN
1634 BEGIN
1635 var_string := true ;
1636 IF actual_parameter_list^.klass = konst THEN
1637 lerr := actual_parameter_list^.values < 8
1638 ELSE
1639 BEGIN
1640 lerr := false ;
1641 addressvar actual_parameter_list string_attr false ;
1642 transfer string_attr inacc ;
1643 freeattr string_attr ;
1644 genstand nreg 8 icmpa tdl ;
1645 genstand nreg 4 itpl tic ;
1646 genexceptcode 26 ra ;
1647 END ;
1648 END ;
1649
1650 IF lerr THEN error 74 ELSE
1651 BEGIN * NOT ERR *
1652 IF whatisit = 0 * DATE * THEN lopplace := dateopplace ELSE
1653 * TIME * lopplace := timeopplace ;
1654 loadadr gattr pr3 ;
1655 IF var_string THEN
1656 BEGIN
1657 genstand nreg 8 ilda tdl ;
1658 genstand pr3 0 ista tn ; * STORE LENGTH 8 FOR STRING PARAMETER *
1659 genstand pr3 1 iepp3 tn ; * GIVE REAL STRING ADDR *
1660 END ;
1661 genstand pr6 evareaw ispri3 tn ;
1662 * CALL OPERATOR *
1663 genstand pr0 lopplace itsp3 tn ;
1664
1665 * NOW RAQ IS LOADED WITH CHARS
1666 MM/DD/YY FOR DATE
1667 HH:MM:SS FOR TIME *
1668 genstand pr6 evareaw iepp3 tny ;
1669 genstand pr6 evareaw istaq tn ;
1670 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1671 geneism imlr ord ' ' p0t0r0 ;
1672 gendesca pr6 evareaw 0 l9 alfaleng tn ;
1673 WITH gattr DO
1674 IF kind = varbl THEN usednameaddr := nameaddr ;
1675 gendesca pr3 0 0 l9 alfaleng tn ;
1676 END * NOT ERR * ;
1677 END * TYPTR NOT NIL * ;
1678
1679 IF no = 10 * * THEN
1680 insymbol ELSE
1681 BEGIN error 4 ; skip 46 ;
1682 END ;
1683
1684 10 : * EXIT HERE IF ERROR *
1685
1686 $OPTIONS compile = trace $
1687 IF stattrace > low THEN
1688 BEGIN
1689 write mpcogout ' @@@ FIN DATE AND TIME @@@ WITH NOCL ' no : 4 cl : 4 ;
1690 nextline ;
1691 END ;
1692 $OPTIONS compile = true $
1693
1694 END * DATE AND TIME * ;
1695
1696 $OPTIONS page $
1697
1698 * ************************************ INSAPP ******************************** *
1699
1700 PROCEDURE insapp typefct : integer ;
1701
1702 * C COMPILATION OF INSERT TWO PREDECLARED PROC. USED FOR AUTOCOMPILATION.
1703 APPEND
1704 *INSERTABC -SHIFTS THE CONTENT OF A LEFT B BITS AND
1705 'OR'S THEM INTO C
1706 -AB UNCHANGED
1707 *APPENDABC +SHIFTS THE CONTENT OF A LEFT B BITS AND
1708 'OR'S C INTO IT. B AND C UNCHANGED
1709 TYPEFCT= 0 FOR INSERT
1710 = 1 FOR APPEND
1711 C *
1712 * E ERRORS DETECTED
1713 4: '' EXPECTED
1714 9: '' EXPECTED
1715 15: NUMERIC EXPECTED
1716 20: '' EXPECTED
1717 21: ILLEGAL SHIFT COUNT
1718 26 : PACKED NOT ALLOWED HERE
1719 E *
1720 LABEL
1721 10 ; * EXIT PROCEDURE *
1722 VAR
1723 isinsert, lerr, easyo : boolean ;
1724 assattr, lattr : attr ;
1725 ltag : tag ;
1726 lcount, ldisp, ldep, lad : integer ;
1727 lbase : preg ;
1728 BEGIN * INSAPP *
1729 $OPTIONS compile = trace $
1730 IF stattrace > none THEN
1731 BEGIN
1732 write mpcogout '@@@ DEBUT INSAPP @@@ WITH TYPEFCT:' typefct : 4 ; nextline ;
1733 END ;
1734 $OPTIONS compile = true $
1735 IF no # 9 * * THEN
1736 BEGIN
1737 error 9 ; skip 46 ; GOTO 10 ;
1738 END ;
1739 isinsert := typefct = 0 ;
1740 freeallregisters ;
1741 lerr := true ;
1742 insymbol ;
1743 IF isinsert THEN
1744 expression ELSE variab true ;
1745 IF gattr.typtr # NIL THEN
1746 IF gattr.typtr@.form # numeric THEN error 15 ELSE
1747 BEGIN
1748 IF NOT isinsert THEN
1749 BEGIN
1750 IF varissimple gattr THEN
1751 BEGIN
1752 easyo := true ; assattr := gattr ;
1753 END ELSE
1754 BEGIN
1755 easyo := false ; lad := 0 ;
1756 IF gattr.pckd THEN error 26 ELSE
1757 BEGIN
1758 loadadr gattr nreg ;
1759 gattr.basereg := currentpr ; gattr.basebloc := currentbloc ;
1760 gattr.dplmt := 0 ; gattr.itsdplmt := 0 ;
1761 lad := oldnewstor bytesindword DIV bytesinword ;
1762 genstand pr6 lad prinst spri currentpr tn ;
1763 END ;
1764 END ;
1765 END ;
1766 transfer gattr inq ;
1767 lattr := gattr ;
1768 lerr := false ;
1769 END ;
1770 IF no # 15 * * THEN
1771 BEGIN
1772 error 20 ; skip 46 ; GOTO 10 ;
1773 END ;
1774 * RQ = INITIAL VALUE OF "A" *
1775 * . TO BE KEPT *
1776 insymbol ; expression ; * SHIFT COUNT *
1777 WITH gattr DO
1778 IF typtr # NIL THEN
1779 IF typtr@.form # numeric THEN error 15 ELSE
1780 BEGIN
1781 IF kind = sval THEN
1782 BEGIN
1783 IF val < 0 OR val > bitsinword - 1 THEN
1784 BEGIN
1785 error 21 ; val := 0 ;
1786 END ;
1787 ltag := tn ; lcount := val ;
1788 END * SVAL * ELSE
1789 BEGIN
1790 transfer gattr inacc ;
1791 ltag := tal ; lcount := 0 ;
1792 END ;
1793 IF NOT lerr THEN
1794 regenere lattr.ldregbloc ;
1795 genstand nreg lcount iqls ltag ;
1796 freeattr gattr ;
1797 END * SHIFT "A" LEFT "B" * ;
1798 IF no # 15 * * THEN
1799 BEGIN
1800 error 20 ; skip 46 ; GOTO 10 ;
1801 END ;
1802 insymbol ;
1803 IF isinsert THEN
1804 variab true ELSE expression ;
1805 IF gattr.typtr # NIL THEN
1806 IF gattr.typtr@.form # numeric THEN error 15 ELSE IF NOT lerr THEN
1807 WITH gattr DO
1808 IF isinsert THEN
1809 BEGIN
1810 IF varissimple gattr THEN
1811 genstand basereg dplmt DIV bytesinword iorsq tn ELSE
1812 IF gattr.pckd THEN error 26 ELSE
1813 BEGIN
1814 ldep := lattr.ldregbloc@.saveplace ;
1815 IF ldep = 0 THEN
1816 BEGIN
1817 genstand pr6 evareaw istq tn ;
1818 ldep := evareaw ;
1819 END ELSE
1820 ldep := ldep DIV bytesinword ;
1821 freebloc lattr.ldregbloc ;
1822 sauvereg rq true ; * TO RESERVE RQ *
1823 calcvarient gattr lbase ldisp ltag ;
1824 genstand lbase ldisp ildq ltag ;
1825 genstand pr6 ldep iorq tn ;
1826 genstand lbase ldisp istq ltag ;
1827 freebloc currentbloc ; * FREE NOW RQ *
1828 END ;
1829 END * ISINSERT * ELSE
1830 BEGIN
1831 transfer gattr inq ; * SAVE LATTR IF NOT SAVED *
1832 genstand pr6 lattr.ldregbloc@.saveplace DIV bytesinword iorq tn ;
1833 IF easyo THEN
1834 transfer assattr out ELSE
1835 BEGIN
1836 genstand pr6 lad istq tny ;
1837 freebloc gattr.ldregbloc ;
1838 END ;
1839 freebloc lattr.ldregbloc ;
1840 END * APPEND * ;
1841 * WITH GATTRNOTLERRNUMERIC *
1842 * #NIL ENDED *
1843 IF no = 10 THEN
1844 insymbol ELSE
1845 BEGIN
1846 error 4 ; skip 46 ;
1847 END ;
1848 10 :
1849 $OPTIONS compile = trace $
1850 IF stattrace > low THEN
1851 BEGIN
1852 write mpcogout '@@@ FIN INSAPP @@@ WITH NO:' no : 4 ; nextline ;
1853 END ;
1854 $OPTIONS compile = true $
1855 END * INSAPP * ;
1856
1857 $OPTIONS page $
1858
1859 * ************************************ PCKUNPCK ****************************** *
1860
1861 PROCEDURE pckunpck code : integer ;
1862
1863 * C . COMPILATION OF PACK
1864 UNPACK
1865 .CODE = 0 FOR PACK AIZ
1866 = 1 FOR UNPACK ZAI
1867 WHERE A IS AN ARRAY S1 OF T
1868 Z IS AN PACKED ARRAY U..V OF T
1869 I STARTING POINT IN A
1870 .PACK MOVES AI.... AI +V-U IN ZU.. ZV
1871 .UNPACK MOVES ZU..ZV IN AI.. A I+V-U
1872 C *
1873 * E ERRORS DETECTED
1874 4: '' EXPECTED
1875 9: '' EXPECTED
1876 20: '' EXPECTED
1877 139: INDEX TYPE NOT COMPATIBLE
1878 142: ARRAY EXPECTED
1879 143: Element type allowed is scalarpointer or numeric
1880 159: UNPACKED ARRAY EXPECTED
1881 160: PACKED ARRAY EXPECTED
1882 161: CONFORMANT ARRAY NOT READY
1883 162: ORIGIN AND TARGET MUST HAVE SAME ELEMENT TYPE
1884 163: ELEMENT TYPE TOO LARGE
1885 302: INDEX OUT OF BOUNDS
1886 E *
1887 LABEL
1888 10 ; * EXIT PROCEDURE *
1889 VAR
1890 loa hia loz hiz oincr tincr lincr locexit locloop : integer ;
1891 itype generic : ctp ;
1892 oattr tattr iattr : attr ;
1893 erro errt erri oisconf tisconf ispack : boolean ;
1894 prtoadd oripr tarpr : preg ;
1895 lload lstor ladd : istand ;
1896 BEGIN * PCKUNPCK *
1897 $OPTIONS compile = trace $
1898 IF stattrace > none THEN
1899 BEGIN
1900 write mpcogout '@@@ DEBUT PCKUNPCK @@@ WITH CODE:' code : 4 ; nextline ;
1901 END ;
1902 $OPTIONS compile = true $
1903 ispack := code = 0 ;
1904 IF no # 9 * * THEN
1905 BEGIN
1906 error 9 ; skip 46 ; GOTO 10 ;
1907 END ;
1908 erro := true ; errt := true ; erri := true ;
1909 itype := NIL ; oattr.typtr := NIL ; tattr.typtr := NIL ; iattr.typtr := NIL ;
1910 * ANALYSIS OF ORIGIN *
1911 * A FOR PACK Z FOR UNPACK *
1912 insymbol ;
1913 freeallregisters ;
1914 variab false ;
1915 WITH gattr DO
1916 IF typtr # NIL THEN
1917 BEGIN
1918 IF typtr@.form # arrays THEN error 142 ELSE
1919 IF NOT typtr^.aeltype^.form IN numeric scalar pointer THEN
1920 error 143 ELSE
1921 IF typtr@.pack = ispack THEN
1922 BEGIN
1923 IF ispack THEN error 159 ELSE error 160 ;
1924 END ELSE
1925 BEGIN * ORIGIN OK *
1926 IF typtr@.conformant THEN
1927 BEGIN
1928 error 161 ; oisconf := true ; erro := true ;
1929 END ELSE
1930 BEGIN
1931 oisconf := false ; oincr := typtr@.subsize ;
1932 WITH typtr@ DO
1933 IF ispack THEN
1934 BEGIN
1935 loa := lo ; hia := hi ; itype := inxtype ;
1936 END * ISPACK * ELSE
1937 BEGIN * UNPACK *
1938 loz := lo ; hiz := hi ;
1939 END ;
1940 erro := false ;
1941 loadadr gattr nreg ;
1942 WITH oattr DO * POINTS ELEMENT OF ORIGIN *
1943 BEGIN
1944 initattrvarbl oattr ;
1945 typtr := gattr.typtr@.aeltype ;
1946 vlev := gattr.vlev ;
1947 basereg := currentpr ;
1948 basebloc := currentbloc ;
1949 access := pointee ;
1950 pckd := NOT ispack ;
1951 END * WITH OATTR * ;
1952 END * NOT CONFORMANT * ;
1953 END * OK FOR ORIGIN * ;
1954 END * TYPTR # NIL * ;
1955 IF no = 15 * * THEN
1956 insymbol ELSE
1957 BEGIN
1958 IF gattr.typtr # NIL THEN error 20 ;
1959 skip 15 ;
1960 IF no # 15 THEN
1961 BEGIN
1962 IF gattr.typtr = NIL THEN error 20 ;
1963 GOTO 10 ;
1964 END ELSE insymbol ;
1965 END ;
1966 IF ispack THEN
1967 expression ELSE variab true ;
1968 WITH gattr DO
1969 IF typtr # NIL THEN
1970 IF ispack THEN
1971 BEGIN
1972 compatbin itype typtr generic ;
1973 IF generic = NIL OR generic = realptr THEN
1974 error 139 ELSE
1975 BEGIN
1976 IF oisconf THEN
1977 BEGIN
1978 * TO BE SUPPLIED *
1979 END ELSE
1980 BEGIN
1981 arrayboundsctp@.nmin := loa ; arrayboundsctp@.nmax := hia ;
1982 IF kind = sval THEN
1983 BEGIN
1984 checkminmax val arrayboundsctp 302 ; val := val - loa ;
1985 END * SVAL * ELSE
1986 BEGIN
1987 IF kind # lval THEN transfer gattr inacc ;
1988 IF inxcheck THEN
1989 checkbnds pckerrcode ldreg arrayboundsctp ;
1990 IF loa # 0 THEN
1991 gencstecode loa opaq sub ldreg ;
1992 END ; * NOT SVAL *
1993 iattr := gattr ;
1994 END ; * NOT CONFORMANT *
1995 erri := false ;
1996 END ; * SUITABLE GENERIC *
1997 END * ISPACK * ELSE
1998 BEGIN * UNPACK *
1999 IF typtr@.form # arrays THEN error 142 ELSE
2000 IF typtr@.pack THEN error 159 ELSE
2001 IF typtr@.aeltype # oattr.typtr THEN error 162 ELSE
2002 BEGIN
2003 IF typtr@.conformant THEN
2004 BEGIN
2005 error 161 ; tisconf := true ; errt := true ;
2006 END ELSE
2007 BEGIN
2008 tisconf := false ; errt := false ;
2009 loa := typtr@.lo ; hia := typtr@.hi ; itype := typtr@.inxtype ;
2010 tincr := typtr@.subsize ;
2011 loadadr gattr nreg ;
2012 WITH tattr DO
2013 BEGIN
2014 initattrvarbl tattr ;
2015 typtr := gattr.typtr@.aeltype ;
2016 vlev := gattr.vlev ;
2017 basereg := currentpr ;
2018 basebloc := currentbloc ;
2019 access := pointee ;
2020 END ;
2021 END * NOT CONFORM * ;
2022 END * NO ERROR * ;
2023 END * UNPACK * ;
2024 IF no = 15 THEN * *
2025 insymbol ELSE
2026 BEGIN
2027 IF gattr.typtr # NIL THEN error 20 ;
2028 skip 15 ;
2029 IF no # 15 THEN
2030 BEGIN
2031 IF gattr.typtr = NIL THEN error 20 ;
2032 GOTO 10 ;
2033 END ;
2034 END ;
2035 IF ispack THEN
2036 variab true ELSE expression ;
2037 WITH gattr DO
2038 IF typtr # NIL THEN
2039 BEGIN
2040 IF ispack THEN
2041 BEGIN
2042 IF typtr@.form # arrays THEN error 142 ELSE
2043 IF NOT typtr@.pack THEN error 160 ELSE
2044 IF typtr@.aeltype # oattr.typtr THEN error 162 ELSE
2045 BEGIN
2046 IF typtr@.conformant THEN
2047 BEGIN
2048 error 161 ; tisconf := true ; errt := true ;
2049 END ELSE
2050 BEGIN
2051 errt := false ; tisconf := false ;
2052 loz := typtr@.lo ; hiz := typtr@.hi ; tincr := typtr@.subsize ;
2053 loadadr gattr nreg ;
2054 WITH tattr DO
2055 BEGIN
2056 initattrvarbl tattr ;
2057 typtr := gattr.typtr@.aeltype ;
2058 vlev := gattr.vlev ;
2059 basereg := currentpr ;
2060 basebloc := currentbloc ;
2061 access := pointee ;
2062 pckd := true ;
2063 END ;
2064 END * NOT CONF. * ;
2065 END * NO ERR * ;
2066 END * PACK * ELSE
2067 BEGIN * UNPACK *
2068 compatbin itype typtr generic ;
2069 IF generic = NIL OR generic = realptr THEN
2070 error 139 ELSE
2071 BEGIN
2072 IF tisconf THEN
2073 BEGIN
2074 * TO BE SUPPLIED *
2075 END ELSE
2076 BEGIN
2077 arrayboundsctp@.nmin := loa ;
2078 arrayboundsctp@.nmax := hia ;
2079 IF kind = sval THEN
2080 BEGIN
2081 checkminmax val + hiz - loz arrayboundsctp 302 ;
2082 checkminmax val arrayboundsctp 302 ;
2083 val := val - loa ;
2084 END * SVAL * ELSE
2085 BEGIN
2086 IF kind # lval THEN transfer gattr inacc ;
2087 IF inxcheck THEN
2088 checkbnds pckerrcode ldreg arrayboundsctp ;
2089 IF loa # 0 THEN
2090 gencstecode loa opaq sub ldreg ;
2091 END * NOT SVAL * ;
2092 iattr := gattr ;
2093 END * NOT CONF * ;
2094 erri := false ;
2095 END * NO ERR * ;
2096 END * UNPACK * ;
2097 END * TYPTR #NIL * ;
2098 IF NOT erro THEN
2099 IF NOT errt THEN
2100 IF NOT erri THEN
2101 BEGIN
2102 regenere oattr.basebloc ; regenere tattr.basebloc ;
2103 IF iattr.kind # sval THEN
2104 regenere iattr.ldregbloc ELSE
2105 transfer iattr inacc ;
2106 IF inxcheck THEN
2107 BEGIN
2108 IF iattr.ldreg = rq THEN
2109 BEGIN lstor := istq ; ladd := iadq ; lload := ildq ;
2110 END ELSE
2111 BEGIN lstor := ista ; ladd := iada ; lload := ilda ;
2112 END ;
2113 genstand pr6 evareaw lstor tn ;
2114 gencstecode hiz - loz ladd ;
2115 arrayboundsctp@.nmin := 0 ; arrayboundsctp@.nmax := hia - loa ;
2116 checkbnds pckerrcode iattr.ldreg arrayboundsctp ;
2117 genstand pr6 evareaw lload tn ;
2118 END ;
2119 IF ispack THEN
2120 BEGIN
2121 prtoadd := oattr.basereg ; lincr := oincr ;
2122 END ELSE
2123 BEGIN
2124 prtoadd := tattr.basereg ; lincr := tincr ;
2125 END ;
2126 oripr := oattr.basereg ; tarpr := tattr.basereg ;
2127 IF lincr # 1 THEN
2128 BEGIN
2129 IF lincr > 4 THEN
2130 error 163 ELSE
2131 genstand nreg lincr DIV 2 opaq shiftl iattr.ldreg tn ;
2132 END ;
2133 genstand prtoadd 0 ia9bd modif iattr.ldreg ; * POINTS NOW AI *
2134 * INIT NOW LOOP U..V *
2135 freeattr iattr ;
2136 genstand nreg oincr ieax6 tn ;
2137 genstand nreg tincr ieax7 tn ;
2138 gencstecode loz ilda ;
2139 locloop := cb ; transfer oattr inq ;
2140 gattr := oattr ;
2141 transfer tattr out ;
2142 * NOW CHECK LAST MOVE *
2143 genstand nreg 1 iada tdl ;
2144 gencstecode hiz icmpa ;
2145 locexit := indfich ; genstand nreg 0 itpnz tic ;
2146 * HERE LOOP NOT ENDED. *
2147 * POINTS NEXT ELEMENTS *
2148 genstand oripr 0 ia9bd tx6 ;
2149 genstand tarpr 0 ia9bd tx7 ;
2150 genstand nreg locloop - cb DIV bytesinword itra tic ;
2151 inser cb locexit ;
2152 END * NOT ERRI ERRO ERRT * ;
2153 IF no = 10 THEN
2154 insymbol ELSE
2155 BEGIN error 4 ; skip 46 ;
2156 END ;
2157 10 : * EXIT PROCEDURE *
2158 $OPTIONS compile = trace $
2159 IF stattrace > low THEN
2160 BEGIN
2161 write mpcogout '@@@ FIN PCKUNPCK @@@ WITH NOCL:' no : 4 cl : 4 ;
2162 nextline ;
2163 END ;
2164 $OPTIONS compile = true $
2165 END * PCKUNPCK * ;
2166
2167 $OPTIONS page $
2168
2169 * ***************************************** MVCIR ******** *
2170
2171 PROCEDURE mvcir codop : integer ;
2172
2173 * C ISCLEAN 1 for SUBARRAY
2174 0 for MVC
2175 C *
2176
2177 LABEL
2178 10 ; * Exit procedure *
2179
2180 VAR
2181 erro errt errl : boolean ;
2182 typelem : ctp ;
2183 easyo easyt easyl : boolean ;
2184 baseo baset : preg ;
2185 dplmtow dplmttw dplmtob dplmttb : integer ;
2186 basebloco basebloct : regpt ;
2187 longop : integer ;
2188 longreg : register ;
2189 isclean : boolean ;
2190
2191 BEGIN * MVCIR *
2192
2193 $OPTIONS cc = trace + $
2194 IF stattrace > none THEN
2195 BEGIN
2196 write mpcogout '@@@ debut MVCIR @@@ with CODOP' codop : 4 ;
2197 nextline ;
2198 END ;
2199 $OPTIONS cc = trace - $
2200 erro := true ; errt := true ; errl := true ;
2201 basebloco := NIL ; basebloct := NIL ;
2202 isclean := false ;
2203
2204 * ORIGIN ANALYSIS *
2205 freeallregisters ;
2206 insymbol ;
2207 variab false ;
2208 WITH gattr DO
2209 IF typtr <> NIL THEN
2210 BEGIN
2211 IF isclean THEN
2212 BEGIN
2213 END ELSE
2214 BEGIN
2215 erro := false ;
2216 END * NOT CLEAN * ;
2217 IF varissimple gattr THEN
2218 BEGIN
2219 easyo := true ; baseo := basereg ; dplmtow := dplmt DIV bytesinword ;
2220 dplmtob := dplmt MOD bytesinword ;
2221 END * varissimple * ELSE
2222 BEGIN * not easy *
2223 easyo := false ; dplmtow := 0 ; dplmtob := 0 ;
2224 loadadr gattr nreg ;
2225 baseo := currentpr ; basebloco := currentbloc ;
2226 END * not easy * ;
2227 END * TYPTR not nil for origin * ;
2228 IF no <> 15 THEN
2229 BEGIN
2230 error 20 ; skip 46 ; GOTO 10 ;
2231 END ;
2232
2233 * TARGET *
2234 insymbol ;
2235 variab true ;
2236 WITH gattr DO
2237 IF typtr <> NIL THEN
2238 BEGIN
2239 IF isclean THEN
2240 BEGIN
2241 END ELSE
2242 BEGIN
2243 errt := false ;
2244 END * NOT CLEAN * ;
2245 IF varissimple gattr THEN
2246 BEGIN
2247 easyt := true ; baset := basereg ; dplmttw := dplmt DIV bytesinword ;
2248 dplmttb := dplmt MOD bytesinword ;
2249 END ELSE
2250 BEGIN * not easy *
2251 easyt := false ; dplmttw := 0 ; dplmttb := 0 ;
2252 loadadr gattr nreg ;
2253 baset := currentpr ; basebloct := currentbloc ;
2254 END * not easy * ;
2255 END * TYPTR not nil for target * ;
2256 IF no <> 15 * * THEN
2257 BEGIN
2258 error 20 ; skip 46 ; GOTO 10 ;
2259 END ;
2260 * THIRD PARAMETER *
2261 insymbol ;
2262 expression ;
2263 WITH gattr DO
2264 IF typtr <> NIL THEN
2265 BEGIN
2266 IF typtr^.form <> numeric THEN error 15 ELSE
2267 BEGIN * NUMERIC *
2268 errl := false ;
2269 IF isclean THEN
2270 BEGIN
2271 END * ISCLEAN * ELSE
2272 BEGIN
2273 IF kind = sval THEN
2274 BEGIN
2275 easyl := true ; longop := val ;
2276 END * SVAL * ELSE
2277 BEGIN * NOT SVAL *
2278 easyl := false ;
2279 IF kind <> lval THEN
2280 transfer gattr inacc ;
2281 longreg := gattr.ldreg ;
2282 END * NOT SVAL * ;
2283 END * NOT CLEAN *
2284 END ; * NUMERIC *
2285 END * typtr not nil for third paramater * ;
2286 IF NOT erro OR errt OR errl THEN
2287 BEGIN
2288 IF NOT easyo THEN regenere basebloco ;
2289 IF NOT easyt THEN regenere basebloct ;
2290 IF easyl THEN
2291 BEGIN
2292 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
2293 geneism imlr ord ' ' p0t0r0 ;
2294 gendesca baseo dplmtow dplmtob l9 longop tn ;
2295 gendesca baset dplmttw dplmttb l9 longop tn ;
2296 END * EASYL * ELSE
2297 BEGIN * register loaded with length *
2298 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
2299 geneism imlr ord ' ' p0t0r0 ;
2300 gendesca baseo dplmtow dplmtob l9 0 modif longreg ;
2301 gendesca baset dplmttw dplmttb l9 0 modif longreg ;
2302 END * not easy * ;
2303 freebloc basebloco ; freebloc basebloct ;
2304 IF NOT easyl THEN freebloc gattr.ldregbloc ;
2305 END ;
2306 IF no <> 10 THEN
2307 BEGIN
2308 error 4 ; skip 46 ;
2309 END ELSE
2310 insymbol ;
2311 10 : * EXIT IF ERRORS *
2312 $OPTIONS cc = trace + $
2313 IF stattrace > low THEN
2314 BEGIN
2315 write mpcogout '@@@ fin mvcir @@@ with NOCL ' no : 4 cl : 4 ;
2316 nextline ;
2317 END ;
2318 $OPTIONS cc = trace - $
2319
2320 END * MVCIR * ;
2321
2322 $OPTIONS page$
2323
2324 * ************************************ INSERT_STRING ********************************** *
2325
2326 PROCEDURE insert_string ;
2327
2328 LABEL
2329 1 ;
2330 VAR
2331 string_attr disp_attr insert_attr : attr ;
2332 dummy l_err : boolean ;
2333 BEGIN
2334 l_err := false ;
2335 IF no <> 9 THEN
2336 BEGIN error 9 ; skip 46 ; GOTO 1 END ;
2337
2338 initattrvarbl string_attr ; initattrvarbl disp_attr ; initattrvarbl insert_attr ;
2339 insymbol ;
2340 expression ;
2341 IF NOT is_possible_string gattr THEN
2342 BEGIN l_err := true ; error 274 END ;
2343 insert_attr := gattr ;
2344 IF no <> 15 THEN
2345 BEGIN
2346 error 20 ; l_err := true
2347 END
2348 ELSE insymbol ;
2349 variab true ;
2350 string_attr := gattr ;
2351 IF string_attr.typtr = NIL THEN l_err := true
2352 ELSE IF string_attr.typtr^.father_schema <> string_ptr THEN
2353 BEGIN error 275 ; l_err := true END ;
2354 IF no <> 15 THEN
2355 BEGIN
2356 error 20 ; l_err := true
2357 END
2358 ELSE insymbol ;
2359 expression ;
2360 IF gattr.typtr = NIL THEN l_err := true
2361 ELSE
2362 IF gattr.typtr^.form <> numeric THEN
2363 BEGIN
2364 error 15 ; l_err := true
2365 END ;
2366 disp_attr := gattr ;
2367 IF no <> 10 THEN
2368 BEGIN
2369 error 4 ; skip 15
2370 END
2371 ELSE insymbol ;
2372 IF NOT l_err THEN
2373 gen_insert insert_attr string_attr disp_attr
2374 ELSE BEGIN
2375 freeattr string_attr ; freeattr disp_attr ; freeattr insert_attr
2376 END ;
2377 1 :
2378 END * INSERT_STRING * ;
2379
2380
2381 $OPTIONS page$
2382
2383 * **************************************************** DELETE_STRING ************************ *
2384
2385 PROCEDURE delete_string ;
2386
2387 LABEL
2388 1 ;
2389 VAR
2390 string_attr disp_attr len_attr : attr ;
2391 dummy l_err : boolean ;
2392 BEGIN
2393 l_err := false ;
2394 IF no <> 9 THEN
2395 BEGIN error 9 ; skip 46 ; GOTO 1 END ;
2396
2397 initattrvarbl string_attr ; initattrvarbl disp_attr ; initattrvarbl len_attr ;
2398 insymbol ;
2399 variab true ;
2400 string_attr := gattr ;
2401 IF string_attr.typtr = NIL THEN l_err := true
2402 ELSE IF string_attr.typtr^.father_schema <> string_ptr THEN
2403 BEGIN error 275 ; l_err := true END ;
2404 check_dynamic_string_length string_attr ;
2405 IF no <> 15 THEN
2406 BEGIN
2407 error 20 ; l_err := true
2408 END
2409 ELSE insymbol ;
2410 expression ;
2411 IF gattr.typtr = NIL THEN l_err := true
2412 ELSE
2413 IF gattr.typtr^.form <> numeric THEN
2414 BEGIN
2415 error 15 ; l_err := true
2416 END ;
2417 disp_attr := gattr ;
2418 IF no <> 15 THEN
2419 BEGIN
2420 error 20 ; l_err := true
2421 END
2422 ELSE insymbol ;
2423 expression ;
2424 IF gattr.typtr = NIL THEN l_err := true
2425 ELSE
2426 IF gattr.typtr^.form <> numeric THEN
2427 BEGIN
2428 error 15 ; l_err := true
2429 END ;
2430 len_attr := gattr ;
2431 IF no <> 10 THEN
2432 BEGIN
2433 error 4 ; skip 15
2434 END
2435 ELSE insymbol ;
2436 IF NOT l_err THEN
2437 gen_delete string_attr disp_attr len_attr
2438 ELSE BEGIN
2439 freeattr string_attr ; freeattr disp_attr ; freeattr len_attr
2440 END ;
2441 1 :
2442 END * DELETE_STRING * ;
2443 BEGIN
2444 END. * Fin des procedures predefinies *