d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
ack/lang/a68s/aem/perqce.p

1079 lines
42 KiB
OpenEdge ABL
Raw Normal View History

Initial revision
1988-10-04 10:56:50 +00:00
~>|sed -e '/ *$/s/ *$/~~~~/' -e '/~~~~/s///' >a68s1ce.pp
00100 (*CODE EMITTER*)
00110 (**************)
00111 Things needing attention
00112 OCVIMMPTR and OCVIMMLONG (see PARAM and EMITOP)
00120 (**)
00130 (*+01() (*$T-+) ()+01*)
00140 (*+02() (*$T-+) ()+02*)
00150 (*-05()
00160 PROCEDURE LOAD (WHERE:SBTTYP; SB:PSB); FORWARD;
00170 PROCEDURE EMITEND; FORWARD;
00180 PROCEDURE EMITX1 (OPCOD:POP;TYP1:OPDTYP;OPND1:ADDRINT); FORWARD;
00190 PROCEDURE EMITX2 (OPCOD:POP;TYP1:OPDTYP;OPND1:ADDRINT;TYP2:OPDTYP;OPND2:ADDRINT); FORWARD;
00200 FUNCTION GENLCLGBL (VAR OPCOD:POP; SB:PSB):OFFSETR; FORWARD;
00210 PROCEDURE FIXUPF(ALABL:LABL);FORWARD;
00220 FUNCTION FIXUPM: LABL; FORWARD;
00230 PROCEDURE UNSTKP1(TYP:OPDTYP; OPND:PSB); FORWARD;
00240 ()-05*)
00250 PROCEDURE EMITOP (OPCOD:POP); FORWARD;
00260 PROCEDURE GENDENOT (OPCOD:POP; SB:PSB); FORWARD;
00270 FUNCTION GETNEXTLABEL: LABL;
00280 BEGIN GETNEXTLABEL := NEXTLABEL; NEXTLABEL := NEXTLABEL+1 END;
00290 (**)
00300 (**)
00310 (*+32()
00320 (*-01() PROCEDURE HALT; VAR I,K: INTEGER; BEGIN I:=0;K := K DIV I END; ()-01*)
00330 PROCEDURE ASSERT (ASSERTION:BOOLEAN; REASON:ALFA);
00340 BEGIN
00350 IF NOT (ASSERTION) THEN
00360 BEGIN
00370 WRITELN(OUTPUT,' ASSERT FAILED ',REASON);
00380 (*+01() PUTSEG(OUTPUT); ()+01*)
00390 EMITEND;
00400 HALT
00410 END
00420 END;
00430 (**)
00440 ()+32*)
00450 (* PERQ CODE EMITTER *)
00460 (*********************)
00470 (*+05()
00480 PROCEDURE PARAM(TYP:OPDTYP; OPND:INTEGER; OPCOD: POP; ALIGN: INTEGER; FIRSTIME: BOOLEAN); FORWARD;
00490 PROCEDURE EMITOPRAND(TYP:OPDTYP;OPERAND:ADDRINT);
00500 VAR REC: RECORD CASE SEVERAL OF
00510 1: (INT:ADDRINT);
00520 2: (LEX:PLEX);
00530 3,4,5,6,7,8,9,10: ()
00540 END;
00550 I:INTEGER;
00560 BEGIN
00570 CASE TYP OF
00580 OCVIMMED: WRITE(LGO[ROUTNL^.RNLEVEL],' ',OPERAND:1);
00590 OCVFREF,OCVMEM,OCVFIM:
00600 WRITE(LGO[ROUTNL^.RNLEVEL],' L',OPERAND:1);
00610 OCVEXT: BEGIN
00620 REC.INT := OPERAND;
00630 WRITE(LGO[ROUTNL^.RNLEVEL], '_');
00640 FOR I := 1 TO 7 DO
00650 (*IF REC.LEX^.S10[I]<>' ' THEN WRITE(LGO[ROUTNL^.RNLEVEL], CHR(ORD(REC.LEX^.S10[I])+32));*)
00660 WRITE(LGO[ROUTNL^.RNLEVEL], REC.LEX^.S10[I]);
00670 END
00680 END;
00690 END;
00700 (**)
00710 PROCEDURE EMITXWORD(TYP:OPDTYP;OPERAND:ADDRINT);
00720 VAR REC: RECORD CASE SEVERAL OF
00730 1: (INT:ADDRINT);
00740 2: (LEX:PLEX);
00750 3,4,5,6,7,8,9,10: ()
00760 END;
00770 I:INTEGER;
00780 BEGIN
00790 (*+32() ASSERT(TYP<>OCVFIM, 'EMITXWORD '); ()+32*)
00800 IF TYP=OCVIMMED THEN WRITE(LGO[ROUTNL^.RNLEVEL],' int ')
00810 ELSE WRITE(LGO[ROUTNL^.RNLEVEL], ' ptrw ');
00820 EMITOPRAND(TYP,OPERAND);
00830 WRITELN(LGO[ROUTNL^.RNLEVEL]);
00840 END;
00850 (**)
00860 PROCEDURE EMITXPROC(TYP:OPDTYP;OPERAND:ADDRINT);
00870 VAR REC: RECORD CASE SEVERAL OF
00880 1: (INT:ADDRINT);
00890 2: (LEX:PLEX);
00900 3,4,5,6,7,8,9,10: ()
00910 END;
00920 I:INTEGER;
00930 BEGIN
00940 WRITE(LGO[ROUTNL^.RNLEVEL],' ptrf ');EMITOPRAND(TYP,OPERAND);
00950 WRITELN(LGO[ROUTNL^.RNLEVEL]);
00960 END;
00970 (**)
00980 PROCEDURE EMITALF(OPERAND: ALFA);
00990 VAR I: INTEGER;
01000 BEGIN
01010 IF DATASTATE=STARTDATA THEN
01020 BEGIN WRITELN(LGO[ROUTNL^.RNLEVEL], 'data'); DATASTATE := INDATA END;
01030 WRITE(LGO[ROUTNL^.RNLEVEL], ' byte '); FOR I := 1 TO 9 DO WRITE(LGO[ROUTNL^.RNLEVEL], ORD(OPERAND[I]):3, ',');
01040 WRITELN(LGO[ROUTNL^.RNLEVEL], ORD(OPERAND[10]):3);
01050 END;
01060 (**)
01070 (**)
01080 PROCEDURE EMITOP (* (OPCOD:POP) *);
01090 VAR I,COUNT:INTEGER; JUMPOVER:LABL;
01100 TEMP:INTEGER; OP:MNEMONICS;
01110 PARAMNOTUSED: BOOLEAN;
01120 BEGIN
01130 IF DATASTATE<>OUTDATA THEN
01140 BEGIN DATASTATE := OUTDATA; WRITELN(LGO[ROUTNL^.RNLEVEL], 'text') END;
01150 COUNT := 0; PARAMNOTUSED := TRUE;
01160 WHILE OPCOD <> 0 DO WITH CODETABLE[OPCOD] DO
01170 BEGIN
01180 IF INLINE THEN
01190 BEGIN
01200 IF PERQCOD='CI ' THEN
01210 IF OCV=OCVFIM THEN WRITE(LGO[ROUTNL^.RNLEVEL], ' cil ')
01220 ELSE IF (OCV=OCVMEM) OR (OCV=OCVFREF) OR (OCV=OCVEXT) THEN WRITE(LGO[ROUTNL^.RNLEVEL], ' lga ')
01230 ELSE WRITE(LGO[ROUTNL^.RNLEVEL], ' ci ')
01240 ELSE IF OPCOD<>PNOOP THEN
01242 BEGIN
01250 WRITE(LGO[ROUTNL^.RNLEVEL],' ');
01260 FOR i := 1 TO 8 DO
01270 WRITE(LGO[ROUTNL^.RNLEVEL],CHR(ORD(PERQCOD[I])+32*ORD(ORD(PERQCOD[I])>63)));
01280 END;
01290 CASE PARTYP OF
01300 WOP,ACP: (* OPERAND SUPPLIED BY CODETABLE *)
01310 WRITE(LGO[ROUTNL^.RNLEVEL], ' ', PARM:1);
01320 WNP,ANP: (*NEGATIVE OPERAND SUPPLIED BY CODETABLE*)
01330 WRITE(LGO[ROUTNL^.RNLEVEL], ' ', -PARM:1);
01340 OPX,ACX: (* OPERAND IS SUPPLIED BY CODE GENERATOR *)
01350 BEGIN EMITOPRAND(OCV, OPRAND+PARM); PARAMNOTUSED := FALSE END;
01360 ONX,ANX: (* NEGATIVE OPERAND SUPPLIED BY CODE GENERATOR*)
01370 BEGIN EMITOPRAND(OCV, -OPRAND-PARM); PARAMNOTUSED := FALSE END;
01380 JMP: (* P-OP GENERATES ITS OWN LABELS FOR LOOPS ETC. *)
01390 BEGIN
01400 COUNT := PARM;
01410 JUMPOVER := GETNEXTLABEL;
01420 WRITE(LGO[ROUTNL^.RNLEVEL],' L',JUMPOVER:1);
01430 END;
01440 NON: (* NO OPERAND *);
01450 GBX: (* GLOBAL LABEL EXPECTED *)
01460 BEGIN WRITE(LGO[ROUTNL^.RNLEVEL],' L',OPRAND:1); PARAMNOTUSED := FALSE END;
01470 LCX: (* INSTRUCTION LABEL EXPECTED *)
01480 BEGIN WRITE(LGO[ROUTNL^.RNLEVEL],' L',OPRAND:1); PARAMNOTUSED := FALSE END;
01490 MOR: (* LONG OPERAND FOLLOWS IN NEXT OPCOD *)
01500 BEGIN OPCOD := NEXT;
01510 WRITE(LGO[ROUTNL^.RNLEVEL], CODETABLE[OPCOD].PERQCOD);
01520 END;
01530 END; (* OF CASE *)
01540 IF PARTYP>=ACP THEN BEGIN ADJUSTSP := ADJUSTSP+SZWORD; PARAMNOTUSED := FALSE END;
01550 IF OPCOD<>PNOOP THEN WRITELN(LGO[ROUTNL^.RNLEVEL]);
01560 IF (PERQCOD[1]=' ') AND (REGSINUSE.ECOUNT<>0) THEN EMITOP(PDISCARD);
01570 OPCOD := CODETABLE[OPCOD].NEXT;
01572 IF COUNT = 1 THEN WRITELN(LGO[ROUTNL^.RNLEVEL],' L',JUMPOVER: 1,':');
01574 COUNT := COUNT-1;
01580 END
01590 ELSE
01600 BEGIN
01610 IF PARAMNOTUSED THEN PARAM(OCVNONE, 0, OPCOD, 0, FALSE);
01620 WRITE(LGO[ROUTNL^.RNLEVEL],' ','call _',ROUTINE); WRITELN(LGO[ROUTNL^.RNLEVEL]) ;
01630 OPCOD := 0;
01640 (*+32() ASSERT((RTSTKDEPTH+ADJUSTSP) MOD 4 = 0, 'EMITOP - A'); ()+32*)
01650 IF COUNT = 1 THEN WRITELN(LGO[ROUTNL^.RNLEVEL],' L',JUMPOVER: 1,':');
01700 COUNT := COUNT-1;
01702 IF ADJUSTSP<>0 THEN EMITX1(PASP, OCVIMMED, ADJUSTSP);
01710 END;
01750 END;
01760 END;
01770 (**)
01780 PROCEDURE FIXUPF (*+05() (ALABL:LABL) ()+05*);
01790 BEGIN
01800 IF DATASTATE=STARTDATA THEN
01810 BEGIN WRITELN(LGO[ROUTNL^.RNLEVEL], 'data'); WRITELN(LGO[ROUTNL^.RNLEVEL], 'align4'); DATASTATE := INDATA END
01820 ELSE IF DATASTATE=ENDDATA THEN
01830 BEGIN WRITELN(LGO[ROUTNL^.RNLEVEL], 'text'); DATASTATE := OUTDATA END;
01840 WRITELN(LGO[ROUTNL^.RNLEVEL],'L',ALABL:1,':');
01850 END;
01860 (**)
01870 FUNCTION FIXUPM:LABL;
01880 VAR L:LABL;
01890 BEGIN
01900 IF DATASTATE=STARTDATA THEN
01910 BEGIN WRITELN(LGO[ROUTNL^.RNLEVEL], 'data'); WRITELN(LGO[ROUTNL^.RNLEVEL], 'align4'); DATASTATE := INDATA END
01920 ELSE IF DATASTATE=ENDDATA THEN
01930 BEGIN WRITELN(LGO[ROUTNL^.RNLEVEL], 'text'); DATASTATE := OUTDATA END;
01940 L := GETNEXTLABEL;
01950 FIXUPM := L;
01960 WRITELN(LGO[ROUTNL^.RNLEVEL],'L',L:1,':');
01970 END;
01980 (**)
01990 PROCEDURE FIXUPFIM(ALABL:LABL;VALUE:A68INT);
02000 BEGIN
02010 WRITELN(LGO[ROUTNL^.RNLEVEL], ' constant L', ALABL:1, ' ', VALUE: 1);
02020 END;
02030 (**)
02040 PROCEDURE FIXLABL(OLDLABL,NEWLABL:LABL; KNOWN:BOOLEAN);
02050 VAR JUMPOVER: LABL;
02060 BEGIN
02070 JUMPOVER := GETNEXTLABEL;
02080 WRITELN(LGO[ROUTNL^.RNLEVEL], ' jump L', JUMPOVER:1);
02090 WRITELN(LGO[ROUTNL^.RNLEVEL], 'L',OLDLABL:1, ':');
02100 WRITELN(LGO[ROUTNL^.RNLEVEL], ' jump L', NEWLABL:1);
02110 WRITELN(LGO[ROUTNL^.RNLEVEL], 'L',JUMPOVER:1, ':');
02120 END;
02130 FUNCTION NORMAL(SB: PSB): SBTTYP;
02140 (*RETURNS THE SBTTYP IN WHICH VALUES OF MODE SB^.SBMODE SHOULD BE STORED DURING BALANCES*)
02150 BEGIN WITH SB^ DO WITH SBMODE^.MDV DO
02160 IF SBTYP=SBTDL THEN NORMAL := SBTDL
02170 ELSE IF SBUNION IN SBINF THEN NORMAL := SBTSTKN
02180 ELSE IF SBNAKED IN SBINF THEN NORMAL := SBTFPR0
02190 ELSE IF MDPILE THEN NORMAL := SBTE
02200 ELSE CASE MDLEN OF
02210 0: NORMAL := SBTVOID;
02220 2: NORMAL := SBTE;
02230 4: NORMAL := SBTFPR0;
02240 END;
02250 END;
02260 (**)
02270 FUNCTION LENOF(SB: PSB): INTEGER;
02280 BEGIN
02290 WITH SB^,SBMODE^.MDV DO
02300 IF SBUNION IN SBINF THEN LENOF := SBLEN
02310 ELSE IF SBNAKED IN SBINF THEN LENOF := SZNAKED
02320 ELSE IF MDPILE THEN LENOF := SZADDR
02330 ELSE LENOF := MDLEN;
02340 END;
02350 (**)
02360 PROCEDURE LOADSTK(SB: PSB);
02370 BEGIN
02380 (*+21() WRITELN(OUTPUT, 'LOADSTK ', ORD(SB)); ()+21*)
02390 IF NOT(SB^.SBTYP IN [SBTSTKN,SBTDL]) THEN
02400 CASE LENOF(SB) OF
02410 0: LOAD(SBTVOID, SB);
02420 2: LOAD(SBTSTK, SB);
02430 4: LOAD(SBTSTK4, SB);
02440 END;
02450 END;
02460 (**)
02470 PROCEDURE TWIST;
02480 VAR TEMPPTR : PSB;
02490 NORM: SBTTYP;
02500 BEGIN
02510 (*+21() WRITELN(OUTPUT, 'TWIST'); ()+21*)
02520 IF [RTSTACK^.SBRTSTK^.SBTYP , RTSTACK^.SBTYP] * [SBTVOID..SBTDEN] = [] THEN
02530 (*NEITHER SB IS A FAKE*)
02540 BEGIN
02550 IF RTSTACK^.SBTYP IN [SBTSTK..SBTDL] THEN
02560 LOAD(NORMAL(RTSTACK),RTSTACK); (*GET IT INTO REGISTER 3*)
02570 TEMPPTR := RTSTACK^.SBRTSTK;
02580 RTSTACK^.SBRTSTK := TEMPPTR^.SBRTSTK;
02590 TEMPPTR^.SBRTSTK := RTSTACK;
02600 RTSTACK := TEMPPTR;
02610 IF RTSTACK^.SBTYP IN [SBTSTK..SBTDL] THEN
02620 BEGIN
02630 NORM := NORMAL(RTSTACK);
02640 IF NORM IN [SBTFPR0..SBTFPR3] THEN IF NORM IN REGSINUSE.FPR THEN NORM := SBTFPR1;
02650 LOAD(NORM,RTSTACK) (*GET IT INTO A REGISTER TOO*)
02660 END
02670 ELSE IF (RTSTACK^.SBTYP IN [SBTE,SBTER0]) AND (RTSTACK^.SBRTSTK^.SBTYP IN [SBTE,SBTER0]) THEN
02680 EMITOP(PSWAP)
02690 END
02700 ELSE BEGIN
02710 TEMPPTR := RTSTACK^.SBRTSTK;
02720 RTSTACK^.SBRTSTK := TEMPPTR^.SBRTSTK;
02730 TEMPPTR^.SBRTSTK := RTSTACK;
02740 RTSTACK := TEMPPTR
02750 END
02760 END;
02770 (**)
02780 PROCEDURE HOIST(HOISTLEN, LEN:INTEGER; ALIGN: BOOLEAN);
02782 (*HOISTLEN IS AMOUNT ALREADY STACKED; LEN IS TOTAL AMOUNT TO BE STACKED*)
02790 BEGIN
02800 IF ((RTSTKDEPTH-HOISTLEN+LEN) MOD 4 = 0) = ALIGN THEN
02810 BEGIN
02820 IF HOISTLEN=0 THEN EMITOP(PALIGN)
02830 ELSE
02840 BEGIN
02850 HOISTLEN := HOISTLEN-RTSTKDEPTH; CLEAR(RTSTACK); HOISTLEN := HOISTLEN+RTSTKDEPTH;
02860 EMITX1(PHEAVE, OCVIMMED, HOISTLEN);
02870 END;
02880 ADJUSTSP := ADJUSTSP+SZWORD;
02890 END;
02900 END;
02910 (**)
02920 PROCEDURE PROC1OP(OPCOD:POP;TYP:OPDTYP;OPND:INTEGER;NOTINL:BOOLEAN;ALIGN:INTEGER);
02930 VAR SB, SB1: PSB;
02940 HOISTLEN,LEN: INTEGER;
02950 BEGIN
02960 SB:=ASPTR(OPND);
02962 SB^.SBINF := SB^.SBINF-[SBSTKDELAY];
02970 IF RTSTACK<>SB THEN TWIST;
02972 WITH CODETABLE[OPCOD] DO
02974 BEGIN
02980 IF NOTINL THEN WITH SB^ DO
02990 BEGIN
03000 IF SBSTKDELAY IN SBRTSTK^.SBINF THEN LOADSTK(SBRTSTK)
03010 ELSE CLEAR(SBRTSTK);
03020 IF TYP=OCVSBS THEN
03030 BEGIN
03040 HOISTLEN := SUBSTLEN([SBTSTK..SBTDL]);
03050 LEN := HOISTLEN+LENOF(SB)*ORD(NOT(SB^.SBTYP IN [SBTSTK..SBTDL]));
03060 END
03070 ELSE BEGIN
03080 LEN := LENOF(SB)*ORD(P1 IN [SBTSTK..SBTDL,SBTPR1,SBTPR2]);
03090 HOISTLEN := SBLEN*ORD(SB^.SBTYP IN [SBTSTK..SBTDL]);
03100 END;
03110 HOIST(HOISTLEN, LEN, NOT ODD(ALIGN+APARAMS));
03120 END;
03150 REPEAT
03151 IF PR IN (REGSINUSE.FPR-[P1]) THEN
03152 BEGIN SB1 := RTSTACK;
03153 WHILE NOT(SB1^.SBTYP IN (REGSINUSE.FPR-[P1])) DO SB1 := SB1^.SBRTSTK;
03155 CLEAR(SB1);
03156 END;
03157 LOAD(P1, SB);
03158 UNTIL P1 IN [SBTSTKN,SBTPR1,SBTPR2,SBTXN,SB^.SBTYP]; (*ESTACK MAY HAVE OVERFLOWED*)
03160 UNSTKP1(TYP,SB);
03180 END;
03190 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
03200 END;
03210 (**)
03220 PROCEDURE PROC2OP(OPCOD:POP;TYP1:OPDTYP;OPND1:INTEGER;TYP2:OPDTYP;OPND2:INTEGER;NOTINL:BOOLEAN;ALIGN:INTEGER);
03230 VAR SB1, SB2, SB3: PSB;
03240 HOISTLEN,LEN1,LEN2: INTEGER;
03250 BEGIN
03260 SB1:=ASPTR(OPND1);
03262 SB1^.SBINF := SB1^.SBINF-[SBSTKDELAY];
03270 SB2:=ASPTR(OPND2);
03271 SB2^.SBINF := SB2^.SBINF-[SBSTKDELAY];
03272 WITH CODETABLE[OPCOD] DO
03274 BEGIN
03280 IF NOTINL THEN WITH RTSTACK^.SBRTSTK^ DO
03290 BEGIN
03300 IF SBSTKDELAY IN SBRTSTK^.SBINF THEN LOADSTK(SBRTSTK)
03310 ELSE CLEAR(SBRTSTK);
03312 IF TYP1=OCVSBS THEN
03314 HOIST(SUBSTLEN([SBTSTK..SBTDL]), SUBSTLEN([SBTID..SBTFPR1]), ODD(ALIGN+APARAMS))
03316 ELSE
03318 BEGIN
03320 LEN1 := LENOF(SB1)*ORD(P1 IN [SBTSTK..SBTDL,SBTPR1,SBTPR2]);
03322 LEN2 := LENOF(SB2)*ORD(P2 IN [SBTSTK..SBTDL,SBTPR1,SBTPR2]);
03330 HOISTLEN := SB1^.SBLEN*ORD(SB1^.SBTYP IN [SBTSTK..SBTDL])
03340 +SB2^.SBLEN*ORD(SB2^.SBTYP IN [SBTSTK..SBTDL]);
03350 HOIST(HOISTLEN, LEN1+LEN2, ODD(ALIGN+APARAMS));
03352 END;
03360 END;
03370 IF RTSTACK<>SB2 THEN TWIST;
03400 IF (SB2^.SBTYP IN [SBTSTK..SBTSTKN,SBTVAR]) OR ((P1 IN REGSINUSE.FPR) AND (P1<>SB1^.SBTYP)) THEN
03410 LOAD(P2,SB2);
03412 REPEAT
03413 IF PR IN (REGSINUSE.FPR-[P1,P2]) THEN
03414 BEGIN SB3 := RTSTACK;
03415 WHILE NOT(SB3^.SBTYP IN (REGSINUSE.FPR-[P1,P2])) DO SB3 := SB3^.SBRTSTK;
03416 CLEAR(SB3);
03418 END;
03420 LOAD(P1, SB1);
03430 LOAD(P2, SB2);
03432 UNTIL (P1 IN [SBTSTKN,SBTPR1,SBTPR2,SBTXN,SB1^.SBTYP]) AND
03434 (P2 IN [SBTSTKN,SBTPR1,SBTPR2,SBTXN,SB2^.SBTYP]); (*ESTACK MAY HAVE OVERFLOWED*)
03440 UNSTKP1(TYP2,SB2);
03450 UNSTKP1(TYP1,SB1);
03470 END;
03480 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
03490 END;
03500 (**)
03510 PROCEDURE FILL (WHERE:SBTTYP; SB:PSB);
03520 BEGIN
03530 WITH SB^ DO WITH REGSINUSE DO
03540 BEGIN
03550 IF SBTYP IN [SBTER0..SBTFPR3] THEN FPR := FPR-[SBTYP];
03560 IF SBTYP IN [SBTE,SBTER0] THEN ECOUNT := ECOUNT-1
03570 ELSE IF SBTYP IN [SBTSTK..SBTDL] THEN RTSTKDEPTH := RTSTKDEPTH-SBLEN;
03572 SBTYP:=WHERE;
03580 IF NOT(WHERE IN [SBTSTKN,SBTDL,SBTXN]) THEN SBLEN := LENARRAY[WHERE];
03590 IF WHERE IN [SBTSTK..SBTDL] THEN
03600 BEGIN
03610 RTSTKDEPTH := RTSTKDEPTH+SBLEN;
03620 WITH ROUTNL^ DO
03630 IF RTSTKDEPTH>RNLENSTK THEN RNLENSTK:=RTSTKDEPTH
03640 END
03650 ELSE
03654 BEGIN
03660 IF WHERE IN [SBTE,SBTER0] THEN
03662 BEGIN ECOUNT := ECOUNT+1; IF ECOUNT>=6 THEN CLEAR(RTSTACK) END;
03670 IF WHERE IN [SBTER0..SBTFPR3] THEN FPR := FPR+[WHERE];
03674 END;
03690 END
03700 END;
03710 (**)
03720 FUNCTION SETINLINE (OPCOD:POP):BOOLEAN;
03730 VAR INL:BOOLEAN;
03740 BEGIN
03750 APARAMS := 0;
03760 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
03770 REPEAT WITH CODETABLE[OPCOD] DO
03780 BEGIN
03790 APARAMS := APARAMS+ORD(PARTYP IN [ACP,ANP]); (*NUMBER OF SECRET PARAMETERS*)
03800 INL := INLINE;
03810 OPCOD := NEXT
03820 END
03830 UNTIL NOT(INL) OR (OPCOD=0);
03840 SETINLINE := INL
03850 END;
03860 (**)
03870 (**)
03880 PROCEDURE LOAD (*+05() (WHERE:SBTTYP; SB:PSB) ()+05*);
03890 (*EMITS CODE TO MOVE SB TO WHERE: CALLS FILL TO RECORD THE MOVE*)
03900 VAR TEMPOP: POP;
03910 TOFFSET: INTEGER;
03920 TEMPTYP: SBTTYP;
03930 OCVFIX: OPDTYP;
03940 TWISTED: BOOLEAN;
03950 TYPS: SET OF SBTTYP;
03960 SB1, SB2: PSB;
03970 SAVE, EC:INTEGER;
03980 BEGIN
03990 (*+21() WRITELN(OUTPUT, 'LOAD ',ORD(SB):5,ORD(SB^.SBTYP):3,' TO ', ORD(WHERE):3, SB=RTSTACK); ()+21*)
04000 WITH SB^ DO
04010 BEGIN
04012 SBINF := SBINF-[SBSTKDELAY];
04020 IF SBRTSTK<>NIL THEN
04030 IF SBSTKDELAY IN SBRTSTK^.SBINF THEN
04040 LOADSTK(SBRTSTK);
04050 IF (WHERE IN [SBTSTK..SBTDL]) THEN CLEAR(SBRTSTK);
04060 TWISTED := FALSE;
04070 IF WHERE IN [SBTSTKN,SBTPR1,SBTPR2] THEN
04080 LOADSTK(SB)
04090 ELSE IF WHERE=SBTXN THEN LOAD(NORMAL(SB),SB)
04100 ELSE
04110 IF WHERE <> SBTVOID THEN
04120 BEGIN
04140 IF WHERE IN [SBTER0..SBTFPR3] THEN
04150 IF (WHERE IN REGSINUSE.FPR) AND (WHERE<>SBTYP) THEN
04160 BEGIN
04170 SB1 := RTSTACK;
04180 WHILE NOT(SB1^.SBTYP IN REGSINUSE.FPR) DO SB1 := SB1^.SBRTSTK;
04190 LOADSTK(SB1);
04200 END;
04240 TYPS := [WHERE, RTSTACK^.SBTYP];
04250 IF (RTSTACK<>SB) THEN
04260 IF (TYPS <= [SBTSTK..SBTDL]) AND NOT(SBTYP IN [SBTSTK..SBTDL]) OR (TYPS<=[SBTE,SBTER0]) THEN
04270 BEGIN TWISTED:=TRUE; TWIST;
04280 (*+32() ASSERT (RTSTACK =SB,'LOAD-B '); ()+32*)
04290 END;
04310 TEMPOP := POPARRAY[WHERE,SBTYP];
04320 (*+32() ASSERT(TEMPOP<>PNONE, 'LOAD-C '); ()+32*)
04330 IF (TEMPOP<>PNOOP) OR (SBTYP=SBTSTKR0) THEN
04340 CASE SBTYP OF
04350 SBTRPROC,SBTPROC,SBTVAR: BEGIN
04360 SAVE := ADJUSTSP; ADJUSTSP := 0;
04370 RTSTKDEPTH := RTSTKDEPTH+SAVE;
04380 IF WHERE <> SBTE THEN BEGIN LOAD(SBTE,SB); LOAD(WHERE,SB) END
04390 ELSE BEGIN TOFFSET:=GENLCLGBL(TEMPOP,SB);
04400 IF SBTYP=SBTVAR THEN
04410 EMITX2(TEMPOP,OCVIMMED,SBLOCRG,OCVIMMED,TOFFSET)
04420 ELSE BEGIN (*SBTPROC OR SBTRPROC*)
04430 IF SBTYP=SBTPROC THEN OCVFIX := OCVMEM
04440 ELSE (* SBTRPROC *) OCVFIX := OCVFREF;
04450 EMITX2(TEMPOP,OCVFIX,SBXPTR,OCVIMMED,TOFFSET);
04460 END;
04470 END;
04480 RTSTKDEPTH := RTSTKDEPTH-SAVE;
04490 ADJUSTSP := SAVE;
04500 END;
04510 (**)
04520 SBTID,SBTIDV: BEGIN TOFFSET:=GENLCLGBL(TEMPOP,SB);
04530 EMITX1(TEMPOP,OCVIMMED,TOFFSET) END;
04540 SBTLIT: EMITX1(TEMPOP, OCVIMMED, SBVALUE);
04550 SBTDEN: GENDENOT(TEMPOP,SB);
04560 SBTPR1,SBTPR2,
04570 SBTSTK,SBTSTK4,SBTDL,SBTER0: EMITOP(TEMPOP);
04580 SBTE: WITH REGSINUSE DO
04600 BEGIN
04610 (*ATTEMPT TO STACK E MUST FORCE STACKING OF ALL E'S ABOVE IT;
04612 THESE ARE THE EXTRAS*)
04620 SB1 := RTSTACK; EEXTRA := 0; EC := ECOUNT; TEMPOP := TEMPOP+ORD(EC=2)+ORD(EC>2);
04630 REPEAT WITH SB1^ DO (*PREVENT CLEAR IF TEMPOP IS AN OCODE*)
04632 BEGIN
04634 IF SBTYP=SBTE THEN
04636 BEGIN FILL(SBTSTK, SB1); EEXTRA := EEXTRA+1 END
04637 ELSE IF SBTYP=SBTER0 THEN
04638 BEGIN FILL(SBTSTKR0, SB1); EEXTRA := 0 END
04639 ELSE IF SBTYP IN [SBTFPR0,SBTFPR1] THEN EEXTRA := 0;
04640 SB2 := SB1; SB1 := SBRTSTK;
04642 END
04644 UNTIL SB2=SB;
04650 EMITX1(TEMPOP, OCVIMMED, ECOUNT);
04660 EEXTRA := EC-EEXTRA;
04661 (*NO. OF E'S OR ER0'S ABOVE FIRST FPR, OR ABOVE & INCL. FIRST ER0*)
04662 END;
04670 SBTSTKR0,SBTFPR0,SBTFPR1: WITH REGSINUSE DO
04680 BEGIN
04690 IF EEXTRA<>0 THEN
04700 BEGIN
04710 EMITX1(PSTKTOE+ORD(EEXTRA=2)+ORD(EEXTRA>2), OCVIMMED, EEXTRA);
04720 SB1 := RTSTACK;
04722 WHILE EEXTRA>0 DO WITH SB1^ DO
04723 BEGIN
04724 IF SBTYP=SBTSTK THEN
04725 BEGIN FILL(SBTE, SB1); EEXTRA := EEXTRA-1 END
04726 ELSE IF SBTYP=SBTSTKR0 THEN
04727 BEGIN FILL(SBTER0, SB1); EEXTRA := EEXTRA-1 END;
04728 SB1 := SBRTSTK;
04729 END;
04730 END;
04740 EMITOP(TEMPOP);
04750 END;
04760 END;
04770 FILL(WHERE,SB);
04780 END;
04790 IF TWISTED THEN TWIST;
04800 END;
04810 END;
04820 (**)
04830 PROCEDURE PARAM (*(TYP:OPDTYP; OPND:INTEGER; OPCOD: POP; ALIGN: INTEGER; FIRSTIME: BOOLEAN)*);
04840 VAR TEMPOP:POP;
04850 OPERANDUSED, INL: BOOLEAN;
04860 BEGIN
04870 IF OCV<>OCVNONE THEN
04880 BEGIN
04890 TEMPOP := PPUSHIM;
04900 EMITOP(TEMPOP) ; ADJUSTSP := ADJUSTSP+SZWORD;
04910 END;
04920 IF FIRSTIME AND (((RTSTKDEPTH+ADJUSTSP) MOD 4 = 0) = ODD(ALIGN+APARAMS)) THEN
04930 BEGIN EMITOP(PALIGN); ADJUSTSP := ADJUSTSP+SZWORD END;
04940 OPRAND:=OPND; OCV := TYP;
04950 END;
04960 (**)
04970 ()+05*)
04980 (**)
04990 (*+01() (*+31() (*$T+ +) ()+31+) ()+01*)
05000 (*+05() (*+31() (*$T+ +) ()+31+) ()+05*)
05010 (**)
05020 (**)
05030 (**)
05040 PROCEDURE CLEAR (SB:PSB);
05050 (*ENSURES THAT NOTHING ON RTSTACK FROM SB DOWNWARDS IS IN A REGISTER*)
05060 LABEL 9;
05070 VAR TEMPPTR: PSB;
05080 BEGIN
05090 (*INVARIANT: IF SBTYP IN [SBTSTK..SBTSTKN], NOTHING BELOW SB IS IN A REGISTER*)
05100 TEMPPTR:=SB;
05110 WHILE TEMPPTR<>NIL DO WITH TEMPPTR^ DO
05120 IF SBTYP>SBTSTKN THEN
05130 BEGIN LOADSTK(TEMPPTR); GOTO 9 END
05140 ELSE IF SBTYP>=SBTSTK THEN GOTO 9 (*BECAUSE OF INVARIANT*)
05150 ELSE TEMPPTR := SBRTSTK;
05160 9:
05170 END;
05180 (**)
05190 (*-23()
05200 ()-23*)
05210 PROCEDURE UNSTKP1 (*+05() (TYP:OPDTYP; OPND:PSB) ()+05*);
05220 BEGIN
05230 IF TYP = OCVSBS THEN
05240 (*ASSERT: OPND = RTSTACK*)
05250 REPEAT
05260 OPND := RTSTACK;
05270 UNSTACKSB;
05280 IF OPND^.SBTYP IN [SBTSTK..SBTDL] THEN ADJUSTSP := ADJUSTSP+OPND^.SBLEN;
05290 OPND^.SBTYP := SBTVOID;
05300 UNTIL OPND=SRSTK[SRSUBP+1].SB
05310 ELSE IF TYP <> OCVSBP THEN
05320 BEGIN UNSTACKSB;
05330 IF OPND^.SBTYP IN [SBTSTK..SBTDL] THEN ADJUSTSP := ADJUSTSP+OPND^.SBLEN;
05340 OPND^.SBTYP:=SBTVOID;
05350 END
05360 (*+02() ELSE (*TYP=OCVSBP*) ADJUSTSP := ADJUSTSP-LENOF(OPND); ()+02*)
05370 END;
05380 (**)
05390 (*-23()
05400 ()-23*)
05410 (**)
05420 PROCEDURE EMITX0(OPCOD: POP);
05430 BEGIN IF NOT SETINLINE(OPCOD) THEN BEGIN ADJUSTSP := 0; CLEAR(RTSTACK) END;
05440 (*+05() PARAM(OCVNONE,0,OPCOD,0,NOT SETINLINE(OPCOD)); ()+05*)
05450 EMITOP(OPCOD);
05460 END;
05470 (**)
05480 (**)
05490 PROCEDURE EMITX1 (*+05() (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT) ()+05*);
05500 VAR SB1:PSB; NOTINL:BOOLEAN;
05510 BEGIN
05520 (*-24()(*+23() WRITELN(LGO[ROUTNL^.RNLEVEL]); ()+23*) ()-24*)
05530 IF TYP1 = OCVRES THEN
05540 BEGIN
05550 SB1 := ASPTR(OPND1);
05560 EMITX0 (OPCOD);
05570 (*+32() ASSERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX1-A ');
05580 ASSERT(SB1^.SBTYP=SBTVOID,'EMITX1-B '); ()+32*)
05590 FILL(CODETABLE[OPCOD].PR,SB1);
05600 SB1^.SBRTSTK:=RTSTACK; RTSTACK:=SB1;
05610 END
05620 ELSE
05630 BEGIN
05640 NOTINL := NOT(SETINLINE(OPCOD));
05650 IF NOTINL THEN ADJUSTSP := 0;
05660 IF TYP1 >= OCVSB THEN
05670 PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),1()+05*))
05680 ELSE
05690 BEGIN
05700 IF NOTINL THEN CLEAR(RTSTACK);
05710 (*+01() NEXTREG := 0; ()+01*)
05720 PARAM(TYP1,OPND1,OPCOD(*+05(),1,NOTINL()+05*));
05730 END;
05740 EMITOP(OPCOD)
05750 END
05760 END;
05770 (**)
05780 (**)
05790 PROCEDURE EMITX2 (*+05() (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT;
05800 TYP2:OPDTYP; OPND2:ADDRINT) ()+05*);
05810 VAR SB2:PSB; NOTINL:BOOLEAN;
05820 BEGIN
05830 (*+23() WRITELN(LGO[ROUTNL^.RNLEVEL]); ()+23*)
05840 IF TYP2 = OCVRES THEN
05850 BEGIN
05860 SB2 := ASPTR(OPND2);
05870 EMITX1 (OPCOD, TYP1,OPND1);
05880 (*+32() ASSERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX2-A ');
05890 ASSERT(SB2^.SBTYP=SBTVOID,'EMITX2-B '); ()+32*)
05900 FILL(CODETABLE[OPCOD].PR,SB2);
05910 SB2^.SBRTSTK:=RTSTACK; RTSTACK:=SB2;
05920 END
05930 ELSE
05940 BEGIN
05950 NOTINL := NOT(SETINLINE(OPCOD));
05960 IF NOTINL THEN ADJUSTSP := 0;
05970 IF TYP1 >= OCVSB THEN
05980 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),2()+05*))
05990 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),2()+05*));
06000 PARAM(TYP2,OPND2,OPCOD(*+05(),1,FALSE()+05*)) END
06010 ELSE
06020 BEGIN
06030 IF NOTINL THEN CLEAR(RTSTACK);
06040 (*+01() NEXTREG:=0; ()+01*)
06050 PARAM(TYP1,OPND1,OPCOD(*+05(),2,NOTINL()+05*));
06060 PARAM(TYP2,OPND2,OPCOD(*+05(),1,FALSE()+05*))
06070 END;
06080 EMITOP(OPCOD)
06090 END
06100 END;
06110 (**)
06120 (**)
06130 PROCEDURE EMITX3 (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT; TYP2:OPDTYP;OPND2:ADDRINT;
06140 TYP3:OPDTYP; OPND3:ADDRINT);
06150 VAR SB3:PSB; NOTINL:BOOLEAN;
06160 BEGIN
06170 (*+23() WRITELN(LGO[ROUTNL^.RNLEVEL]); ()+23*)
06180 IF TYP3 = OCVRES THEN
06190 BEGIN
06200 SB3 := ASPTR(OPND3);
06210 EMITX2 (OPCOD, TYP1,OPND1, TYP2,OPND2);
06220 (*+32() ASSERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX3-A ');
06230 ASSERT(SB3^.SBTYP=SBTVOID,'EMITX3-B '); ()+32*)
06240 FILL(CODETABLE[OPCOD].PR,SB3);
06250 SB3^.SBRTSTK:=RTSTACK; RTSTACK:=SB3;
06260 END
06270 ELSE
06280 BEGIN
06290 NOTINL := NOT(SETINLINE(OPCOD));
06300 IF NOTINL THEN ADJUSTSP := 0;
06310 IF TYP1 >= OCVSB THEN
06320 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),3()+05*))
06330 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),3()+05*));
06340 PARAM(TYP2,OPND2,OPCOD(*+05(),2,FALSE()+05*)) END
06350 ELSE
06360 BEGIN
06370 IF NOTINL THEN CLEAR(RTSTACK);
06380 (*+01() NEXTREG:=0; ()+01*)
06390 PARAM(TYP1,OPND1,OPCOD(*+05(),3,NOTINL()+05*));
06400 PARAM(TYP2,OPND2,OPCOD(*+05(),2,FALSE()+05*))
06410 END;
06420 PARAM(TYP3,OPND3,OPCOD(*+05(),1,FALSE()+05*));
06430 EMITOP(OPCOD)
06440 END
06450 END;
06460 (**)
06470 (**)
06480 PROCEDURE EMITX4 (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT; TYP2:OPDTYP;OPND2:ADDRINT;
06490 TYP3:OPDTYP; OPND3:ADDRINT; TYP4:OPDTYP;OPND4:ADDRINT);
06500 VAR SB4:PSB; NOTINL:BOOLEAN;
06510 BEGIN
06520 (*+23() WRITELN(LGO[ROUTNL^.RNLEVEL]); ()+23*)
06530 IF TYP4 = OCVRES THEN
06540 BEGIN
06550 SB4 := ASPTR(OPND4);
06560 EMITX3 (OPCOD, TYP1,OPND1, TYP2,OPND2, TYP3,OPND3);
06570 (*+32() ASSERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX4-A ');
06580 ASSERT(SB4^.SBTYP=SBTVOID,'EMITX4-B '); ()+32*)
06590 FILL(CODETABLE[OPCOD].PR,SB4);
06600 SB4^.SBRTSTK:=RTSTACK; RTSTACK:=SB4;
06610 END
06620 ELSE
06630 BEGIN
06640 NOTINL := NOT(SETINLINE(OPCOD));
06650 IF NOTINL THEN ADJUSTSP := 0;
06660 IF TYP1 >= OCVSB THEN
06670 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),4()+05*))
06680 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),4()+05*));
06690 PARAM(TYP2,OPND2,OPCOD(*+05(),3,FALSE()+05*)) END
06700 ELSE
06710 BEGIN
06720 IF NOTINL THEN CLEAR(RTSTACK);
06730 (*+01() NEXTREG:=0; ()+01*)
06740 PARAM(TYP1,OPND1,OPCOD(*+05(),4,NOTINL()+05*));
06750 PARAM(TYP2,OPND2,OPCOD(*+05(),3,FALSE()+05*))
06760 END;
06770 PARAM(TYP3,OPND3,OPCOD(*+05(),2,FALSE()+05*));
06780 PARAM(TYP4,OPND4,OPCOD(*+05(),1,FALSE()+05*));
06790 EMITOP(OPCOD)
06800 END
06810 END;
06820 (**)
06830 (**)
06840 PROCEDURE EMITX5 (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT; TYP2:OPDTYP;OPND2:ADDRINT;
06850 TYP3:OPDTYP;OPND3:ADDRINT;TYP4:OPDTYP;OPND4:ADDRINT;TYP5:OPDTYP;OPND5:ADDRINT);
06860 VAR SB5:PSB; NOTINL:BOOLEAN;
06870 BEGIN
06880 (*+23() WRITELN(LGO[ROUTNL^.RNLEVEL]); ()+23*)
06890 IF TYP5 = OCVRES THEN
06900 BEGIN
06910 SB5 := ASPTR(OPND5);
06920 EMITX4 (OPCOD, TYP1,OPND1, TYP2,OPND2, TYP3,OPND3,TYP4,OPND4);
06930 (*+32() ASSERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX5-A ');
06940 ASSERT(SB5^.SBTYP=SBTVOID,'EMITX5-B '); ()+32*)
06950 FILL(CODETABLE[OPCOD].PR,SB5);
06960 SB5^.SBRTSTK:=RTSTACK; RTSTACK:=SB5;
06970 END
06980 ELSE
06990 BEGIN
07000 NOTINL := NOT(SETINLINE(OPCOD));
07010 IF NOTINL THEN ADJUSTSP := 0;
07020 IF TYP1 >= OCVSB THEN
07030 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),5()+05*))
07040 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),5()+05*));
07050 PARAM(TYP2,OPND2,OPCOD(*+05(),4,FALSE()+05*)) END
07060 ELSE
07070 BEGIN
07080 IF NOTINL THEN CLEAR(RTSTACK);
07090 (*+01() NEXTREG:=0; ()+01*)
07100 PARAM(TYP1,OPND1,OPCOD(*+05(),5,NOTINL()+05*));
07110 PARAM(TYP2,OPND2,OPCOD(*+05(),4,FALSE()+05*))
07120 END;
07130 PARAM(TYP3,OPND3,OPCOD(*+05(),3,FALSE()+05*));
07140 PARAM(TYP4,OPND4,OPCOD(*+05(),2,FALSE()+05*));
07150 PARAM(TYP5,OPND5,OPCOD(*+05(),1,FALSE()+05*));
07160 EMITOP(OPCOD)
07170 END
07180 END;
07190 (**)
07200 (**)
07210 (*-23()
07220 ()-23*) (* MORE PERQ DEPENDENT ROUTINES *)
07230 (**) (********************************)
07240 (*+05()
07250 PROCEDURE EMITBEG;
07260 VAR TEMP : PLEX;
07270 S: ARGSTRING;
07280 I,J: INTEGER;
07290 PROCEDURE NAMEFILE(S: ARGSTRING; SU, SL: INTEGER; VAR F: ANYFILE); EXTERN;
07300 FUNCTION GETARG(VAR S: ARGSTRING; SU, SL: INTEGER; I: INTEGER): BOOLEAN; EXTERN;
07310 BEGIN
07320 NEXTLABEL := 1;
07330 DATASTATE := ENDDATA;(* ??? *)
07340 ADJUSTSP := 0;
07350 WITH REGSINUSE DO
07360 BEGIN
07370 ECOUNT := 0;
07380 EEXTRA := 0;
07390 FPR := [];
07400 END;
07410 IF GETARG(S, 50, 1, 2) THEN
07420 BEGIN
07430 J := 1; WHILE S[J]<>CHR(0) DO J := J+1; S[J+1] := CHR(0);
07440 FOR I := 0 TO LASTRNLEVEL DO
07450 BEGIN S[J] := CHR(I+ORD('0')); NAMEFILE(S, 50, 1, LGO[I]); REWRITE(LGO[I]) END;
07460 END;
07470 (*+33() WRITELN(LGO[ROUTNL^.RNLEVEL], 'stab "a68",8#44,0,0,_AL68_'); ()+33*)
07480 WRITELN(LGO[ROUTNL^.RNLEVEL],'global _AL68_');
07490 WRITELN(LGO[ROUTNL^.RNLEVEL],'function _AL68_');
07492 ROUTNL^.RNADDRESS := GETNEXTLABEL;
07494 WRITELN(LGO[ROUTNL^.RNLEVEL],'function L', ROUTNL^.RNADDRESS:1);
07500 ROUTNL^.RNPROCBLK := GETNEXTLABEL;
07502 WRITELN(LGO[ROUTNL^.RNLEVEL], 'data');
07504 WRITELN(LGO[ROUTNL^.RNLEVEL], 'int 1,1,1,1');
07506 (*so that no dblock has address < maxsize of undressed value*)
07510 EMITX1(PASP, OCVFIM, ROUTNL^.RNPROCBLK);
07520 EMITX0(PPBEGIN+1);
07530 EMITX0(PPBEGIN);
07540 END;
07550 (**)
07560 (**)
07570 FUNCTION EMITRTNHEAD: LABL;
07580 VAR L: LABL;
07590 BEGIN
07600 L := GETNEXTLABEL;
07610 (*+33() WRITELN(LGO[ROUTNL^.RNLEVEL], 'stab "a68",8#44,0,0,L', L:1); ()+33*)
07620 WRITELN(LGO[ROUTNL^.RNLEVEL], 'function L', L:1);
07630 EMITRTNHEAD := L;
07640 END;
07650 (**)
07660 (**)
07670 PROCEDURE EMITEND;
07680 BEGIN
07690 WITH ROUTNL^ DO IF (RNLENIDS MOD 4) = 0 THEN RNLENIDS := RNLENIDS+SZWORD;
07700 FIXUPFIM(ROUTNL^.RNPROCBLK, -(ROUTNL^.RNLENIDS+SIZIBTOP+SZWORD+FIRSTIBOFFSET));
07710 RTSTKDEPTH := 0;
07720 EMITX0(PPEND);
07730 WRITELN(LGO[ROUTNL^.RNLEVEL],' return');
07740 END;
07750 ()+05*)
07760 (**)
07770 (*+05()
07780 PROCEDURE GENDENOT (* (OPCOD: POP; SB: PSB) *) ;
07790 VAR I: INTEGER;
07800 ALABL: LABL;
07810 THING: OBJECT;
07820 BEGIN WITH SB^ DO
07830 WITH SBLEX^ (*A LEXEME*) DO
07840 IF SBLEX=LEXFALSE THEN
07850 EMITX1(OPCOD, OCVIMMED, 0)
07860 ELSE IF SBLEX=LEXTRUE THEN
07870 EMITX1(OPCOD, OCVIMMED, TRUEVALUE)
07880 ELSE IF ((SBMODE=MDINT) OR (SBMODE=MDBITS) OR (SBMODE=MDCHAR))
07890 AND (LXTOKEN=TKDENOT) THEN
07900 EMITX1(OPCOD, OCVIMMED, LXDENRP)
07910 ELSE
07920 BEGIN
07930 IF LXV.LXPYPTR=0 THEN
07940 BEGIN
07950 DATASTATE := STARTDATA; ALABL := FIXUPM;
07960 LXV.LXPYPTR := ALABL;
07970 IF SBMODE^.MDV.MDPILE THEN WITH THING DO
07980 BEGIN
07990 FIRSTWORD := 0; PCOUNT := 255;
08000 EMITXWORD(OCVIMMED, FIRSTWORD);
08010 EMITXWORD(OCVIMMED, 0);
08012 EMITXWORD(OCVIMMED, 0);
08014 EMITXWORD(OCVIMMED, 0);
08020 EMITXWORD(OCVIMMED, LXDENRP);
08030 FOR I := 3 TO LXCOUNT DO
08040 EMITXWORD(OCVIMMED, INTEGERS[I])
08050 END
08060 ELSE IF SBMODE^.MDV.MDID IN [MDIDCHAN,MDIDPASC] THEN
08070 BEGIN
08080 EMITXWORD(OCVIMMED, -2);
08090 EMITXPROC(OCVEXT, ORD(SBLEX));
08100 END
08110 ELSE
08120 BEGIN
08130 EMITXWORD(OCVIMMED,INTEGERS[2]);
08140 EMITXWORD(OCVIMMED,INTEGERS[3]);
08150 END;
08160 END;
08170 EMITX1(OPCOD+1, OCVMEM, LXV.LXPYPTR)
08180 END;
08190 END;
08200 (**)
08210 PROCEDURE GENDP(M: MODE);
08220 (*FUNCTION: RETURNS THE ADDRESS OF THE DBLOCK FOR MODE M, OR THE VALULENGTH,
08230 IN GLOBAL VARIABLE GENDPVAL, WITH CORRESPONDING OPDTYP IN GENDPOCV.
08240 *)
08250 VAR OFFSET: 0..127;
08260 PROCEDURE DBLOCK(M: MODE);
08270 VAR I, J: INTEGER;
08280 BEGIN WITH M^ DO
08290 FOR I := 0 TO MDV.MDCNT-1 DO
08300 WITH MDSTRFLDS[I] DO WITH MDSTRFMD^.MDV DO
08310 IF MDDRESSED THEN
08320 BEGIN EMITXWORD(OCVIMMED, OFFSET); OFFSET := OFFSET+MDLEN END
08330 ELSE IF MDID=MDIDSTRUCT THEN
08340 DBLOCK(MDSTRFMD)
08350 ELSE OFFSET := OFFSET+MDLEN
08360 END;
08370 PROCEDURE DBLOCKM(M: MODE);
08380 VAR I: INTEGER; X: XTYPE;
08390 BEGIN WITH M^ DO
08400 FOR I := 0 TO MDV.MDCNT-1 DO
08410 WITH MDSTRFLDS[I] DO
08420 BEGIN X := TX(MDSTRFMD);
08430 IF X=12 THEN DBLOCKM(MDSTRFMD)
08440 ELSE EMITXWORD(OCVIMMED, X+1)
08450 END
08460 END;
08470 BEGIN WITH M^ DO
08480 IF MDV.MDID=MDIDROW THEN GENDP(MDPRRMD)
08490 ELSE IF MDV.MDID=MDIDSTRUCT THEN
08500 BEGIN
08510 IF MDSTRSDB=0 THEN (*DBLOCK MUST BE CREATED*)
08520 BEGIN
08530 DATASTATE := STARTDATA; MDSTRSDB := FIXUPM;
08540 EMITXWORD(OCVIMMED, MDV.MDLEN);
08550 OFFSET := 0; DBLOCK(M);
08560 EMITXWORD(OCVIMMED, -1);
08570 DBLOCKM(M);
08580 END;
08590 GENDPOCV := OCVMEM; GENDPVAL :=MDSTRSDB
08600 END
08610 ELSE IF MDV.MDDRESSED THEN
08620 BEGIN GENDPVAL:=0; GENDPOCV:=OCVIMMED END
08630 ELSE
08640 BEGIN GENDPVAL := MDV.MDLEN; GENDPOCV := OCVIMMED END;
08650 END;
08660 (**)
08670 (**)
08680 ()+05*)
08690 (**)
08700 (**)
08710 (*-01() (*-02() (*-05()
08720 (*MODEL EMITBEG AND EMITEND FOR THOSE WHO HAVE NOT WRITTEN THEIR OWN YET*)
08730 PROCEDURE EMITBEG;
08740 BEGIN
08750 NEXTLABEL := 1;
08760 REWRITE(LGO);
08770 (*NOW INITIALIZE YOUR CODE BUFFER, OR WHATEVER, AND EMIT INIAL CODE*)
08780 END;
08790 (**)
08800 (**)
08810 PROCEDURE EMITEND;
08820 BEGIN
08830 (*EMIT YOUR FINAL CODE*)
08840 (*FLUSH YOUR CODE BUFFER, OR WHATEVER*)
08850 END;
08860 ()-05*) ()-02*) ()-01*)
08870 (**)
08880 (*-02() (*-05()
08890 (**)
08900 PROCEDURE GENDP(M: MODE);
08910 (*FUNCTION: RETURNS THE ADDRESS OF THE DBLOCK FOR MODE M, OR THE VALULENGTH,
08920 IN GLOBAL VARIABLE GENDPVAL, WITH CORRESPONDING OPDTYP IN GENDPOCV.
08930 *)
08940 VAR JUMPOVER: LABL;
08950 OFFSET: 0..127;
08960 PROCEDURE DBLOCK(M: MODE);
08970 VAR I, J: INTEGER;
08980 BEGIN WITH M^ DO
08990 FOR I := 0 TO MDV.MDCNT-1 DO
09000 WITH MDSTRFLDS[I] DO WITH MDSTRFMD^.MDV DO
09010 IF MDDRESSED THEN
09020 BEGIN EMITXWORD(OCVIMMED, OFFSET); OFFSET := OFFSET+MDLEN END
09030 ELSE IF MDID=MDIDSTRUCT THEN
09040 DBLOCK(MDSTRFMD)
09050 ELSE OFFSET := OFFSET+MDLEN
09060 END;
09070 PROCEDURE DBLOCKM(M: MODE);
09080 VAR I: INTEGER; X: XTYPE;
09090 BEGIN WITH M^ DO
09100 FOR I := 0 TO MDV.MDCNT-1 DO
09110 WITH MDSTRFLDS[I] DO
09120 BEGIN X := TX(MDSTRFMD);
09130 IF X=12 THEN DBLOCKM(MDSTRFMD)
09140 ELSE EMITXWORD(OCVIMMED, X+1)
09150 END
09160 END;
09170 BEGIN WITH M^ DO
09180 IF MDV.MDID=MDIDROW THEN GENDP(MDPRRMD)
09190 ELSE IF MDV.MDID=MDIDSTRUCT THEN
09200 BEGIN
09210 IF MDSTRSDB=0 THEN (*DBLOCK MUST BE CREATED*)
09220 BEGIN
09230 JUMPOVER := GETNEXTLABEL; EMITX1(PJMP, OCVFREF, JUMPOVER);
09240 MDSTRSDB := FIXUPM;
09250 EMITXWORD(OCVIMMED, MDV.MDLEN);
09260 OFFSET := 0; DBLOCK(M);
09270 EMITXWORD(OCVIMMED, -1);
09280 DBLOCKM(M);
09290 FIXUPF(JUMPOVER)
09300 END;
09310 GENDPOCV := OCVMEM; GENDPVAL :=MDSTRSDB
09320 END
09330 ELSE IF MDV.MDDRESSED THEN
09340 BEGIN GENDPVAL:=0; GENDPOCV:=OCVIMMED END
09350 ELSE
09360 BEGIN GENDPVAL := MDV.MDLEN; GENDPOCV := OCVIMMED END
09370 END;
09380 (**)
09390 ()-05*) ()-02*)
09400 (**)
09410 FUNCTION GETCASE(M: MODE; OLST: OLSTTYP; SB: PSB): STATE;
09420 (*FUNCTION: COMPUTES AN ADDITION TO SOME OPCOD.
09430 THE SB HERE AND IN RELATED PLACES IS A TEMPORARY KLUDGE ??????
09440 *)
09450 VAR WHICH: STATE;
09460 WEAKREF: BOOLEAN;
09470 BEGIN WITH M^ DO
09480 BEGIN
09490 IF SB<>NIL THEN WEAKREF:=(SBWEAKREF IN SB^.SBINF) ELSE WEAKREF:=FALSE;
09500 IF NOT MDV.MDPILE THEN
09510 IF MDV.MDLEN=SZINT THEN WHICH := 0 ELSE WHICH := 1
09520 ELSE IF WEAKREF THEN WHICH:=2
09530 ELSE IF MDV.MDID=MDIDROW THEN WHICH:=3
09540 ELSE IF MDV.MDDRESSED THEN WHICH:=4
09550 ELSE WHICH:=5;
09560 NEEDDP := OLST[WHICH].DP;
09570 GETCASE := OLST[WHICH].OVAL
09580 END
09590 END;
09600 (**)
09610 (**)
09620 PROCEDURE GENOP(VAR OPCOD: POP; M: MODE; VAR OLIST: OLSTTYP; SB: PSB);
09630 (*USES GETCASE TO MODIFY OPCOD AND DOES GENDP IF NECESSARY*)
09640 BEGIN
09650 OPCOD := OPCOD+GETCASE(M, OLIST, SB);
09660 IF NEEDDP THEN
09670 BEGIN
09680 IF SB<>NIL THEN
09690 IF SBWEAKREF IN SB^.SBINF THEN M := M^.MDPRRMD;
09700 GENDP(M);
09710 END
09720 ELSE BEGIN GENDPOCV:=OCVNONE; GENDPVAL:=0 END
09730 END;
09740 (**)
09750 (**)
09760 FUNCTION GENLCLGBL (*+05() (VAR OPCOD: POP; SB: PSB):INTEGER ()+05*) ;
09770 VAR I,X: INTEGER;
09780 VP : SBTTYP;
09790 BEGIN WITH SB^ DO
09800 BEGIN
09810 (*-05() GENLCLGBL:=SBOFFSET; ()-05*)
09820 (*+05() GENLCLGBL:=-SBOFFSET; ()+05*)
09830 IF (SBLEVEL = 0) (*+05() AND (SBLEVEL<>ROUTNL^.RNLEVEL) ()+05*) THEN (*GLOBAL*)
09840 BEGIN X:=1; (*-05() GENLCLGBL:=SBOFFSET+FIRSTIBOFFSET; ()-05*)
09850 END
09860 ELSE IF SBLEVEL = ROUTNL^.RNLEVEL THEN (*LOCAL*) X := 0
09870 ELSE (*INTERMEDIATE*) BEGIN
09880 (*-02() EMITX0(PENVCHAIN);
09890 FOR I:=1 TO ROUTNL^.RNLEVEL-SBLEVEL-1 DO
09900 BEGIN
09910 EMITX0(PENVCHAIN+1);
09920 END;
09930 ()-02*)
09940 (*+02() EMITX1(PENVCHAIN,OCVIMMED,ROUTNL^.RNLEVEL-SBLEVEL); ()+02*)
09950 X := 2 END;
09960 OPCOD := OPCOD+X;
09970 END
09980 END;
09990 (**)
10000 (**)
10010 (*-05()
10020 PROCEDURE GENDENOT (* (OPCOD: POP; SB: PSB) *) ;
10030 VAR THING: OBJECT; I: INTEGER;
10040 JUMPOVER: LABL;
10050 BEGIN WITH SB^ DO
10060 WITH SBLEX^ (*A LEXEME*) DO
10070 IF SBMODE^.MDV.MDID IN [MDIDCHAN,MDIDPASC] THEN
10080 EMITX1(OPCOD, OCVEXT, ORD(SBLEX))
10090 ELSE IF SBLEX=LEXFALSE THEN
10100 EMITX1(OPCOD, OCVIMMED, 0)
10110 ELSE IF ((LXDENMD=MDINT) OR (LXDENMD=MDBITS) OR (LXDENMD=MDCHAR))
10120 (*+01() AND (LXDENRP<400000B) ()+01*) AND (LXTOKEN=TKDENOT) THEN
10130 EMITX1(OPCOD, OCVIMMED, LXDENRP)
10140 ELSE
10150 BEGIN
10160 IF LXV.LXPYPTR=0 THEN
10170 BEGIN
10180 JUMPOVER := GETNEXTLABEL; EMITX1(PJMP, OCVFREF, JUMPOVER);
10190 LXV.LXPYPTR := FIXUPM;
10200 IF SBLEX=LEXTRUE THEN
10210 EMITXWORD(OCVIMMED, TRUEVALUE)
10220 ELSE IF LXDENMD^.MDV.MDPILE THEN WITH THING DO
10230 BEGIN
10240 FIRSTWORD := 0; PCOUNT := 255;
10250 LENGTH := (*-04() LXDENRP; ()-04*)(*+04() SHRINK(LXDENRP); ()+04*)
10260 EMITXWORD(OCVIMMED, FIRSTWORD);
10270 FOR I := 3 TO LXCOUNT DO
10280 EMITXWORD(OCVIMMED, INTEGERS[I])
10290 END
10300 ELSE EMITXWORD(OCVIMMED, LXDENRP);
10310 FIXUPF(JUMPOVER)
10320 END;
10330 IF LXTOKEN=TKDENOT THEN (*NOT LEXTRUE*)
10340 IF LXDENMD^.MDV.MDPILE THEN OPCOD := OPCOD-1;
10350 EMITX1(OPCOD+1, OCVMEM, LXV.LXPYPTR)
10360 END
10370 END;
10380 ()-05*)
~>
####S
Reference in a new issue Copy permalink