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 genoper ;
20 $IMPORT
21 * IMPORTED PROCEDURES *
22 'CONTEXTTABLE pascal' :
23 conformantdim,
24 create_konst_box,
25 create_vars_box,
26 create_types_box ;
27
28 'UNIQUE pascal' :
29 heaperror ;
30
31 'RACINE pascal' :
32 error,
33 nameisref,
34 nextline,
35 poweroftwo,
36 sup ;
37 'GENERE pascal' :
38 gendesca,
39 gendescb,
40 geneism,
41 genstand,
42 inser ;
43 'STATE pascal' :
44 addressvar,
45 calcvarient,
46 choicerarq,
47 entercst,
48 enterlcst,
49 enterllcst,
50 enterundlab,
51 freebloc,
52 gencheckmultover,
53 gencstecode,
54 genexceptcode,
55 getpr,
56 loadadr,
57 newbloc,
58 oldnewstor,
59 regenere,
60 raisused,
61 rqisused,
62 sauvereg,
63 stack_extension,
64 transfer ;
65 'MODVARIABLE pascal' :
66 init_desc_address ;
67
68 'MODATTR pascal ' :
69 convreal,
70 easyvar,
71 freeattr,
72 initattrvarbl,
73 isstring,
74 lvalvarbl,
75 printattr,
76 varissimple ;
77 * IMPORTED VARIABLES *
78 'DECLARE pascal' :
79 nextalf ;
80
81 'RACINE pascal' :
82 alfaptr,
83 charptr,
84 declarationpart,
85 envstandard,
86 level,
87 intptr,
88 mpcogout,
89 nilptr,
90 realptr,
91 string_ptr,
92 symbolfile,
93 symbolline,
94 symbolmap ;
95 'GENERE pascal' :
96 cb,
97 illegal_generation,
98 indfich,
99 mfari1,
100 mfari2,
101 usednameaddr ;
102 'STATE pascal' :
103 asscheck,
104 cltransf,
105 currentbloc,
106 currentpr,
107 gattr,
108 maxprused,
109 modif,
110 nilanaq,
111 nileraq,
112 opaq,
113 prinst,
114 psrsize,
115 revcltransf,
116 stattrace $
117
118 $EXPORT
119 check_dynamic_string_length,
120 gen_delete,
121 gen_insert,
122 gen_string_comp,
123 gen_substring,
124 gen_string_position,
125 genandor,
126 gencompare,
127 genconcat,
128 gendivmod,
129 genjump,
130 genopadd,
131 genopdivi,
132 genopmult,
133 genoppw,
134 genopsub,
135 genptcomp,
136 genstcomp $
137
138
139
140 $OPTIONS page $
141
142
143 $INCLUDE 'CONSTTYPE' $
144
145 * LOCAL TYPES *
146
147 string_item_info = RECORD
148 length_is_known : boolean ;
149 len_place : integer ; len_reg : preg ; * IF LENGTH OF IN MEMORY *
150 l_tag : tag ; l_val : integer ; mfari : zari ; reg_bloc, len_bloc : regpt ;
151 register : preg ;
152 bloc : regpt ; bloc_is_new : boolean ;
153 length : integer ;
154 wdisp, bdisp : integer ;
155 END ;
156
157 $OPTIONS page $
158
159 VAR
160
161 * REDEFINE IMPORTED VARIABLES *
162 * FROM DECLARE *
163 nextalf : ctp ;
164
165 * FROM RACINE *
166 alfaptr : ctp ;
167 charptr : ctp ;
168 declarationpart : boolean ;
169 envstandard : stdkind ;
170 intptr : ctp ;
171 level : levrange ;
172 mpcogout : text ;
173 nilptr : ctp ;
174 realptr : ctp ;
175 string_ptr : ctp ;
176 symbolfile, symbolline : integer ;
177 symbolmap : boolean ;
178
179 * FROM GENERE *
180 cb : integer ;
181 illegal_generation : boolean ;
182 indfich : integer ;
183 mfari1 : zari ;
184 mfari2 : zari ;
185 usednameaddr : ctp ;
186
187
188 * FROM STATE *
189 asscheck : boolean ;
190 cltransf : ARRAY 1..6 OF integer ; * GIVES THE TRANSF CORR. TO OPER. 8CL *
191 currentbloc : regpt ;
192 currentpr : preg ;
193 gattr : attr ;
194 modif : ARRAY nxreg..rq OF tag ;
195 maxprused : preg ;
196 opaq : ARRAY typeofop ra..reaq OF istand ;
197 prinst : ARRAY epp..lprp pr1..pr6 OF istand ;
198 nilanaq,
199 nileraq : setarray ; * USED FOR NIL COMPARISONS *
200 psrsize : integer ; * USEFULL SIZE OF PSR *
201 revcltransf : ARRAY 1..6 OF integer ; * GIVES 8CL --> REVERSE TRANSF *
202 stattrace : levtrace ;
203
204 * ************************** VARIABLES DE GENOPER *
205
206 clearpt : setarray ; * Masque de nettoyage du numero de ring dans
207 GENPTCOMP *
208
209
210
211
212 $OPTIONS page $
213
214 $OPTIONS page $
215
216 $VALUE
217
218 clearpt = '777777077777'o '777777777777'o 6 * 0 ;
219
220 $
221
222 * REDEFINE IMPORTED PROCEDURES *
223 * FROM GENERE *
224 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
225 PROCEDURE geneism fcode : ieism ; ffield : integer ; fbits : zptr ; EXTERNAL ;
226 PROCEDURE gendesca fareg : preg ; fadr fcn : integer ; fta : lgcar ;
227 fn : integer ; frlgth : mreg ; EXTERNAL ;
228 PROCEDURE gendescb fareg : preg ; fadr fc fb : integer ; fn : integer ;
229 frlgth : mreg ; EXTERNAL ;
230 PROCEDURE inser fcb : integer ; fplace : integer ; EXTERNAL ;
231
232
233 * FROM CONTEXTTABLE *
234
235 PROCEDURE create_konst_box VAR box : ctp ; fname : alfaid ; typeofconst : consttype ; EXTERNAL ;
236 PROCEDURE create_types_box VAR tp : ctp ; fname : alfaid ; form : typform ; bool : boolean ; EXTERNAL ;
237 PROCEDURE create_vars_box VAR tp : ctp ; name : alfaid ; EXTERNAL ;
238 FUNCTION conformantdim ftp : ctp : boolean ; EXTERNAL ;
239
240 * FROM UNIQUE *
241
242 PROCEDURE heaperror ; EXTERNAL ;
243
244 * FROM RACINE *
245 PROCEDURE error errno : integer ; EXTERNAL ;
246 PROCEDURE nameisref ctpt : ctp ; fil lin : integer ; EXTERNAL ;
247 PROCEDURE nextline ; EXTERNAL ;
248 FUNCTION poweroftwo fval : integer : integer ; EXTERNAL ;
249 FUNCTION sup fval1 fval2 : integer : integer ; EXTERNAL ;
250
251
252
253
254 * FROM STATE *
255 PROCEDURE choicerarq ; EXTERNAL ;
256 PROCEDURE enterundlab VAR fundinx : integer ; EXTERNAL ;
257 PROCEDURE stack_extension ; EXTERNAL ;
258 PROCEDURE transfer VAR fattr : attr ; inwhat : destination ; EXTERNAL ;
259 PROCEDURE freebloc VAR fbtofree : regpt ; EXTERNAL ;
260 PROCEDURE genexceptcode errcode : integer ; freg : register ; EXTERNAL ;
261 PROCEDURE getpr ; EXTERNAL ;
262 PROCEDURE loadadr VAR fattr : attr ; wantedpr : preg ; EXTERNAL ;
263 PROCEDURE newbloc freg : register ; EXTERNAL ;
264 FUNCTION oldnewstor i : integer : integer ; EXTERNAL ;
265 PROCEDURE regenere oldbloc : regpt ; EXTERNAL ;
266 PROCEDURE addressvar fctp : ctp ; VAR fattr : attr ; modif : boolean ; EXTERNAL ;
267 PROCEDURE calcvarient VAR fattr : attr ; VAR fbase : preg ; VAR fdisp : integer ;
268 VAR ftag : tag ; EXTERNAL ;
269 PROCEDURE sauvereg freg : register ; fload : boolean ; EXTERNAL ;
270 PROCEDURE entercst fval : integer ; VAR box : wcstpt ; EXTERNAL ;
271 PROCEDURE enterlcst VAR fval : setarray ; VAR fboxpt : lcstpt ; EXTERNAL ;
272 PROCEDURE enterllcst VAR fval : setarray ; VAR fboxpt : llcstpt ; EXTERNAL ;
273 FUNCTION raisused : boolean ; EXTERNAL ;
274 FUNCTION rqisused : boolean ; EXTERNAL ;
275 PROCEDURE gencheckmultover ; EXTERNAL ;
276 PROCEDURE gencstecode i : integer ; finst : istand ; EXTERNAL ;
277
278 * FROM MODVARIABLE *
279 PROCEDURE init_desc_address ctpt : ctp ; VAR fattr : attr ; EXTERNAL ;
280
281 * FROM MODATTR *
282
283 PROCEDURE convreal VAR fattr : attr ; EXTERNAL ;
284 PROCEDURE printattr VAR fattr : attr ; EXTERNAL ;
285 PROCEDURE initattrvarbl VAR fattr : attr ; EXTERNAL ;
286 FUNCTION isstring VAR fattr : attr : boolean ; EXTERNAL ;
287 PROCEDURE lvalvarbl VAR fattr : attr ; EXTERNAL ;
288 FUNCTION easyvar VAR fattr : attr : boolean ; EXTERNAL ;
289 FUNCTION varissimple VAR fattr : attr : boolean ; EXTERNAL ;
290 PROCEDURE freeattr VAR fattr : attr ; EXTERNAL ;
291
292
293 $OPTIONS page $
294
295
296 $OPTIONS page $
297
298 FUNCTION int_op op : integer ; int_left int_right : integer : integer ;
299
300 * C THIS PROCEDURE COMPUTESC THE RESULT OF OPERATION APPLIEDC TOC TWO
301 GIVEN INTEGER OPERANDS
302 IT CHECKS INTEGER OVERFLOW OR UNDERFLOW C *
303
304 * E
305 ERROR DETECTED :
306 228 : OVERFLOW IN INTGER EXPRESSION
307 229 UNDERFLOW IN INTEGER EXPRESSION
308 E *
309
310 VAR
311 f_left, f_right, f_res : real ;
312 f_min, f_max : real ;
313
314 BEGIN
315 int_op := 0 ;
316 f_max := maxint ; f_min := -maxint - 1 ;
317 f_left := int_left ; f_right := int_right ;
318 CASE op OF
319 1 : f_res := f_left * f_right ;
320 2 : f_res := f_left / f_right ;
321 3 : f_res := f_left + f_right ;
322 4 : f_res := f_left - f_right ;
323 END ;
324 IF f_res > f_max THEN error 228 ELSE
325 IF f_res < f_min THEN error 229 ELSE
326 int_op := trunc f_res ;
327 END * INT_OP * ;
328 $OPTIONS page $
329
330 * ************************************ GENOPADD ****************************** *
331
332 PROCEDURE genopadd VAR fattr : attr ; generic : ctp ;
333
334 * C . GATTR DESCRIBES THE RIGHT OPERAND
335 FATTR " " LEFT
336 . GENERIC IS GENERIC-TYPE NUMERIC OR REAL
337 . AT OUTPUT .GATTR DESCRIBES RESULT
338 .ADDITION IS GENERATED
339 C *
340 * E ERRORS DETECTED
341 432: TYPSEQ 0 ==> CHOICE ERROR
342 E *
343 VAR
344 tattr, * TRANSFERED ATTR *
345 cattr : attr ; * ADRESSED ATTR *
346 typseq : integer ; * SEQUENCE CODE *
347 lbase : preg ;
348 ldisp : integer ;
349 ltag : tag ;
350 linst : istand ;
351 BEGIN * GENOPADD *
352 $OPTIONS compile = trace $
353 IF stattrace > none THEN
354 BEGIN
355 write mpcogout '@@@ DEBUT GENOPADD @@@' ; nextline ;
356 END ;
357 $OPTIONS compile = true $
358 typseq := 0 ;
359 IF fattr.kind = sval THEN
360 IF fattr.typtr = realptr THEN
361 BEGIN
362 IF fattr.rsval = 0 THEN typseq := 4 ;
363 END ELSE
364 BEGIN
365 IF fattr.val = 0 THEN typseq := 4 ;
366 END
367 ELSE
368 IF gattr.kind = sval THEN
369 IF gattr.typtr = realptr THEN
370 BEGIN
371 IF gattr.rsval = 0 THEN typseq := 3 ;
372 END ELSE
373 BEGIN
374 IF gattr.val = 0 THEN typseq := 3 ;
375 END ;
376 IF typseq = 0 THEN
377 BEGIN
378 IF generic = realptr THEN
379 BEGIN
380 IF fattr.typtr # realptr THEN
381 convreal fattr ELSE
382 IF gattr.typtr # realptr THEN
383 convreal gattr ;
384 linst := idfad ;
385 END * REAL * ELSE
386 linst := iada ;
387 IF fattr.kind = lval THEN
388 lvalvarbl fattr ;
389 WITH gattr DO
390 CASE fattr.kind OF
391 varbl : BEGIN typseq := 2 ;
392 IF kind = lval THEN
393 IF ldreg = rq THEN typseq := 10 ;
394 END ;
395 sval : CASE kind OF
396 varbl : typseq := 2 ;
397 lval : IF ldreg = rq THEN typseq := 10 ELSE typseq := 2 ;
398 sval : BEGIN
399 typseq := 2 ;
400 IF generic = realptr THEN
401 BEGIN
402 IF abs fattr.rsval < maxint THEN
403 IF abs rsval < maxint THEN
404 IF abs rsval >= 1 THEN
405 typseq := 12 ;
406 END ELSE
407 typseq := 12 ;
408 END * SVAL * ;
409 END * CASE GATTR.KIND FOR FATTR SVAL * ;
410 lval : CASE fattr.ldreg OF
411 ra : IF kind = varbl THEN
412 IF easyvar gattr THEN typseq := 1 ELSE typseq := 2
413 ELSE
414 IF kind = sval THEN
415 typseq := 1 ELSE
416 typseq := 13 ;
417 rq :
418 IF gattr.kind = varbl THEN
419 IF easyvar gattr THEN typseq := 9 ELSE typseq := 10
420 ELSE
421 IF gattr.kind = lval THEN typseq := 14 ELSE typseq := 9 ;
422 reaq : typseq := 1 ;
423 END * CASE FATTR.LDREG * ;
424 END * CASE FATTR.KIND * ;
425 END * TYPSEQ=0 * ;
426 IF odd typseq THEN
427 BEGIN
428 tattr := fattr ; cattr := gattr ;
429 END ELSE
430 BEGIN
431 tattr := gattr ; cattr := fattr ;
432 END ;
433 IF declarationpart AND
434 NOT typseq IN 0 3 4 12 THEN
435 BEGIN
436 illegal_generation := true ;
437 tattr.typtr := NIL ;
438 END
439 ELSE
440 CASE typseq OF
441 0 :
442 $OPTIONS compile = security $
443 error 432
444 $OPTIONS compile = true $
445 ;
446 1, 2 : BEGIN transfer tattr inacc ;
447 calcvarient cattr lbase ldisp ltag ;
448 WITH cattr DO
449 IF kind = varbl THEN usednameaddr := nameaddr ;
450 genstand lbase ldisp linst ltag ;
451 END * 12 * ;
452 3, 4 : IF generic = realptr THEN
453 IF tattr.typtr # realptr THEN convreal tattr ;
454 9, 10 : BEGIN transfer tattr inq ;
455 calcvarient cattr lbase ldisp ltag ;
456 WITH cattr DO
457 IF kind = varbl THEN usednameaddr := nameaddr ;
458 genstand lbase ldisp iadq ltag ;
459 END * 910 * ;
460 12 : IF generic = realptr THEN tattr.rsval := cattr.rsval + tattr.rsval ELSE
461 tattr.val := int_op 3 cattr.val tattr.val * ADD * ;
462 13, 14 : BEGIN genstand pr6 evareaw istq tn ; freeattr cattr ;
463 genstand pr6 evareaw iada tn ;
464 END * 1314 * ;
465 END * CASE TYPSEQ * ;
466 gattr := tattr ;
467 $OPTIONS compile = trace $
468 IF stattrace > low THEN
469 BEGIN
470 write mpcogout '@@@ FIN GENOPADD @@@ WITH TYPSEQ:' typseq : 4 ; nextline ;
471 END ;
472 $OPTIONS compile = true $
473 END * GENOPADD * ;
474
475
476 $OPTIONS page $
477
478 * ************************************ GENOPSUB ****************************** *
479
480 PROCEDURE genopsub VAR fattr : attr ; generic : ctp ;
481
482 * C . GENERATES A SUBSTRACTION NOT COMMUTATIVE
483 . FATTR LEFT OPERAND
484 . GATTR RIGHT OPERAND
485 * RETURNS GATTR.
486 C *
487 * E ERRORS DETECTED
488 303 : VALUE OUT OF RANGE
489 433 : TYPSEQ IS ZERO.
490 E *
491 VAR
492 linst, linstq, lneg : istand ;
493 lbase : preg ;
494 typseq, ldisp : integer ;
495 ltag : tag ;
496 rev : boolean ;
497 BEGIN * GENOPSUB *
498 $OPTIONS compile = trace $
499 IF stattrace > none THEN
500 BEGIN
501 write mpcogout '@@@ DEBUT GENOPSUB @@@' ; nextline ;
502 END ;
503 $OPTIONS compile = true $
504 typseq := 0 ;
505 WITH gattr DO
506 IF kind = sval THEN
507 BEGIN
508 IF typtr = realptr THEN
509 BEGIN
510 IF rsval = 0 THEN typseq := 3 ;
511 END ELSE
512 IF val = 0 THEN typseq := 3 ;
513 END ;
514 IF typseq = 0 THEN
515 BEGIN
516 IF generic = realptr THEN
517 BEGIN
518 linst := idfsb ; lneg := ifneg ;
519 IF fattr.typtr # realptr THEN
520 convreal fattr ELSE
521 IF gattr.typtr # realptr THEN
522 convreal gattr ;
523 END ELSE
524 BEGIN
525 linst := isba ; lneg := ineg ; linstq := isbq ;
526 IF gattr.kind = sval THEN
527 BEGIN
528 IF gattr.val # - maxint - 1 AND gattr.val < 0 THEN
529 BEGIN
530 gattr.val := -gattr.val ; linst := iada ; linstq := iadq ; rev := true ;
531 END ELSE rev := false ;
532 END ;
533 END ;
534 IF fattr.kind = lval THEN
535 lvalvarbl fattr ;
536 WITH gattr DO
537 CASE fattr.kind OF
538 varbl : CASE kind OF
539 lval : typseq := 2 ;
540 varbl : IF easyvar gattr THEN typseq := 1 ELSE typseq := 2 ;
541 sval : typseq := 1 ;
542 END * GATTR.KIND FOR FATTR VARBL * ;
543 sval : IF generic # realptr THEN
544 BEGIN
545 IF fattr.val = 0 THEN
546 BEGIN
547 IF kind = sval THEN
548 BEGIN
549 IF val = -maxint - 1 THEN error 303 ELSE typseq := 12 ;
550 END ELSE
551 IF kind = varbl THEN
552 BEGIN
553 IF easyvar gattr THEN typseq := 16 ELSE typseq := 30 ;
554 END ELSE
555 typseq := 30 ;
556 END * FATTR.VAL = 0 * ELSE
557 BEGIN
558 CASE kind OF
559 varbl : IF easyvar gattr THEN typseq := 1 ELSE typseq := 2 ;
560 lval : typseq := 2 ;
561 sval : typseq := 12 ;
562 END * CASE KIND * ;
563 END * FATTR.VAL # 0 * ;
564 END * GENERIC # REALPTR * ELSE
565 BEGIN * = REAL *
566 IF fattr.rsval = 0 THEN
567 IF kind = sval THEN typseq := 12 ELSE typseq := 30
568 * #0 * ELSE
569 CASE kind OF
570 varbl : IF easyvar gattr THEN typseq := 1 ELSE typseq := 2 ;
571 lval : typseq := 2 ;
572 sval : BEGIN typseq := 1 ;
573 IF abs rsval < maxint THEN
574 IF abs rsval >= 1 THEN
575 IF abs fattr.rsval < maxint THEN typseq := 12 ;
576 END ;
577 END * CASE KIND * ;
578 END * GENERIC=REALPTR * ;
579 * END SVAL *
580 lval : CASE fattr.ldreg OF
581 reaq : typseq := 1 ;
582 ra : CASE kind OF
583 varbl : IF easyvar gattr THEN typseq := 1 ELSE typseq := 2 ;
584 sval : typseq := 1 ;
585 lval : typseq := 13 ;
586 END ;
587 rq : CASE kind OF
588 varbl : IF easyvar gattr THEN typseq := 9 ELSE typseq := 32 ;
589 sval : typseq := 9 ;
590 lval : typseq := 15 ;
591 END ;
592 END * CASE FATTR.LDREG * ;
593 END * CASE FATTR.KINDWITH GATTR * ;
594 END * TYPSEQ= 0 * ;
595 IF declarationpart AND
596 NOT typseq IN 0 3 4 12 THEN
597 BEGIN
598 illegal_generation := true ;
599 fattr.typtr := NIL ;
600 END
601 ELSE
602 CASE typseq OF
603 0 :
604 $OPTIONS compile = security $
605 error 433
606 $OPTIONS compile = true $
607 ;
608 1 : BEGIN transfer fattr inacc ;
609 calcvarient gattr lbase ldisp ltag ;
610 WITH gattr DO
611 IF kind = varbl THEN usednameaddr := nameaddr ;
612 genstand lbase ldisp linst ltag ;
613 END ; * 1 *
614 2 : BEGIN transfer gattr inacc ;
615 calcvarient fattr lbase ldisp ltag ;
616 WITH fattr DO
617 IF kind = varbl THEN usednameaddr := nameaddr ;
618 genstand lbase ldisp linst ltag ;
619 genstand nreg 0 lneg tn ;
620 END * 2 * ;
621 3 : IF generic = realptr THEN
622 IF fattr.typtr # realptr THEN convreal fattr ;
623 9 : BEGIN transfer fattr inq ;
624 calcvarient gattr lbase ldisp ltag ;
625 WITH gattr DO
626 IF kind = varbl THEN usednameaddr := nameaddr ;
627 genstand lbase ldisp linstq ltag ;
628 END * 9 * ;
629 12 :
630 IF generic = realptr THEN
631 gattr.rsval := fattr.rsval - gattr.rsval ELSE
632 IF rev THEN
633 gattr.val := int_op 3 fattr.val gattr.val ELSE * ADD *
634 gattr.val := int_op 4 fattr.val gattr.val ; * SUB *
635 13 : BEGIN genstand pr6 evareaw istq tn ; freeattr gattr ;
636 genstand pr6 evareaw isba tn ;
637 END ;
638 15 : BEGIN genstand pr6 evareaw ista tn ; freeattr gattr ;
639 genstand pr6 evareaw isbq tn ;
640 END * 15 * ;
641 16 : BEGIN calcvarient gattr lbase ldisp ltag ;
642 WITH gattr DO
643 BEGIN
644 IF NOT rqisused THEN
645 BEGIN ldreg := rq ; linst := ilcq ;
646 END ELSE
647 BEGIN ldreg := ra ; linst := ilca ;
648 END ;
649 sauvereg ldreg true ;
650 ldregbloc := currentbloc ;
651 END ;
652 WITH gattr DO
653 IF kind = varbl THEN usednameaddr := nameaddr ;
654 genstand lbase ldisp linst ltag ;
655 gattr.kind := lval ;
656 END * 16 * ;
657 30 : BEGIN transfer gattr inacc ;
658 genstand nreg 0 lneg tn ;
659 END * 30 * ;
660 32 : BEGIN transfer gattr inacc ;
661 sauvereg rq false ;
662 calcvarient fattr lbase ldisp ltag ;
663 WITH fattr DO
664 IF kind = varbl THEN usednameaddr := nameaddr ;
665 genstand lbase ldisp linst ltag ;
666 genstand nreg 0 lneg tn ;
667 END * 32 * ;
668 END * CASE TYPSEQ * ;
669 IF odd typseq THEN
670 gattr := fattr ;
671 $OPTIONS compile = trace $
672 IF stattrace > low THEN
673 BEGIN
674 write mpcogout '@@@ FIN GENOPSUB @@@ WITH TYPSEQ' typseq : 4 ; nextline ;
675 END ;
676 $OPTIONS compile = true $
677 END * GENOPSUB * ;
678
679
680 $OPTIONS page $
681
682 * ************************************ GENANDOR ****************************** *
683
684 PROCEDURE genandor VAR fattr : attr ; fno : integer ;
685
686 * C .CODE GENERATION FOR OPERATIONS "AND" FNO=6 ON BOOLEAN.
687 "OR" FNO=7
688 .FATTR DESCRIBES LEFT OPERAND
689 .GATTR DESCRIBES RIGHT OPERAND
690 * RETURNS A GATTR.
691 C *
692 VAR
693 typseq, ldisp : integer ;
694 cattr, tattr : attr ;
695 lbase : preg ;
696 ltag : tag ;
697 isand : boolean ;
698 insta, instq : istand ;
699 BEGIN * GENANDOR *
700 $OPTIONS compile = trace $
701 IF stattrace > none THEN
702 BEGIN
703 write mpcogout '@@@ DEBUT GENANDOR @@@ WITH FNO' fno : 4 ; nextline ;
704 END ;
705 $OPTIONS compile = true $
706 isand := fno = 6 ;
707 IF isand THEN
708 BEGIN
709 insta := iana ; instq := ianq ;
710 END ELSE
711 BEGIN * OR *
712 insta := iora ; instq := iorq ;
713 END ;
714 IF gattr.kind = lcond THEN choicerarq ;
715 IF fattr.kind = lval THEN lvalvarbl fattr ;
716 WITH gattr DO
717 IF kind = sval THEN
718 BEGIN
719 IF val = ord false THEN
720 typseq := 3 + ord isand
721 ELSE
722 typseq := 4 - ord isand
723 END ELSE
724 IF fattr.kind = sval THEN
725 BEGIN
726 IF fattr.val = ord false THEN
727 typseq := 4 - ord isand ELSE
728 typseq := 3 + ord isand ;
729 END ELSE
730 IF kind = varbl THEN
731 BEGIN
732 IF easyvar gattr THEN
733 BEGIN
734 typseq := 1 ;
735 IF fattr.kind = lval THEN
736 IF fattr.ldreg # ra THEN
737 typseq := 9 ;
738 END ELSE
739 BEGIN
740 typseq := 2 ;
741 IF fattr.kind = lval THEN
742 IF fattr.ldreg # ra THEN
743 typseq := 10 ;
744 END * NOT EASYVAR * ;
745 END * GATTR.KIND=VARBL * ELSE
746 * GATTR LVAL *
747 IF ldreg = ra THEN
748 IF fattr.kind = varbl THEN typseq := 2 ELSE typseq := 14 * END RA * ELSE
749 * RQ *
750 IF fattr.kind = varbl THEN typseq := 10 ELSE typseq := 13 ;
751 IF odd typseq THEN
752 BEGIN
753 tattr := fattr ; cattr := gattr ;
754 END ELSE
755 BEGIN
756 tattr := gattr ; cattr := fattr ;
757 END ;
758 CASE typseq OF
759 1, 2 : BEGIN transfer tattr inacc ;
760 calcvarient cattr lbase ldisp ltag ;
761 WITH cattr DO
762 IF kind = varbl THEN usednameaddr := nameaddr ;
763 genstand lbase ldisp insta ltag ;
764 END * 12 * ;
765 3, 4 : BEGIN freeattr cattr ;
766 END * 34 * ;
767 9, 10 : BEGIN transfer tattr inq ;
768 calcvarient cattr lbase ldisp ltag ;
769 WITH cattr DO
770 IF kind = varbl THEN usednameaddr := nameaddr ;
771 genstand lbase ldisp instq ltag ;
772 END * 910 * ;
773 13, 14 : BEGIN genstand pr6 evareaw istq tn ; freeattr cattr ;
774 genstand pr6 evareaw insta tn ;
775 END * 1314 * ;
776 END * CASE TYPSEQ * ;
777 gattr := tattr ;
778 $OPTIONS compile = trace $
779 IF stattrace > low THEN
780 BEGIN
781 write mpcogout '@@@ FIN GENANDOR @@@ WITH TYPSEQ:' typseq : 4 ; nextline ;
782 END ;
783 $OPTIONS compile = true $
784 END * GENANDOR * ;
785
786
787 $OPTIONS page $
788
789 * ************************************ GENOPDIVI ***************************** *
790
791 PROCEDURE genopdivi VAR fattr : attr ;
792
793 * C BEFORE CALL FATTR GATTR ARE REAL
794 DIVCHECKS ALREADY MADE
795 AT OUTPUT BUILDS GATTR. GENERATES DIVISION
796 FATTR CAN BE
797 ESAY 8 RSVAL EAQ
798 GATTR CAN BE
799 EASY 8 NOT EASY 8 RSVAL EAQ
800 C *
801 * E ERRORS DETECTED
802 300: ZERO DIVIDE CAN BE NOT SUITABLE
803 E *
804 VAR
805 typseq, ldisp : integer ;
806 lbase : preg ;
807 ltag : tag ;
808 BEGIN * GENOPDIVI *
809 $OPTIONS compile = trace $
810 IF stattrace > none THEN
811 BEGIN
812 write mpcogout '@@@ DEBUT GENOPDIVI @@@' ; nextline ;
813 END ;
814 $OPTIONS compile = true $
815 IF gattr.kind = sval THEN
816 BEGIN
817 IF gattr.rsval = 0 THEN
818 typseq := 0 ELSE
819 IF gattr.rsval = 1.0 THEN
820 typseq := 3 ELSE
821 BEGIN
822 IF fattr.kind = sval THEN
823 BEGIN
824 IF fattr.rsval = 0.0 THEN
825 typseq := 3 ELSE
826 BEGIN
827 typseq := 1 ;
828 IF abs gattr.rsval >= 1 THEN
829 IF abs gattr.rsval < maxint THEN IF abs fattr.rsval >= 1 THEN
830 IF abs fattr.rsval < maxint THEN typseq := 12 ;
831 END ;
832 END * FATTR.SVAL * ELSE
833 typseq := 1 ;
834 END ;
835 END * GATTR SVAL * ELSE
836 BEGIN
837 IF fattr.kind = lval THEN
838 lvalvarbl fattr ;
839 CASE fattr.kind OF
840 varbl : typseq := 2 ;
841 lval : typseq := 1 ;
842 sval : IF fattr.rsval = 0.0 THEN
843 typseq := 3 ELSE
844 typseq := 2 ;
845 END * CASE * ;
846 END * GATTR ^=SVAL * ;
847 CASE typseq OF
848 0 : error 300 ;
849 1 : BEGIN
850 transfer fattr inacc ;
851 calcvarient gattr lbase ldisp ltag ;
852 WITH gattr DO
853 IF kind = varbl THEN usednameaddr := nameaddr ;
854 genstand lbase ldisp idfdv ltag ;
855 gattr := fattr ;
856 END ;
857 2 : BEGIN
858 transfer gattr inacc ;
859 calcvarient fattr lbase ldisp ltag ;
860 WITH fattr DO
861 IF kind = varbl THEN usednameaddr := nameaddr ;
862 genstand lbase ldisp idfdi ltag ;
863 * GATTR UNCHANGED *
864 END ;
865 3 : BEGIN freeattr gattr ;
866 gattr := fattr ;
867 END ;
868 12 : gattr.rsval := fattr.rsval / gattr.rsval ;
869 END * CASE TYPSEQ * ;
870 $OPTIONS compile = trace $
871 IF stattrace > low THEN
872 BEGIN
873 write mpcogout '@@@ FIN GENOPDIVI @@@ WITH TYPSEQ' typseq : 4 ; nextline ;
874 END ;
875 $OPTIONS compile = true $
876 END * GENOPDIVI * ;
877
878
879 $OPTIONS page $
880
881 * ************************************ GENDIVMOD ***************************** *
882
883 PROCEDURE gendivmod VAR fattr : attr ; fcl : integer ;
884
885 * C .CODE GENERATION FOR DIV MOD ON NUMERIC OPERANDS
886 FCL=4 ==> DIV
887 FCL=5 ==> MOD
888 .FATTR IS LEFT OPERAND GATTR RIGHT OPERAND
889 .SPECIAL CASES SVAL 012**N
890 . Q OPERAND DIV Y OPERAND ==> QUOTIENT IN Q
891 REMAINDER IN A
892 . RETURNS GATTR
893 C *
894 * E ERRORS DETECTED
895 308 : RIGHT ARGUMENT OF DIV IS NULL
896 309 : RIGHT ARGUMENT OF MOD IS NEGATIVE OR NULL
897 E *
898 VAR
899 locskip, typseq, ldisp : integer ;
900 ismod : boolean ;
901 lbase : preg ;
902 ltag : tag ;
903 BEGIN * GENDIVMOD *
904 $OPTIONS compile = trace $
905 IF stattrace > none THEN
906 BEGIN
907 write mpcogout '@@@ DEBUT GENDIVMOD @@@ WITH FCL' fcl : 4 ; nextline ;
908 END ;
909 $OPTIONS compile = true $
910 ismod := fcl = 5 ;
911 IF fattr.kind = lval THEN
912 lvalvarbl fattr ;
913 WITH gattr DO
914 CASE fattr.kind OF
915 varbl : CASE kind OF
916 varbl : IF easyvar gattr THEN typseq := 25 ELSE typseq := 32 ;
917 lval : typseq := 25 ;
918 sval : IF ismod THEN
919 IF val <= 0 THEN typseq := 1
920 ELSE typseq := 25
921 ELSE IF val = 0 THEN typseq := 0
922 ELSE IF val = 1 THEN typseq := 3 ELSE typseq := 25 ;
923 END ;
924 sval : IF kind = sval THEN
925 IF ismod THEN
926 IF val <= 0 THEN typseq := 1
927 ELSE IF fattr.val = 0 THEN typseq := 3 ELSE typseq := 12
928 ELSE IF val = 0 THEN typseq := 0
929 ELSE IF fattr.val = 0 THEN typseq := 3 ELSE typseq := 12
930 ELSE IF fattr.val = 0 THEN typseq := 3
931 ELSE IF kind = varbl THEN
932 IF easyvar gattr THEN typseq := 25 ELSE typseq := 32
933 ELSE typseq := 25 ;
934 lval : CASE kind OF
935 varbl : IF easyvar gattr THEN typseq := 25
936 ELSE IF fattr.ldreg = ra THEN typseq := 27 ELSE typseq := 32 ;
937 sval : IF ismod THEN
938 IF val <= 0 THEN typseq := 1 ELSE typseq := 25
939 ELSE IF val = 0 THEN typseq := 0
940 ELSE IF val = 1 THEN typseq := 3 ELSE typseq := 25 ;
941 lval : IF ldreg = rq THEN typseq := 27 ELSE typseq := 25 ;
942 END ;
943 END ;
944 CASE typseq OF
945 0 : error 308 ;
946 1 : error 309 ;
947 3 : freeattr gattr ;
948 12 : IF ismod THEN
949 fattr.val := fattr.val MOD gattr.val ELSE
950 fattr.val := fattr.val DIV gattr.val ;
951 25 : BEGIN
952 * Temporary correction of a bug 25= Sequence 32 *
953 * A ameliorer plus tard *
954 transfer gattr inacc ;
955 sauvereg ra false ;
956 IF fattr.kind = lval THEN lvalvarbl fattr ;
957 transfer fattr inq ;
958 calcvarient gattr lbase ldisp ltag ;
959 WITH gattr DO
960 IF kind = varbl THEN usednameaddr := nameaddr ;
961 genstand lbase ldisp idiv ltag ;
962 IF ismod THEN
963 BEGIN
964 genstand nreg bitsinword ilrs tn ;
965 locskip := indfich ;
966 genstand nreg 0 itpl tic ;
967 calcvarient gattr lbase ldisp ltag ;
968 WITH gattr DO
969 IF kind = varbl THEN usednameaddr := nameaddr ;
970 genstand lbase ldisp iadq ltag ;
971 inser cb locskip ;
972 END ;
973 END * 25 * ;
974 27 : BEGIN transfer gattr inq ; transfer fattr inq ;
975 calcvarient gattr lbase ldisp ltag ;
976 WITH gattr DO
977 IF kind = varbl THEN usednameaddr := nameaddr ;
978 genstand lbase ldisp idiv ltag ;
979 IF ismod THEN
980 BEGIN
981 genstand nreg bitsinword ilrs tn ;
982 locskip := indfich ;
983 genstand nreg 0 itpl tic ;
984 calcvarient gattr lbase ldisp ltag ; * NOT NECESSARY *
985 WITH gattr DO
986 IF kind = varbl THEN usednameaddr := nameaddr ;
987 genstand lbase ldisp iadq ltag ;
988 inser cb locskip ;
989 END ;
990 END * 27 * ;
991 32 : BEGIN transfer gattr inacc ; sauvereg ra false ; transfer fattr inq ;
992 calcvarient gattr lbase ldisp ltag ;
993 WITH gattr DO
994 IF kind = varbl THEN usednameaddr := nameaddr ;
995 genstand lbase ldisp idiv ltag ;
996 IF ismod THEN
997 BEGIN
998 genstand nreg bitsinword ilrs tn ;
999 locskip := indfich ;
1000 genstand nreg 0 itpl tic ;
1001 calcvarient gattr lbase ldisp ltag ; * NOT NECESSARY *
1002 WITH gattr DO
1003 IF kind = varbl THEN usednameaddr := nameaddr ;
1004 genstand lbase ldisp iadq ltag ;
1005 inser cb locskip ;
1006 END ;
1007 END * 32 * ;
1008 END * CASE TYPSEQ * ;
1009 gattr := fattr ;
1010 $OPTIONS compile = trace $
1011 IF stattrace > low THEN
1012 BEGIN
1013 write mpcogout '@@@ FIN GENDIVMOD @@@ WITH TYPSEQ' typseq : 4 ; nextline ;
1014 END ;
1015 $OPTIONS compile = true $
1016 END * GENDIVMOD * ;
1017
1018
1019 $OPTIONS page $
1020
1021 * ************************************ GENOPMULT ***************************** *
1022
1023 PROCEDURE genopmult VAR fattr : attr ; generic : ctp ;
1024
1025 * C *CODE GENERATION FOR A MULTIPLICATION
1026 .SPECIAL CASES SVAL 01 2**N
1027 FATTR IS LEFT OPERAND
1028 GATTR IS RIGHT OPERAND
1029 *RETURNS GATTR
1030 C *
1031 * E ERRORS DETECTED
1032 419: TYPSEQ IS 0
1033 E *
1034 VAR
1035 typseq, itl, itg, ldisp, nbshif : integer ;
1036 ltag : tag ;
1037 lbase : preg ;
1038 isreal : boolean ;
1039 linst : istand ;
1040 tattr, cattr : attr ;
1041 BEGIN * GENOPMULT *
1042 $OPTIONS compile = trace $
1043 IF stattrace > none THEN
1044 BEGIN
1045 write mpcogout '@@@ DEBUT GENOPMULT @@@' ; nextline ;
1046 END ;
1047 $OPTIONS compile = true $
1048 typseq := 0 ; itg := 0 ; itl := 0 ;
1049 IF fattr.kind = sval THEN
1050 WITH fattr DO
1051 BEGIN
1052 IF typtr = realptr THEN
1053 BEGIN
1054 IF rsval = 0 THEN typseq := 3 ELSE
1055 IF rsval = 1 THEN typseq := 4
1056 END ELSE
1057 IF val = 0 THEN typseq := 3 ELSE
1058 IF val = 1 THEN typseq := 4 ELSE
1059 itl := poweroftwo val ;
1060 END * WITH FATTR FATTR.KIND=SVAL * ELSE
1061 IF gattr.kind = sval THEN
1062 WITH gattr DO
1063 BEGIN
1064 IF typtr = realptr THEN
1065 BEGIN
1066 IF rsval = 0 THEN typseq := 4 ELSE
1067 IF rsval = 1 THEN typseq := 3
1068 END ELSE
1069 IF val = 0 THEN typseq := 4 ELSE
1070 IF val = 1 THEN typseq := 3 ELSE
1071 itg := poweroftwo val ;
1072 END * WITH GATTR GATTR.KIND=SVAL * ;
1073 IF typseq = 0 THEN
1074 BEGIN
1075 IF generic = realptr THEN
1076 BEGIN
1077 IF fattr.typtr # realptr THEN
1078 convreal fattr ELSE
1079 IF gattr.typtr # realptr THEN
1080 convreal gattr ;
1081 linst := idfmp ;
1082 END * REALPTR * ELSE
1083 linst := impy ;
1084 IF fattr.kind = lval THEN
1085 lvalvarbl fattr ;
1086 isreal := generic = realptr ;
1087 WITH gattr DO
1088 CASE fattr.kind OF
1089 varbl : IF NOT isreal THEN
1090 BEGIN
1091 IF itg > 0 THEN
1092 IF NOT rqisused THEN typseq := 33 ELSE typseq := 29
1093 ELSE
1094 typseq := 36
1095 END * NOT REAL * ELSE
1096 typseq := 2 ;
1097 sval : IF isreal THEN
1098 BEGIN
1099 typseq := 2 ;
1100 IF kind = sval THEN
1101 IF abs rsval >= 1 THEN
1102 IF abs rsval < maxint THEN
1103 IF abs fattr.rsval < maxint THEN typseq := 12 ;
1104 END * ISREAL * ELSE
1105 BEGIN * NOT REAL *
1106 IF kind = sval THEN
1107 BEGIN
1108 typseq := 12 ;
1109 END * GATTR SVAL * ELSE
1110 IF itl > 0 THEN
1111 BEGIN
1112 IF kind = varbl THEN
1113 IF NOT rqisused THEN typseq := 34 ELSE typseq := 30
1114 ELSE
1115 IF ldreg = ra THEN typseq := 30 ELSE typseq := 34
1116 END * ITL > 0 * ELSE
1117 typseq := 36 ;
1118 END * NOT REAL FATTR.KIND=SVAL * ;
1119 lval : IF isreal THEN typseq := 1 ELSE
1120 CASE kind OF
1121 varbl : IF easyvar gattr THEN typseq := 35 ELSE typseq := 36 ;
1122 sval : IF itg > 0 THEN
1123 IF fattr.ldreg = ra THEN typseq := 29 ELSE typseq := 33
1124 ELSE
1125 typseq := 35 ;
1126 lval : IF ldreg = rq THEN typseq := 35 ELSE typseq := 36 ;
1127 END * CASE KIND NOT ISREAL FATTR LVAL * ;
1128 END * CASE FATTR.KINDWITH GATTR * ;
1129 END * TYPSEQ IS 0 * ;
1130 IF odd typseq THEN
1131 BEGIN
1132 tattr := fattr ; cattr := gattr ; nbshif := itg ;
1133 END ELSE
1134 BEGIN
1135 tattr := gattr ; cattr := fattr ; nbshif := itl ;
1136 END ;
1137 IF declarationpart AND
1138 NOT typseq IN 0 3 4 12 THEN
1139 BEGIN
1140 illegal_generation := true ;
1141 tattr.typtr := NIL ;
1142 END
1143 ELSE
1144 CASE typseq OF
1145 0 :
1146 $OPTIONS compile = trace $
1147 error 419
1148 $OPTIONS compile = true $
1149 ;
1150 1, 2 : BEGIN transfer tattr inacc ;
1151 calcvarient cattr lbase ldisp ltag ;
1152 WITH cattr DO
1153 IF kind = varbl THEN usednameaddr := nameaddr ;
1154 genstand lbase ldisp linst ltag ;
1155 IF linst = impy THEN
1156 IF asscheck THEN gencheckmultover ;
1157 END * 12 * ;
1158 3, 4 : BEGIN freeattr cattr ;
1159 IF generic = realptr THEN
1160 IF tattr.typtr # realptr THEN convreal tattr ;
1161 END * 34 * ;
1162 12 : IF generic = realptr THEN
1163 tattr.rsval := cattr.rsval * tattr.rsval ELSE
1164 tattr.val := int_op 1 cattr.val tattr.val ;
1165 29, 30 : BEGIN transfer tattr inacc ;
1166 genstand nreg nbshif ials tn ;
1167 END * 2930 * ;
1168 33, 34 : BEGIN transfer tattr inq ;
1169 genstand nreg nbshif iqls tn ;
1170 END * 3334 * ;
1171 35, 36 : BEGIN transfer tattr inq ;
1172 sauvereg ra false ;
1173 calcvarient cattr lbase ldisp ltag ;
1174 WITH cattr DO
1175 IF kind = varbl THEN usednameaddr := nameaddr ;
1176 genstand lbase ldisp linst ltag ;
1177 IF linst = impy THEN
1178 IF asscheck THEN gencheckmultover ;
1179 END * 3536 * ;
1180 END * CASE TYPSEQ * ;
1181 gattr := tattr ;
1182 $OPTIONS compile = trace $
1183 IF stattrace > low THEN
1184 BEGIN
1185 write mpcogout '@@@ FIN GENOPMULT @@@ WITH TYPSEQ :' typseq : 4 ; nextline ;
1186 END ;
1187 $OPTIONS compile = true $
1188 END * GENOPMULT * ;
1189
1190
1191 $OPTIONS page $
1192
1193 * ************************************ GENPTCOMP ***************************** *
1194
1195 PROCEDURE genptcomp VAR fattr : attr ; fcl : integer ;
1196
1197 * C . FATTR LEFT OPERAND
1198 GATTR RIGHT OPERAND
1199 ."NIL" IS SVAL CF. CALCVARIENT
1200 .PRODUCES A GATTR LCOND.
1201 C *
1202 VAR
1203 typseq : integer ;
1204 lretpt : lcstpt ;
1205 BEGIN * GENPTCOMP *
1206 $OPTIONS compile = trace $
1207 IF stattrace > none THEN
1208 BEGIN
1209 write mpcogout '@@@ DEBUT GENPTCOMP @@@' ; nextline ;
1210 END ;
1211 $OPTIONS compile = true $
1212 typseq := 2 ;
1213 IF fattr.typtr = nilptr THEN
1214 BEGIN transfer gattr inacc ; typseq := 4 ;
1215 END ELSE
1216 IF gattr.typtr = nilptr THEN
1217 BEGIN transfer fattr inacc ; typseq := 3 ;
1218 END ;
1219 IF typseq <= 2 THEN
1220 BEGIN
1221
1222 transfer gattr inacc ;
1223 enterlcst clearpt lretpt ;
1224 enterundlab lretpt^.lplace ;
1225 genstand nreg 0 ianaq tic ;
1226 genstand pr6 evareaw istaq tn ;
1227 freebloc gattr.ldregbloc ;
1228
1229 IF fattr.kind = lval THEN
1230 lvalvarbl fattr ;
1231 transfer fattr inacc ;
1232 enterlcst clearpt lretpt ;
1233 enterundlab lretpt^.lplace ;
1234 genstand nreg 0 ianaq tic ;
1235 genstand pr6 evareaw icmpaq tn ;
1236 typseq := 1 ; * REVERSE COMPARAISON *
1237 END ELSE
1238 BEGIN enterlcst nileraq lretpt ; enterundlab lretpt@.lplace ;
1239 genstand nreg 0 ieraq tic ;
1240 enterlcst nilanaq lretpt ; enterundlab lretpt@.lplace ;
1241 genstand nreg 0 ianaq tic ;
1242 END ;
1243 freeattr gattr ; freeattr fattr ;
1244 WITH gattr DO
1245 BEGIN
1246 kind := lcond ; accbool := false ; accbloc := NIL ;
1247 IF odd typseq THEN
1248 transf := cltransf fcl ELSE
1249 transf := revcltransf fcl ;
1250 * TYPTR OUTSIDE *
1251 END ;
1252 $OPTIONS compile = trace $
1253 IF stattrace > low THEN
1254 BEGIN
1255 write mpcogout '@@@ FIN GENPTCOMP @@@ WITH FCLTRANSF :' fcl : 4 gattr.transf ;
1256 nextline ;
1257 END ;
1258 $OPTIONS compile = true $
1259 END * GENPTCOMP * ;
1260
1261
1262 $OPTIONS page $
1263
1264 * ************************************ GENSTCOMP ***************************** *
1265
1266 PROCEDURE genstcomp VAR fattr : attr ; fcl : integer ;
1267
1268 * C . FATTR IS LEFT OPERAND
1269 GATTR IS RIGHT OPERAND
1270 . OUTPUT PROCEDURE IS A GATTR LCOND
1271 C *
1272 * E ERRORS DETECTED
1273 29 : SAME LENGTH STRINGS EXPECTED HERE
1274 131 : LENGTH TOO LARGECONFLICT
1275 307 : LENGTH TOO LARGE LIMIT IMPLEMENTATION
1276 E *
1277 VAR
1278 lfbase, rgbase : preg ;
1279 lfchain, rgchain : boolean ;
1280 lflong, rglong, lfdisp, rgdisp, lfmod, rgmod, suplr, ltransf : integer ;
1281 lftag, rgtag : tag ;
1282 BEGIN * GENSTCOMP *
1283 $OPTIONS compile = trace $
1284 IF stattrace > none THEN
1285 BEGIN
1286 write mpcogout '@@@ DEBUT GENSTCOMP @@@ WITH FCL' fcl : 4 ; nextline ;
1287 END ;
1288 $OPTIONS compile = true $
1289 WITH fattr DO * LEFT OPER. *
1290 BEGIN
1291 IF kind = chain THEN
1292 BEGIN
1293 loadadr fattr nreg ;
1294 lfbase := currentpr ; lflong := alfactp@.alfalong ; lfchain := true ;
1295 lfdisp := 0 ; lfmod := 0 ;
1296 WITH fattr DO
1297 BEGIN
1298 kind := varbl ; access := pointee ;
1299 basebloc := currentbloc ; basereg := currentpr ;
1300 inxbloc := NIL ; inxmem := 0 ; dplmt := 0 ; inxmemrw := false ; pckd := true ;
1301 vlev := level ;
1302 END ;
1303 END * CHAIN * ELSE
1304 BEGIN * VARBL *
1305 lfchain := false ;
1306 IF basereg <= maxprused THEN
1307 regenere basebloc ;
1308 lfbase := basereg ; lfdisp := dplmt DIV bytesinword ;
1309 lflong := typtr@.size ; lfmod := dplmt MOD bytesinword ;
1310 END * VARBL * ;
1311 END * WITH FATTR * ;
1312 WITH gattr DO * RIGHT OPERAND *
1313 BEGIN
1314 IF kind = chain THEN
1315 BEGIN
1316 loadadr gattr pr3 ;
1317 rgbase := pr3 ; rglong := alfactp@.alfalong ; rgchain := true ; rgdisp := 0 ;
1318 rgmod := 0 ;
1319 END * CHAIN * ELSE
1320 BEGIN * VARBL *
1321 rgchain := false ; rglong := typtr@.size ;
1322 IF NOT varissimple gattr THEN
1323 BEGIN
1324 loadadr gattr pr3 ;
1325 rgbase := pr3 ; rgmod := 0 ; rgdisp := 0 ;
1326 END ELSE
1327 BEGIN
1328 rgbase := basereg ; rgdisp := dplmt DIV bytesinword ;
1329 rgmod := dplmt MOD bytesinword ;
1330 END ;
1331 END * VARBL * ;
1332 END * WITH GATTR * ;
1333 IF lfchain THEN
1334 BEGIN
1335 IF lflong > rglong THEN error 131 ;
1336 END ELSE
1337 IF rgchain THEN
1338 BEGIN
1339 IF lflong < rglong THEN error 131 ;
1340 END ;
1341 suplr := sup lflong rglong ;
1342 IF envstandard <> stdextend THEN
1343 IF lflong # rglong THEN error 29 ;
1344 IF suplr < twoto12 THEN
1345 BEGIN
1346 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; lftag := tn ; rgtag := tn ;
1347 END ELSE
1348 BEGIN
1349 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ; lftag := tx6 ; rgtag := tx7 ;
1350 IF suplr > twoto17m1 THEN
1351 error 307 ELSE
1352 BEGIN
1353 genstand nreg lflong ieax6 tn ;
1354 genstand nreg rglong ieax7 tn ;
1355 END ;
1356 lflong := 0 ; rglong := 0 ;
1357 END ;
1358 geneism icmpc ord ' ' p0t0r0 ;
1359 IF fcl IN 2 4 THEN
1360 BEGIN * <= > *
1361 WITH gattr DO
1362 IF kind = varbl THEN usednameaddr := nameaddr ELSE
1363 IF kind = chain THEN usednameaddr := alfactp ;
1364 gendesca rgbase rgdisp rgmod l9 rglong rgtag ;
1365 WITH fattr DO
1366 IF kind = varbl THEN usednameaddr := nameaddr ELSE
1367 IF kind = chain THEN usednameaddr := alfactp ;
1368 gendesca lfbase lfdisp lfmod l9 lflong lftag ;
1369 IF fcl = 2 THEN
1370 fcl := 3 * >= * ELSE fcl := 1 ; * < *
1371 END ELSE
1372 BEGIN
1373 WITH fattr DO
1374 IF kind = varbl THEN usednameaddr := nameaddr ELSE
1375 IF kind = chain THEN usednameaddr := alfactp ;
1376 gendesca lfbase lfdisp lfmod l9 lflong lftag ;
1377 WITH gattr DO
1378 IF kind = varbl THEN usednameaddr := nameaddr ELSE
1379 IF kind = chain THEN usednameaddr := alfactp ;
1380 gendesca rgbase rgdisp rgmod l9 rglong rgtag ;
1381 END ;
1382 CASE fcl OF
1383 1 : ltransf := 11 ; * CARRY OFF TRUE *
1384 3 : ltransf := 12 ; * CARRY ON TRUE *
1385 5 : ltransf := 6 ; * ZERO OFF TRUE *
1386 6 : ltransf := 2 ; * ZERO ON TRUE *
1387 END * CASE FCL * ;
1388 freeattr fattr ;
1389 freeattr gattr ;
1390 WITH gattr DO * TYPTR OUTSIDE *
1391 BEGIN
1392 kind := lcond ; accbool := false ; accbloc := NIL ;
1393 transf := ltransf ;
1394 END ;
1395 $OPTIONS compile = trace $
1396 IF stattrace > low THEN
1397 BEGIN
1398 write mpcogout '@@@ FIN GENSTCOMP @@@ WITH TRANSF' ltransf ; nextline ;
1399 END ;
1400 $OPTIONS compile = true $
1401 END * GENSTCOMP * ;
1402
1403
1404 $OPTIONS page $
1405
1406 * ************************************ GENJUMP ******************************* *
1407
1408 PROCEDURE genjump VAR inserplace : integer ; jumpdisp : integer ;
1409
1410 * C .CALLED IN ORDER TO GENERATE THE JUMP IF FALSE FOR
1411 REPEAT NO INSER JUMPDISP KNOWN BACKWARDS
1412 WHILEIF INSER JUMPDISP=0
1413 .BEFORE CALL GATTR IS TESTED AND HAS TYPTR=BOOLPTR
1414 C *
1415 VAR
1416 linst : istand ;
1417 locinser : integer ;
1418 BEGIN * GENJUMP *
1419 $OPTIONS compile = trace $
1420 IF stattrace > none THEN
1421 BEGIN
1422 write mpcogout '@@@ DEBUT GENJUMP @@@ WITH JUMPDISP' jumpdisp ; nextline ;
1423 END ;
1424 $OPTIONS compile = true $
1425 WITH gattr DO
1426 IF kind = lcond THEN
1427 BEGIN
1428 CASE transf OF
1429 1, 7 : linst := itpl ; * JUMP IF NEGATIVE OFF *
1430 2, 13, 15 : linst := itnz ; * JUMP IF ZERO OFF *
1431 3, 6, 14 : linst := itze ; * JUMP IF ZERO ON *
1432 4 : linst := inop ; * NO JUMP *
1433 5 : linst := itra ; * INCONDITIONAL JUMP *
1434 8 : linst := itpnz ; * JUMP IF NEGATIVE OFF AND ZERO OFF *
1435 9 : linst := itmi ; * JUMP IF NEGATIVE ON *
1436 10 : linst := itmoz ; * JUMP IF NEGATIVE ON OR ZERO ON *
1437 11 : linst := itrc ; * JUMP IF CARRY ON *
1438 12 : linst := itnc ; * JUMP IF CARRY OFF *
1439 END * CASE TRANSF * ;
1440 IF accbloc # NIL THEN freebloc accbloc ;
1441 locinser := indfich ;
1442 END * LCOND * ELSE
1443 IF kind = sval THEN
1444 BEGIN
1445 IF val = ord false THEN
1446 linst := itra ELSE linst := inop ;
1447 locinser := indfich ;
1448 END * SVAL * ELSE
1449 BEGIN
1450 transfer gattr inacc ; * SET INDICATORS *
1451 locinser := indfich ; linst := itze ; * SKIP IF ZERO OFF =FALSE *
1452 freebloc ldregbloc ;
1453 END * NEITHER LCOND NOR SVAL * ;
1454 IF linst # inop THEN
1455 BEGIN
1456 IF jumpdisp # 0 * REPEAT BACKWARDS * THEN
1457 BEGIN
1458 genstand nreg jumpdisp - cb DIV bytesinword linst tic ;
1459 END ELSE
1460 BEGIN * WHILEIF ==> FORWARDS *
1461 inserplace := locinser ;
1462 genstand nreg 0 linst tic ;
1463 END ;
1464 END ;
1465 $OPTIONS compile = trace $
1466 IF stattrace > low THEN
1467 BEGIN
1468 write mpcogout '@@@ FIN GENJUMP @@@ WITH V.INSERPLACE' inserplace ; nextline ;
1469 END ;
1470 $OPTIONS compile = true $
1471 END * GENJUMP * ;
1472
1473
1474 $OPTIONS page $
1475
1476 * ************************************ GENCOMPARE **************************** *
1477
1478 PROCEDURE gencompare VAR fattr : attr ; fcl : integer ; generic : ctp ;
1479
1480 * C . GATTR IS RIGHT OPERAND
1481 FATTR IS LEFT OPERAND
1482 . GENERIC TYPE
1483 . AT OUTPUT PRODUCES A GATTR LCOND
1484 WITH TRANSF FUNCTION OF INDICATORS SET
1485 C *
1486 * E ERROR DETECTED
1487 434 TYPSEQ = 0
1488 E *
1489 VAR
1490 tattr, cattr : attr ;
1491 lbase : preg ;
1492 ldisp, typseq : integer ;
1493 ltag : tag ;
1494 linst : istand ;
1495 BEGIN * GENCOMPARE *
1496 $OPTIONS compile = trace $
1497 IF stattrace > none THEN
1498 BEGIN
1499 write mpcogout '@@@ DEBUT GENCOMPARE @@@' ; nextline ;
1500 END ;
1501 $OPTIONS compile = true $
1502 IF generic = realptr THEN
1503 BEGIN linst := idfcmp ;
1504 IF gattr.typtr # realptr THEN
1505 convreal gattr ELSE
1506 IF fattr.typtr # realptr THEN
1507 convreal fattr ;
1508 END ELSE
1509 linst := icmpa ;
1510 IF gattr.kind = lcond THEN choicerarq ;
1511 IF fattr.kind = lval THEN
1512 lvalvarbl fattr ;
1513 typseq := 0 ;
1514 WITH gattr DO
1515 CASE fattr.kind OF
1516 varbl : CASE kind OF
1517 varbl : typseq := 2 ;
1518 lval : IF ldreg = rq THEN typseq := 10 ELSE typseq := 2 ;
1519 sval : IF generic = realptr THEN
1520 BEGIN IF rsval = 0 THEN typseq := 29 ELSE typseq := 2 ;
1521 END ELSE
1522 BEGIN
1523 IF val = 0 THEN typseq := 17 ELSE typseq := 2 ;
1524 END ;
1525 END * CASE GATTR.KIND * ;
1526 sval : IF generic = realptr THEN
1527 BEGIN
1528 IF fattr.rsval = 0 THEN typseq := 30 ELSE typseq := 2 ;
1529 END ELSE
1530 BEGIN
1531 IF fattr.val # 0 THEN
1532 BEGIN typseq := 2 ;
1533 IF kind = lval THEN
1534 IF ldreg = rq THEN typseq := 10 ;
1535 END ELSE
1536 BEGIN typseq := 30 ;
1537 IF kind = varbl THEN
1538 BEGIN
1539 IF easyvar gattr THEN typseq := 18 ;
1540 END ELSE
1541 IF kind = lval THEN
1542 IF ldreg = rq THEN typseq := 34 ;
1543 END ;
1544 END * NOT REAL * ;
1545 lval : CASE fattr.ldreg OF
1546 ra :
1547 CASE kind OF
1548 varbl : IF easyvar gattr THEN typseq := 1 ELSE typseq := 2 ;
1549 sval : IF val = 0 THEN typseq := 29 ELSE typseq := 1 ;
1550 lval : typseq := 13 ;
1551 END * CASE GATTR.KIND FOR RA * ;
1552 rq :
1553 CASE kind OF
1554 varbl : IF easyvar gattr THEN typseq := 9 ELSE typseq := 10 ;
1555 sval : IF val = 0 THEN typseq := 33 ELSE typseq := 9 ;
1556 lval : typseq := 14 ;
1557 END ; * CASE GATTR.KIND FOR RQ *
1558 reaq : BEGIN typseq := 1 ;
1559 IF kind = sval THEN
1560 IF rsval = 0.0 THEN typseq := 29 ;
1561 END ;
1562 END * CASE FATTR.LDREG * ;
1563 END * CASE FATTR.KIND WITH GATTR * ;
1564 IF odd typseq THEN
1565 BEGIN
1566 tattr := fattr ; cattr := gattr ;
1567 END ELSE
1568 BEGIN
1569 tattr := gattr ; cattr := fattr ;
1570 END ;
1571 CASE typseq OF
1572 0 :
1573 $OPTIONS compile = trace $
1574 error 434
1575 $OPTIONS compile = true $
1576 ;
1577 1, 2 : BEGIN transfer tattr inacc ;
1578 calcvarient cattr lbase ldisp ltag ;
1579 WITH cattr DO
1580 IF kind = varbl THEN usednameaddr := nameaddr ;
1581 genstand lbase ldisp linst ltag ;
1582 END * 12 * ;
1583 9, 10 : BEGIN transfer tattr inq ;
1584 calcvarient cattr lbase ldisp ltag ;
1585 WITH cattr DO
1586 IF kind = varbl THEN usednameaddr := nameaddr ;
1587 genstand lbase ldisp icmpq ltag ;
1588 END * 910 * ;
1589 13, 14 : BEGIN genstand pr6 evareaw istq tn ; freeattr cattr ;
1590 genstand pr6 evareaw icmpa tn ;
1591 END * 1314 * ;
1592 17, 18 : BEGIN calcvarient tattr lbase ldisp ltag ;
1593 WITH tattr DO
1594 IF kind = varbl THEN usednameaddr := nameaddr ;
1595 genstand lbase ldisp iszn ltag ;
1596 END * 1718 * ;
1597 29, 30 : transfer tattr inacc ;
1598 33, 34 : transfer tattr inq ;
1599 END * CASE TYPSEQ * ;
1600 freeattr tattr ; freeattr cattr ;
1601 WITH gattr DO
1602 BEGIN
1603 * TYPTR OUTSIDE *
1604 kind := lcond ; accbloc := NIL ; accbool := false ;
1605 IF odd typseq THEN
1606 transf := cltransf fcl ELSE
1607 transf := revcltransf fcl ;
1608 END * WITH GATTR * ;
1609 $OPTIONS compile = trace $
1610 IF stattrace > low THEN
1611 BEGIN
1612 write mpcogout '@@@ FIN GENCOMPARE @@@ WITH TYPSEQTRANSF' typseq : 4
1613 gattr.transf ;
1614 nextline ;
1615 END ;
1616 $OPTIONS compile = true $
1617 END * GENCOMPARE * ;
1618
1619
1620 $OPTIONS page $
1621
1622 * **************************************************** GENOPPW ************** *
1623
1624 PROCEDURE genoppw VAR fattr : attr ; fno fcl : integer ;
1625
1626 * C GENERATES CODE FOR SETS OPERATION
1627 .GATTR IS RIGHT OPERAND
1628 .FATTR IS LEFT OPERAND
1629 .FNO= 6 FCL= 1 SET INTERSECTION
1630 .FNO= 7 FCL= 1 SET UNION
1631 FCL= 2 SET DIFFERENCE NOT COMMUTATIV
1632 .FNO= 8 FCL= 2 <= SET INCLUSION
1633 FCL= 3 >=
1634 FCL= 5 #
1635 FCL= 6 =
1636 .RETURNS A GATTR
1637 .BEFORE CALL FATTR CAN BE .LVAL IN AQ *GATTR CAN BE .LVAL AQ
1638 .LVAL IN PSR * .LVAL PSR
1639 .SVAL 8 * .SVAL 8
1640 .VARBL EASY 8 * .SVAL MAX
1641 .VARBL EASY MAX * .VAR EASY 8
1642 .SVAL MAX * .VAR EASY MAX
1643 .VAR NOT EASY
1644 C *
1645 * E ERRORS DETECTED
1646 E *
1647 VAR
1648 typseq : integer ;
1649 bolr, revbolr : integer ;
1650 linstaq : istand ;
1651 lbase : preg ;
1652 ldisp, fattsize, gattsize, tattsize, cattsize, ltransf : integer ;
1653 ltag : tag ;
1654 lretpt : lcstpt ;
1655 llretpt : llcstpt ;
1656 tattr, cattr : attr ;
1657 rshort, lshort, classe1 : boolean ;
1658 BEGIN * GENOPPW *
1659 $OPTIONS compile = trace $
1660 IF stattrace > none THEN
1661 BEGIN
1662 write mpcogout '@@@ DEBUT GENOPPW @@@ WITH FNOFCL:' fno : 4 fcl : 4 ; nextline ;
1663 END ;
1664 $OPTIONS compile = true $
1665 typseq := 0 ;
1666 fattsize := fattr.typtr^.setlength ;
1667 gattsize := gattr.typtr^.setlength ;
1668 WITH fattr DO
1669 CASE kind OF
1670 varbl : ;
1671 sval : IF longv = bytesforset THEN fattsize := bitsforset ELSE fattsize := bitsindword ;
1672 lval : IF ldreg = psr THEN fattsize := bitsforset ELSE fattsize := bitsindword ;
1673 END * CASE KINDWITH FATTR * ;
1674 WITH gattr DO
1675 CASE kind OF
1676 varbl : ;
1677 sval : IF longv = bytesforset THEN gattsize := bitsforset ELSE gattsize := bitsindword ;
1678 lval : IF ldreg = psr THEN gattsize := bitsforset ELSE gattsize := bitsindword ;
1679 END * CASE KINDWITH GATTR * ;
1680 * FNO+FCL GIVES EACH OPERATOR. *
1681 CASE fno + fcl OF
1682 7 : * 6+1 * * AND *
1683 BEGIN bolr := 1 ; revbolr := 1 ; linstaq := ianaq ;
1684 END ;
1685 8 : * 7+1 * * OR *
1686 BEGIN bolr := 7 ; revbolr := 7 ; linstaq := ioraq ;
1687 END ;
1688 9 : * 7+2 * * - *
1689 BEGIN bolr := 4 ; revbolr := 2 ; linstaq := inop ;
1690 END ;
1691 10 : * 8+2 * * <= *
1692 BEGIN bolr := 2 ; * A<=B <---> A * NOTB = *
1693 revbolr := 2 ; linstaq := inop ;
1694 ltransf := 2 ; * ZERO ON = TRUE *
1695 END ;
1696 11 : * 8+3 * * >= *
1697 BEGIN bolr := 2 ; revbolr := 4 ; linstaq := inop ; ltransf := 2 ;
1698 END ;
1699 13 : * 8+5 * * # *
1700 BEGIN bolr := 6 ; * 0110 = EXCLUSIVE OR * revbolr := 6 ; linstaq := icmpaq ;
1701 ltransf := 6 ; * ZERO OFF =TRUE *
1702 END ;
1703 14 : * 8+6 * * = *
1704 BEGIN bolr := 6 ; revbolr := 6 ; linstaq := icmpaq ;
1705 ltransf := 2 ; * ZERO ON =TRUE *
1706 END ;
1707 END * CASE FNO+FCL * ;
1708 lshort := fattsize = bitsindword ;
1709 rshort := gattsize = bitsindword ;
1710 IF gattr.kind = varbl THEN
1711 IF NOT varissimple gattr OR gattr.pckd THEN
1712 rshort := false ;
1713 IF fattr.kind = lval THEN
1714 IF fattr.ldregbloc@.saveplace # 0 THEN
1715 lvalvarbl fattr ;
1716 classe1 := fno + fcl IN 9..11 ; * - <= >= *
1717 $OPTIONS compile = trace $
1718 IF stattrace = high THEN
1719 BEGIN
1720 write mpcogout ' GENOPPW: FATTR and GATTR are:' ; nextline ;
1721 printattr fattr ; printattr gattr ;
1722 write mpcogout 'Fattsize Gattsize Lshort Rshort are:'
1723 fattsize gattsize lshort : 7 rshort : 7 ;
1724 nextline ;
1725 END ;
1726 $OPTIONS compile = true $
1727 IF classe1 THEN
1728 BEGIN
1729 typseq := 6 ;
1730 END * CLASSE1 * ELSE
1731 BEGIN
1732 WITH gattr DO
1733 CASE fattr.kind OF
1734 sval, varbl : IF lshort AND rshort THEN typseq := 2 ELSE
1735 typseq := 6 ;
1736 lval : IF lshort THEN
1737 BEGIN
1738 IF kind = lval THEN typseq := 8 ELSE
1739 IF rshort THEN typseq := 1 ELSE
1740 BEGIN
1741 typseq := 5 ;
1742 IF kind = varbl THEN
1743 IF NOT varissimple gattr THEN typseq := 8 ;
1744 END
1745 END ELSE
1746 BEGIN
1747 IF kind = lval AND rshort THEN typseq := 7 ELSE
1748 BEGIN
1749 typseq := 5 ;
1750 END ;
1751 END * LVAL * ;
1752 END * CASE FATTR.KIND WITH GATTR * ;
1753 END * NOT CLASSE1 * ;
1754 IF odd typseq THEN
1755 BEGIN
1756 tattr := fattr ; cattr := gattr ; tattsize := fattsize ; cattsize := gattsize ;
1757 END * ODD * ELSE
1758 BEGIN
1759 tattr := gattr ; cattr := fattr ; tattsize := gattsize ; cattsize := fattsize ;
1760 bolr := revbolr ;
1761 END ;
1762 CASE typseq OF
1763 0 : ;
1764 1, 2 : BEGIN transfer tattr inaq ;
1765 calcvarient cattr lbase ldisp ltag ;
1766 IF cattr.kind = varbl THEN usednameaddr := cattr.nameaddr ;
1767 genstand lbase ldisp linstaq ltag ;
1768 END ;
1769 5, 6 : BEGIN transfer tattr inpsr ; psrsize := bytesforset ;
1770 IF cattr.kind = varbl THEN
1771 IF varissimple cattr THEN
1772 calcvarient cattr lbase ldisp ltag ELSE
1773 BEGIN
1774 loadadr cattr pr3 ; lbase := pr3 ; ldisp := 0 ;
1775 END ELSE
1776 IF cattr.kind = sval THEN
1777 BEGIN
1778 IF cattr.longv = bytesindword THEN
1779 BEGIN enterlcst cattr.valpw lretpt ; cattsize := bitsindword ;
1780 enterundlab lretpt@.lplace ;
1781 END ELSE
1782 BEGIN enterllcst cattr.valpw llretpt ;
1783 enterundlab llretpt@.llplace ;
1784 END ;
1785 genstand nreg 0 iepp3 tic ; lbase := pr3 ; ldisp := 0 ;
1786 END ELSE
1787 calcvarient cattr lbase ldisp ltag ;
1788 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1789 geneism icsl bolr p0t0r0 * FILL 0 * ;
1790 IF cattr.kind = varbl THEN usednameaddr := cattr.nameaddr ;
1791 gendescb lbase ldisp 0 0 cattsize tn ;
1792 gendescb pr6 psrdepw 0 0 bitsforset tn ;
1793 END ;
1794 7, 8 : BEGIN transfer tattr inpsr ; psrsize := bytesforset ;
1795 genstand pr6 evareaw istaq tn ;
1796 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1797 geneism icsl bolr p0t0r0 ;
1798 gendescb pr6 evareaw 0 0 cattsize tn ;
1799 gendescb pr6 psrdepw 0 0 bitsforset tn ;
1800 END ;
1801 END * CASE TYPSEQ * ;
1802 IF fno <= 7 THEN
1803 BEGIN
1804 gattr := tattr ; freeattr cattr ;
1805 END ELSE
1806 BEGIN
1807 freeattr tattr ; freeattr cattr ;
1808 WITH gattr DO
1809 BEGIN
1810 * TYPTR OUTSIDE *
1811 kind := lcond ; accbool := false ; accbloc := NIL ;
1812 transf := ltransf ;
1813 END ;
1814 END * FNO=8 RELATIONAL OPERATOR * ;
1815 $OPTIONS compile = trace $
1816 IF stattrace > low THEN
1817 BEGIN
1818 write mpcogout '@@@ FIN GENOPPW @@@ WITH TYPSEQ :' typseq : 4 ; nextline ;
1819 END ;
1820 $OPTIONS compile = true $
1821 END * GENOPPW * ;
1822
1823 * ******************************* CHECK_DYNAMIC_STRING_LENGTH *************************** *
1824
1825 PROCEDURE check_dynamic_string_length VAR fattr : attr ;
1826
1827 VAR
1828 loaded_reg : register ;
1829 string_attr : attr ; string_base : preg ; string_disp, loc1, loc2 : integer ;
1830 string_bloc : regpt ;
1831
1832
1833 BEGIN
1834 string_bloc := NIL ;
1835 IF fattr.typtr <> NIL THEN
1836 IF fattr.typtr^.father_schema = string_ptr THEN
1837 IF fattr.typtr^.actual_parameter_list <> NIL THEN
1838 BEGIN
1839 IF varissimple fattr THEN
1840 BEGIN
1841 string_bloc := fattr.basebloc ;
1842 string_base := fattr.basereg ; string_disp := fattr.dplmt DIV bytesinword ;
1843 END ELSE BEGIN
1844 loadadr fattr nreg ;
1845 string_base := currentpr ; string_disp := 0 ;
1846 WITH fattr DO
1847 BEGIN
1848 access := pointee ; basereg := currentpr ; basebloc := currentbloc ;
1849 dplmt := 0 ;
1850 END
1851 END ;
1852 WITH fattr.typtr^ DO
1853 BEGIN
1854 IF raisused THEN
1855 BEGIN
1856 loaded_reg := rq ;
1857 sauvereg rq false ;
1858 END
1859 ELSE BEGIN
1860 loaded_reg := ra ;
1861 END ;
1862 IF actual_parameter_list^.klass <> konst THEN
1863 BEGIN
1864 addressvar actual_parameter_list string_attr false ;
1865 IF loaded_reg = rq THEN
1866 transfer string_attr inq
1867 ELSE
1868 transfer string_attr inacc ;
1869 freeattr string_attr ;
1870 END
1871 ELSE
1872 gencstecode actual_parameter_list^.values opaq load loaded_reg ;
1873 IF string_bloc <> NIL THEN regenere string_bloc ;
1874 genstand string_base string_disp iszn tn ;
1875 loc1 := indfich ; genstand nreg 0 itmi tic ;
1876 genstand string_base string_disp opaq cmp loaded_reg tn ;
1877 loc2 := indfich ; genstand nreg 0 itpl tic ;
1878 inser cb loc1 ;
1879 genexceptcode stringlength_range_error loaded_reg ;
1880 inser cb loc2 ;
1881 END ;
1882 END
1883 END ;
1884
1885
1886 $OPTIONS page$
1887
1888 * ************************************* PREPARE STRING *********************************** *
1889
1890
1891 PROCEDURE prepare_string VAR fattr : attr ; VAR info : string_item_info ; len_dest : destination ;
1892
1893 VAR
1894 a_or_q : register ;
1895 locbox : wcstpt ;
1896
1897 PROCEDURE get_a_or_q ;
1898 BEGIN
1899 IF len_dest = out THEN
1900 IF raisused THEN
1901 BEGIN
1902 sauvereg rq false ;
1903 a_or_q := rq ;
1904 END
1905 ELSE a_or_q := ra
1906 ELSE IF len_dest = inacc THEN a_or_q := ra
1907 ELSE a_or_q := rq ;
1908 END ;
1909
1910 PROCEDURE get_adr ;
1911 BEGIN
1912 WITH info, fattr DO
1913 IF varissimple fattr THEN
1914 BEGIN
1915 register := basereg ; bloc := basebloc ;
1916 wdisp := dplmt DIV bytesinword ; bdisp := dplmt MOD bytesinword ;
1917 END
1918 ELSE BEGIN
1919 loadadr fattr nreg ; bloc_is_new := true ;
1920 register := currentpr ; bloc := currentbloc ;
1921 wdisp := 0 ; bdisp := 0 ;
1922 END ;
1923 END * get_adr * ;
1924
1925 BEGIN * prepare string *
1926 WITH info DO
1927 BEGIN
1928 bloc_is_new := false ; len_bloc := NIL ;
1929 l_tag := tn ; l_val := -1 ; mfari := a1r0i0 ; reg_bloc := NIL ;
1930 END ;
1931 WITH fattr, info DO
1932 IF typtr = charptr THEN
1933 BEGIN * CHAR *
1934 length := 1 ; l_val := 1 ;
1935 CASE kind OF
1936 varbl : BEGIN
1937 get_adr ;
1938 IF NOT pckd THEN bdisp := bdisp + 3 ;
1939 END ;
1940 lval : BEGIN
1941 wdisp := oldnewstor bytesinword DIV bytesinword ; bdisp := 3 ;
1942 register := pr6 ; bloc := NIL ;
1943 IF fattr.ldregbloc <> NIL THEN regenere fattr.ldregbloc ;
1944 genstand pr6 wdisp opaq stor fattr.ldreg tn ;
1945 freeattr fattr ;
1946 END ;
1947 sval : BEGIN
1948 entercst val locbox ;
1949 getpr ; register := currentpr ; bloc := currentbloc ;
1950 bloc_is_new := true ;
1951 enterundlab locbox^.cstplace ;
1952 genstand nreg 0 prinst epp register tic ;
1953 wdisp := 0 ; bdisp := 3 ;
1954 freeattr fattr ;
1955 END ;
1956 END ;
1957 END
1958 ELSE IF isstring fattr THEN
1959 IF conformantdim typtr THEN
1960 BEGIN
1961 get_a_or_q ;
1962 init_desc_address fattr.nameaddr fattr ;
1963 register := basereg ; bloc := basebloc ; wdisp := 0 ; bdisp := 0 ;
1964 regenere fattr.descbloc ;
1965 IF len_dest <> out THEN
1966 BEGIN
1967 sauvereg a_or_q true ; reg_bloc := currentbloc ;
1968 END ;
1969 genstand fattr.descreg 1 opaq load a_or_q tn ;
1970 genstand fattr.descreg 0 opaq sub a_or_q tn ;
1971 genstand nreg 1 opaq add a_or_q tdl ; * reg contains actual length *
1972 IF len_dest = out THEN
1973 BEGIN
1974 len_place := oldnewstor bytesinword DIV bytesinword ;
1975 genstand pr6 len_place opaq stor a_or_q tn ;
1976 len_reg := pr6 ;
1977 END ;
1978 freebloc gattr.descbloc ;
1979 mfari := a1r1i0 ; l_tag := modif a_or_q ;
1980 END
1981 ELSE
1982 BEGIN
1983 CASE kind OF
1984 chain : BEGIN
1985 loadadr fattr nreg ; register := currentpr ; bloc := currentbloc ;
1986 wdisp := 0 ; bdisp := 0 ; length := alfactp^.alfalong ;
1987 bloc_is_new := true ;
1988 END ;
1989 varbl : BEGIN
1990 get_adr ;
1991 length := typtr^.hi - typtr^.lo + 1 ;
1992 END ;
1993 END ;
1994 IF length > twoto12 THEN
1995 BEGIN
1996 get_a_or_q ;
1997 IF len_dest <> out THEN
1998 BEGIN
1999 sauvereg a_or_q true ; reg_bloc := currentbloc ;
2000 END ;
2001 gencstecode length opaq load a_or_q ;
2002 IF len_dest = out THEN
2003 BEGIN
2004 len_place := oldnewstor bytesinword DIV bytesinword ;
2005 len_reg := pr6 ;
2006 genstand pr6 len_place opaq stor a_or_q tn
2007 END ;
2008 mfari := a1r1i0 ; l_tag := modif a_or_q ;
2009 END
2010 ELSE l_val := length ;
2011 END
2012 ELSE IF typtr^.father_schema = string_ptr THEN
2013 BEGIN
2014 get_adr ;
2015 IF len_dest <> out THEN
2016 BEGIN
2017 get_a_or_q ;
2018 sauvereg a_or_q true ; reg_bloc := currentbloc ;
2019 IF bloc <> NIL THEN regenere bloc ;
2020 genstand register wdisp opaq load a_or_q tn ;
2021 mfari := a1r1i0 ; l_tag := modif a_or_q ;
2022 END
2023 ELSE BEGIN
2024 len_place := wdisp ; len_reg := register ; len_bloc := bloc ;
2025 END ;
2026 wdisp := wdisp + 1 ; bdisp := 0 ;
2027 END ;
2028 WITH info DO
2029 IF l_val = -1 THEN
2030 BEGIN
2031 l_val := 0 ; length_is_known := false
2032 END
2033 ELSE length_is_known := true ;
2034 END * prepare_string * ;
2035
2036 $OPTIONS page $
2037
2038 * ************************************ GENCONCAT **************************** *
2039
2040 PROCEDURE genconcat VAR fattr : attr ;
2041
2042 TYPE
2043 item_info = RECORD
2044 register : preg ;
2045 bloc : regpt ; bloc_is_new : boolean ;
2046 length, length_place : integer ;
2047 wdisp, bdisp : integer ;
2048 END ;
2049 VAR
2050 first_alfa, current_alfa : alfapt ;
2051 result_place : integer ;
2052 fattr_info, gattr_info : item_info ;
2053 target_pointer : preg ; target_bloc : regpt ;
2054 total_length, total_place : integer ;
2055
2056 PROCEDURE prepare VAR fattr : attr ; VAR info : item_info ;
2057
2058 PROCEDURE add_length ;
2059 BEGIN
2060 WITH info DO
2061 IF total_place = 0 THEN
2062 total_length := total_length + length
2063 ELSE
2064 BEGIN
2065 gencstecode length ildq ;
2066 genstand pr6 total_place iasq tn
2067 END ;
2068 END ;
2069 PROCEDURE add_variable_length ;
2070 BEGIN
2071 WITH info DO
2072 BEGIN
2073 IF total_place = 0 THEN
2074 BEGIN
2075 total_place := oldnewstor bytesinword DIV bytesinword ;
2076 IF total_length <> 0 THEN
2077 gencstecode total_length iadq ;
2078 genstand pr6 total_place istq tn ;
2079 END
2080 ELSE
2081 genstand pr6 total_place iasq tn ;
2082 END ;
2083 END ;
2084
2085 PROCEDURE get_adr ;
2086 BEGIN
2087 WITH info, fattr DO
2088 IF varissimple fattr THEN
2089 BEGIN
2090 register := basereg ; bloc := basebloc ;
2091 wdisp := dplmt DIV bytesinword ; bdisp := dplmt MOD bytesinword ;
2092 END
2093 ELSE BEGIN
2094 loadadr fattr nreg ; bloc_is_new := true ;
2095 register := currentpr ; bloc := currentbloc ;
2096 wdisp := 0 ; bdisp := 0 ;
2097 END ;
2098 END * get_adr * ;
2099
2100 BEGIN * prepare *
2101 info.length_place := 0 ; info.bloc_is_new := false ;
2102 WITH fattr, info DO
2103 IF typtr = charptr THEN
2104 BEGIN * CHAR *
2105 length := 1 ; length_place := 0 ;
2106 CASE kind OF
2107 varbl : BEGIN
2108 get_adr ;
2109 IF NOT pckd THEN bdisp := bdisp + 3 ;
2110 END ;
2111 lval, sval : BEGIN
2112 wdisp := oldnewstor bytesinword DIV bytesinword ; bdisp := 3 ;
2113 register := pr6 ; bloc := NIL ;
2114 IF kind = lval THEN
2115 BEGIN
2116 IF fattr.ldregbloc <> NIL THEN regenere fattr.ldregbloc ;
2117 genstand pr6 wdisp opaq stor fattr.ldreg tn
2118 END
2119 ELSE BEGIN
2120 sauvereg ra false ;
2121 genstand nreg fattr.val ilda tdl ;
2122 genstand pr6 wdisp ista tn
2123 END ;
2124 freeattr fattr ;
2125 END ;
2126 END ;
2127 add_length ;
2128 END
2129 ELSE IF isstring fattr THEN
2130 IF conformantdim typtr THEN
2131 BEGIN
2132 init_desc_address fattr.nameaddr fattr ;
2133 register := basereg ; bloc := basebloc ; wdisp := 0 ; bdisp := 0 ;
2134 regenere fattr.descbloc ;
2135 sauvereg rq false ;
2136 genstand fattr.descreg 1 ildq tn ;
2137 genstand fattr.descreg 0 isbq tn ;
2138 genstand nreg 1 iadq tdl ; * Q contains actual length *
2139 length_place := oldnewstor bytesinword DIV bytesinword ;
2140 genstand pr6 length_place istq tn ;
2141 add_variable_length ;
2142 freebloc fattr.descbloc ;
2143 END
2144 ELSE
2145 BEGIN
2146 CASE kind OF
2147 chain : BEGIN
2148 loadadr fattr nreg ; register := currentpr ; bloc := currentbloc ;
2149 wdisp := 0 ; bdisp := 0 ; length := alfactp^.alfalong ; length_place := 0 ;
2150 bloc_is_new := true ;
2151 END ;
2152 varbl : BEGIN
2153 get_adr ;
2154 length := typtr^.hi - typtr^.lo + 1 ; length_place := 0 ;
2155 END ;
2156 END ;
2157 add_length ;
2158 END
2159 ELSE IF typtr^.father_schema = string_ptr THEN
2160 BEGIN
2161 get_adr ;
2162 IF bloc <> NIL THEN regenere bloc ;
2163 sauvereg rq false ;
2164 genstand register wdisp ildq tn ;
2165 wdisp := wdisp + 1 ; bdisp := 0 ;
2166 add_variable_length ;
2167 END ;
2168 END * prepare * ;
2169
2170 PROCEDURE concat_item VAR fattr : attr ; * ADD CONSTANT CHAIN *
2171
2172 VAR
2173 it : integer ;
2174 current_box : alfapt ;
2175 PROCEDURE add_char ch : char ;
2176
2177 BEGIN
2178 total_length := total_length + 1 ;
2179 IF current_alfa^.longfill = longalfbox THEN
2180 BEGIN
2181 new current_alfa^.nextval ; IF current_alfa^.nextval = NIL THEN heaperror ;
2182 current_alfa := current_alfa^.nextval ;
2183 WITH current_alfa^ DO
2184 BEGIN
2185 longfill := 0 ;
2186 nextval := NIL ;
2187 alfaval := ' ' ;
2188 END ;
2189 END ;
2190 WITH current_alfa^ DO
2191 BEGIN
2192 longfill := longfill + 1 ;
2193 alfaval longfill := ch ;
2194 END ;
2195 END ;
2196
2197 BEGIN
2198 WITH fattr DO
2199 IF kind = sval THEN add_char chr val
2200 ELSE BEGIN
2201 current_box := alfactp^.alfadeb ;
2202 WHILE current_box <> NIL DO
2203 BEGIN
2204 WITH current_box^ DO
2205 FOR it := 1 TO longfill DO add_char alfaval it ;
2206 current_box := current_box^.nextval ;
2207 END ;
2208 END ;
2209 freeattr fattr ;
2210 END ;
2211
2212 BEGIN * genconcat *
2213 IF fattr.kind = chain OR fattr.kind = sval
2214 AND gattr.kind = chain OR gattr.kind = sval THEN
2215 BEGIN * BOTH ARE KNOWN CONSTANTS *
2216 new first_alfa ; IF first_alfa = NIL THEN heaperror ;
2217 current_alfa := first_alfa ; WITH current_alfa^ DO
2218 BEGIN
2219 nextval := NIL ;
2220 longfill := 0 ;
2221 alfaval := ' ' ;
2222 END ;
2223 total_length := 0 ;
2224 concat_item fattr ; concat_item gattr ;
2225 WITH gattr DO
2226 BEGIN
2227 kind := chain ; typtr := alfaptr ;
2228 create_konst_box alfactp ' ' alfaconst ;
2229 WITH alfactp^ DO
2230 BEGIN
2231 contype := alfaptr ; succ := nextalf ;
2232 alfadeb := first_alfa ;
2233 alfalong := total_length ;
2234 END ;
2235 nextalf := alfactp ;
2236 END
2237 END
2238 ELSE
2239 BEGIN * DYNAMIC EVALUATION *
2240 total_place := 0 ; total_length := 0 ;
2241 prepare fattr fattr_info ;
2242 prepare gattr gattr_info ;
2243 sauvereg ra false ; sauvereg rq false ;
2244 IF total_place = 0 THEN * total is known *
2245 BEGIN
2246 gencstecode total_length ildq ;
2247 result_place := oldnewstor total_length + 4 DIV bytesinword ;
2248 genstand pr6 result_place iepp3 tn ;
2249 END
2250 ELSE
2251 BEGIN
2252 genstand pr6 total_place ildq tn ;
2253 stack_extension ;
2254 genstand pr6 evareaw iepp3 tny ;
2255 END ;
2256 genstand pr3 0 istq tn ;
2257 genstand pr3 1 prinst epp pr3 tn ;
2258 WITH fattr_info, fattr DO
2259 BEGIN
2260 IF bloc <> NIL THEN regenere bloc ;
2261 IF length_place = 0 THEN
2262 IF typtr^.father_schema = string_ptr THEN
2263 genstand register wdisp - 1 ildq tn
2264 ELSE gencstecode length ildq
2265 ELSE genstand pr6 length_place ildq tn ;
2266 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
2267 IF bloc <> NIL THEN regenere bloc ;
2268 geneism imlr ord ' ' p0t0r0 ;
2269 IF kind = varbl THEN usednameaddr := nameaddr
2270 ELSE IF kind = chain THEN usednameaddr := alfactp ;
2271 gendesca register wdisp bdisp l9 0 tql ;
2272 gendesca pr3 0 0 l9 0 tql ;
2273 IF bloc_is_new THEN freebloc bloc ;
2274 END ;
2275 freeattr fattr ;
2276 genstand pr3 0 ia9bd tql ;
2277 WITH gattr_info, gattr DO
2278 BEGIN
2279 IF bloc <> NIL THEN regenere bloc ;
2280 IF length_place = 0 THEN
2281 IF typtr^.father_schema = string_ptr THEN
2282 genstand register wdisp - 1 ildq tn
2283 ELSE gencstecode length ildq
2284 ELSE genstand pr6 length_place ildq tn ;
2285 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
2286 geneism imlr ord ' ' p0t0r0 ;
2287 IF kind = varbl THEN usednameaddr := nameaddr
2288 ELSE IF kind = chain THEN usednameaddr := alfactp ;
2289 gendesca register wdisp bdisp l9 0 tql ;
2290 gendesca pr3 0 0 l9 0 tql ;
2291 IF bloc_is_new THEN freebloc bloc ;
2292 END ;
2293 freeattr gattr ;
2294 initattrvarbl gattr ;
2295 getpr ; target_pointer := currentpr ; target_bloc := currentbloc ;
2296 genstand pr3 0 prinst epp target_pointer tn ;
2297 WITH gattr DO
2298 BEGIN
2299 IF total_place = 0 THEN
2300 genstand pr6 result_place prinst epp target_pointer tn
2301 ELSE
2302 genstand pr6 evareaw prinst epp target_pointer tny ;
2303 temporary := true ;
2304 basereg := target_pointer ; basebloc := target_bloc ; dplmt := 0 ;
2305 create_types_box typtr blank records false ;
2306 WITH typtr^ DO
2307 BEGIN
2308 father_schema := string_ptr ;
2309 IF total_place = 0 THEN
2310 BEGIN
2311 create_konst_box actual_parameter_list 'maxlength' wordconst ;
2312 WITH actual_parameter_list^ DO
2313 BEGIN
2314 values := total_length ; contype := intptr ;
2315 nxtel := NIL ;
2316 END
2317 END
2318 ELSE BEGIN
2319 create_vars_box actual_parameter_list 'maxlength' ;
2320 WITH actual_parameter_list^ DO
2321 BEGIN
2322 vtype := intptr ;
2323 vaddr := total_place ;
2324 nxtel := NIL ;
2325 END ;
2326 END ;
2327 END ;
2328 END ;
2329 END
2330 END * genconcat * ;
2331
2332 $OPTIONS page $
2333
2334 * ************************** GEN_STRING_COMP ******************************** *
2335
2336 PROCEDURE gen_string_comp VAR fattr : attr ; fcl : integer ;
2337
2338 * THIS PROCEDURE IS SIMILAR TO genstcomp BUT IS MORE GENERAL BECAUSE
2339 IT COMPARES ANY STRING EXPRESSION TO ANY OTHER STRING EXPRESSION.
2340
2341 STRING EXPRESSION MAY BE CHAR PACKED ARRAY OF CHAR CONFORMANT OR NOT OR STRING
2342
2343 *
2344
2345 VAR
2346 result_place, ltransf : integer ;
2347 fattr_info, gattr_info : string_item_info ;
2348
2349 BEGIN
2350 IF fcl IN 2 4 THEN
2351 BEGIN
2352 IF fcl = 2 THEN fcl := 3 ELSE fcl := 1 ;
2353 prepare_string fattr gattr_info inacc ;
2354 prepare_string gattr fattr_info inq ;
2355 END
2356 ELSE BEGIN
2357 prepare_string fattr fattr_info inacc ;
2358 prepare_string gattr gattr_info inq ;
2359 END ;
2360 WITH fattr_info DO
2361 BEGIN
2362 IF reg_bloc <> NIL THEN regenere reg_bloc ;
2363 IF bloc <> NIL THEN regenere bloc ;
2364 END ;
2365 WITH gattr_info DO
2366 BEGIN
2367 IF reg_bloc <> NIL THEN regenere reg_bloc ;
2368 IF bloc <> NIL THEN regenere bloc ;
2369 END ;
2370 mfari1 := fattr_info.mfari ; mfari2 := gattr_info.mfari ;
2371 geneism icmpc 0 p0t0r0 ;
2372 WITH fattr_info DO
2373 gendesca register wdisp bdisp l9 l_val l_tag ;
2374 WITH gattr_info DO
2375 gendesca register wdisp bdisp l9 l_val l_tag ;
2376 CASE fcl OF
2377 1 : ltransf := 11 ; * CARRY OFF TRUE *
2378 3 : ltransf := 12 ; * CARRY ON TRUE *
2379 5 : ltransf := 6 ; * ZERO OFF TRUE *
2380 6 : ltransf := 2 ; * ZERO ON TRUE *
2381 END * CASE FCL * ;
2382 WITH fattr_info DO
2383 BEGIN
2384 IF bloc_is_new THEN freebloc bloc ;
2385 IF reg_bloc <> NIL THEN freebloc reg_bloc ;
2386 END ;
2387 WITH gattr_info DO
2388 BEGIN
2389 IF bloc_is_new THEN freebloc bloc ;
2390 IF reg_bloc <> NIL THEN freebloc reg_bloc ;
2391 END ;
2392 freeattr fattr ;
2393 freeattr gattr ;
2394 WITH gattr DO * TYPTR OUTSIDE *
2395 BEGIN
2396 kind := lcond ; accbool := false ; accbloc := NIL ;
2397 transf := ltransf ;
2398 END ;
2399 END * GEN STRING COMP * ;
2400
2401 $OPTIONS page$
2402
2403 * **************************** GEN_STRING_POSITION ************************************* *
2404
2405 PROCEDURE gen_string_position VAR fattr : attr ;
2406
2407 * GENERATES CODE TO FIND POSITION OF STRING DESCRIBED BY FATTR
2408 IN STRING DESCRIBED BY GATTR *
2409
2410 VAR
2411 to_find_info, to_scan_info : string_item_info ;
2412 fattr_info, gattr_info : string_item_info ;
2413 loc1, loc2, temp_place, retplace : integer ;
2414
2415 BEGIN
2416 temp_place := oldnewstor bytesinword DIV bytesinword ;
2417 prepare_string fattr to_find_info inacc ; * STRING TO FIND *
2418 IF to_find_info.l_tag = tal THEN * LENGTH IS IN A *
2419 genstand pr6 temp_place ista tn ;
2420 prepare_string gattr to_scan_info inq ; * STRING TO SCAN *
2421 WITH to_scan_info DO
2422 IF length_is_known THEN
2423 BEGIN
2424 sauvereg rq false ;
2425 gencstecode l_val ildq ;
2426 END ;
2427 IF to_find_info.l_tag = tal THEN * LENGTH IS IN A *
2428 genstand pr6 temp_place isbq tn
2429 ELSE
2430 genstand nreg to_find_info.l_val isbq tdl ;
2431 loc1 := indfich ; genstand nreg 0 itmi tic ;
2432 genstand pr6 temp_place istq tn ;
2433 genstand nreg 0 ildq tdl ;
2434 WITH to_scan_info DO
2435 BEGIN
2436 IF register IN prstatic prlink pr6 THEN
2437 BEGIN
2438 getpr ;
2439 IF bloc <> NIL THEN regenere bloc ;
2440 genstand register wdisp prinst epp currentpr tn ;
2441 register := currentpr ; bloc := currentbloc ; bloc_is_new := true ;
2442 wdisp := 0 ;
2443 END ;
2444 END ;
2445 WITH to_find_info DO
2446 BEGIN
2447 IF reg_bloc <> NIL THEN regenere reg_bloc ;
2448 IF bloc <> NIL THEN regenere bloc ;
2449 END ;
2450 sauvereg x7 false ;
2451 genstand nreg 1 ildx7 tdu ;
2452 retplace := cb ; * LOOP BEGINNING *
2453 genstand nreg 1 iadq tdl ;
2454 mfari1 := to_find_info.mfari ; mfari2 := to_find_info.mfari ;
2455 geneism icmpc 0 p0t0r0 ;
2456 WITH to_scan_info DO
2457 gendesca register wdisp bdisp l9 to_find_info.l_val to_find_info.l_tag ;
2458 WITH to_find_info DO
2459 gendesca register wdisp bdisp l9 l_val l_tag ;
2460 loc2 := indfich ; genstand nreg 0 itze tic ; * TRANSFER IF FOUND *
2461 genstand to_scan_info.register 0 ia9bd tx7 ;
2462 genstand pr6 temp_place icmpq tn ;
2463 genstand nreg retplace - cb DIV bytesinword itmoz tic ;
2464 inser cb loc1 ;
2465 genstand nreg 0 ildq tdl ;
2466 inser cb loc2 ;
2467 WITH to_scan_info DO
2468 BEGIN
2469 IF bloc_is_new THEN freebloc bloc ;
2470 IF reg_bloc <> NIL THEN freebloc reg_bloc ;
2471 END ;
2472 WITH to_find_info DO
2473 BEGIN
2474 IF bloc_is_new THEN freebloc bloc ;
2475 IF reg_bloc <> NIL THEN freebloc reg_bloc ;
2476 END ;
2477 freeattr fattr ;
2478 freeattr gattr ;
2479 initattrvarbl gattr ;
2480 WITH gattr DO
2481 BEGIN
2482 kind := lval ; typtr := intptr ; ldreg := rq ;
2483 newbloc rq ; ldregbloc := currentbloc ;
2484 END ;
2485 genstand nreg 0 iorq tdl ; * TO SET INDICATORS : STANDARD FUNCTION RETURN OR PASCAL *
2486 END ;
2487
2488 $OPTIONS page$
2489
2490 * ********************************* GEN_SUBSTRING ****************************** *
2491
2492
2493 PROCEDURE gen_substring VAR string_attr disp_attr len_attr : attr ;
2494
2495 VAR
2496 loc1, temp_place : integer ;
2497 check_done : boolean ;
2498 string_info : string_item_info ;
2499 total_length, total_place : integer ;
2500 result_pointer : preg ; result_bloc : regpt ; result_place : integer ;
2501 loaded_reg : register ;
2502 dm1_place, from_wdisp, from_bdisp, dm1_value : integer ;
2503 disp_in_desc : boolean ; i : integer ;
2504 from_bloc : regpt ; from_reg : preg ; from_bloc_is_new : boolean ;
2505
2506 BEGIN
2507 total_length := -1 ; result_place := 0 ; * NOT KNOWN *
2508 * COMPUTE "DISP - 1" - ERROR IF NEGATIVE -
2509 STORE IT AT "DM1_PLACE" IN STACK IF NOT KNOWN *
2510 dm1_place := 0 ;
2511 WITH disp_attr DO
2512 BEGIN
2513 CASE kind OF
2514 varbl : IF raisused THEN
2515 BEGIN loaded_reg := rq ; sauvereg rq false ; transfer disp_attr inq END
2516 ELSE BEGIN loaded_reg := ra ; transfer disp_attr inacc END ;
2517 lval : BEGIN
2518 loaded_reg := ldreg ; IF ldregbloc <> NIL THEN regenere ldregbloc
2519 END ;
2520 sval : IF val - 1 < 0 THEN
2521 BEGIN error 278 ; dm1_value := 0 END
2522 ELSE dm1_value := val - 1 ;
2523 END ;
2524 IF kind IN varbl lval THEN
2525 BEGIN
2526 dm1_place := oldnewstor bytesinword DIV bytesinword ;
2527 genstand nreg 1 opaq sub loaded_reg tdl ;
2528 IF asscheck THEN
2529 BEGIN
2530 loc1 := indfich ; genstand nreg 0 itpl tic ;
2531 genexceptcode substring_offset_error loaded_reg ;
2532 inser cb loc1 ;
2533 END ;
2534 genstand pr6 dm1_place opaq stor loaded_reg tn ;
2535 END ;
2536 END ;
2537 freeattr disp_attr ;
2538 WITH len_attr DO * GET LENGTH IN Q *
2539 BEGIN
2540 CASE kind OF
2541 varbl : BEGIN
2542 sauvereg rq false ;
2543 transfer len_attr inq ;
2544 END ;
2545 sval : BEGIN
2546 IF raisused THEN
2547 BEGIN sauvereg rq false ; loaded_reg := rq ; END
2548 ELSE loaded_reg := rq ;
2549 IF val < 0 THEN
2550 BEGIN error 279 ; total_length := 0 END
2551 ELSE total_length := val ;
2552 result_place := oldnewstor 4 + total_length + 3 DIV bytesinword ;
2553 gencstecode total_length opaq load loaded_reg ;
2554 genstand pr6 result_place opaq stor loaded_reg tn ;
2555 END ;
2556 lval : BEGIN
2557 IF ldregbloc <> NIL THEN regenere ldregbloc ;
2558 IF ldreg = ra THEN
2559 BEGIN
2560 sauvereg rq false ;
2561 genstand nreg 36 ilrs tn ;
2562 IF asscheck THEN genstand nreg 0 iorq tdl ; * TO SET INDICATORS *
2563 END ;
2564 END ;
2565 END ;
2566 freeattr len_attr ;
2567 END ;
2568 IF result_place = 0 THEN * DYNAMIC ALLOCATION *
2569 BEGIN
2570 IF asscheck THEN
2571 BEGIN
2572 loc1 := indfich ; genstand nreg 0 itpl tic ;
2573 genexceptcode substring_negative_length_error rq ;
2574 inser cb loc1 ;
2575 END ;
2576 stack_extension ; * GET SPACE FOR RESULT *
2577 genstand pr6 evareaw istq tny ; * STORE LENGTH IN RESULT STRING *
2578 total_place := oldnewstor bytesinword DIV bytesinword ;
2579 genstand pr6 total_place istq tn ; * FOR MAXLENGTH VARIABLE OF RESULT TYPE *
2580 loaded_reg := rq ;
2581 END ;
2582 prepare_string string_attr string_info inacc ;
2583 WITH string_info DO
2584 BEGIN
2585 IF reg_bloc <> NIL THEN freebloc reg_bloc ;
2586 IF asscheck THEN
2587 BEGIN * CHECK THAT ACTUAL_LENGTH - DISP-1 >= LEN *
2588 check_done := false ;
2589 IF length_is_known THEN
2590 IF dm1_place = 0 THEN
2591 IF total_length <> -1 THEN
2592 BEGIN
2593 IF l_val - dm1_value < total_length THEN
2594 error 280 ;
2595 check_done := true ;
2596 END
2597 ELSE
2598 BEGIN
2599 sauvereg ra false ;
2600 gencstecode l_val - dm1_value ilda ;
2601 END
2602 ELSE
2603 BEGIN
2604 sauvereg ra false ;
2605 gencstecode l_val ilda ;
2606 genstand pr6 dm1_place isba tn ;
2607 END
2608 ELSE
2609 IF dm1_place = 0 THEN
2610 gencstecode dm1_value isba
2611 ELSE
2612 genstand pr6 dm1_place isba tn ;
2613 IF NOT check_done THEN
2614 BEGIN
2615 IF total_length <> -1 THEN
2616 gencstecode total_length icmpa
2617 ELSE
2618 genstand pr6 total_place icmpa tn ;
2619 loc1 := indfich ; genstand nreg 0 itpl tic ;
2620 genexceptcode substring_too_long_error ra ;
2621 inser cb loc1 ;
2622 END ;
2623 END * ASSCHECK * ;
2624 * NOW COMPUTE ADRESSES AND LENGTH FOR STRING TO MOVE *
2625 disp_in_desc := false ; from_bloc_is_new := false ;
2626 IF dm1_place = 0 THEN
2627 BEGIN
2628 i := wdisp * bytesinword + bdisp + dm1_value ;
2629 from_wdisp := i DIV bytesinword ;
2630 from_bdisp := i MOD bytesinword ;
2631 IF from_wdisp < twoto17 THEN
2632 BEGIN
2633 from_reg := register ; from_bloc := bloc ;
2634 disp_in_desc := true ;
2635 END ;
2636 END ;
2637 IF NOT disp_in_desc THEN
2638 BEGIN
2639 IF register IN prstatic prlink pr6 THEN
2640 BEGIN
2641 getpr ;
2642 IF bloc <> NIL THEN regenere bloc ;
2643 genstand register 0 prinst epp currentpr tn ;
2644 from_reg := currentpr ; from_bloc := currentbloc ; from_bloc_is_new := true ;
2645 END
2646 ELSE BEGIN
2647 from_bloc := bloc ; from_bloc_is_new := false ; from_reg := register ;
2648 END ;
2649 IF dm1_place <> 0 THEN
2650 genstand pr6 dm1_place ildq tn
2651 ELSE gencstecode dm1_value ildq ;
2652 IF from_bloc <> NIL THEN regenere from_bloc ;
2653 genstand from_reg 0 ia9bd tql ;
2654 from_wdisp := wdisp ; from_bdisp := bdisp ;
2655 END ;
2656 l_val := 0 ; l_tag := tal ;
2657 IF total_length <> -1 THEN
2658 BEGIN
2659 result_pointer := pr6 ; result_bloc := NIL ;
2660 IF total_length < twoto12 THEN
2661 BEGIN
2662 l_val := total_length ; l_tag := tn
2663 END
2664 ELSE
2665 gencstecode total_length ilda
2666 END
2667 ELSE
2668 BEGIN
2669 getpr ; result_place := 0 ; result_pointer := currentpr ; result_bloc := currentbloc ;
2670 genstand pr6 evareaw prinst epp result_pointer tny ;
2671 genstand pr6 total_place ilda tn ;
2672 END ;
2673 IF l_tag = tn THEN
2674 BEGIN
2675 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
2676 END
2677 ELSE BEGIN
2678 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
2679 END ;
2680 IF from_bloc <> NIL THEN regenere from_bloc ;
2681 IF result_bloc <> NIL THEN regenere result_bloc ;
2682 geneism imlr 0 p0t0r0 ;
2683 gendesca from_reg from_wdisp from_bdisp l9 l_val l_tag ;
2684 gendesca result_pointer result_place + 1 0 l9 l_val l_tag ;
2685 IF bloc_is_new THEN freebloc bloc ;
2686 freeattr string_attr ;
2687 IF from_bloc_is_new THEN freebloc from_bloc ;
2688 END ;
2689 initattrvarbl gattr ;
2690 WITH gattr DO
2691 BEGIN
2692 temporary := true ;
2693 basereg := result_pointer ; basebloc := result_bloc ; dplmt := result_place * bytesinword ;
2694 create_types_box typtr blank records false ;
2695 WITH typtr^ DO
2696 BEGIN
2697 father_schema := string_ptr ;
2698 IF total_length <> -1 THEN
2699 BEGIN
2700 create_konst_box actual_parameter_list 'maxlength' wordconst ;
2701 WITH actual_parameter_list^ DO
2702 BEGIN
2703 values := total_length ; contype := intptr ;
2704 nxtel := NIL ;
2705 END
2706 END
2707 ELSE BEGIN
2708 create_vars_box actual_parameter_list 'maxlength' ;
2709 WITH actual_parameter_list^ DO
2710 BEGIN
2711 vtype := intptr ;
2712 vaddr := total_place ;
2713 nxtel := NIL ;
2714 END ;
2715 END ;
2716 END ;
2717 END ;
2718 END ;
2719
2720 $OPTIONS page$
2721
2722 * ************************************* GEN_DELETE ****************************************** *
2723
2724 PROCEDURE gen_delete VAR string_attr disp_attr del_len_attr : attr ;
2725
2726 * GENERATES CODE FOR
2727
2728 DELETE <STRING VARIABLE> DISP LEN ;
2729
2730 *
2731 VAR
2732 string_info : string_item_info ;
2733 dm1_place, dm1_value : integer ;
2734 loaded_reg : register ; loc1 : integer ;
2735 del_len_place, del_len_value : integer ; del_len_bloc : regpt ;
2736 del_len_reg : preg ;
2737 remaining_length : integer ; check_done : boolean ;
2738 from_reg, to_reg : preg ; from_bloc, to_bloc : regpt ;
2739 from_offset_in_desc, to_offset_in_desc : boolean ;
2740 from_bloc_is_new, to_bloc_is_new : boolean ;
2741 i : integer ; l_len : integer ; l_tag : tag ;
2742 to_wdisp, to_bdisp, from_wdisp, from_bdisp : integer ;
2743 del_len_bloc_is_new : boolean ;
2744
2745 BEGIN
2746 * COMPUTE "DISP - 1" - ERROR IF NEGATIVE -
2747 STORE IT AT "DM1_PLACE" IN STACK IF NOT KNOWN *
2748 dm1_place := 0 ;
2749 WITH disp_attr DO
2750 BEGIN
2751 CASE kind OF
2752 varbl : IF raisused THEN
2753 BEGIN loaded_reg := rq ; sauvereg rq false ; transfer disp_attr inq END
2754 ELSE BEGIN loaded_reg := ra ; transfer disp_attr inacc END ;
2755 lval : BEGIN
2756 loaded_reg := ldreg ; IF ldregbloc <> NIL THEN regenere ldregbloc
2757 END ;
2758 sval : IF val - 1 < 0 THEN
2759 BEGIN error 276 ; dm1_value := 0 END
2760 ELSE dm1_value := val - 1 ;
2761 END ;
2762 IF kind IN varbl lval THEN
2763 BEGIN
2764 dm1_place := oldnewstor bytesinword DIV bytesinword ;
2765 genstand nreg 1 opaq sub loaded_reg tdl ;
2766 IF asscheck THEN
2767 BEGIN
2768 loc1 := indfich ; genstand nreg 0 itpl tic ;
2769 genexceptcode delete_offset_error loaded_reg ;
2770 inser cb loc1 ;
2771 END ;
2772 genstand pr6 dm1_place opaq stor loaded_reg tn ;
2773 END ;
2774 END ;
2775 freeattr disp_attr ;
2776 * GET INFO ABOUT LEN. IF KNOWN LEN_VALUE IS <> -1 *
2777 del_len_reg := nreg ; del_len_bloc := NIL ; del_len_bloc_is_new := false ;
2778 del_len_value := -1 ; del_len_place := 0 ;
2779 WITH del_len_attr DO
2780 BEGIN
2781 CASE kind OF
2782 varbl : IF varissimple del_len_attr THEN
2783 BEGIN
2784 del_len_reg := basereg ; del_len_bloc := basebloc ; del_len_place := dplmt DIV bytesinword
2785 END
2786 ELSE BEGIN
2787 loadadr del_len_attr nreg ; del_len_reg := currentpr ; del_len_bloc := currentbloc ;
2788 del_len_bloc_is_new := true
2789 END ;
2790 sval : IF val < 0 THEN BEGIN error 277 ; del_len_value := 0 END
2791 ELSE del_len_value := val ;
2792 lval : BEGIN
2793 del_len_place := oldnewstor bytesinword DIV bytesinword ; del_len_reg := pr6 ;
2794 IF ldregbloc <> NIL THEN regenere ldregbloc ;
2795 genstand del_len_reg del_len_place opaq stor ldreg tn ;
2796 END ;
2797 END ;
2798 IF asscheck THEN
2799 IF kind IN varbl lval THEN
2800 BEGIN
2801 IF del_len_attr.kind = varbl THEN
2802 IF symbolmap THEN nameisref del_len_attr.nameaddr symbolfile symbolline ;
2803 genstand del_len_reg del_len_place iszn tn ;
2804 loc1 := indfich ; genstand nreg 0 itpl tic ;
2805 genexceptcode delete_negative_length_error ra ;
2806 inser cb loc1 ;
2807 END ;
2808 END ;
2809 remaining_length := -1 ;
2810 prepare_string string_attr string_info inacc ;
2811 WITH string_info DO
2812 BEGIN
2813 IF reg_bloc <> NIL THEN freebloc reg_bloc ;
2814 check_done := false ;
2815 IF length_is_known THEN
2816 BEGIN
2817 sauvereg ra false ; check_done := false ;
2818 IF del_len_value <> -1 THEN
2819 BEGIN
2820 IF l_val - del_len_value < 0 THEN
2821 BEGIN error 276 ; del_len_value := 0 END ;
2822 IF dm1_place = 0 THEN
2823 BEGIN
2824 remaining_length := l_val - del_len_value - dm1_value ;
2825 IF remaining_length < 0 THEN
2826 BEGIN error 276 ; remaining_length := 0 END ;
2827 END ;
2828 gencstecode l_val - del_len_value ilda ; check_done := true ;
2829 END
2830 ELSE BEGIN
2831 gencstecode l_val ilda ;
2832 IF del_len_bloc <> NIL THEN regenere del_len_bloc ;
2833 IF del_len_attr.kind = varbl THEN
2834 IF symbolmap THEN nameisref del_len_attr.nameaddr symbolfile symbolline ;
2835 genstand del_len_reg del_len_place isba tn
2836 END
2837 END
2838 ELSE IF del_len_value <> -1 THEN
2839 gencstecode del_len_value isba
2840 ELSE BEGIN
2841 IF del_len_bloc <> NIL THEN regenere del_len_bloc ;
2842 IF del_len_attr.kind = varbl THEN
2843 IF symbolmap THEN nameisref del_len_attr.nameaddr symbolfile symbolline ;
2844 genstand del_len_reg del_len_place isba tn
2845 END ;
2846 IF bloc <> NIL THEN regenere bloc ;
2847 genstand register wdisp - 1 ista tn ; * STORE NEW LENGTH OF THE STRING *
2848 * NOW GET IN RA LENGTH OF STRING TO BE MOVED *
2849 l_len := 0 ; l_tag := tal ;
2850 IF remaining_length = -1 THEN
2851 IF dm1_place = 0 THEN
2852 IF dm1_value <> 0 THEN
2853 gencstecode dm1_value isba
2854 ELSE * nothing *
2855 ELSE BEGIN
2856 genstand pr6 dm1_place isba tn ;
2857 IF asscheck THEN
2858 BEGIN
2859 loc1 := indfich ; genstand nreg 0 itpl tic ;
2860 genexceptcode delete_too_long_error ra ;
2861 inser cb loc1 ;
2862 END ;
2863 END
2864 ELSE
2865 BEGIN
2866 l_len := remaining_length ; l_tag := tn ;
2867 gencstecode remaining_length ilda ;
2868 END ;
2869 * COMPUTE ADDRESSES OF MOVE *
2870 from_bloc := NIL ; to_bloc := NIL ;
2871 to_offset_in_desc := false ; from_offset_in_desc := false ;
2872 to_bloc_is_new := false ; from_bloc_is_new := false ;
2873 IF dm1_place = 0 THEN
2874 BEGIN
2875 i := wdisp * bytesinword + dm1_value + bdisp ;
2876 to_wdisp := i DIV bytesinword ;
2877 to_bdisp := i MOD bytesinword ;
2878 IF to_wdisp < twoto17 THEN
2879 BEGIN
2880 to_bloc := bloc ; to_reg := register ;
2881 to_offset_in_desc := true ;
2882 IF del_len_value <> -1 THEN
2883 BEGIN
2884 i := i + del_len_value ;
2885 from_wdisp := i DIV bytesinword ;
2886 from_bdisp := i MOD bytesinword ;
2887 IF from_wdisp < twoto17 THEN
2888 BEGIN
2889 from_bloc := to_bloc ; from_reg := to_reg ;
2890
2891 from_offset_in_desc := true ;
2892 END ;
2893 END ;
2894 END ;
2895 END ;
2896 IF NOT to_offset_in_desc THEN
2897 BEGIN
2898 to_wdisp := wdisp ; to_bdisp := bdisp ;
2899 IF register IN prstatic prlink pr6 THEN
2900 BEGIN
2901 getpr ; to_bloc := currentbloc ; to_reg := currentpr ;
2902 to_bloc_is_new := true ;
2903 IF bloc <> NIL THEN regenere bloc ;
2904 genstand register 0 prinst epp to_reg tn ;
2905 END
2906 ELSE BEGIN
2907 to_bloc := bloc ; to_reg := register ;
2908 END ;
2909 IF dm1_place = 0 THEN
2910 gencstecode dm1_value ildq
2911 ELSE genstand pr6 dm1_place ildq tn ;
2912 IF to_bloc <> NIL THEN regenere to_bloc ;
2913 genstand to_reg 0 ia9bd tql ;
2914 END ;
2915 IF NOT from_offset_in_desc THEN
2916 IF del_len_value <> -1 THEN
2917 BEGIN
2918 i := to_wdisp * bytesinword + to_bdisp + del_len_value ;
2919 from_wdisp := i DIV bytesinword ;
2920 from_bdisp := i MOD bytesinword ;
2921 IF from_wdisp < twoto17 THEN
2922 BEGIN
2923 from_bloc := to_bloc ; from_reg := to_reg ;
2924 from_offset_in_desc := true ;
2925 END ;
2926 END ;
2927 IF NOT from_offset_in_desc THEN
2928 BEGIN
2929 from_bdisp := bdisp ; from_wdisp := wdisp ;
2930 IF del_len_value <> -1 THEN
2931 gencstecode del_len_value ildq
2932 ELSE BEGIN
2933 IF del_len_bloc <> NIL THEN regenere del_len_bloc ;
2934 genstand del_len_reg del_len_place ildq tn ;
2935 END ;
2936 IF del_len_bloc_is_new THEN freebloc del_len_bloc ;
2937 freeattr del_len_attr ;
2938 getpr ; from_bloc := currentbloc ; from_reg := currentpr ;
2939 from_bloc_is_new := true ;
2940 IF from_bloc <> NIL THEN regenere from_bloc ;
2941 genstand to_reg 0 prinst epp from_reg tn ;
2942 genstand from_reg 0 ia9bd tql ;
2943 END
2944 ELSE BEGIN
2945 IF del_len_bloc_is_new THEN freebloc del_len_bloc ;
2946 freeattr del_len_attr
2947 END ;
2948 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
2949 IF to_bloc <> NIL THEN regenere to_bloc ; IF from_bloc <> NIL THEN regenere from_bloc ;
2950 geneism imlr 0 p0t0r0 ;
2951 gendesca from_reg from_wdisp from_bdisp l9 l_len l_tag ;
2952 gendesca to_reg to_wdisp to_bdisp l9 l_len l_tag ;
2953 IF bloc_is_new THEN freebloc bloc ;
2954 IF from_bloc_is_new THEN freebloc from_bloc ;
2955 IF to_bloc_is_new THEN freebloc to_bloc ;
2956 freeattr string_attr ;
2957 END ;
2958 END * GEN_DELETE * ;
2959
2960 $OPTIONS page$
2961
2962 * ************************************* GEN_INSERT ****************************************** *
2963
2964 PROCEDURE gen_insert VAR insert_attr string_attr disp_attr : attr ;
2965
2966 * GENERATES CODE FOR
2967
2968 INSERT <STRING EXPRESSION> <STRING VARIABLE> DISP ;
2969
2970 *
2971 VAR
2972 maxl_attr : attr ;
2973 string_info : string_item_info ;
2974 insert_info : string_item_info ;
2975 dm1_place, dm1_value : integer ;
2976 loaded_reg : register ; loc1, loc2, loc3 : integer ;
2977 check_done : boolean ;
2978 from_reg, to_reg : preg ; from_bloc, to_bloc : regpt ;
2979 from_offset_in_desc, to_offset_in_desc : boolean ;
2980 from_bloc_is_new, to_bloc_is_new : boolean ;
2981 i : integer ; l_len : integer ; l_tag : tag ;
2982 to_wdisp, to_bdisp, from_wdisp, from_bdisp : integer ;
2983
2984 BEGIN
2985 * COMPUTE "DISP - 1" - ERROR IF NEGATIVE -
2986 STORE IT AT "DM1_PLACE" IN STACK IF NOT KNOWN *
2987 dm1_place := 0 ;
2988 WITH disp_attr DO
2989 BEGIN
2990 CASE kind OF
2991 varbl : IF raisused THEN
2992 BEGIN loaded_reg := rq ; sauvereg rq false ; transfer disp_attr inq END
2993 ELSE BEGIN loaded_reg := ra ; transfer disp_attr inacc END ;
2994 lval : BEGIN
2995 loaded_reg := ldreg ; IF ldregbloc <> NIL THEN regenere ldregbloc
2996 END ;
2997 sval : IF val - 1 < 0 THEN
2998 BEGIN error 276 ; dm1_value := 0 END
2999 ELSE dm1_value := val - 1 ;
3000 END ;
3001 IF kind IN varbl lval THEN
3002 BEGIN
3003 dm1_place := oldnewstor bytesinword DIV bytesinword ;
3004 genstand nreg 1 opaq sub loaded_reg tdl ;
3005 IF asscheck THEN
3006 BEGIN
3007 loc1 := indfich ; genstand nreg 0 itpl tic ;
3008 genexceptcode delete_offset_error loaded_reg ;
3009 inser cb loc1 ;
3010 END ;
3011 genstand pr6 dm1_place opaq stor loaded_reg tn ;
3012 END ;
3013 END ;
3014 freeattr disp_attr ;
3015 * GET INFO ABOUT TARGET *
3016 prepare_string string_attr string_info out ;
3017 * GET INFO ABOUT INSERT. *
3018 prepare_string insert_attr insert_info out ;
3019 * CHECK THAT LENGTH STRING IS VALID
3020 AND THAT LENGTH STRING + LENGTH INSERT IS NOT > MAXLENGTH STRING *
3021 IF asscheck THEN
3022 WITH string_attr, string_info DO
3023 IF typtr^.actual_parameter_list <> NIL THEN
3024 BEGIN
3025 WITH typtr^ DO
3026 BEGIN
3027 IF raisused THEN
3028 BEGIN
3029 loaded_reg := rq ;
3030 sauvereg rq false ;
3031 END
3032 ELSE BEGIN
3033 loaded_reg := ra ;
3034 END ;
3035 IF actual_parameter_list^.klass <> konst THEN
3036 BEGIN
3037 addressvar actual_parameter_list maxl_attr false ;
3038 IF loaded_reg = rq THEN
3039 transfer maxl_attr inq
3040 ELSE
3041 transfer maxl_attr inacc ;
3042 freeattr maxl_attr ;
3043 END
3044 ELSE
3045 gencstecode actual_parameter_list^.values opaq load loaded_reg ;
3046 IF bloc <> NIL THEN regenere bloc ;
3047 genstand register wdisp - 1 iszn tn ;
3048 loc1 := indfich ; genstand nreg 0 itmi tic ;
3049 genstand register wdisp - 1 opaq cmp loaded_reg tn ;
3050 loc2 := indfich ; genstand nreg 0 itmi tic ;
3051 WITH insert_info DO
3052 IF length_is_known THEN
3053 gencstecode length opaq sub loaded_reg
3054 ELSE
3055 BEGIN
3056 IF len_bloc <> NIL THEN regenere len_bloc ;
3057 genstand len_reg len_place opaq sub loaded_reg tn ;
3058 END ;
3059 genstand register wdisp - 1 opaq cmp loaded_reg tn ;
3060 loc3 := indfich ; genstand nreg 0 itpl tic ;
3061 genexceptcode insert_overflow_error loaded_reg ;
3062 inser cb loc1 ; inser cb loc2 ;
3063 genexceptcode stringlength_range_error loaded_reg ;
3064 inser cb loc3 ;
3065 END ;
3066 END ;
3067 WITH string_info DO
3068 BEGIN
3069 * NOW GET IN RA LENGTH OF STRING TO BE MOVED *
3070 genstand register wdisp - 1 ilda tn ;
3071 IF dm1_place = 0 THEN
3072 IF dm1_value <> 0 THEN
3073 gencstecode dm1_value isba
3074 ELSE * nothing *
3075 ELSE
3076 genstand pr6 dm1_place isba tn ;
3077 * STORE NEW LENGTH IN STRING *
3078 IF insert_info.length_is_known THEN
3079 IF insert_info.length <> 0 THEN
3080 BEGIN
3081 gencstecode insert_info.length ildq ;
3082 IF bloc <> NIL THEN regenere bloc ;
3083 genstand register wdisp - 1 iasq tn ;
3084 END
3085 ELSE * nothing *
3086 ELSE
3087 BEGIN
3088 IF insert_info.len_bloc <> NIL THEN regenere insert_info.len_bloc ;
3089 genstand insert_info.len_reg insert_info.len_place ildq tn ;
3090 IF bloc <> NIL THEN regenere bloc ;
3091 genstand register wdisp - 1 iasq tn ;
3092 END ;
3093 * COMPUTE ADDRESSES OF MOVE *
3094 to_bloc := NIL ; from_bloc := NIL ;
3095 from_offset_in_desc := false ; to_offset_in_desc := false ;
3096 from_bloc_is_new := false ; to_bloc_is_new := false ;
3097 IF dm1_place = 0 THEN
3098 BEGIN
3099 i := wdisp * bytesinword + dm1_value + bdisp ;
3100 from_wdisp := i DIV bytesinword ;
3101 from_bdisp := i MOD bytesinword ;
3102 IF from_wdisp < twoto17 THEN
3103 BEGIN
3104 from_bloc := bloc ; from_reg := register ;
3105 from_offset_in_desc := true ;
3106 IF insert_info.length_is_known THEN
3107 BEGIN
3108 i := i + insert_info.length ;
3109 to_wdisp := i DIV bytesinword ;
3110 to_bdisp := i MOD bytesinword ;
3111 IF to_wdisp < twoto17 THEN
3112 BEGIN
3113 to_bloc := from_bloc ; to_reg := from_reg ;
3114 to_offset_in_desc := true ;
3115 END ;
3116 END ;
3117 END ;
3118 END ;
3119 IF NOT from_offset_in_desc THEN
3120 BEGIN
3121 from_wdisp := wdisp ; from_bdisp := bdisp ;
3122 IF register IN prstatic prlink pr6 THEN
3123 BEGIN
3124 getpr ; from_bloc := currentbloc ; from_reg := currentpr ;
3125 from_bloc_is_new := true ;
3126 IF bloc <> NIL THEN regenere bloc ;
3127 genstand register 0 prinst epp from_reg tn ;
3128 END
3129 ELSE BEGIN
3130 from_bloc := bloc ; from_reg := register ;
3131 END ;
3132 IF dm1_place = 0 THEN
3133 gencstecode dm1_value ildq
3134 ELSE genstand pr6 dm1_place ildq tn ;
3135 IF from_bloc <> NIL THEN regenere from_bloc ;
3136 genstand from_reg 0 ia9bd tql ;
3137 END ;
3138 IF NOT to_offset_in_desc THEN
3139 IF insert_info.length_is_known THEN
3140 BEGIN
3141 i := from_wdisp * bytesinword + from_bdisp + insert_info.length ;
3142 to_wdisp := i DIV bytesinword ;
3143 to_bdisp := i MOD bytesinword ;
3144 IF to_wdisp < twoto17 THEN
3145 BEGIN
3146 to_bloc := from_bloc ; to_reg := from_reg ;
3147 to_offset_in_desc := true ;
3148 END ;
3149 END ;
3150 IF NOT to_offset_in_desc THEN
3151 BEGIN
3152 to_bdisp := bdisp ; to_wdisp := wdisp ;
3153 IF insert_info.length_is_known THEN
3154 gencstecode insert_info.length ildq
3155 ELSE BEGIN
3156 genstand insert_info.len_reg insert_info.len_place ildq tn ;
3157 END ;
3158 getpr ; to_bloc := currentbloc ; to_reg := currentpr ;
3159 to_bloc_is_new := true ;
3160 IF to_bloc <> NIL THEN regenere to_bloc ;
3161 genstand from_reg 0 prinst epp to_reg tn ;
3162 genstand to_reg 0 ia9bd tql ;
3163 END ;
3164 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
3165 IF from_bloc <> NIL THEN regenere from_bloc ; IF to_bloc <> NIL THEN regenere to_bloc ;
3166 geneism imrl 0 p0t0r0 ;
3167 gendesca from_reg from_wdisp from_bdisp l9 0 tal ;
3168 gendesca to_reg to_wdisp to_bdisp l9 0 tal ;
3169 IF to_bloc_is_new THEN freebloc to_bloc ;
3170 mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
3171 WITH insert_info DO
3172 BEGIN
3173 l_tag := tal ; l_val := 0 ;
3174 IF bloc <> NIL THEN regenere bloc ;
3175 IF length_is_known THEN
3176 IF length < twoto12 THEN
3177 BEGIN
3178 l_tag := tn ; l_val := length ;
3179 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
3180 END
3181 ELSE
3182 gencstecode length ilda
3183 ELSE
3184 genstand len_reg len_place ilda tn ;
3185 geneism imlr 0 p0t0r0 ;
3186 gendesca register wdisp bdisp l9 l_val l_tag ;
3187 gendesca from_reg from_wdisp from_bdisp l9 l_val l_tag ;
3188 END ;
3189 IF bloc_is_new THEN freebloc bloc ;
3190 IF from_bloc_is_new THEN freebloc from_bloc ;
3191 WITH insert_info DO
3192 IF bloc_is_new THEN freebloc bloc ;
3193 freeattr insert_attr ;
3194 freeattr string_attr ;
3195 END ;
3196 END * GEN_INSERT * ;
3197
3198 BEGIN
3199 END. * END OF MODULE *