1 * *************************************************************************
2 * *
3 * Copyright c 1980 by Centre Interuniversitaire de Calcul de Grenoble *
4 * and Institut National de Recherche en Informatique et Automatique *
5 * *
6 ************************************************************************* *
7
8
9
10
11 * HISTORY COMMENTS:
12 1 change86-09-11JMAthane, approve86-09-11MCR7521,
13 audit86-09-15JPFauche, install86-11-12MR12.0-1212:
14 Release 8.03 for MR12
15 END HISTORY COMMENTS *)
16
17
18 PROGRAM modvariable ;
19
20 $OPTIONS switch trace := true ; switch security := true ; t + $
21
22
23 $IMPORT
24 'STATE pascal ' :
25 addressvar,
26 checkbnds,
27 choicerarq,
28 enterlcst,
29 enterllcst,
30 enterundlab,
31 freebloc,
32 gencstecode,
33 genexceptcode,
34 getpr,
35 inbounds,
36 loadadr,
37 loadbase,
38 newbloc,
39 oldnewstor,
40 raisused,
41 regenere,
42 sauvereg,
43 stack_extension,
44 transfer,
45 variab,
46 variabctptr ;
47 'CONTEXTTABLE pascal ' :
48 areconformeq,
49 checkminmax,
50 compatbin,
51 conformantdim,
52 findminmax,
53 legalconfarrsubstitution,
54 packedsize ;
55 'RACINE pascal ' :
56 error,
57 insymbol,
58 nameisref,
59 nextline,
60 recadre,
61 skip,
62 sup ;
63 'optimized_procedures alm' :
64 search,
65 srchrec ;
66 'MODATTRpascal' :
67 convreal,
68 freeattr,
69 initattrvarbl,
70 is_pl1_varying_char,
71 isstring,
72 printattr,
73 varissimple ;
74 'EXPR pascal ' :
75 expression ;
76 'GENOPER pascal' :
77 check_dynamic_string_length ;
78 'GENERE pascal ' :
79 gendesca,
80 inser,
81 genstand,
82 geneism ;
83 'RACINE pascal ' :
84 alfaptr,
85 charptr,
86 ctptr,
87 envstandard,
88 interactive,
89 intptr,
90 level,
91 mpcogout,
92 no,
93 realptr,
94 string_ptr,
95 symbolfile,
96 symbolline,
97 symbolmap,
98 textfilectp ;
99 'GENERE pascal ' :
100 cb,
101 indfich,
102 mfari1,
103 mfari2,
104 usednameaddr ;
105 'STATE pascal ' :
106 arrayboundsctp,
107 asscheck,
108 currentbloc,
109 currentpr,
110 currwithlist,
111 gattr,
112 inxcheck,
113 modif,
114 opaq,
115 prinst,
116 regcharge,
117 stattrace,
118 withvariable ;
119 $
120
121
122 $EXPORT
123 init_desc_address,
124 passparams,
125 variable
126
127 $
128 $INCLUDE 'CONSTTYPE' $
129
130
131 VAR
132
133 * REDEFINE IMPORTED VARIABLES FROM RACINE *
134
135 alfaptr : ctp ;
136 charptr : ctp ;
137 ctptr : ctp ;
138 envstandard : stdkind ;
139 interactive : boolean ;
140 intptr : ctp ;
141 level : levrange ;
142 mpcogout : text ;
143 no : integer ;
144 realptr : ctp ;
145 string_ptr : ctp ;
146 symbolfile : integer ;
147 symbolline : integer ;
148 symbolmap : boolean ;
149 textfilectp : ctp ;
150
151 * REDEFINE IMPORTED VARIABLES FROM GENERE *
152
153 cb : integer ;
154 indfich : integer ;
155 mfari1 : zari ;
156 mfari2 : zari ;
157 usednameaddr : ctp ;
158
159 * REDEFINE IMPORTED VARIABLES FROM STATE *
160
161 arrayboundsctp : ctp ;
162 asscheck : boolean ;
163 currentbloc : regpt ;
164 currentpr : preg ;
165 currwithlist : withreflist ;
166 gattr : attr ;
167 inxcheck : boolean ;
168 modif : ARRAY nxreg..rq OF tag ; * GIVES FOR A REGISTER R ITS TAG TR *
169 opaq : ARRAY typeofop ra..reaq OF istand ;
170 prinst : ARRAY typepr pr1..pr6 OF istand ;
171 regcharge : statearray ;
172 stattrace : levtrace ;
173 variabctptr : ctp ;
174 withvariable : boolean ;
175
176 * REDEFINE IMPORTED PROCEDURES FROM STATE *
177
178 PROCEDURE addressvar fctp : ctp ; VAR fattr : attr ; modif : boolean ; EXTERNAL ;
179 PROCEDURE checkbnds errcode : integer ; freg : register ; fctp : ctp ; EXTERNAL ;
180 PROCEDURE choicerarq ; EXTERNAL ;
181 PROCEDURE enterlcst VAR fval : setarray ; VAR fboxpt : lcstpt ; EXTERNAL ;
182 PROCEDURE enterllcst VAR fval : setarray ; VAR fboxpt : llcstpt ; EXTERNAL ;
183 PROCEDURE enterundlab VAR fundinx : integer ; EXTERNAL ;
184 PROCEDURE freebloc VAR fbtofree : regpt ; EXTERNAL ;
185 PROCEDURE gencstecode farg : integer ; finst : istand ; EXTERNAL ;
186 PROCEDURE genexceptcode ferrcode : integer ; freg : register ; EXTERNAL ;
187 PROCEDURE getpr ; EXTERNAL ;
188 FUNCTION inbounds fval fmin fmax : integer : boolean ; EXTERNAL ;
189 PROCEDURE loadadr VAR fattr : attr ; wantedpr : preg ; EXTERNAL ;
190 PROCEDURE loadbase flev : integer ; EXTERNAL ;
191 PROCEDURE newbloc freg : register ; EXTERNAL ;
192 FUNCTION oldnewstor incrinbytes : integer : integer ; EXTERNAL ;
193 FUNCTION raisused : boolean ; EXTERNAL ;
194 PROCEDURE regenere oldbloc : regpt ; EXTERNAL ;
195 PROCEDURE sauvereg freg : register ; fload : boolean ; EXTERNAL ;
196 PROCEDURE stack_extension ; EXTERNAL ;
197 PROCEDURE transfer VAR fattr : attr ; inwhat : destination ; EXTERNAL ;
198 PROCEDURE variab fvarset : boolean ; EXTERNAL ;
199
200 * REDEFINE IMPORTED PROCEDURES FROM CONTEXTTABLE *
201
202 FUNCTION areconformeq f1 f2 : ctp : boolean ; EXTERNAL ;
203 PROCEDURE checkminmax fvalu : integer ; fctp : ctp ; ferrnum : integer ; EXTERNAL ;
204 PROCEDURE compatbin typleft typright : ctp ; VAR fgeneric : ctp ; EXTERNAL ;
205 FUNCTION conformantdim ffound : ctp : boolean ; EXTERNAL ;
206 PROCEDURE findminmax fctp : ctp ; VAR fmin fmax : integer ; EXTERNAL ;
207 FUNCTION legalconfarrsubstitution ffound fdecl : ctp : boolean ; EXTERNAL ;
208 FUNCTION packedsize fctp : ctp : integer ; EXTERNAL ;
209
210 * REDEFINE IMPORTED PROCEDURES FROM RACINE *
211
212 PROCEDURE error errno : integer ; EXTERNAL ;
213 PROCEDURE insymbol ; EXTERNAL ;
214 PROCEDURE nameisref p : ctp ; f l : integer ; EXTERNAL ;
215 PROCEDURE nextline ; EXTERNAL ;
216 FUNCTION recadre fnum fmod : integer : integer ; EXTERNAL ;
217 PROCEDURE search ; EXTERNAL ;
218 PROCEDURE skip nosym : integer ; EXTERNAL ;
219 PROCEDURE srchrec fdebsrch : ctp ; EXTERNAL ;
220 FUNCTION sup fval1 fval2 : integer : integer ; EXTERNAL ;
221
222 * REDFINE IMPORTED PROCEDURES FROM MODATTR *
223
224 FUNCTION is_pl1_varying_char VAR typeptr : ctp : boolean ; EXTERNAL ;
225 PROCEDURE convreal VAR fattr : attr ; EXTERNAL ;
226 PROCEDURE initattrvarbl VAR fattr : attr ; EXTERNAL ;
227 PROCEDURE freeattr VAR fattr : attr ; EXTERNAL ;
228 FUNCTION isstring VAR fattr : attr : boolean ; EXTERNAL ;
229 PROCEDURE printattr VAR fattr : attr ; EXTERNAL ;
230 FUNCTION varissimple VAR fattr : attr : boolean ; EXTERNAL ;
231
232 * REDEFINE IMPORTED PROCEDURES FROM EXPRESSION *
233
234 PROCEDURE expression ; EXTERNAL ;
235
236 * REDEFINE IMPORTED PROEDURES FORM GENOPER *
237
238 PROCEDURE check_dynamic_string_length VAR fattr : attr ; EXTERNAL ;
239
240 * REDEFINE IMPORTED PROCEDURES FROM GENERE *
241
242 PROCEDURE gendesca fareg : preg ; fadr fcn : integer ; fta : lgcar ;
243 fn : integer ; frlgth : mreg ; EXTERNAL ;
244 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
245 PROCEDURE inser fcb : integer ; fplace : integer ; EXTERNAL ;
246 PROCEDURE geneism fcode : ieism ; ffield : integer ; fbits : zptr ; EXTERNAL ;
247
248
249 $OPTIONS page $
250
251 * ************************** INIT_DESC_ADDRESS ********* *
252
253 PROCEDURE init_desc_address fctptr : ctp ; VAR fattr : attr ;
254
255 * C A conformant array or schema variable described by FATTR is input.
256 As output a pointer register on dopevector and his box
257 FATTR points real variable
258 C *
259
260 VAR
261 ldisp : integer ;
262 locpt : ctp ;
263 lreg : preg ;
264 lbloc : regpt ;
265
266
267 BEGIN * INIT_DESC_ADDRESS *
268
269 IF fattr.descreg = nreg THEN
270 BEGIN
271 $OPTIONS compile = trace $
272 IF stattrace = high THEN
273 BEGIN
274 write mpcogout '^^^ Debut de INIT_DESC_ADDRESS ^^^ ' ; nextline ;
275 END ;
276 $OPTIONS compile = true $
277
278 locpt := fattr.nameaddr ;
279 ldisp := 1 ;
280 IF locpt <> NIL THEN
281 IF locpt^.vtype <> NIL THEN
282 IF locpt^.vtype^.father_schema <> NIL THEN ldisp := 0 ;
283 * Return DOPEVECTOR BASE *
284 getpr ;
285 genstand fattr.basereg fctptr^.vdescaddr DIV bytesinword prinst epp currentpr tny ;
286 genstand currentpr ldisp * Header * prinst epp currentpr tn ;
287 lreg := currentpr ;
288 lbloc := currentbloc ;
289
290 loadadr fattr nreg ; * Returns CURRENTPR and CURRENTBLOC *
291
292 initattrvarbl fattr ;
293 WITH fattr DO
294 BEGIN
295 access := pointee ; basereg := currentpr ; basebloc := currentbloc ;
296 nameaddr := locpt ;
297 descreg := lreg ; descbloc := lbloc ;
298 END ;
299
300 END ;
301
302 $OPTIONS compile = trace $
303 IF stattrace = high THEN
304 BEGIN
305 write mpcogout '^^^ Fin de INIT_DESC_ADDRESS ^^^' ; nextline ;
306 END ;
307 $OPTIONS compile = true $
308
309 END * INIT_DESC_ADDRESS * ;
310
311 $OPTIONS page $
312
313 * *************************** VARIABLE ****************************** *
314
315 PROCEDURE variable fvarset : boolean ;
316
317 * C
318 BUILD A GATTR FOR ELEMENT ARRAY NO=11
319 POINTED ITEM =18 ^
320 RECORD FIELD =17 .
321 FILE ELEMENT =18 ^
322
323 FIRST CALL ADDRESSVAR
324 C *)
325
326 * E ERRORS DETECTED
327 2: IDENTIFIER EXPECTED
328 12: "]" EXPECTED
329 139: INDEX TYPE NOT COMPATIBLE with DECLARATION
330 140: RECORDS EXPECTED
331 141: FILES or POINTER EXPECTED
332 142: ARRAYS EXPECTED
333 152: NO SUCH FIELD in THIS RECORD
334 302: INDEX OUT OF BOUNDS
335 E *
336
337 VAR
338 loc1 loc2 : integer ;
339 string_base : preg ; string_disp : integer ;
340 loaded_reg : register ;
341 lattr : attr ;
342 lerr smallelem isconform totransfer stoprepeat : boolean ;
343 locvariabctptr : ctp ;
344 nextdimisconform done_with_index : boolean ;
345 arraytype generic : ctp ;
346 destused : destination ;
347 regused : register ;
348 $OPTIONS compile = trace $
349 newattr : boolean ;
350 $OPTIONS compile = true $
351 subarraysize pointzero twopower lmin lmax : integer ;
352 lbase : preg ;
353 lcomp : istand ;
354 oldline oldfile : integer ;
355 lp oldptr : ctp ;
356 checkismade : boolean ;
357 locdopevectordisp : integer ;
358 previouswasarrow savewithflag : boolean ;
359 it : integer ;
360 refs : RECORD
361 nbr : integer ;
362 ref : ARRAY 1..maxfield OF
363 RECORD
364 symbp : ctp ;
365 rfile rline : integer
366 END
367 END ;
368
369
370 * *************************************************** ENTERREF **************************** *
371
372 PROCEDURE enterref ;
373
374 BEGIN
375 IF oldptr <> NIL THEN
376 IF refs.nbr < maxfield THEN
377 BEGIN
378 refs.nbr := refs.nbr + 1 ;
379 WITH refs.ref refs.nbr DO
380 BEGIN
381 symbp := oldptr ;
382 rfile := symbolfile ;
383 rline := symbolline ;
384 END ;
385 oldptr := NIL ;
386 END
387 END ;
388
389 BEGIN * VARIABLE *
390 $OPTIONS compile = trace $
391 IF stattrace > none THEN
392 BEGIN
393 write mpcogout '^^^ DEBUT VARIABLE ^^^' ;
394 nextline ;
395 END ;
396 newattr := false ;
397 $OPTIONS compile = true $
398
399 locvariabctptr := ctptr ;
400 addressvar ctptr lattr fvarset ;
401 locdopevectordisp := 0 ;
402
403
404
405 oldfile := symbolfile ; oldline := symbolline ; oldptr := ctptr ;
406 insymbol ;
407 previouswasarrow := false ;
408 refs.nbr := 0 ;
409 WHILE no IN 11 17 18 DO * . ^ *)
410 BEGIN
411 $OPTIONS compile = trace $
412 newattr := true ;
413 $OPTIONS compile = true $
414 IF no = 11 THEN * ARRAY'S ELEMENT *
415 BEGIN
416 savewithflag := withvariable ;
417 withvariable := false ;
418 done_with_index := false ;
419 IF lattr.typtr <> NIL THEN
420 WITH lattr.typtr^ DO
421 IF father_schema = string_ptr AND no = 11 THEN
422 BEGIN * STRING INDEX. SPECIAL SEQUENCE *
423 done_with_index := true ;
424 IF asscheck THEN
425 check_dynamic_string_length lattr ;
426 IF varissimple lattr THEN
427 BEGIN
428 string_base := lattr.basereg ; string_disp := lattr.dplmt DIV bytesinword ;
429 END ELSE BEGIN
430 loadadr lattr nreg ;
431 string_base := currentpr ; string_disp := 0 ;
432 WITH lattr DO
433 BEGIN
434 access := pointee ; basereg := currentpr ; basebloc := currentbloc ;
435 dplmt := 0 ;
436 END
437 END ;
438 lerr := false ;
439 insymbol ; expression ;
440 compatbin intptr gattr.typtr generic ;
441 IF generic = NIL OR generic = realptr THEN
442 BEGIN
443 lerr := true ; error 280 ;
444 END ;
445 IF no <> 12 THEN
446 BEGIN lerr := true ; error 12 END
447 ELSE insymbol ;
448 IF NOT lerr THEN
449 BEGIN
450 WITH gattr DO
451 CASE kind OF
452 varbl : BEGIN
453 IF raisused THEN
454 BEGIN
455 loaded_reg := rq ; sauvereg rq false ;
456 transfer gattr inq ;
457 END
458 ELSE BEGIN
459 loaded_reg := ra ;
460 transfer gattr inacc ;
461 END ;
462 END ;
463 sval : BEGIN
464 IF raisused THEN
465 BEGIN
466 loaded_reg := rq ; sauvereg rq false ;
467 END ELSE
468 loaded_reg := ra ;
469 gencstecode val opaq load loaded_reg ;
470 END ;
471 lval : BEGIN
472 loaded_reg := ldreg ;
473 IF asscheck THEN
474 genstand nreg 0 opaq add loaded_reg tdl ; * TO SET INDIC *
475 END ;
476 END ;
477 freeattr gattr ;
478 IF asscheck THEN
479 BEGIN
480 loc2 := indfich ; genstand nreg 0 itmoz tic ;
481 genstand string_base string_disp opaq cmp loaded_reg tn ;
482 loc1 := indfich ; genstand nreg 0 itmoz tic ;
483 inser cb loc2 ;
484 genexceptcode bad_string_index loaded_reg ;
485 inser cb loc1 ;
486 END ;
487 WITH lattr DO
488 BEGIN
489 IF basereg IN prstatic prlink pr6 THEN
490 BEGIN
491 getpr ; genstand basereg 0 prinst epp currentpr tn ;
492 basereg := currentpr ; basebloc := currentbloc ;
493 END ;
494 genstand basereg 0 ia9bd modif loaded_reg ;
495 dplmt := dplmt + 3 ;
496 nameaddr := NIL ;
497 pckd := true ;
498 END ;
499 END ;
500 lattr.typtr := charptr ;
501 END ;
502
503 IF NOT done_with_index THEN
504 BEGIN
505 REPEAT * LOOP ON EACH DIMENSION *
506 WITH lattr DO * DESCRIBE PREVIOUS *
507 BEGIN
508 IF typtr <> NIL THEN
509 BEGIN * NO PREV. FATAL ERROR *
510 IF typtr^.form <> arrays THEN
511 BEGIN
512 typtr := NIL ;
513 error 142 ;
514 END * ERR * ELSE
515 WITH typtr^ DO
516 IF aeltype <> NIL THEN
517 BEGIN * ARRAYS *
518 IF conformantdim typtr THEN
519 BEGIN
520 IF symbolmap THEN
521 BEGIN
522 nameisref pthigh oldfile oldline ;
523 nameisref ptlow oldfile oldline ;
524 END ;
525 IF lattr.descreg = nreg THEN
526 BEGIN
527 lp := typtr ;
528 WHILE conformantdim lp^.aeltype DO
529 BEGIN
530 locdopevectordisp := locdopevectordisp + 3 ;
531 lp := lp^.aeltype
532 END ;
533 init_desc_address locvariabctptr lattr ;
534 END ;
535 END ;
536 smallelem := cadrage < bytesinword ;
537 pckd := smallelem OR aeltype^.form = pointer
538 AND pack ;
539 isconform := conformant ;
540 nextdimisconform := conformantdim aeltype ;
541 END * ARRAYS * ;
542 END * TYPTR <>nil * ;
543 arraytype := typtr ;
544 END * with LATTR * ;
545 * *
546 * ANALYSIS FOR CURRENT *
547 * INDEX EXPRESSION *
548 * * *
549
550 insymbol ; expression ;
551
552 IF gattr.typtr <> NIL THEN
553 IF arraytype <> NIL THEN
554 WITH gattr arraytype^ DO
555 BEGIN
556 compatbin arraytype^.inxtype typtr generic ;
557 IF generic = NIL OR generic = realptr THEN
558 error 139 ELSE
559 BEGIN * TYPES COMPAT *
560
561 $OPTIONS compile = trace $
562 IF stattrace = high THEN
563 BEGIN
564 write mpcogout '&&& Variable. Break point 3.' ; nextline ;
565 write mpcogout ' SMALLELEM =' smallelem : 8 ' PCKD = ' pckd : 8
566 ' ISCONFORM = ' isconform : 8 ; nextline ;
567 write mpcogout ' GATTR Follows:' ; nextline ;
568 printattr gattr ;
569 write mpcogout ' LATTR Follows:' ; nextline ;
570 printattr lattr ;
571 write mpcogout '&&& Variable. Break point 3 .Fin.' ; nextline ;
572 END ;
573 $OPTIONS compile = true $
574 IF isconform THEN
575 BEGIN
576 IF gattr.kind = sval THEN
577 checkminmax gattr.val arraytype^.inxtype 302 ;
578 transfer gattr inq ;
579 checkismade := false ; destused := inq ; regused := rq ;
580 END * ISCONFORM * ELSE
581 BEGIN * STANDARD ARRAY *
582 subarraysize := subsize ;
583 twopower := opt2 ;
584 pointzero := lattr.dplmt - lo * subarraysize ;
585 * FIND DESTINATION REGISTER *
586 IF twopower >= 2 * SIZE 4816... * THEN
587 CASE kind OF
588 lval :
589 regused := ldreg ;
590 sval lcond varbl :
591 IF raisused THEN
592 regused := rq ELSE
593 regused := ra ;
594 END * CASE KINDTWOPOWER>=2 * ELSE
595 regused := rq ; * MULTIPLICAND in RQ *
596 IF regused = ra THEN
597 destused := inacc ELSE
598 destused := inq ;
599 END * STANDARD ARRAYS * ;
600 IF kind = sval THEN
601 BEGIN
602 arrayboundsctp^.nmin := lo ;
603 arrayboundsctp^.nmax := hi ;
604 checkminmax val arrayboundsctp 302 ;
605 checkismade := true ;
606 IF lattr.pckd THEN
607 transfer gattr destused ;
608 END ELSE
609 checkismade := false ;
610 IF kind = sval THEN * ONLY STANDARD *
611 BEGIN
612 lattr.dplmt := pointzero + val * subarraysize ;
613 END * SVAL * ELSE
614 BEGIN * NOT SVAL *
615 IF inxcheck THEN
616 BEGIN
617 transfer gattr destused ;
618 IF isconform THEN
619 BEGIN
620 regenere lattr.descbloc ;
621 genstand lattr.descreg locdopevectordisp icmpq tn ;
622 lmin := indfich ; genstand nreg 0 itmi tic ;
623 genstand lattr.descreg locdopevectordisp + 1 icmpq tn ;
624 END ELSE
625 IF NOT checkismade THEN
626 BEGIN
627 lcomp := opaq cmp regused ;
628 gencstecode lo lcomp ;
629 lmin := indfich ;
630 genstand nreg 0 itmi tic ; * ERR if NEG ON *
631 gencstecode hi lcomp ;
632 END * NOT CONF * ;
633 * COMMON SECTION *
634 IF NOT checkismade THEN
635 BEGIN
636 lmax := indfich ;
637 genstand nreg 0 itmoz tic ; * OK if <= *
638 inser cb lmin ; genexceptcode inxerrcode ldreg ;
639 inser cb lmax ;
640 END ;
641 END * INXCHECK * ELSE
642 IF NOT isconform THEN
643 BEGIN * NOT INXCHECKS *
644 totransfer := true ;
645 IF kind = varbl THEN
646 IF vlev <> 0 THEN
647 IF subarraysize = bytesinword THEN
648 IF varissimple gattr THEN
649 IF lattr.inxmem = 0 THEN
650 BEGIN
651 totransfer := false ;
652 lattr.dplmt := pointzero ;
653 lattr.inxmem := dplmt ;
654 lattr.inxmemrw := false ; * READ-ONLY *
655 END ;
656 IF totransfer THEN
657 transfer gattr destused ;
658 END * NOT INXCHECK * ;
659 END * NOT SVAL * ;
660 * NOW INDEX IS in REGUSED *
661 * EXCEPT SVAL endED *
662 * VARBL INXMEMRW F endED *
663
664 $OPTIONS compile = trace $
665 IF stattrace = high THEN
666 BEGIN
667 write mpcogout '&&& Variable. Break point 2.' ; nextline ;
668 write mpcogout ' REGUSED =' ord regused : 4
669 ' DESTUSED =' ord destused : 4 ; nextline ;
670
671 write mpcogout ' GATTR Follows:' ; nextline ;
672 printattr gattr ;
673 write mpcogout ' LATTR Follows:' ; nextline ;
674 printattr lattr ;
675 write mpcogout '&&& Variable. Break point 2 .Fin.' ; nextline ;
676 END ;
677 $OPTIONS compile = true $
678 IF kind = lval THEN * COMPUTE DISP *
679 BEGIN
680 IF isconform THEN
681 BEGIN
682 * Zero point correction *
683 regenere lattr.descbloc ;
684 genstand lattr.descreg locdopevectordisp isbq tn ;
685 sauvereg ra false ;
686 genstand lattr.descreg locdopevectordisp + 2 impy tn ;
687 IF NOT nextdimisconform THEN
688 BEGIN
689 freebloc lattr.descbloc ;
690 lattr.descreg := nreg ;
691 END ;
692
693 regenere lattr.basebloc ;
694 IF pack THEN genstand lattr.basereg 0 iabd tql
695 ELSE genstand lattr.basereg 0 iawd tql ;
696 freebloc gattr.ldregbloc ;
697 regused := nreg ;
698
699 locdopevectordisp := locdopevectordisp - 3 ; * Next dim *
700
701 END ELSE
702 BEGIN * STANDARD *
703 * COMMON PART *
704 * ZERO POINT CORRECTION *
705 IF lo <> 0 THEN
706 BEGIN
707 IF NOT smallelem AND
708 inbounds pointzero -twoto16 twoto16 - 1 THEN
709 lattr.dplmt := pointzero ELSE
710 gencstecode lo opaq sub regused ;
711 END * LO<>0 * ;
712 IF NOT smallelem THEN
713 BEGIN * WORD DISP *
714 IF twopower > 2 * 8 16 32 .. * THEN
715 genstand nreg twopower - 2 opaq shiftl regused tn ELSE
716 * TWOPOWER =2 NO-OP ; *
717 * 01 IMPOSSIBLE HERE *
718 IF twopower < 0 THEN
719 BEGIN
720 transfer gattr inq ;
721 sauvereg ra false ;
722 genstand nreg subarraysize DIV bytesinword impy tdl ;
723 regused := rq ;
724 END * TWOPOWER < 0 * ;
725 END * WORD DISP * ELSE
726 BEGIN * PACKED *
727 * ADD BYTES DISP TO A PR *
728 loadadr lattr nreg ;
729 WITH lattr DO * CAUTION NESTED ATTR *
730 BEGIN
731 basereg := currentpr ; basebloc := currentbloc ;
732 dplmt := 0 ;
733 inxreg := nxreg ; inxbloc := NIL ;
734 inxmem := 0 ; inxmemrw := true ;
735 itsdplmt := 0 ; access := pointee ;
736 END * NESTED * ;
737 * RA RQ BECOMES "BYTES" DISP *
738 IF twopower > 0 THEN
739 genstand nreg twopower opaq shiftl regused tn ELSE
740 * NO-OP FOR BYTE *
741 IF twopower < 0 THEN
742 BEGIN
743 transfer gattr inq ;
744 sauvereg ra false ;
745 gencstecode subarraysize impy ;
746 regused := rq ;
747 END * < 0 * ;
748 IF size >= twoto15 THEN
749 BEGIN
750 IF regused = ra THEN
751 BEGIN
752 sauvereg rq false ;
753 regused := rq ; * SEE A9BD LATER *
754 genstand nreg 2 ilrl tn ;
755 END * RA * ELSE
756 BEGIN
757 sauvereg ra false ;
758 genstand nreg 34 ills tn ;
759 END ;
760 genstand nreg 34 iqrl tn ;
761 * NOW A=WORD DISP. *
762 * Q=BYTES DISP. *
763 genstand currentpr 0 iawd tal ;
764 END * LONG * ;
765 genstand currentpr 0 ia9bd modif regused ;
766 freebloc ldregbloc ;
767 regused := nreg ;
768 END * PACKED * ;
769 END * STANDARD ARRAY * ;
770
771 $OPTIONS compile = trace $
772 IF stattrace = high THEN
773 BEGIN
774 write mpcogout '&&& Variable. Break point 1.' ; nextline ;
775 write mpcogout ' REGUSED =' ord regused : 4
776 ' DESTUSED =' ord destused : 4 ; nextline ;
777
778 write mpcogout ' GATTR Follows:' ; nextline ;
779 printattr gattr ;
780 write mpcogout ' LATTR Follows:' ; nextline ;
781 printattr lattr ;
782 write mpcogout '&&& Variable. Break point 1 .Fin.' ; nextline ;
783 END ;
784 $OPTIONS compile = true $
785 IF regused <> nreg THEN
786 WITH lattr DO * CAUTION NESTED ATTR *
787 BEGIN
788 IF inxreg = nxreg THEN
789 BEGIN
790 inxreg := regused ; * BITS 18..35 *
791 inxbloc := gattr.ldregbloc ;
792 END * NXREG * ELSE
793 IF inxreg = regused THEN
794 BEGIN * NECESSARY SAVED *
795 IF inxmem = 0 THEN
796 BEGIN
797 inxmem := inxbloc^.saveplace ;
798 END * INXMEM=0 * ELSE
799 BEGIN * <>0 *
800 * ADD SAVED OLD INDEX AT NEW INDEX *
801 genstand pr6 inxbloc^.saveplace DIV bytesinword
802 opaq add regused tn ;
803 END * <>0 * ;
804 freebloc inxbloc ;
805 inxbloc := gattr.ldregbloc ;
806 END * NECESSARY SAVED * ELSE
807 * OLD INDEX IS OTHER *
808 * REGISTER A <==>Q *
809 IF inxmem = 0 THEN
810 BEGIN
811 IF inxbloc^.saveplace <> 0 THEN
812 BEGIN
813 inxreg := regused ;
814 inxmem := inxbloc^.saveplace ;
815 freebloc inxbloc ;
816 inxbloc := gattr.ldregbloc ;
817 END ELSE
818 BEGIN * OLD INDEX NOT SAVED *
819 inxmem := oldnewstor bytesinword ;
820 genstand pr6 inxmem DIV bytesinword ista tn ;
821 IF inxreg = rq THEN
822 freebloc gattr.ldregbloc ELSE
823 BEGIN
824 freebloc inxbloc ; inxreg := rq ;
825 inxbloc := gattr.ldregbloc ;
826 END ;
827 END * OLD INDEX NOT SAVED * ;
828 END * INXMEM=0 * ELSE
829 BEGIN * INXMEM <> 0 *
830 IF inxbloc^.saveplace <> 0 THEN
831 BEGIN * OLD SAVED *
832 genstand pr6 inxbloc^.saveplace DIV bytesinword
833 opaq add regused tn ;
834 freebloc inxbloc ;
835 inxbloc := gattr.ldregbloc ;
836 inxreg := regused ;
837 END * OLD SAVED * ELSE
838 BEGIN * OLD NOT SAVED *
839 IF inxmemrw THEN
840 genstand pr6 inxmem DIV bytesinword iasa tn ELSE
841 BEGIN * READ-ONLY STORAGE *
842 genstand pr6 inxmem DIV bytesinword iada tn ;
843 inxmem := oldnewstor bytesinword ;
844 inxmemrw := true ;
845 genstand pr6 inxmem DIV bytesinword ista tn ;
846 END ;
847 IF regused = rq THEN
848 BEGIN
849 freebloc inxbloc ; inxreg := rq ;
850 inxbloc := gattr.ldregbloc ;
851 END ELSE
852 freebloc gattr.ldregbloc ;
853 END * OLD NOT SAVED * ;
854 END * INXMEM<>0 * ;
855 END * with LATTR ==> with GATTR * ;
856 END * GATTR.KIND=LVAL * ;
857 END * TYPES COMPAT * ;
858
859 lattr.typtr := aeltype ; * GET NEXT DIM *
860
861 END * with GATTRARRAYTYPE^ NO TYPE ERROR * ;
862 IF no = 15 * * THEN
863 stoprepeat := false ELSE
864 IF no = 12 * ] * THEN
865 BEGIN
866 insymbol ; stoprepeat := no <> 11 ; * *)
867 END ELSE
868 BEGIN
869 insymbol ;
870 error 12 ; stoprepeat := true ;
871 END ;
872 UNTIL stoprepeat ;
873 END ;
874 withvariable := savewithflag ;
875 previouswasarrow := false ;
876 END * NO=11 ARRAY ELEMENT * ELSE
877 IF no = 17 * . RECORD FIELD * THEN
878 BEGIN
879 IF symbolmap THEN
880 BEGIN
881 enterref ;
882 IF previouswasarrow THEN
883 BEGIN
884 FOR it := 1 TO refs.nbr DO
885 WITH refs.ref it DO
886 nameisref symbp rfile rline ;
887 refs.nbr := 0 ;
888 END
889 END ;
890 insymbol ;
891 oldfile := symbolfile ; oldline := symbolline ; oldptr := NIL ;
892 IF no <> 1 THEN * NOT ID *
893 BEGIN
894 error 2 ; lattr.typtr := NIL ;
895 END ELSE
896 WITH lattr DO
897 BEGIN
898 IF typtr <> NIL THEN
899 IF typtr^.form <> records THEN
900 BEGIN
901 error 140 ; typtr := NIL ;
902 END ELSE
903 BEGIN
904 srchrec typtr^.fstfld ;
905 IF ctptr = NIL THEN
906 BEGIN
907 error 152 ; typtr := NIL ;
908 END ELSE
909 BEGIN
910 nameaddr := ctptr ;
911 oldptr := ctptr ;
912 WITH ctptr^ DO
913 BEGIN
914 dplmt := dplmt + fldaddr ;
915 pckd := false ;
916 IF typtr^.pack THEN
917 IF bytwidth < bytesinword OR fldtype^.form = power AND
918 bytwidth <= bytesindword THEN
919 pckd := true ELSE
920 IF fldtype^.form = pointer THEN
921 pckd := true ;
922 typtr := fldtype ;
923 IF pckd THEN
924 IF access = direct THEN
925 access := pointee ;
926 END * with CTPTR CTPTR<>nil * ;
927 END ;
928 END * NO TYPE ERROR * ;
929 insymbol ;
930 END * with LATTR NO=1 * ;
931 previouswasarrow := false ;
932 END * NO=17 * ELSE
933 BEGIN * NO=18 * * ^ FILE or POINTER *
934 WITH lattr DO
935 IF typtr <> NIL THEN
936 IF typtr^.form = pointer THEN
937 BEGIN
938 totransfer := false ;
939 IF access = pointable THEN
940 totransfer := true ELSE
941 IF access = direct THEN
942 BEGIN
943 IF inxmem <> 0 OR inxreg <> nxreg THEN
944 totransfer := true ;
945 END ELSE
946 IF access = pointee THEN
947 IF pckd OR inxmem <> 0 OR inxreg <> nxreg THEN
948 totransfer := true ;
949 IF totransfer THEN
950 transfer lattr inpr * BECOMES POINTEE * ELSE
951 BEGIN
952 itsdplmt := dplmt ; dplmt := 0 ; access := pointable ;
953 END ;
954 typtr := typtr^.eltype ;
955 END * POINTER * ELSE
956 IF typtr^.form = files THEN
957 BEGIN
958 IF interactive THEN
959 IF typtr = textfilectp THEN
960 BEGIN
961 IF basereg <> pr5 THEN
962 BEGIN
963 sauvereg pr5 true ;
964 freebloc basebloc ;
965 basebloc := currentbloc ;
966 END ;
967 genstand basereg itsdplmt DIV bytesinword iepp5 tny ;
968 basereg := pr5 ;
969 access := pointee ; itsdplmt := 0 ; dplmt := 0 ;
970 genstand pr0 checkbeforetextreferenceplace itsp3 tn ;
971 END ;
972 dplmt := fdescsize ;
973 pckd := false ;
974 IF typtr^.pack THEN
975 IF packedsize typtr^.feltype < bytesinword THEN
976 pckd := true ELSE
977 IF typtr^.feltype^.form = pointer THEN
978 pckd := true ;
979 typtr := typtr^.feltype ;
980 IF pckd THEN
981 IF access = direct THEN
982 access := pointee ;
983 END * FILES * ELSE
984 BEGIN
985 error 141 ; typtr := NIL ;
986 END ;
987 insymbol ;
988 previouswasarrow := true ;
989 END * NO=18 * ;
990 END * while NO in 111718 * ;
991 IF symbolmap THEN
992 BEGIN
993 enterref ;
994 IF previouswasarrow THEN
995 BEGIN
996 FOR it := 1 TO refs.nbr DO
997 WITH refs.ref it DO
998 nameisref symbp rfile rline ;
999 refs.nbr := 0 ;
1000 END
1001 ELSE
1002 FOR it := 1 TO refs.nbr DO
1003 WITH refs.ref it DO
1004 IF fvarset THEN nameisref symbp rfile -rline
1005 ELSE nameisref symbp rfile rline ;
1006 IF withvariable THEN
1007 BEGIN
1008 currwithlist.nbr := refs.nbr ;
1009 FOR it := 1 TO refs.nbr DO
1010 currwithlist.symbolp it := refs.ref it.symbp ;
1011 END ;
1012 END ;
1013 gattr := lattr ;
1014 $OPTIONS compile = trace $
1015 IF stattrace > low THEN
1016 BEGIN
1017 IF stattrace = high AND newattr THEN
1018 printattr gattr ;
1019 write mpcogout '^^^ FIN VARIABLE with NO' no : 4 ; nextline ;
1020 END ;
1021 $OPTIONS compile = true $
1022 END * VARIABLE * ;
1023
1024 $OPTIONS page $
1025 PROCEDURE passparams fctplace : integer ;
1026
1027 * C. CALLED IN ORDER TO
1028 . ANALYSE ACTUAL PARAMETERS FOR A PROCEDURE FUNCTION CALL
1029 . BUILD ARGUMENT'S LIST
1030 * STANDARD HEADER
1031 * POINTERS LIST ON PARAMETERS
1032 * FOR A FUNCTION ONE MORE "ITS" POINTING THE PLACE TO BE
1033 ASSIGNED
1034 . FOR ACTUAL PROCEDUREFUNCTION PARAMETER TWO "ITS" ARE GIVEN
1035 * THE RIGHT ITS IN LINKAGE SECTION
1036 * THE COMPUTED DYNAMIC LINK
1037 . FOR A CONFORMANT ARRAY FOUR ITEMS
1038 * "ITS" ON REAL ARRAY
1039 * LOW BOUND HIGHBOUND DIM SIZE IN WORDS
1040 FCTPLACE IS THE DISP IN CALLER FRAME WHERE RETURNED VALUE MUST BE PUT
1041 . CTPTR POINTS THE BOX "PROC" OF THE CALLED PROCEDURE
1042 . FIRST INSYMBOL ALREADY DONE
1043 C *
1044 * E ERRORS DETECTED
1045 4: "" EXPECTED
1046 15: "" EXPECTED
1047 28: PREDEF PROC/FUNCT NOT ALLOWED HERE
1048 103: UNAPPROPRIATE CLASS FOR ID.
1049 104: UNDECLARED ID.
1050 126: NUMBER OF PARAMETERS DOES NOT AGREE WITH DECLARATION
1051 127: ILLEGAL PARAMETER SUBSTITUTION
1052 128: PARAMETER CONFLICT IN FORMAL PROC.
1053 133: ILLEGAL CONFORMANT ARRAY SUBSTITUTION
1054 230 : EFFICTIVE PARAMETER PASSED BY VALUE CAOONT BE CONFORMANT ARRAY
1055 303: VALUE ASSIGNED OUT OF RANGE
1056 318: PARAMETER PROCEDURE PASSED TO AN EXTERNAL PROCEDURE MUST BE EXPORTABLE
1057 E *)
1058 LABEL
1059 2
1060 1 ; * EXIT PROC WHEN FATAL ERROR *
1061 * IS DETECTED *
1062 VAR
1063 itisafunct pisformal pisext paramisproc paramisvar ended lerr : boolean ;
1064 procnameaddr parmctp foundtype decltype generic : ctp ;
1065 plevel procplacew nbparm longlist deplist curritsw currparmw currparb : integer ;
1066 lbase : preg ;
1067 declsize foundsize ldisp lmod lpad suplr : integer ;
1068 ltag lftag rgtag : tag ;
1069 lattr : attr ;
1070 lretpt : lcstpt ; llretpt : llcstpt ;
1071 prevdecltype : ctp ;
1072 temppt tempact : ctp ;
1073 nbofdim : integer ;
1074 locdisp : integer ;
1075 prevfoundtype : ctp ;
1076 dvdispw : integer ;
1077 multiplier lowbound highbound : integer ;
1078 arrconfblockw : integer ;
1079 firstoflist : boolean ;
1080 wlength alfalow alfahigh : integer ;
1081 all_descriptors pisimported : boolean ;
1082 procbox : ctp ;
1083 pr5bloc : regpt ;
1084 formal_length : integer ;
1085 done : boolean ;
1086 nbofparm : integer ; parm_attr : attr ;
1087 loaded_reg : register ;
1088
1089
1090 * ************************************ LOADLINK < PASSPARAMS ***************** *
1091
1092 PROCEDURE loadlink fpreg : preg ; fplev : levrange ;
1093
1094 * C.LOAD FPREG WITH THE DYNAMIC LINK SUITABLE.
1095 .THREE CASES
1096 *CURRENT LEVEL= CALLED-LEVEL
1097 CALL OF A SUBPROCEDURE DYN-LINK = PR6 OF CALLER
1098 * OR SEARCHS PREVIOUS CALLERS D-LINK
1099 .CAUTION WHEN LEVEL IS N PROCLEVEL IS N-1
1100 C *
1101 VAR
1102 linst : istand ;
1103 it : integer ;
1104 BEGIN
1105 linst := prinst epp fpreg ;
1106 IF level = fplev THEN
1107 genstand pr6 0 linst tn ELSE
1108 BEGIN
1109 genstand pr6 dlkdepw linst tny ;
1110 FOR it := 1 TO level - fplev - 1 DO
1111 genstand fpreg dlkdepw linst tny ;
1112 END ;
1113 END * LOADLINK * ;
1114
1115
1116 * ************************************ FCT COMPATLIST< PASSPARAMS ************ *
1117
1118 FUNCTION compatlist declproc foundproc : ctp : boolean ;
1119
1120 * C .DECLPARM POINTS THE PROCEDURE BOX
1121 FOUNDPARM POINTS THE " "
1122 .RETURNS TRUE OR FALSE
1123 C *
1124 VAR
1125 iscompat lerr lerrvarval : boolean ;
1126 declparm foundparm : ctp ;
1127 decltype foundtype : ctp ;
1128
1129 FUNCTION both_are_string_param : boolean ;
1130
1131 * SAYS IF BOTH PARAMETERS ARE DECLARED " : STRING" *
1132
1133 BEGIN
1134 IF decltype^.father_schema <> NIL AND decltype^.actual_parameter_list <> NIL
1135 AND decltype^.father_schema = foundtype^.father_schema
1136 AND foundtype^.actual_parameter_list <> NIL
1137 THEN
1138 both_are_string_param :=
1139 decltype^.actual_parameter_list^.vkind = arraybound
1140 AND foundtype^.actual_parameter_list^.vkind = arraybound
1141 ELSE both_are_string_param := false
1142 END ;
1143 BEGIN * COMPATLIST *
1144 $OPTIONS compile = trace $
1145 IF stattrace > none THEN
1146 BEGIN
1147 write mpcogout '@@@ DEBUT COMPATLIST @@@' ; nextline ;
1148 END ;
1149 $OPTIONS compile = true $
1150 declparm := declproc@.formals ; foundparm := foundproc@.formals ;
1151 iscompat := true ; lerrvarval := false ;
1152 WHILE declparm # NIL AND iscompat DO
1153 BEGIN
1154 IF foundparm = NIL THEN
1155 iscompat := false ELSE
1156 BEGIN
1157 IF declparm@.klass # foundparm@.klass THEN
1158 iscompat := false ELSE
1159 BEGIN
1160 IF declparm@.klass = proc THEN
1161 iscompat := compatlist declparm foundparm ELSE
1162 BEGIN
1163 IF declparm@.varparam # foundparm@.varparam THEN
1164 lerrvarval := true ;
1165 decltype := declparm@.vtype ; lerr := false ;
1166 foundtype := foundparm@.vtype ;
1167 WHILE decltype # foundtype AND NOT lerr DO
1168 BEGIN
1169 lerr := true ;
1170 IF decltype # NIL THEN
1171 IF foundtype # NIL THEN
1172 IF both_are_string_param THEN
1173 BEGIN
1174 decltype := foundtype ; * TO STOP WHILE LOOP *
1175 lerr := false * SCHEMA OK *
1176 END
1177 ELSE
1178 IF decltype@.form = arrays THEN
1179 IF foundtype@.form = arrays THEN
1180 IF decltype@.conformant THEN
1181 IF foundtype@.conformant THEN
1182 IF decltype@.inxtype = foundtype@.inxtype THEN
1183 IF decltype^.pack = foundtype^.pack THEN
1184 BEGIN
1185 lerr := false ;
1186 decltype := decltype@.aeltype ;
1187 foundtype := foundtype@.aeltype ;
1188 END ; * EQUIVALENT CONFORMANT SCHEMAS *
1189 END ; * TYPES # AND NO ERR *
1190 iscompat := NOT lerr OR lerrvarval ;
1191 END * NOT PROC * ;
1192 declparm := declparm@.nxtel ; foundparm := foundparm@.nxtel ;
1193 END * SAME KLASS * ;
1194 END * FOUNDPARM#NIL * ;
1195 END * WHILE * ;
1196 IF declparm = NIL AND foundparm # NIL THEN iscompat := false ;
1197
1198 * NOW CHEK IF IT IS TWO PROC OR TWO FUNCTIONS *
1199 IF iscompat THEN
1200 IF declproc@.proctype # declproc THEN
1201 BEGIN
1202 IF foundproc@.proctype = foundproc THEN
1203 iscompat := false ELSE
1204 iscompat := declproc@.proctype = foundproc@.proctype ;
1205 END ELSE
1206 iscompat := foundproc@.proctype = foundproc ;
1207 compatlist := iscompat ;
1208 $OPTIONS compile = trace $
1209 IF stattrace > low THEN
1210 BEGIN
1211 write mpcogout '@@@ FIN COMPATLIST @@@ WITH RETURNED VALUE ' iscompat : 6 ;
1212 nextline ;
1213 END ;
1214 $OPTIONS compile = true $
1215 END * COMPATLIST * ;
1216
1217
1218
1219
1220
1221 BEGIN * PASSPARAMS *
1222 $OPTIONS compile = trace $
1223 IF stattrace > none THEN
1224 BEGIN
1225 write mpcogout '@@@ DEBUT PASSPARAMS @@@ WITH FCTPLACE' fctplace ; nextline ;
1226 END ;
1227 $OPTIONS compile = true $
1228 WITH ctptr@ DO
1229 BEGIN
1230 itisafunct := proctype # ctptr ;
1231 parmctp := formals ; * FIRST DECLARED PARAMETER *
1232 pisformal := prockind = formal ;
1233 pisext := prockind > formal ;
1234 pisimported := prockind = imported ;
1235 plevel := proclevel ;
1236 procplacew := procaddr DIV bytesinword ; * PR4 PR6 WORD OFFSET *
1237 nbparm := nbparproc ; * NUMBER OF "ITS" IN PARAMETER LIST *
1238 all_descriptors := pwantdescs ;
1239 procbox := ctptr ;
1240 END * WITH CTPTR@ * ;
1241 procnameaddr := ctptr ;
1242 * PREPARE CURRENT ARGUMENT LIST *
1243 longlist := bytesindword * HEADER * + nbparm * bytesindword ;
1244 IF ctptr^.phasdescriptor OR all_descriptors THEN
1245 longlist := longlist + nbparm * bytesindword ;
1246 deplist := oldnewstor longlist ; * POINTED LATER BY ARGUMENT POINTER *
1247 curritsw := deplist + bytesindword DIV bytesinword ;
1248 IF all_descriptors AND nbparm <> 0 THEN
1249 BEGIN
1250 newbloc pr5 ;
1251 pr5bloc := currentbloc ;
1252 usednameaddr := procnameaddr ;
1253 genstand prlink procplacew iepp5 tny ;
1254 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1255 geneism imlr 0 p0t0r0 ;
1256 gendesca prstatic procbox^.pdescsaddrplace DIV bytesinword 0 l9 nbparm * bytesindword tn ;
1257 gendesca pr6 deplist DIV bytesinword + 2 + nbparm * 2 0 l9 nbparm * bytesindword tn ;
1258 END ;
1259 IF no = 9 * * THEN
1260 BEGIN
1261 prevdecltype := NIL ; prevfoundtype := NIL ;
1262 dvdispw := 0 ; arrconfblockw := 0 ;
1263 REPEAT * LOOP ON ACTUAL PARAMETER'S LIST *
1264 IF parmctp = NIL THEN
1265 BEGIN
1266 error 126 ; skip 46 ; GOTO 1 ; * EXIT PROC *
1267 END ;
1268 paramisproc := parmctp@.klass = proc ;
1269 IF NOT paramisproc THEN
1270 paramisvar := parmctp@.varparam ;
1271 insymbol ;
1272 IF paramisproc THEN
1273 BEGIN * PROC OR FUNCT TO BE PASSED *
1274 IF no # 1 THEN
1275 BEGIN error 2 ; skip 15 ; * *
1276 END ELSE
1277 BEGIN * ID *
1278 search ;
1279 IF ctptr = NIL THEN
1280 error 104 ELSE
1281 BEGIN
1282 IF symbolmap THEN nameisref ctptr symbolfile symbolline ;
1283 WITH ctptr@ DO
1284 IF klass # proc THEN
1285 error 103 ELSE
1286 IF NOT compatlist parmctp ctptr THEN
1287 error 128 ELSE
1288 BEGIN
1289 IF predefproc THEN error 28 ;
1290 IF prockind # formal THEN * ACTUAL PROCEDURE PASSED *
1291 BEGIN
1292 currparmw := oldnewstor procparmsize DIV bytesinword ;
1293 IF proclevel = level THEN
1294 genstand pr6 currparmw + 2 ispri6 tn ELSE
1295 BEGIN
1296 loadlink pr3 proclevel ;
1297 genstand pr6 currparmw + 2 ispri3 tn ;
1298 END ;
1299 genstand prlink procaddr DIV bytesinword iepp3 tny ;
1300 genstand pr6 currparmw ispri3 tn ;
1301 IF prockind > formal THEN ldisp := extcallplace
1302 ELSE IF pisimported THEN error 318 ELSE ldisp := intcallplace ;
1303 genstand nreg ldisp ilda tdl ;
1304 genstand
1305 pr6 currparmw + 4 ista tn ; * USED IN CALL SEQ. *
1306 * NOW LOAD PR3 *
1307 * WITH "ITS" ON CURRPARM *
1308 usednameaddr := ctptr ;
1309 genstand pr6 currparmw iepp3 tn ;
1310 genstand pr6 curritsw ispri3 tn ;
1311 END * NOT FORMAL * ELSE
1312 BEGIN * FORMAL *
1313 IF proclevel = level THEN
1314 lbase := pr6 ELSE
1315 BEGIN
1316 loadbase proclevel ; freebloc currentbloc ;
1317 lbase := currentpr ;
1318 END ;
1319 usednameaddr := ctptr ;
1320 genstand lbase procaddr DIV bytesinword iepp3 tny ;
1321 genstand pr6 curritsw ispri3 tn ;
1322 IF pisimported THEN
1323 BEGIN
1324 genstand pr3 4 ilda tn ; * CALL OP NUMBER *
1325 genstand pr0 parmproccheckplace itsp3 tn ;
1326 END ;
1327 END * FORMAL * ;
1328 curritsw := curritsw + 2 ;
1329 END * NO ERRORS IN PASSING A PROCEDURE/FUNCTION AS PARAMETER * ;
1330 END ;
1331 insymbol ;
1332 END * ID * ;
1333 END * PARAMISPROC * ELSE
1334 IF paramisvar THEN
1335 BEGIN
1336 variab true ;
1337 done := false ;
1338 WITH gattr DO
1339 IF typtr # NIL THEN
1340 IF parmctp^.vtype <> NIL THEN
1341 BEGIN
1342 IF parmctp^.vtype^.father_schema <> NIL THEN
1343 IF parmctp^.vtype^.actual_parameter_list = NIL THEN * nothing * ELSE
1344 IF parmctp^.vtype^.actual_parameter_list^.vkind = arraybound THEN
1345 * FORMAL PARAMETER IS A SCHEMA. PASS ACTUAL BOUNDS IN DESCRIPTOR *
1346 IF typtr^.father_schema <> parmctp^.vtype^.father_schema THEN error 127
1347 ELSE
1348 BEGIN
1349 decltype := parmctp^.vtype ; foundtype := typtr ;
1350 lerr := false ;
1351 IF prevdecltype = decltype THEN
1352 BEGIN * list of parameters of same schema *
1353 firstoflist := false ;
1354 IF prevfoundtype <> foundtype THEN
1355 BEGIN
1356 lerr := true ; error 127 ;
1357 END ;
1358 END ELSE
1359 BEGIN
1360 firstoflist := true ;
1361 prevfoundtype := foundtype ;
1362 prevdecltype := decltype ;
1363 END ;
1364 IF NOT lerr THEN
1365 BEGIN
1366 IF foundtype^.actual_parameter_list^.vkind = arraybound THEN
1367 BEGIN * PASSED PARAMETER IS ITSELF A VARIABLE SCHEMA. KEEP HIS DESC *
1368 IF gattr.descbloc = NIL THEN
1369 BEGIN
1370 init_desc_address variabctptr gattr ;
1371 genstand pr6 curritsw prinst spri gattr.basereg tn ;
1372 freebloc gattr.basebloc ;
1373 END
1374 ELSE
1375 BEGIN
1376 loadadr gattr pr3 ;
1377 genstand pr6 curritsw ispri3 tn ;
1378 END ;
1379 IF firstoflist THEN
1380 BEGIN
1381 temppt := decltype^.actual_parameter_list ;
1382 nbofparm := 0 ;
1383 WHILE temppt <> NIL DO
1384 BEGIN
1385 nbofparm := nbofparm + 1 ; ; temppt := temppt^.nxtel
1386 END ;
1387 wlength := 2 * MULTICS EXTENDED ARG DESC * + 1 * SIZE * + nbofparm * ONE WORD PER PARM * ;
1388 dvdispw := oldnewstor wlength * bytesinword DIV bytesinword ;
1389 regenere gattr.descbloc ;
1390 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1391 geneism imlr 0 p0t0r0 ;
1392 gendesca gattr.descreg 2 0 l9 wlength - 2 * bytesinword tn ;
1393 gendesca pr6 dvdispw + 2 0 l9 wlength - 2 * bytesinword tn ;
1394 END ;
1395 freebloc gattr.descbloc ;
1396 getpr ;
1397 genstand pr6 dvdispw prinst epp currentpr tn ;
1398 genstand pr6 curritsw + nbparm * 2 prinst spri currentpr tn ;
1399 freebloc currentbloc ;
1400 curritsw := curritsw + 2 ;
1401 END * Actual is Schema * ELSE
1402 BEGIN
1403 loadadr gattr pr3 ;
1404 genstand pr6 curritsw ispri3 tn ;
1405
1406 IF firstoflist THEN
1407 BEGIN
1408 * Evaluation du nombre de parametres *
1409 temppt := decltype^.actual_parameter_list ;
1410 nbofparm := 0 ;
1411 WHILE temppt <> NIL DO
1412 BEGIN
1413 nbofparm := nbofparm + 1 ; ; temppt := temppt^.nxtel
1414 END ;
1415 wlength := 2 * MULTICS EXTENDED ARG DESC * + 1 * SIZE * + nbofparm * ONE WORD PER PARM * ;
1416 dvdispw := oldnewstor wlength * bytesinword DIV bytesinword ;
1417 temppt := typtr^.actual_parameter_list ; tempact := foundtype ; locdisp := 2 ;
1418 gencstecode typtr^.size ilda ;
1419 genstand pr6 dvdispw + locdisp ista tn ;
1420 locdisp := locdisp + 1 ;
1421 WHILE temppt <> NIL DO
1422 BEGIN
1423 sauvereg ra false ;
1424 IF temppt^.klass <> konst THEN
1425 BEGIN
1426 addressvar temppt parm_attr false ;
1427 transfer parm_attr inacc ;
1428 freeattr parm_attr
1429 END
1430 ELSE gencstecode temppt^.values ilda ;
1431 genstand pr6 dvdispw + locdisp ista tn ;
1432
1433 locdisp := locdisp + 1 ;
1434 temppt := temppt^.nxtel ;
1435 END ;
1436 END * FIRSTOFLIST * ;
1437
1438 genstand pr6 dvdispw iepp3 tn ;
1439 genstand pr6 curritsw + nbparm * 2 ispri3 tn ;
1440 curritsw := curritsw + 2 ;
1441 END * Actual not Schema * ;
1442 END ;
1443 done := true ;
1444 END ;
1445 IF NOT done THEN
1446 IF gattr.pckd AND NOT parmctp^.vtype^.pack THEN error 127 ELSE
1447 IF typtr = parmctp@.vtype THEN
1448 BEGIN
1449 loadadr gattr pr3 ;
1450 IF procnameaddr^.pwantspl1descriptors AND
1451 is_pl1_varying_char parmctp^.vtype THEN
1452 genstand pr3 1 iepp3 tn ;
1453 genstand pr6 curritsw ispri3 tn ; curritsw := curritsw + 2 ;
1454 END * SAME TYPE * ELSE
1455 IF NOT conformantdim parmctp^.vtype THEN
1456 error 127 ELSE
1457 BEGIN * Not Same Type *
1458 decltype := parmctp^.vtype ; foundtype := gattr.typtr ;
1459 lerr := false ;
1460 IF NOT legalconfarrsubstitution foundtype decltype THEN
1461 BEGIN
1462 error 127 ;
1463 * SKIP BOUNDS PARAM *
1464 WHILE parmctp^.vkind = arraybound DO
1465 BEGIN
1466 parmctp := parmctp ^.nxtel ;
1467 END ;
1468 END * not Legal Substitution * ELSE
1469 BEGIN
1470 IF prevdecltype = decltype THEN
1471 BEGIN * Liste *
1472 firstoflist := false ;
1473 IF prevfoundtype <> foundtype THEN
1474 BEGIN
1475 lerr := true ; error 127 ;
1476 END ;
1477 END ELSE
1478 BEGIN
1479 firstoflist := true ;
1480 prevfoundtype := foundtype ;
1481 prevdecltype := decltype ;
1482 END ;
1483 IF NOT lerr THEN
1484 BEGIN
1485 IF conformantdim foundtype THEN
1486 BEGIN
1487 * Load PR3 with previous descriptor on block parameter *
1488 IF gattr.descbloc = NIL THEN
1489 BEGIN
1490 init_desc_address variabctptr gattr ;
1491 genstand pr6 curritsw prinst spri gattr.basereg tn ;
1492 freebloc gattr.basebloc ;
1493 END
1494 ELSE
1495 BEGIN
1496 loadadr gattr pr3 ;
1497 genstand pr6 curritsw ispri3 tn ;
1498 END ;
1499 IF firstoflist THEN
1500 BEGIN
1501 temppt := decltype ;
1502 nbofdim := 0 ;
1503 WHILE conformantdim temppt DO
1504 BEGIN
1505 nbofdim := nbofdim + 1 ;
1506 temppt := temppt^.aeltype ;
1507 parmctp := parmctp^.nxtel^.nxtel ;
1508 END ;
1509 wlength := nbofdim * dopevectorsize DIV bytesinword ;
1510 dvdispw := oldnewstor wlength + 2 * bytesinword DIV bytesinword ;
1511 IF all_descriptors THEN
1512 BEGIN
1513 getpr ;
1514 genstand pr6 curritsw + nbparm * 2 prinst epp currentpr tny ;
1515 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1516 geneism imlr 0 p0t0r0 ;
1517 gendesca currentpr 0 0 l9 wlength + 2 * bytesinword tn ;
1518 gendesca pr6 dvdispw 0 l9 wlength + 2 * bytesinword tn ;
1519 freebloc currentbloc ;
1520 END ;
1521 regenere gattr.descbloc ;
1522 geneism imlr 0 p0t0r0 ;
1523 gendesca gattr.descreg 0 0 l9 wlength * bytesinword tn ;
1524 gendesca pr6 dvdispw + 1 0 l9 wlength * bytesinword tn ;
1525 END ;
1526 freebloc gattr.descbloc ;
1527
1528 getpr ;
1529 genstand pr6 dvdispw prinst epp currentpr tn ;
1530 genstand pr6 curritsw + nbparm * 2 prinst spri currentpr tn ;
1531 freebloc currentbloc ;
1532
1533 curritsw := curritsw + 2 ;
1534
1535 END * Actual Is Conformant * ELSE
1536 BEGIN
1537
1538 loadadr gattr pr3 ;
1539 genstand pr6 curritsw ispri3 tn ;
1540
1541 IF firstoflist THEN
1542 BEGIN
1543 * Evaluation du nombre de dimensions *
1544 temppt := decltype ;
1545 nbofdim := 0 ;
1546 WHILE conformantdim temppt DO
1547 BEGIN
1548 nbofdim := nbofdim + 1 ;
1549 temppt := temppt^.aeltype ;
1550 END ;
1551
1552 * Acquisition dope vector *
1553 dvdispw := oldnewstor nbofdim * dopevectorsize + 8 DIV bytesinword ;
1554 wlength := nbofdim * dopevectorsize DIV bytesinword ;
1555 IF all_descriptors THEN
1556 BEGIN
1557 getpr ;
1558 genstand pr6 curritsw + nbparm * 2 prinst epp currentpr tny ;
1559 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1560 geneism imlr 0 p0t0r0 ;
1561 gendesca currentpr 0 0 l9 wlength + 2 * bytesinword tn ;
1562 gendesca pr6 dvdispw 0 l9 wlength + 2 * bytesinword tn ;
1563 freebloc currentbloc ;
1564 END ;
1565
1566 * Incrementation et passage des bornes *
1567 temppt := decltype ; tempact := foundtype ; locdisp := 3 * nbofdim - 2 ;
1568 WHILE conformantdim temppt DO
1569 BEGIN
1570 * PAsse Low Bound et remplit premoer mot du dope vector *
1571 lowbound := tempact^.lo ;
1572 sauvereg ra false ; gencstecode lowbound ilda ;
1573 genstand pr6 dvdispw + locdisp ista tn ;
1574
1575 * Passe high bound et remplit deuxieme mot du dope vector *
1576 highbound := tempact^.hi ;
1577 gencstecode highbound ilda ;
1578 genstand pr6 dvdispw + locdisp + 1 ista tn ;
1579
1580 * Passe MULTIPLIER *
1581 IF tempact^.pack THEN
1582 multiplier := packedsize tempact^.aeltype * bitsinbyte ELSE
1583 multiplier := sup tempact^.aeltype^.size bytesinword DIV bytesinword ;
1584 gencstecode multiplier ilda ;
1585 genstand pr6 dvdispw + locdisp + 2 ista tn ;
1586
1587 * Prepare dimension suivante *
1588 locdisp := locdisp - 3 ;
1589 temppt := temppt^.aeltype ; tempact := tempact^.aeltype ;
1590 parmctp := parmctp^.nxtel^.nxtel ;
1591
1592 END ;
1593 END * FIRSTOFLIST * ;
1594
1595 genstand pr6 dvdispw iepp3 tn ; * Dope vector address *
1596 genstand pr6 curritsw + nbparm * 2 ispri3 tn ;
1597 curritsw := curritsw + 2 ;
1598 END * Actual not conformant * ;
1599 END * not LERR * ;
1600 END * Legal Substitution * ;
1601 END * Not Same Type * ;
1602 END * TYPTR#NILWITH GATTR * ;
1603 END * PARAMISVAR * ELSE
1604 BEGIN * VALUE PARAMETER *
1605 expression ;
1606 WITH gattr DO
1607 IF typtr <> NIL THEN
1608 BEGIN
1609 compatbin parmctp^.vtype typtr generic ;
1610 IF generic = NIL THEN
1611 BEGIN
1612 IF parmctp^.vtype = NIL THEN * nothing *
1613 ELSE IF parmctp^.vtype^.father_schema = string_ptr
1614 THEN IF parmctp^.vtype^.actual_parameter_list = NIL THEN * nothing *
1615 ELSE
1616 BEGIN
1617 IF parmctp^.vtype^.actual_parameter_list^.klass = konst THEN
1618 formal_length := parmctp^.vtype^.actual_parameter_list^.values
1619 ELSE formal_length := 0 ; * ERROR SOMEWHERE BEFORE *
1620 currparmw := oldnewstor formal_length + 4 DIV bytesinword ;
1621 IF typtr^.father_schema = string_ptr THEN
1622 BEGIN
1623 loadadr gattr pr3 ;
1624 genstand pr3 0 ildq tn ;
1625 genstand nreg 4 iadq tdl ;
1626 gencstecode formal_length + 4 ilda ;
1627 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
1628 geneism imlr 0 p0t0r0 ;
1629 gendesca pr3 0 0 l9 0 tql ;
1630 gendesca pr6 currparmw 0 l9 0 tal ;
1631 IF procnameaddr^.pwantspl1descriptors THEN
1632 genstand pr6 currparmw + 1 iepp3 tn
1633 ELSE
1634 genstand pr6 currparmw iepp3 tn ;
1635 genstand pr6 curritsw ispri3 tn ;
1636 END ELSE
1637 IF typtr = charptr THEN
1638 BEGIN
1639 IF kind = lval THEN loaded_reg := ldreg
1640 ELSE
1641 IF raisused THEN
1642 BEGIN
1643 loaded_reg := rq ; sauvereg rq false ;
1644 transfer gattr inq ;
1645 END ELSE
1646 BEGIN
1647 loaded_reg := ra ;
1648 transfer gattr inacc ;
1649 END ;
1650 freeattr gattr ;
1651 genstand nreg 27 opaq shiftl loaded_reg tn ;
1652 genstand pr6 currparmw + 1 opaq stor loaded_reg tn ;
1653 genstand nreg 1 opaq load loaded_reg tdl ;
1654 genstand pr6 currparmw opaq stor loaded_reg tn ;
1655 IF procnameaddr^.pwantspl1descriptors THEN
1656 genstand pr6 currparmw + 1 iepp3 tn
1657 ELSE
1658 genstand pr6 currparmw iepp3 tn ;
1659 genstand pr6 curritsw ispri3 tn ;
1660 END
1661 ELSE IF isstring gattr THEN
1662 BEGIN
1663 IF NOT conformantdim typtr THEN
1664 BEGIN
1665 loadadr gattr pr3 ;
1666 sauvereg ra false ;
1667 IF kind = chain THEN
1668 BEGIN
1669 IF alfactp^.alfalong > formal_length THEN error 127 ;
1670 gencstecode alfactp^.alfalong ilda ;
1671 END
1672 ELSE BEGIN
1673 IF typtr^.size > formal_length THEN error 127 ;
1674 gencstecode typtr^.size ilda ;
1675 END ;
1676 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
1677 genstand pr6 currparmw ista tn ;
1678 geneism imlr 0 p0t0r0 ;
1679 gendesca pr3 0 0 l9 0 tal ;
1680 gendesca pr6 currparmw + 1 0 l9 0 tal ;
1681 IF procnameaddr^.pwantspl1descriptors THEN
1682 genstand pr6 currparmw + 1 iepp3 tn
1683 ELSE
1684 genstand pr6 currparmw iepp3 tn ;
1685 genstand pr6 curritsw ispri3 tn ;
1686 END
1687 ELSE * conformant string *
1688 BEGIN
1689 init_desc_address gattr.nameaddr gattr ;
1690 sauvereg rq false ;
1691 genstand gattr.descreg 1 ildq tn ;
1692 genstand gattr.descreg 0 isbq tn ;
1693 genstand nreg 1 iadq tdl ; * rq contains actual length *
1694 freebloc gattr.descbloc ;
1695 genstand pr6 currparmw istq tn ;
1696 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
1697 gencstecode formal_length ilda ;
1698 genstand pr6 currparmw iepp3 tn ;
1699 IF gattr.basebloc <> NIL THEN regenere gattr.basebloc ;
1700 geneism imlr 0 p0t0r0 ;
1701 gendesca gattr.basereg gattr.dplmt DIV bytesinword gattr.dplmt MOD bytesinword l9 0 tql ;
1702 gendesca pr3 1 0 l9 0 tal ;
1703 freebloc gattr.basebloc ;
1704 IF procnameaddr^.pwantspl1descriptors THEN
1705 genstand pr3 1 iepp3 tn ;
1706 genstand pr6 curritsw ispri3 tn ;
1707 END
1708 END ELSE error 127 ;
1709 curritsw := curritsw + 2 ;
1710 END ELSE
1711 BEGIN
1712 IF conformantdim parmctp^.vtype THEN
1713 BEGIN * CONFORMARRAY VALUE SUBSTITUTION *
1714 decltype := parmctp^.vtype ; foundtype := gattr.typtr ;
1715 lerr := false ;
1716 IF NOT legalconfarrsubstitution foundtype decltype THEN
1717 BEGIN
1718 error 127 ;
1719 END * not LEGAL SUBSTITUTION * ELSE
1720 BEGIN
1721 IF prevdecltype = decltype THEN
1722 BEGIN * LISTE *
1723 firstoflist := false ;
1724 IF prevfoundtype <> foundtype THEN
1725 BEGIN
1726 lerr := true ; error 127 ;
1727 END ;
1728 END ELSE
1729 BEGIN
1730 firstoflist := true ;
1731 prevfoundtype := foundtype ;
1732 prevdecltype := decltype ;
1733 END ;
1734 IF NOT lerr THEN
1735 BEGIN
1736 * RECOPIE TABLEAU ACTUEL *
1737 IF gattr.typtr = alfaptr THEN
1738 BEGIN
1739 foundsize := alfactp^.alfalong ;
1740 alfalow := 1 ; alfahigh := foundsize ;
1741 END ELSE
1742 BEGIN
1743 foundsize := gattr.typtr^.size ;
1744 alfalow := 0 ; alfahigh := 0 ;
1745 END ;
1746
1747 currparb := oldnewstor recadre foundsize bytesinword ;
1748 currparmw := currparb DIV bytesinword ;
1749 WITH lattr DO
1750 BEGIN
1751 typtr := parmctp^.vtype ;
1752 initattrvarbl lattr ;
1753 dplmt := currparb ; pckd := parmctp^.vtype^.pack ;
1754 END ;
1755 lbase := nreg ;
1756 lpad := ord ' ' ;
1757 IF gattr.kind = varbl THEN
1758 IF varissimple gattr THEN
1759 BEGIN
1760 lbase := basereg ; ldisp := dplmt DIV bytesinword ;
1761 lmod := dplmt MOD bytesinword ;
1762 END ;
1763 IF lbase = nreg THEN
1764 BEGIN
1765 loadadr gattr pr3 ;
1766 lbase := pr3 ; ldisp := 0 ; lmod := 0 ;
1767 END ;
1768
1769 IF foundsize < twoto12 THEN
1770 BEGIN
1771 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; lftag := tn ; rgtag := tn ;
1772 END ELSE
1773 BEGIN
1774 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ; lftag := tx6 ;
1775 rgtag := tx7 ;
1776 IF foundsize > twoto17m1 THEN
1777 error 307 ELSE
1778 BEGIN
1779 genstand nreg foundsize ieax6 tn ;
1780 genstand nreg foundsize ieax7 tn ;
1781 END ;
1782 foundsize := 0 ;
1783 END ;
1784 geneism imlr lpad p0t0r0 ;
1785 IF kind = varbl THEN usednameaddr := nameaddr ;
1786 gendesca lbase ldisp lmod l9 foundsize rgtag ;
1787 gendesca pr6 currparmw 0 l9 foundsize lftag ;
1788 genstand pr6 currparmw iepp3 tn ;
1789 genstand pr6 curritsw ispri3 tn ;
1790
1791 IF firstoflist THEN
1792 BEGIN
1793 * EVALUATION DU NOMBRE DE DIMENSIONS *
1794 temppt := decltype ;
1795 nbofdim := 0 ;
1796 WHILE conformantdim temppt DO
1797 BEGIN
1798 nbofdim := nbofdim + 1 ;
1799 temppt := temppt^.aeltype ;
1800 END ;
1801 * ACQUISITION DOPE VECTOR *
1802 dvdispw := oldnewstor nbofdim * dopevectorsize + 8 DIV
1803 bytesinword ;
1804 wlength := nbofdim * dopevectorsize DIV bytesinword ;
1805 IF all_descriptors THEN
1806 BEGIN
1807 getpr ;
1808 genstand pr6 curritsw + nbparm * 2 prinst epp currentpr tny ;
1809 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1810 geneism imlr 0 p0t0r0 ;
1811 gendesca currentpr 0 0 l9 wlength + 2 * bytesinword tn ;
1812 gendesca pr6 dvdispw 0 l9 wlength + 2 * bytesinword tn ;
1813 freebloc currentbloc ;
1814 END ;
1815
1816 * INCREMENTATION ET PASSAGE DES BORNES *
1817 temppt := decltype ; tempact := foundtype ; locdisp := 3 * nbofdim - 2 ;
1818 WHILE conformantdim temppt DO
1819 BEGIN
1820 * PASSE LOW BOUND ET REMPLIT PREMOER MOT DU DOPE VECTOR *
1821 IF alfalow <> 0 THEN
1822 lowbound := alfalow ELSE
1823 lowbound := tempact^.lo ;
1824 sauvereg ra false ; gencstecode lowbound ilda ;
1825 genstand pr6 dvdispw + locdisp ista tn ;
1826
1827 * PASSE HIGH BOUND ET REMPLIT DEUXIEME MOT DU DOPE VECTOR *
1828 IF alfahigh <> 0 THEN
1829 highbound := alfahigh ELSE
1830 highbound := tempact^.hi ;
1831 gencstecode highbound ilda ;
1832 genstand pr6 dvdispw + locdisp + 1 ista tn ;
1833
1834 * PASSE MULTIPLIER *
1835 IF tempact^.pack THEN
1836 multiplier := packedsize tempact^.aeltype * bitsinbyte ELSE
1837 multiplier := sup tempact^.aeltype^.size bytesinword DIV bytesinword ;
1838 gencstecode multiplier ilda ;
1839 genstand pr6 dvdispw + locdisp + 2 ista tn ;
1840
1841 * PREPARE DIMENSION SUIVANTE *
1842 locdisp := locdisp - 3 ;
1843 temppt := temppt^.aeltype ; tempact := tempact^.aeltype ;
1844 parmctp := parmctp^.nxtel^.nxtel ;
1845
1846 END ;
1847 END * FIRSTOFLIST * ;
1848
1849 genstand pr6 dvdispw iepp3 tn ;
1850 genstand pr6 curritsw + nbparm * 2 ispri3 tn ;
1851 curritsw := curritsw + 2 ;
1852 END * not LERR * ;
1853 END * LEGAL SUBSTITUTION * ;
1854 END * CONFORMANT ARRAY VALUE SUBSTITUTION * ELSE
1855 error 127 ;
1856 END ;
1857 END * GENERIC WAS nil * ELSE
1858
1859 BEGIN declsize := parmctp@.vtype@.size ;
1860 CASE parmctp@.vtype@.form OF
1861 reel : IF typtr # realptr THEN convreal gattr ;
1862 numeric scalar :
1863 IF typtr = realptr THEN error 127 ELSE
1864 IF kind = sval THEN
1865 checkminmax val parmctp@.vtype 303 ELSE
1866 IF asscheck THEN
1867 BEGIN
1868 IF kind # lval THEN transfer gattr inacc ;
1869 checkbnds parerrcode ldreg parmctp@.vtype ;
1870 END ;
1871 pointer records power : foundsize := typtr@.size ;
1872 arrays : BEGIN
1873 lerr := false ;
1874 IF typtr = alfaptr THEN
1875 BEGIN foundsize := alfactp@.alfalong ;
1876 IF envstandard <> stdextend THEN
1877 BEGIN
1878 IF foundsize # declsize THEN lerr := true ;
1879 END ELSE
1880 IF foundsize > declsize THEN lerr := true ;
1881 END * ALFAPTR * ELSE
1882 BEGIN
1883 foundsize := typtr@.size ;
1884 IF foundsize # declsize THEN lerr := true ;
1885 END ;
1886 IF lerr THEN error 127 ;
1887 END * ARRAYS * ;
1888 END * CASE * ;
1889 currparb := oldnewstor recadre declsize bytesinword ;
1890 currparmw := currparb DIV bytesinword ;
1891 WITH lattr DO
1892 BEGIN
1893 typtr := parmctp@.vtype ;
1894 initattrvarbl lattr ;
1895 dplmt := currparb ;
1896 pckd := parmctp@.vtype@.pack ;
1897 END ;
1898 IF typtr@.form < power THEN
1899 BEGIN
1900 choicerarq ;
1901 transfer lattr out ;
1902 END * < POWER * ELSE
1903 BEGIN
1904 IF kind = lval THEN * ONLY POWER *
1905 transfer lattr out ELSE
1906 BEGIN
1907 IF typtr@.form = power THEN
1908 BEGIN lpad := 0 ;
1909 IF kind = sval THEN
1910 BEGIN
1911 IF longv = bytesindword THEN
1912 BEGIN enterlcst valpw lretpt ;
1913 enterundlab lretpt@.lplace ;
1914 foundsize := bytesindword ;
1915 END ELSE
1916 BEGIN enterllcst valpw llretpt ;
1917 enterundlab llretpt@.llplace ;
1918 END ;
1919 genstand nreg 0 iepp3 tic ;
1920 lbase := pr3 ;
1921 ldisp := 0 ;
1922 lmod := 0 ;
1923 END * SVAL * ELSE
1924 lbase := nreg ;
1925 END * POWER * ELSE
1926 BEGIN lpad := ord ' ' ; lbase := nreg ;
1927 END ;
1928 IF kind = varbl THEN
1929 IF varissimple gattr THEN
1930 BEGIN
1931 lbase := basereg ;
1932 ldisp := dplmt DIV bytesinword ;
1933 lmod := dplmt MOD bytesinword ;
1934 END ;
1935 IF lbase = nreg THEN
1936 BEGIN
1937 loadadr gattr pr3 ;
1938 lbase := pr3 ;
1939 ldisp := 0 ;
1940 lmod := 0 ;
1941 END ;
1942 suplr := sup foundsize declsize ;
1943 IF suplr < twoto12 THEN
1944 BEGIN
1945 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; lftag := tn ; rgtag := tn ;
1946 END ELSE
1947 BEGIN
1948 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ; lftag := tx6 ; rgtag := tx7 ;
1949 IF suplr > twoto17m1 THEN
1950 error 307 ELSE
1951 BEGIN
1952 genstand nreg declsize ieax6 tn ;
1953 genstand nreg foundsize ieax7 tn ;
1954 END ;
1955 declsize := 0 ; foundsize := 0 ;
1956 END ;
1957 geneism imlr lpad p0t0r0 ;
1958 IF kind = varbl THEN usednameaddr := nameaddr ;
1959 gendesca lbase ldisp lmod l9 foundsize rgtag ;
1960 gendesca pr6 currparmw 0 l9 declsize lftag ;
1961 BEGIN
1962 END ;
1963 END * >=POWER * ;
1964 END ;
1965 IF procnameaddr^.pwantspl1descriptors AND
1966 is_pl1_varying_char parmctp^.vtype THEN
1967 genstand pr6 currparmw + 1 iepp3 tn
1968 ELSE
1969 genstand pr6 currparmw iepp3 tn ;
1970 genstand pr6 curritsw ispri3 tn ;
1971 curritsw := curritsw + 2 ;
1972 END * GENERIC NOT NIL * ;
1973 END * TYPTR # NILWITH GATTR * ;
1974 END * VALUE PARAMETER * ;
1975 parmctp := parmctp@.nxtel ;
1976 2 : IF parmctp <> NIL THEN * FOR SECURITY IN CASE OF ERROR SKIP CONF. ARRAY DIMS *
1977 IF parmctp^.vkind = arraybound THEN
1978 BEGIN
1979 parmctp := parmctp^.nxtel ;
1980 GOTO 2
1981 END ;
1982 IF no <> 15 THEN * NOT *
1983 BEGIN
1984 IF no <> 10 * * THEN
1985 IF parmctp <> NIL THEN
1986 BEGIN error 15 ; skip 15 ;
1987 END ;
1988 END ;
1989 UNTIL no # 15 ; * *
1990 IF no = 10 THEN
1991 insymbol ELSE
1992 BEGIN
1993 error 4 ; skip 46 ;
1994 END ;
1995 END * NO=9 * ;
1996 IF parmctp # NIL THEN
1997 error 126 ;
1998 IF itisafunct THEN
1999 BEGIN
2000 genstand pr6 fctplace DIV bytesinword iepp3 tn ;
2001 genstand pr6 curritsw ispri3 tn ;
2002 END ;
2003 IF pisformal THEN
2004 BEGIN
2005 ltag := tx7 ; ldisp := 0 ;
2006 IF plevel = level THEN
2007 lbase := pr6 ELSE
2008 BEGIN
2009 loadbase plevel ; lbase := currentpr ; freebloc currentbloc ;
2010 END ;
2011 usednameaddr := procnameaddr ;
2012 genstand lbase procplacew iepp5 tny ; * ITS ON PROC INFO *
2013 genstand pr5 2 iepp1 tny ; * PR1 = D-LINK *
2014 * NOW LOAD X7 WITH *
2015 * CODE INTERNAL-EXTERNAL CALL *
2016 genstand pr5 4 ilxl7 tn ; * OPERATOR NUMBER *
2017 genstand pr5 0 iepp5 tny ; * PROCEDURE ENTRY POINT *
2018 END * FORMAL * ELSE
2019 BEGIN
2020 ltag := tn ;
2021 IF pisext THEN
2022 ldisp := extcallplace ELSE
2023 ldisp := intcallplace ;
2024 loadlink pr1 plevel ;
2025 IF all_descriptors AND nbparm <> 0 THEN
2026 BEGIN
2027 regenere pr5bloc ;
2028 freebloc pr5bloc END ELSE
2029 BEGIN
2030 usednameaddr := procnameaddr ;
2031 genstand prlink procplacew iepp5 tny ;
2032 END ;
2033 END ;
2034 * LOAD X1 WITH *
2035 * PARAMETER LIST DISPLACEMENT *
2036 genstand pr6 deplist DIV bytesinword ieax1 tn ;
2037 * 2* NBPARPROC IN A 0..17 *
2038 genstand nreg 2048 * nbparm ifld tdl ;
2039 IF all_descriptors THEN
2040 genstand nreg nbparm * 2 ildq tdu ;
2041 genstand pr0 ldisp itsp3 ltag ;
2042 IF pisext OR envstandard <> stdpure AND pisformal THEN
2043 genstand pr6 pr4depw iepp4 tny ;
2044 1 :
2045 $OPTIONS compile = trace $
2046 IF stattrace > low THEN
2047 BEGIN
2048 write mpcogout '@@@ FIN PASSPARAMS @@@ WITH NO' no : 4 ; nextline ;
2049 END ;
2050 $OPTIONS compile = true $
2051 END * PASSPARAMS * ;
2052
2053 BEGIN
2054 END.