! ! IBM VERSION OF THE OPCODES ! %CONSTINTEGER FOURKTDISP=16 %CONSTINTEGER LGR=X'58',ST=X'50',LM=X'98',STM=X'90',MVC=X'D2',CLC=X'D5', LR=X'18',BCR=7,BAL=X'45',BC=X'47',CR=X'19',COMP=X'59',LA=X'41', %C IC=X'43',STC=X'42',STH=X'40',STE=X'70',STD=X'60', %C BCTR=6,BALR=X'05',MVI=X'92',SPM=4,SRL=X'88',SLL=X'89',LH=X'48', SRDA=X'8E',SLDA=X'8F',BCT=X'46',EX=X'44',CLI=X'95' %CONSTINTEGER LE=X'78',LD=X'68',LDR=X'28',LER=X'38',LCDR=X'23', %C LPDR=X'20',ADR=X'2A',SDR=X'2B',MDR=X'2C',DDR=X'2D',CDR=X'29', AD=X'6A',SD=X'6B',MD=X'6C',DD=X'6D',LTDR=X'22',AW=X'6E' ! INTEGER ARIRTHEMETIC FOLLOW ! %CONSTINTEGER AR=X'1A',SR=X'1B',MR=X'1C',LTR=X'12',LPR=X'10', %C LCR=X'13',XR=X'17',NR=X'14',OR=X'16',DR=X'1D',MH=X'4C', AH=X'4A',SH=X'4B' %CONSTINTEGER ADD=X'5A',SUB=X'5B',MULT=X'5C',DIV=X'5D',AND=X'54', OI=X'96' ! %CONSTINTEGER SHUFFLEDECS=B'1011110'; ! WHICH ALTS OF DEC ARE REORDERED %CONSTINTEGER MARGIN=512; ! MARGIN FOR ADRESSABILITY %CONSTINTEGER MAXREG=22; ! FOR DECLARING REGISTER ETC %CONSTINTEGER CODER=12 %CONSTINTEGER WSPR =11 %CONSTINTEGER GLA =13 %CONSTINTEGER LINKREG=15; ! REGISTER FOR RETURN ADDRESS %CONSTINTEGER EPREG=14; ! REGISTER HOLDING RT ENTRYPOINT %CONSTINTEGER CTABLEREG=14; ! REGISTER HOLDING CONSTANT TABLE %EXTRINSICINTEGERARRAY PLABS(0:31) %EXTRINSICINTEGERARRAY PLINK(0:31) %EXTRINSICBYTEINTEGERARRAY CODE(0:268) %EXTRINSICBYTEINTEGERARRAY GLABUF(0:268) %EXTRINSICINTEGER CA,CABUF,GLACA,GLACABUF %EXTRINSICINTEGER PPCURR,LCA,INHCODE,DCOMP,PARMOPT,LINE %ROUTINESPEC IBMCODE(%INTEGER A,B,C) %SYSTEMROUTINESPEC LPUT(%INTEGER A,B,C,D) ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** !*DELSTART %EXTERNALROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(" CODE FOR LINE"); WRITE(LINE,5) IBMCODE(S,F,AD) NEWLINE %FINISH %END !*DELEND %EXTERNALROUTINE CODEOUT %IF PPCURR>0 %THEN %START !*DELSTART RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %IF DCOMP#0 !*DELEND LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) %IF INHCODE=0 PPCURR=0; CABUF=CA %FINISH %END %EXTERNALROUTINE PLANT(%INTEGER HALFWORD) !*********************************************************************** !* ADD A HALF WORD OF BINARY TO THE BUFFER * !*********************************************************************** CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %EXTERNALROUTINE PCONST(%INTEGER WORD) !*********************************************************************** !* ADD A WORD OF BINARY TO THE BUFFER * !*********************************************************************** %INTEGER I %CYCLE I=24,-8,0 CODE(PPCURR)=WORD>>I&255 PPCURR=PPCURR+1 %REPEAT CA=CA+4 CODE OUT %IF PPCURR>=256 %END %EXTERNALROUTINE PRR(%INTEGER OPCODE,R1,R2) CODE(PPCURR)=OPCODE CODE(PPCURR+1)=(R1&15)<<4!(R2&15) PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE MOVE BACK PC(%INTEGER LCA) %IF LCA4095 R1=R1&15 %IF PARMOPT=0 %THEN %START %IF OPCODE=LGR %OR OPCODE=ST %THEN %START %IF LCA+4=CA %AND LB=B %AND R2=0 %AND %C ((LOPCODE=OPCODE %AND (LR1+1)&15=R1 %AND LR2=0 %AND %C D=LD+4) %OR (LOPCODE=OPCODE+X'40' %AND %C (LR2+1)&15=R1 %AND D=LD+((R1-LR1)&15)*4)) %START %IF DCOMP#0 %THEN PRINTSTRING("** LOADS COMBINED **") MOVE BACK PC(LCA) PRX(STM+OPCODE&15,LR1,R1,LB,LD);! CHANGE L & ST TO LM&STM %RETURN %FINISH %FINISH LCA=CA; LR1=R1; LR2=R2 LB=B; LD=D; LOPCODE=OPCODE %FINISH CODE(PPCURR)=OPCODE CODE(PPCURR+1)=R1<<4!R2 CODE(PPCURR+2)=B<<4!D>>8 CODE(PPCURR+3)<-D PPCURR=PPCURR+4 CA=CA+4 CODEOUT %IF PPCURR>=256 %END %EXTERNALROUTINE PSI(%INTEGER OPCODE,J,B,D) %MONITOR %AND %STOP %IF D>4095 CODE(PPCURR)=OPCODE CODE(PPCURR+1)=J CODE(PPCURR+2)=B<<4!D>>8 CODE(PPCURR+3)<-D PPCURR=PPCURR+4 CA=CA+4 CODEOUT %IF PPCURR>=256 %END %EXTERNALROUTINE PSS(%INTEGER OPCODE,N,B1,D1,B2,D2) %MONITOR %AND %STOP %IF D1>4095 %OR D2>4095 CODE(PPCURR)=OPCODE N=N-1 %UNLESS N=0 CODE(PPCURR+1)=N CODE(PPCURR+2)=B1<<4!D1>>8 CODE(PPCURR+3)<-D1 CODE(PPCURR+4)=B2<<4!D2>>8 CODE(PPCURR+5)<-D2 PPCURR=PPCURR+6 CA=CA+6 CODEOUT %IF PPCURR>=256 %END %EXTERNALROUTINE PMVC(%INTEGER L,B1,D1,B2,D2) !*********************************************************************** !* PLANTS AN MVC INSTRN. IN OPTIMISING MODE TRIES TO GLUE IT * !* ON TO THE LAST ONE PLANTED * !*********************************************************************** %OWNINTEGER LL,LB1,LD1,LB2,LD2 %IF PARMOPT=0 %THEN %START %IF LCA+6=CA %AND B1=LB1 %AND B2=LB2 %C %AND D1=LD1+LL %AND D2=LD2+LL %AND LL+L<=256 %START MOVE BACK PC(LCA) CA=LCA; L=L+LL D1=LD1; D2=LD2 %FINISH LCA=CA; LL=L; LB1=B1; LD1=D1 LB2=B2; LD2=D2 %FINISH PSS(MVC,L,B1,D1,B2,D2) %END %EXTERNALROUTINE CNOP(%INTEGER I, J) PRR(BCR,0,0) %WHILE CA&(J-1)#I %END %EXTERNALROUTINE PGLA(%INTEGER BDRY, L, INF ADR) %OWNINTEGER GLACURR=0 %INTEGER I, J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING %IF L+GLACURR>256 %THEN %START %IF INHCODE=0 %C %THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0))) GLACURR=0; GLACABUF=GLACA %FINISH %CYCLE I=0,1,L-1 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) %REPEAT GLACA=GLACA+L; GLACURR=GLACURR+L %END %EXTERNALROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES) !*********************************************************************** !* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGERNAME WCABUF %INTEGER I, RELAD, BUFAD WCABUF==CABUF; BUFAD=ADDR(CODE(0)) %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0)) RELAD=AT-WCABUF %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START %CYCLE I=0,1,BYTES-1 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3) %REPEAT %FINISH %ELSE %START %IF RELAD=-2 %THEN CODEOUT %IF INHCODE=0 %THEN LPUT(AREA,BYTES,AT,ADDR(VALUE)+4-BYTES) !*DELSTART IBMCODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) %C %IF DCOMP=1=AREA !*DELEND %FINISH %END %EXTERNALROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK LPUT TO ARRANGE FOR A TRIPLE WORD AT 'AT' IN THE GLA * !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH (SINGLE WORD ONLY) * !*********************************************************************** %INTEGER LPUTNO %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12 LPUT(LPUTNO,2<<24!XTRA,AT,ADDR(NAME)) %END %EXTERNALROUTINE CXREF(%STRING(255) NAME, %INTEGER MODE,XTRA,%INTEGERNAME AT) !*********************************************************************** !* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET * !* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT * !* PARAMETERS ARE AS FOR GXREF. * !*********************************************************************** %INTEGER Z1,Z2,Z3,Z4 Z1=0; Z2=0; Z3=0; Z4=0 PGLA(4,16,ADDR(Z1)); ! 4 ZERO WORDS AT=GLACA-16 GXREF(NAME,MODE,XTRA,AT) %END %EXTERNALROUTINE IMPEPILOGUE(%INTEGERNAME LOGEPDISP,EXPEPDISP, %ROUTINE POP(%INTEGERNAME A,B,C,D)) !*********************************************************************** !* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING * !* THE CODE GENERATION PHASE * !*********************************************************************** %INTEGER D,J %ROUTINESPEC FILL(%INTEGER LAB) ! FINISH OFF RESOLUTION ! ON ENTRY GR0 HAS ADDRESS OF WK AREA AS MAIN RESOLUTION SUBROUTINE ! ! STM 1,5,4(WSPR) SAVE REGS ! LR 1,0 ! BALR 5,0 ! L 2,0(1) ORIGINAL STRING ! AH 2,6(1) PAST BIT ALREADY USED ! LH 3,4(1) WORK OUT LENGTH ! SH 3,6(1) LENGTH IN BYTES ! L 4,8(1) DEST FOR FRAGMENT ! EX 3,MOVE 44(5) RUBBISH LENGTH + CHARS ! STC 3,0(4) VAILD LENGTH ! CLC 0(1,4),8(1) MAX LENGTH CHECK ! LM 1,5,4(WSPR) ! BCR 13,LINKREG ! BC 15,PLABS9 LENGTH CHECK FAILS !MOVE MVC 0(1,4),0(2) %IF PLINK(15)=0 %THEN ->P16 FILL(15) PRX(STM,1,5,WSPR,4) PRR(LR,1,0) PRR(BALR,5,0) PRX(LGR,2,0,1,0) PRX(AH,2,0,1,6) PRX(LH,3,0,1,4) PRX(SH,3,0,1,6) PRX(LGR,4,0,1,8) PRX(EX,3,0,5,44) PRX(STC,3,0,4,0) PSS(CLC,1,4,0,1,8) PRX(LM,1,5,WSPR,4) PRR(BCR,13,LINKREG) PRX(BC,15,0,CODER,PLABS(9)) PSS(MVC,1,4,0,2,0) P16: ! ! STRING RESOLUTION SUBROUTINE ! ON ENTRY GR0 HAS ADDRESS OF WK AREA HOLDING ! W1(GR2) HAS ADDRESS OF ORIGINAL STRING ! W2(GR3) HAS BYTES USED UP IN PREV RESOLUTIONS. TOP HALF HAS ORIGINA ! LENGTH OF LHS ! W3(GR4) HAS ZERO OR STRINGNAME TO HOLD FRAGMENT ! W4(GR5) HAS ADDRESS OF RESOLUTION EXPRESSION(READ ONLY) ! ! ON EXIT RESULT IS SET BY CC AND W2 UPDATED. NO OTHER EFFECTS ! EXCEPT POSSIBLY STORING INTO FRAGMENT W3 ! ! STM 1,10,4(WSPR) LOTS OF REGISTERS NEEDED ! LR 1,0 NOW PICK UP W1-4 ! LM 2,5,0(1) ! BALR 9,0 BASE REGISTER COVER VIA 9 ! CLI 7(1),0 FIRST ENTRY ? ! BC 7,NOT FIRST 14(9) ! MVC 5(1,1),0(2) COPY ORIGINAL LENGTH !NOTFIRST ! WORK OUT NO OF VALID COMPARISONS ! ! LH 6,4(1) ORIGINAL LENGTH ! SH 6,6(1) MINUS BYTES USED ! SR 7,7 ! IC 7,0(5) LENGTH OF EXPRESSION ! SR 6,7 ! BL RESFAIL 64(9) NOT ENOUGH LENGTH ! LA 6,1(6) EQUAL LENGTHS = 1 VALID COMP ! LTR 7,7 ! BC 8,NULL RES 144(9) RESOLVING FOR NULL STRING ! BCTR 7,0 FOR EXECUTING ! AH 2,6(1) POINT TO START SERACH -1 ! LR 10,2 SAVE THIS FOR STORING FRAGMNT !NRLOOP ! EX 7,COMP 76(9) COMPARE ! BC 8,NROK 82(9) FOUND IT ! LA 2,1(2) STEP ALONG 1 ! BCT 6,NRLOOP 52(9) AND KEEP GOING !RESFAIL LM 1,10,4(WSPR) WONT RESOLVE ! NR WSPR,WSPR SET NON ZERO CC ! BCR 15,LINKREG AND RETURN !COMP CLC 1(1,5),1(2) !NROK ! SR 2,10 LENGTH OF FRAGMENT ! LTR 4,4 IS FRAGMNT TO BE STORED ! BC 8,NOSTORE 108(9) ! EX 2,MOVE 130(9) COPY IT +RUBBISH LENGTH BYTE ! STC 2,0(4) RESET LENGTH BYTE ! CLC 0(1,4),8(1) PERFORM CAP EXCEEDED CHECK ! BC 2,CPE 136(9) !NOSTORE AH 2,6(1) R2=FRAG LENGTH + ORIG USED ! AR 2,7 PLUS BYTES OF EXPR ! LA 2,1(2) ! STH 2,6(1) BACK INTO WORK AREA !REND LM 1,10,4(WSPR) ! CR WSPR,WSPR SET CC TO 0 ! BCR 15,LINKREG !MOVE MVC 0(1,4),0(10) !CPE LM 1,10,4(WSPR) ! BC 15,PLABS9 !NULL RES RESOLVING ON NULL STRING ! LTR 4,4 ANY FRAG STRING ! BC 8,REND 122(9) NO SO EXIT ! MVI 0(4),0 SET IT TO NULL ! BC 15,REND 122(9) ! BCR 15,LINREG %IF PLINK(16)=0 %THEN ->P17 FILL(16) PRX(STM,1,10,WSPR,4) PRR(LR,1,0) PRX(LM,2,5,1,0) PRR(BALR,9,0) PSI(CLI,0,1,7) PRX(BC,7,0,9,14) PSS(MVC,1,1,5,2,0) PRX(LH,6,0,1,4) PRX(SH,6,0,1,6) PRR(SR,7,7) PRX(IC,7,0,5,0) PRR(SR,6,7) PRX(BC,4,0,9,64) PRX(LA,6,0,6,1) PRR(LTR,7,7) PRX(BC,8,0,9,144) PRR(BCTR,7,0) PRX(AH,2,0,1,6) PRR(LR,10,2) PRX(EX,7,0,9,76) PRX(BC,8,0,9,82) PRX(LA,2,0,2,1) PRX(BCT,6,0,9,52) PRX(LM,1,10,WSPR,4) PRR(NR,WSPR,WSPR) PRR(BCR,15,LINKREG) PSS(CLC,1,5,1,2,1) PRR(SR,2,10) PRR(LTR,4,4) PRX(BC,8,0,9,108) PRX(EX,2,0,9,130) PRX(STC,2,0,4,0) PSS(CLC,1,4,0,1,8) PRX(BC,2,0,9,136) PRX(AH,2,0,1,6) PRR(AR,2,7) PRX(LA,2,0,2,1) PRX(STH,2,0,1,6) PRX(LM,1,10,WSPR,4) PRR(CR,WSPR,WSPR) PRR(BCR,15,LINKREG) PSS(MVC,1,4,0,10,0) PRX(LM,1,10,WSPR,4) PRX(BC,15,0,CODER,PLABS(9)) PRR(LTR,4,4) PRX(BC,8,0,9,122) PSI(MVI,0,4,0) PRX(BC,15,0,9,122) P17: ! ! EVALUATE X**Y ! ******** **** ! Y IS IN FR0 AND X IS AT TOP OF STACK ! EVENT 5/5 IS SIGNALLED IF X<0 OR (X=0 AND Y<=0) ! OTHERWISE RESULT=EXP(Y*LOG(Y)) ! ! ST 15,12(WSPR) SAVE LINK ! BALR 1,0 ! LTDR 0,0 ! BC 4,PLAB7 ! BC 7,20(1) ! LD 2,0(WSPR) ! LTDR 2,2 ! BC 12,PLAB7 ! LA WSPR,16(WSPR) PROTECT X AND RETURN ADD ! STD 0,64(WSPR) PARAMETER X TO LOG ! STM 4,14,16(WSPR) SAVE ENVIRONMENT ! LM CODER,EPREG,LOGEPDISP ! BALR LINKREG,EPREG ! LA 0,16 ! SR WSPR,0 ! MD 0,0(WSPR) ! STD 0,64(WSPR) Y*LOG(X) TO EXP ! STM 4,14,16(WSPR) ! LGR LINKREG,12(WSPR) ! LM CODER,EPREG,EXPEPDISP ! BCR 15,LINKREG RETURNS DIRECT TO PROGRAM ! %IF PLINK(17)=0 %THEN ->P18 FILL(17) %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",0,2,LOGEPDISP) %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",0,2,EXPEPDISP) PRX(ST,LINKREG,0,WSPR,12) PRR(BALR,1,0) PRR(LTDR,0,0) PRX(BC,4,0,CODER,PLABS(7)) PRX(BC,7,0,1,20) PRX(LD,2,0,WSPR,0) PRR(LTDR,2,2) PRX(BC,12,0,CODER,PLABS(7)) PRX(LA,WSPR,0,WSPR,16) PRX(STD,0,0,WSPR,64) PRX(STM,4,14,WSPR,16) PRX(LM,CODER,EPREG,GLA,LOGEPDISP) PRR(BALR,LINKREG,EPREG) PRX(LA,0,0,0,16) PRR(SR,WSPR,0) PRX(MD,0,0,WSPR,0) PRX(STD,0,0,WSPR,64) PRX(STM,4,14,WSPR,64) PRX(LGR,LINKREG,0,WSPR,12) PRX(LM,CODER,EPREG,GLA,EXPEPDISP) PRR(BCR,15,LINKREG) P18: ! ! MAPPED STRING ASSIGNMENT CHECK. CHECKING MODE ONLY. MUST MOVE ONLY ! CURRENT LENGTH INTO MAPPED STRINGS BUT MUST NOT OMIT THE CAPACITY ! CHECK. ACC & DR SET FOR MV ! ! ST TOS SAVE ACC DESRPTR ! AND X'1FF00000000' GET CURRENT LENGTH ! STUH B INTO BREG ! LSD TOS RESTORE ACC ! STD TOS SAVE DR DESCRPTR ! SBB 1 ! JAF 13,*+3 ! MODD B PROVOKE FAILURE IF RELEVANT ! ADB 1 ! LD TOS ! LDB B BOUND=CURRENT L +1(FOR LBYTE) ! J TOS ! %IF PLINK(18)=0 %THEN ->P19 P19: ! CONCATENATION ONE ! COPY THE FIRST STRING INTO THE WORK AREA ! GR0 HAS ADDRESS OF WK AREA. GR1 HAS STRING ! ! STM 2,4,8(WSPR) SAVE REGS (MAY BE OPTIMISED) ! LR 3,0 TO WORK AREA ! IC 2,0(1) LENGTH OF STRING ! BALR 4,0 GIVE ADDRESSABILITY ! EX 2,MV EXECUTE PREV INSTRN ! LM 2,4,8(WSPR) ! BCR 15,LINKREG !MV MVC 3(1,3),0(1) MOVEL BYTE & FOR EXECUTE %IF PLINK(19)!PLINK(20)=0 %THEN ->P21 FILL(19) PRX(STM,2,4,WSPR,8) PRR(LR,3,0) PRX(IC,2,0,1,0) PRR(BALR,4,0) PRX(EX,2,0,4,10) PRX(LM,2,4,WSPR,8) PRR(BCR,15,LINKREG) PSS(MVC,1,3,3,1,0) ! ! CONCATENATION TWO ! ADD THE SECOND AND SUBSEQUENT STRINGS TO THE FIRST ! PARAMETERS AND RESULTS AS CONCATENATION ONE ! ! STM 2,5,8(WSPR) SAVE 3 REGS ! LR 3,0 ! SR 4,4 ! IC 4,3(3) LENGTH BYTE FROM WA ! AR 3,4 PLACE TO MOVE TO ! SR 2,2 ! IC 2,0(1) LENGTH BYTE OF STRING ! BALR 5,0 BASE REGISTER ! EX 2,MV ! AR 2,4 ! LR 3,0 ! ST 2,0(3) UPDATED LENGTH BACK ! C 2,12(CODER) =F'255' ! BC 2,PLABS(7) ! LM 2,5,8(WSPR) ! BCR 15,LINKREG !MV MVC 4(1,3),1(1) FOR EXECUTING %IF PLINK(20)=0 %THEN ->P21 FILL(20) PRX(STM,2,5,WSPR,8) PRR(LR,3,0) PRR(SR,4,4) PRX(IC,4,0,3,3) PRR(AR,3,4) PRR(SR,2,2) PRX(IC,2,0,1,0) PRR(BALR,5,0) PRX(EX,2,0,5,26) PRR(AR,2,4) PRR(LR,3,0) PRX(ST,2,0,3,0) PRX(COMP,2,0,CODER,12) PRX(BC,2,0,CODER,PLABS(8)) PRX(LM,2,5,WSPR,8) PRR(BCR,15,LINKREG) PSS(MVC,1,3,4,1,1) P21: ! ! THE STOP SEQUENCE ! CALL %SYSTEMROUTINE STOP(NO PARAMETERS) ! !STOP1 PRCL 4 ! LXN (LNB+4) ! RALN 5 ! CALL ((XNB+STOPEPDISP)) ! **PLEASE DONT COME BACK** ! %IF PLINK(21)=0 %THEN ->P22 FILL(21) CXREF("S#STOP",0,2,J) PRX(STM,4,14,11,16) %IF J>4095 %THEN PRX(ADD,GLA,0,CODER,(J>>12<<2)+FOURKTDISP) PRX(LM,CODER,EPREG,GLA,J&4095) PRR(BALR,LINKREG,EPREG) P22: ! ! PRINTPROFILE ! %IF PLINK(22)=0 %THEN ->P23 FILL(22) CXREF("S#PPROFILE",0,2,J) P23: ! ! FIX FR0 LEAVING RESULT ON STACK TOP. SAVE ALL WORK REGS ! ! CNOP 0,8 ALIGN ! STD 2,8(WSPR) SAVE A WORK FREG ! ST 15,16(WSPR) SAVE RETURN ADDRESS ! BALR 15,0 AND SET A BASE REGISTER ! LDR 2,0 COPY DATAUM ! MD 2,=X'7810000000000000' FORCE OVERFLOW IF TOO LARGE ! LDR 2,0 ! AW 2,=X'4E00000000000000' UNNORMALISED ZERO ! LTDR 0,0 ! BC 10,L1 POSITIVE OR ZERO ! AD 2,=D'0' RENORMALISE ! SDR 0,2 CHECK FOR EXACT INTEGER ! BC 4,L2 WAS NOT EXACT TRUNC OCCURRED ! AW 2,=X'4E00000100000000' ! BC 15,L1 !L2 AW 2,=X'4E000000FFFFFFFF' ROUND DOWN NOT TOWARDS 0 !L1 STD 2,0(WSPR) STACK RESULT ! L 15,16(WSPR) ! LD 2,8(WSPR) ! BCR 15,LINKREG ! =X'7810000000000000' 54(15) ! =X'4E00000000000000' 62(15) ! =X'0000000000000000' 70(15) ! =X'4E00000100000000' 78(15) ! =X'4E000000FFFFFFFF' 86(15) ! %IF PLINK(23)=0 %THEN ->P24 CNOP(0,8) FILL(23) PRX(STD,2,0,WSPR,8) PRX(ST,15,0,WSPR,16) PRR(BALR,15,0) PRR(LDR,2,0) PRX(MD,2,0,15,54) PRR(LDR,2,0) PRX(AW,2,0,15,62) PRR(LTDR,0,0) PRX(BC,10,0,15,40) PRX(AD,2,0,15,70) PRR(SDR,0,2) PRX(BC,4,0,15,36) PRX(AW,2,0,15,78) PRX(BC,15,0,15,40) PRX(AW,2,0,15,86) PRX(STD,2,0,WSPR,0) PRX(LGR,15,0,WSPR,16) PRX(LD,2,0,WSPR,8) PRR(BCR,15,LINKREG) PCONST(X'78100000') PCONST(0) PCONST(X'4E000000') PCONST(0) %FOR J=1,1,3 PCONST(X'4E000001') PCONST(0) PCONST(X'4E000000') PCONST(-1) P24: %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS * !* TOP BIT SET IN INSTRN WHEN 4K MULT ALREADY LOADED * !*********************************************************************** %INTEGER AT,INSTRN,I,MULT %INTEGERARRAY A(0:2) MULT=CA>>12 MULT=4*MULT+FOURKTDISP; ! DISP OF MULT %WHILE PLINK(LAB)#0 %CYCLE POP(PLINK(LAB),A(0),A(1),A(2)) %CYCLE I=0,1,2 INSTRN=A(I) %IF INSTRN#0 %THEN %START AT=INSTRN&X'FFFFFF'+2 %IF INSTRN>0 %THEN PLUG(1,AT,MULT,2) %AND AT=AT+4 PLUG(1,AT,CODER<<12!CA&4095,2) %FINISH %REPEAT %REPEAT PLABS(LAB)=CA %END %END %EXTERNAL%STRINGFN MESSAGE(%INTEGER N) !*********************************************************************** !* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT * !* 1 %REPEAT is not required * !* 2 Label & has already been set in this block * !* 4 & is not a Switch name at current textual level * !* 5 Switch name & in expression or assignment * !* 6 Switch label &(#) set a second time * !* 7 Name & has already been declared * !* 8 Routine or fn & has more parameters than specified * !* 9 Parameter # of & differs in type from specification * !* 10 Routine or fn & has fewer parameters than specified * !* 11 Label & referenced at line # has not been set * !* 12 %CYCLE at line # has two control clauses * !* 13 %REPEAT for %CYCLE at line # is missing * !* 14 %END is not required * !* 15 # %ENDs are missing * !* 16 Name & has not been declared * !* 17 Name & does not require parameters or subscripts * !* 18 # too few parameters provided for & * !* 19 # too many parameters provided for & * !* 20 # too few subscripts provided for array & * !* 21 # too many subscripts provided for array & * !* 22 Actual parameter # of & conflicts with specification * !* 23 Routine name & in an expression * !* 24 Integer operator has Real operands * !* 25 Real expression in integer context * !* 26 # is not a valid %EVENT number * !* 27 & is not a routine name * !* 28 Routine or fn & has specification but no body * !* 29 %FUNCTION name & not in expression * !* 30 %RETURN outwith routine body * !* 31 %RESULT outwith fn or map body * !* 34 Too many textual levels * !* 37 Array & has too many dimensions * !* 38 Array & has upper bound # less than lower bound * !* 39 Size of Array & is more than X'FFFFFF' bytes * !* 40 Declaration is not at head of block * !* 41 Constant cannot be evaluated at compile time * !* 42 # is an invalid repetition factor * !* 43 %CONSTANT name & not in expression * !* 44 Invalid constant initialising & after # items * !* 45 Array initialising items expected ## items given # * !* 46 Invalid %EXTERNAL %EXTRINSIC or variable %SPEC * !* 47 %ELSE already given at line # * !* 48 %ELSE invalid after %ON %EVENT * !* 49 Attempt to initialise %EXTRINSIC or %FORMAT & * !* 50 Subscript of # is outwith the bounds of & * !* 51 %FINISH is not required * !* 52 %REPEAT instead of %FINISH for %START at line # * !* 53 %FINISH for %START at line # is missing * !* 54 %EXIT outwith %CYCLE %REPEAT body * !* 55 %CONTINUE outwith %CYCLE %REPEAT body * !* 56 %EXTERNALROUTINE & at wrong textual level * !* 57 Executable statement found at textual level zero * !* 58 Program among external routines * !* 59 %FINISH instead of %REPEAT for %CYCLE at line # * !* 61 Name & has already been used in this %FORMAT * !* 62 & is not a %RECORD or %RECORD %FORMAT name * !* 63 %RECORD length is greater than # bytes * !* 64 Name & requires a subname in this context * !* 65 Subname & is not in the %RECORD %FORMAT * !* 66 Expression assigned to record & * !* 67 Records && and & have different formats * !* 69 Subname && is attached to & which is not of type %RECORD * !* 70 String declaration has invalid max length of # * !* 71 & is not a String variable * !* 72 Arithmetic operator in a String expression * !* 73 Arithmetic constant in a String expression * !* 74 Resolution is not the correct format * !* 75 String expression contains a sub expression * !* 76 String variable & in arithmetic expression * !* 77 String constant in arithmetic expression * !* 78 String operator '.' in arithmetic expression * !* 80 Pointer variable & compared with expression * !* 81 Pointer variable & equivalenced to expression * !* 82 & is not a pointer name * !* 83 && and & are not equivalent in type * !* 86 Global pointer && equivalenced to local & * !* 87 %FORMAT name & use in expression * !* 90 Untyped name & used in expression * !* 91 %FOR control variable & not integer * !* 92 %FOR clause has zero step * !* 93 %FOR clause has noninteger number of traverses * !* 95 Name & not valid in assembler * !* 96 Operand # not valid in assembler * !* 97 Assembler construction not valid * !* 98 Addressability * !* 99 No base register available in Assembler * !* 101 Source line has too many continuations * !* 102 Workfile of # Kbytes is too small * !* 103 Dictionary completely full * !* 104 Dictionary completely full * !* 105 Too many textual levels * !* 106 String constant too long * !* 107 Compiler tables are completely full * !* 108 Condition too complicated * !* 109 Compiler inconsistent * !* 110 Input ended * !* 201 Long integers are inefficient as subscripts * !* 202 Name & not used * !* 203 Label & not used * !* 204 Global %FOR control variable & * !* 205 Name & not addressable * !* 206 Semicolon in comment text * !* 207 %CONSTANT variable & not initialised * !* 255 SEE IMP MANUAL * !*********************************************************************** %CONSTBYTEINTEGERARRAY OUTTT(0:63)='?','A','B','C','D','E','F','G', 'H','I','J','K','L','M','N', 'O','P','Q','R','S','T','U', 'V','W','X','Y','Z','&','-', '/','''','(',')', 'a','b','c','d','e','f','g', 'h','i','j','k','l','m','n', 'o','p','q','r','s','t','u', 'v','w','x','y','z','.','%', '#','?'(2) %CONSTINTEGER WORDMAX= 762,DEFAULT= 758 %CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,%C 1, 32769, 32771, 32772, 32773, 2, 32775, 32776, 32777, 32778, 32780, 32781, 32782, 32783, 32784, 4, 32776, 32771, 32772, 32785, 32786, 32788, 32789, 32790, 32792, 32794, 5, 32786, 32788, 32776, 32782, 32795, 32797, 32798, 6, 32786, 32800, 32801, 32781, 32785, 32802, 32804, 7, 32805, 32776, 32777, 32778, 32780, 32806, 8, 32808, 32797, 32810, 32776, 32777, 32811, 32812, 32814, 32815, 9, 32817, 32819, 32820, 32776, 32821, 32782, 32823, 32824, 32825, 10, 32808, 32797, 32810, 32776, 32777, 32828, 32812, 32814, 32815, 11, 32775, 32776, 32829, 32789, 32831, 32819, 32777, 32772, 32780, 32781, 12, 32832, 32789, 32831, 32819, 32777, 32834, 32835, 32837, 13, 32769, 32839, 32832, 32789, 32831, 32819, 32771, 32840, 14, 32842, 32771, 32772, 32773, 15, 32819, 32843, 32844, 32840, 16, 32805, 32776, 32777, 32772, 32780, 32806, 17, 32805, 32776, 32845, 32772, 32846, 32812, 32797, 32848, 18, 32819, 32850, 32851, 32812, 32852, 32839, 32776, 19, 32819, 32850, 32854, 32812, 32852, 32839, 32776, 20, 32819, 32850, 32851, 32848, 32852, 32839, 32855, 32776, 21, 32819, 32850, 32854, 32848, 32852, 32839, 32855, 32776, 22, 32856, 32858, 32819, 32820, 32776, 32860, 32862, 32825, 23, 32808, 32788, 32776, 32782, 32863, 32795, 24, 32864, 32866, 32777, 32868, 32869, 25, 32868, 32795, 32782, 32871, 32873, 26, 32819, 32771, 32772, 32785, 32875, 32876, 32878, 27, 32776, 32771, 32772, 32785, 32880, 32788, 28, 32808, 32797, 32810, 32776, 32777, 32825, 32882, 32883, 32884, 29, 32885, 32788, 32776, 32772, 32782, 32795, 30, 32887, 32889, 32880, 32884, 31, 32891, 32889, 32810, 32797, 32893, 32884, 34, 32894, 32854, 32792, 32895, 37, 32897, 32776, 32777, 32850, 32854, 32898, 38, 32897, 32776, 32777, 32900, 32901, 32819, 32902, 32814, 32903, 32901, 39, 32904, 32820, 32897, 32776, 32771, 32811, 32814, 32905, 32907, 40, 32908, 32771, 32772, 32789, 32911, 32820, 32784, 41, 32912, 32914, 32916, 32917, 32789, 32919, 32804, 42, 32819, 32771, 32863, 32921, 32923, 32925, 43, 32927, 32788, 32776, 32772, 32782, 32795, 44, 32929, 32931, 32933, 32776, 32936, 32819, 32937, 45, 32897, 32933, 32937, 32938, 32940, 32937, 32941, 32819, 46, 32929, 32942, 32944, 32797, 32946, 32948, 47, 32949, 32778, 32941, 32789, 32831, 32819, 48, 32949, 32921, 32936, 32950, 32876, 49, 32951, 32953, 32954, 32944, 32797, 32956, 32776, 50, 32958, 32820, 32819, 32771, 32889, 32960, 32961, 32820, 32776, 51, 32963, 32771, 32772, 32773, 52, 32769, 32965, 32820, 32963, 32839, 32967, 32789, 32831, 32819, 53, 32963, 32839, 32967, 32789, 32831, 32819, 32771, 32840, 54, 32969, 32889, 32832, 32769, 32884, 55, 32970, 32889, 32832, 32769, 32884, 56, 32972, 32776, 32789, 32976, 32792, 32794, 57, 32977, 32979, 32981, 32789, 32792, 32794, 32982, 58, 32983, 32985, 32986, 32988, 59, 32963, 32965, 32820, 32769, 32839, 32832, 32789, 32831, 32819, 61, 32805, 32776, 32777, 32778, 32780, 32990, 32782, 32783, 32956, 62, 32776, 32771, 32772, 32785, 32991, 32797, 32991, 32956, 32788, 63, 32991, 32993, 32771, 32995, 32814, 32819, 32907, 64, 32805, 32776, 32997, 32785, 32999, 32782, 32783, 32873, 65, 33001, 32776, 32771, 32772, 32782, 32960, 32991, 32956, 66, 33003, 33005, 32953, 33007, 32776, 67, 33009, 33011, 33012, 32776, 33013, 33014, 33016, 69, 33001, 33011, 32771, 33018, 32953, 32776, 33020, 32771, 32772, 32820, 32823, 32991, 70, 33021, 33023, 32777, 32921, 33026, 32993, 32820, 32819, 71, 32776, 32771, 32772, 32785, 33021, 32946, 72, 33027, 32866, 32782, 32785, 33021, 32795, 73, 33027, 32931, 32782, 32785, 33021, 32795, 74, 33029, 32771, 32772, 32960, 33031, 33033, 75, 33021, 32795, 33035, 32785, 33037, 32795, 76, 33021, 32946, 32776, 32782, 33038, 32795, 77, 33021, 32931, 32782, 33038, 32795, 78, 33021, 32866, 33040, 32782, 33038, 32795, 80, 33041, 32946, 32776, 33043, 32862, 32795, 81, 33041, 32946, 32776, 33045, 32953, 32795, 82, 32776, 32771, 32772, 32785, 33048, 32788, 83, 33011, 33012, 32776, 32844, 32772, 33050, 32782, 32823, 86, 33052, 33048, 33011, 33045, 32953, 33054, 32776, 87, 32956, 32788, 32776, 33055, 32782, 32795, 90, 33056, 32788, 32776, 32990, 32782, 32795, 91, 33058, 32835, 32946, 32776, 32772, 32871, 92, 33058, 33059, 32777, 32982, 33061, 93, 33058, 33059, 32777, 33062, 32878, 32820, 33064, 90, 33056, 32788, 32776, 32990, 33066, 32946, 95, 32805, 32776, 32772, 32875, 32782, 33067, 96, 33069, 32819, 32772, 32875, 32782, 33067, 97, 33071, 33073, 32772, 32875, 98, 33076, 99, 33079, 33080, 33081, 33083, 32782, 33071, 101, 33085, 32831, 32777, 32850, 32854, 33087, 102, 33090, 32820, 32819, 33092, 32771, 32850, 33094, 103, 33095, 33097, 33099, 104, 33095, 33097, 33099, 105, 32894, 32854, 32792, 32895, 106, 33021, 32931, 32850, 33100, 107, 33101, 33103, 32844, 33097, 33099, 108, 33105, 32850, 33107, 109, 33101, 33110, 110, 33113, 33114, 201, 33115, 33116, 32844, 33118, 33066, 32848, 202, 32805, 32776, 32772, 32990, 203, 32775, 32776, 32772, 32990, 204, 33052, 33058, 32835, 32946, 32776, 205, 32805, 32776, 32772, 33121, 206, 33124, 32782, 33126, 33128, 207, 32927, 32946, 32776, 32772, 33129, 255, 33132, 33133, 33134, 0 %CONSTINTEGERARRAY LETT(0: 367)=0,%C X'7890A80B',X'02A00000',X'53980000',X'5D7E8000', X'652E3AD3',X'652C8000',X'190C52D8',X'36000000', X'510E6000',X'436652C3',X'49C80000',X'452CB700', X'672E8000',X'53700000',X'69453980',X'4565F1D6', X'42000000',X'27BD3A47',X'50000000',X'5D0DB280', X'43A00000',X'47AE594B',X'5DA00000',X'692F1A6B', X'43600000',X'592ED2D8',X'4BC6194B',X'679D37DC', X'5F900000',X'439E74CF',X'5D6CB768',X'590C52D8', X'36FFB000',X'672C77DD',X'48000000',X'694DB280', X'1D0DB280',X'492C7643',X'652C8000',X'257EBA53', X'5D280000',X'4D700000',X'5B7E5280',X'610E50DB', X'4BA4B966',X'69443700',X'6784B1D3',X'4D4CB200', X'210E50DB',X'4BA4B900',X'7A000000',X'5F300000', X'494CD34B',X'65980000',X'69CE1280',X'4D95F680', X'6784B1D3',X'4D4C70E9',X'537DC000',X'4D2EF2E4', X'652CD2E5',X'4B7472C8',X'594DD280',X'781B2199', X'0A000000',X'69BDE000',X'477DDA65',X'5F600000', X'47643AE7',X'4B980000',X'4D7E4000',X'5B4E79D3', X'5D380000',X'7829C200',X'7829C266',X'4394A000', X'497CB980',X'652E3AD3',X'65280000',X'67AC59C7', X'654E1A66',X'697DE000',X'4D2EE000',X'6195FB53', X'492C8000',X'5B0DDC80',X'439650F2',X'031E9AC3', X'58000000',X'610E50DB',X'4BA4B900',X'477DD359', X'531E9980',X'6F4E9400',X'43700000',X'137692CF', X'4B900000',X'5F84B943',X'697E4000',X'252C3600', X'5F84B943',X'5D266000',X'537692CF',X'4B900000', X'477DDA4B',X'71A00000',X'6D0D94C8',X'782AC29D', X'28000000',X'5DADB14B',X'64000000',X'657EBA53', X'5D280000',X'45AE8000',X'5D780000',X'457C9C80', X'7832A707',X'2849E700',X'7890AA2B',X'24700000', X'5FAE9BD3',X'69400000',X'7890A9AB',X'18A00000', X'5B0E0000',X'297DE000',X'592ED2D9',X'66000000', X'039650F2',X'494DB2DD',X'674DF766',X'6B8612E4', X'457EB748',X'592E7980',X'597EF2E4',X'274F5280', X'30F0C30D',X'0C30CF00',X'45CE92E6',X'092C7643', X'650E94DF',X'5C000000',X'512C3200',X'077DD9E9', X'43768000',X'470DD75F',X'68000000',X'45280000', X'4BB4366B',X'43A4B200',X'477DB853',X'59280000', X'5376D0D9',X'53200000',X'652E12E9',X'53A537DC', X'4D0C7A5F',X'64000000',X'7819E727',X'2809CA00', X'1376D0D9',X'53200000',X'477DD9E9',X'43768000', X'53753A53',X'436539D3',X'5D380000',X'433692E4', X'53A4B6E6',X'4BC612C7',X'692C8000',X'7BE80000', X'4F4ED2DC',X'782B0A0B',X'24702600',X'782B0A25', X'12726486',X'6D0E54C3',X'4564A000',X'789A0286', X'7829898A',X'7879C000',X'03A692DB',X'61A00000', X'69780000',X'53753A53',X'436539CA',X'7831E91B', X'02A00000',X'27AC59C7',X'654E1A00',X'6944A000', X'457EB749',X'66000000',X'78312713',X'26400000', X'53767A4B',X'43200000',X'789A80A5',X'28000000', X'782B04A8',X'7819E729',X'1272A280',X'782B0A0B', X'24702625',X'1EAA849D',X'0A000000',X'6F95F74E', X'0BC4B1EB',X'690C564A',X'67A43A4B',X'5B2DDA00', X'4D7EB748',X'752E5780',X'2195F3E5',X'43680000', X'436DF74E',X'4BC692E5',X'5D0D8000',X'657EBA53', X'5D2E6000',X'6B9CB200',X'7890A19F',X'24200000', X'592DD3E9',X'50000000',X'4F94B0E9',X'4B900000', X'652E3AD3',X'652E6000',X'67AC5743',X'5B280000', X'27AC5743',X'5B280000',X'0BC6194B',X'679D37DC', X'439E74CF',X'5D2C8000',X'652C77E5',X'48000000', X'252C77E5',X'49980000',X'36D80000',X'43748000', X'510ED280',X'494CD34B',X'652DDA00',X'4D7E56C3', X'69980000',X'43A690C7',X'512C8000',X'6F4531D0', X'27A654DD',X'4E000000',X'492C7643',X'650E94DF', X'5C000000',X'5B0F0000',X'03953A51',X'5B2E94C6', X'252E77D9',X'6BA537DC',X'477E594B',X'47A00000', X'4D7E56C3',X'68000000',X'477DDA43',X'53766000', X'67AC4000',X'43953A51',X'5B2E94C6',X'3DDBC000', X'217D3769',X'4B900000',X'477DB843',X'652C8000', X'4B8EB4ED',X'4364B747',X'4B200000',X'617D3769', X'4B900000',X'4B8EB4ED',X'4364B768',X'0F65F143', X'58000000',X'597C70D8',X'6B9CA000',X'2B769CE1', X'4B200000',X'7831E900',X'47643AE7',X'4A000000', X'67A4B800',X'5D7DD4DD',X'692CF2E4',X'69943B4B', X'659CB980',X'43980000',X'439E72DB',X'4564B900', X'1F84B943',X'5D200000',X'039E72DB',X'4564B900', X'477DD9E9',X'65AC7A53',X'5F700000',X'0324994B', X'679C3153',X'594E9C80',X'1D780000',X'450E7280', X'652CF4E7',X'692E4000',X'43B434D9',X'43159280', X'277EB947',X'4A000000',X'477DDA53',X'5DAC3A53', X'5F766000',X'2F7E55CD',X'5364A000',X'17173A4B', X'66000000',X'676C3658',X'094C7A53',X'5F743972', X'477DB859',X'4BA4B672',X'4DAD9600',X'597DD380', X'077DB853',X'592E4000',X'690C564B',X'66000000', X'077DD253',X'694DF700',X'477DB859',X'531C3A4B', X'48000000',X'537477DD',X'674E7A4B',X'5DA00000', X'13761AE8',X'4B7492C8',X'197DD380',X'537692CF', X'4B966000',X'5374B34D',X'531D32DD',X'68000000', X'4324994B',X'679C3159',X'4A000000',X'272DB4C7', X'5F65F700',X'477DB6CB',X'5DA00000',X'692F1A00', X'53753A53',X'436539CB',X'48000000',X'2628A000', X'126A0000',X'1A09CA83',X'18000000' %INTEGER I,J,K,M,Q,S %STRING(70)OMESS OMESS=" " %CYCLE I=1,1,WORDMAX-1 ->FOUND %IF N=WORD(I) %REPEAT I=DEFAULT FOUND: J=1 %CYCLE K=WORD(I+J) %IF K&X'8000'=0 %THEN %EXIT K=K!!X'8000' OMESS=OMESS." " %UNLESS J=1 %UNTIL M&1=0 %CYCLE M=LETT(K); S=25 %UNTIL S<0 %CYCLE Q=M>>S&63; %IF Q\=0 %THEN OMESS=OMESS.TOSTRING(OUTTT(Q)) S=S-6 %REPEAT K=K+1 %REPEAT J=J+1 %REPEAT %RESULT=OMESS %END %EXTERNALSTRING(16)%FN SWRITE(%INTEGER VALUE, PLACES) %STRING (16) S %STRING(1)SIGN %INTEGER D0, D1, D2 PLACES=PLACES&15 SIGN=" " S="" %IF VALUE<0 %THEN SIGN="-" %AND VALUE=-VALUE D0=VALUE %CYCLE D1=D0//10 D2=D0-10*D1 S=TOSTRING(D2+'0').S D0=D1 %REPEAT %UNTIL D0=0 S=SIGN.S S=" ".S %WHILE BYTEINTEGER(ADDR(S))<=PLACES %RESULT=S %END %EXTERNALROUTINE IBMCODE(%INTEGER START, FINISH, CA) %SWITCH SW(0 : 3) %INTEGER D1, D2, D3, D4, H1, H2, H3, LENGTH, K, M, X, Y, Z, PTR %INTEGER B0, B1, OPC %CONSTINTEGER BLANKS = M' ' %CONSTBYTEINTEGERARRAY HEX(0:15)=48,49,50,51,52,53,54,55,56,57, 65,66,67,68,69,70; %CONSTINTEGERARRAY C(0 : 127) = %C M' ',M' ',M' ',M' ',M'SPM ', M'BALR',M'BCTR',M'BCR ',M'SSK ',M'ISK ',M'SVC ',M' ',M' ', M' ',M' ',M' ',M'LPR ',M'LNR ',M'LTR ',M'LCR ', M'NR ',M'CLR ',M'OR ',M'XR ',M'LR ',M'CR ',M'AR ',M'SR ', M'MR ', M'DR ',M'ALR ',M'SLR ',M'LPDR',M'LNDR',M'LTDR',M'LCDR',M'HDR ', M' ',M' ',M' ',M'LDR ',M'CDR ',M'ADR ',M'SDR ',M'MDR ', M'DDR ',M'AWR ',M'SWR ',M'LPER',M'LNER',M'LTER', M'LCER',M'HER ',M' ',M' ',M' ',M'LER ',M'CER ',M'AER ', M'SER ',M'MER ',M'DER ',M'AUR ',M'SUR ', M'STH ',M'LA ',M'STC ',M'IC ',M'EX ',M'BAL ',M'BCT ',M'B ', M'LH ',M'CH ',M'AH ',M'SH ',M'MH ',M' ',M'CVD ',M'CVB ', M'ST ',M' ',M' ',M' ',M'N ',M'CL ',M'O ',M'X ', M'L ',M'C ',M'A ',M'S ',M'M ',M'D ',M'AL ',M'SL ', M'STD ',M' ',M' ',M' ',M' ',M' ',M' ',M' ', M'LD ',M'CD ',M'AD ',M'SD ',M'MD ',M'DD ',M'AW ', M'SW ',M'STE ',M' ',M' ',M' ',M' ', M' ',M' ',M' ',M'LE ',M'CE ',M'AE ',M'SE ',M'ME ', M'DE ',M'AU ',M'SU ' %CONSTINTEGERARRAY D(128 : 159) = %C M'IDL ',M' ',M'PC ',M'DIG ',M' ', M'RDD ',M'BXH ',M'BXLE',M'SRL ',M'SLL ', M'SRA ',M'SLA ',M'SRDL',M'SLDL',M'SRDA',M'SLDA',M'STM ',M'TM ', M'MVI ',M' ',M'NI ',M'CLI ',M'OI ',M'XI ',M'LM ', M' ',M' ',M' ',M'SDV ',M'TDV ',M'HDV ',M'CKC' %CONSTINTEGERARRAY E(208 : 255) = %C M'SSP ',M'MVN',M'MVC ',M'MVZ ',M'NC ', M'CLC ',M'OC ',M'XC ',M'LSP ',M' ',M' ',M' ',M'TR ', M'TRT ',M'ED ',M'EDMK', M' ',M' ',M' ',M' ',M' ',M' ', M' ',M' ',M' ',M' ',M' ',M' ', M' ',M' ',M' ',M' ',M' ',M'MVO ',M'PACK',M'UNPK', M' ',M' ',M' ',M' ',M'ZAP ',M'CP ',M'AP ',M'SP ', M'MP ',M'DP ',M' ',M' ' !--------------------------------------UNPK----------------------------- %ROUTINE UNPK(%INTEGER Z) %INTEGER I %IF Z = BLANKS %THEN SPACES(4) %ELSE %START %CYCLE I=12,-4,0 PRINTSYMBOL(HEX(Z>>I&15)) %REPEAT %FINISH %END; ! OF UNPK %ROUTINE FETCH HALF B0=BYTEINTEGER(X+START) B1=BYTEINTEGER(X+START+1) K=B0<<8!B1 X=X+2 %END; ! OF FETCH HALF %ROUTINE PS(%INTEGER N) %INTEGER I %CYCLE I=24,-8,0 PRINTSYMBOL(N>>I&127) %REPEAT %END; ! OF PS %ROUTINE PRINTCODE NEWLINE UNPK(PTR+CA) WRITE(PTR+CA,5) SPACES(5); UNPK(H1) UNPK(H2); UNPK(H3) SPACES(4) %END; ! OF PRINTCODE %ROUTINE DB(%INTEGER D, B) WRITE(D,4); PRINTSTRING("(") WRITE(B,2); PRINTSTRING(")") %END; ! OF DB ! X = 0 Y = FINISH-START %CYCLE %IF X >= Y %THEN %RETURN H2 = BLANKS H3 = BLANKS FETCH HALF H1 = K; M = B0>>6 -> SW(M) %UNLESS 160 <= B0 %AND B0 <= 207 INV: PTR = X-2 PRINTCODE %CONTINUE SW(0): ! RR FORMAT OPC = C(B0) -> INV %IF OPC = BLANKS PTR = X-2; PRINTCODE PS(OPC); WRITE(B1>>4,4) %CONTINUE %IF B0 = 4 PRINTSTRING(","); WRITE(B1&15,4); %CONTINUE SW(1): ! D(X,B) FORMAT INSTRUCTIONS OPC = C(B0) -> INV %IF OPC = BLANKS D1 = B1>>4 D3 = B1&15 FETCH HALF H2 = K PTR = X-4 PRINT CODE PS(OPC) WRITE(D1,4) PRINTSTRING(",") WRITE(K&4095,4) PRINTSTRING("(") WRITE(D3,2) PRINTSTRING(",") WRITE(K>>12,2) PRINTSTRING(")") %CONTINUE SW(2): ! R,R,D(B) AND SI FORMATS OPC = D(B0) -> INV %IF OPC = BLANKS Z = B0 D3 = B1 FETCH HALF H2 = K PTR = X-4 PRINT CODE PS(OPC) D2 = K>>12 D4 = K&4095 %UNLESS 134 <= Z <= 144 %OR Z = 152 %START;! SI FORMAT DB(D4,D2) PRINTSTRING(",") WRITE(D3,3) %CONTINUE %FINISH WRITE(D3>>4,4); PRINTSTRING(",") %UNLESS 136 <= Z <= 143 %START;! UNLESS SHIFTS WRITE(D3&15,4); PRINTSTRING(",") %FINISH DB(D4,D2); %CONTINUE SW(3): ! STORE TO STORE FORMATS OPC = E(B0); -> INV %IF OPC = BLANKS LENGTH = B1; FETCH HALF; H2 = K D1 = K&4095; D2 = K>>12; FETCH HALF; H3 = K PTR = X-6; PRINT CODE; PS(OPC) WRITE(LENGTH+1,4); PRINTSTRING(",") DB(D1,D2); PRINTSTRING(",") DB(H3&4095,H3>>12) %REPEAT %END; !OF RECODE %ENDOFFILE