COMMENT STANFORD ALGOL W COMPILER RUN - TIME LIBRARY MAY 1971 VERSION ; BEGIN COMMENT MAIN PROGRAM CALLS COMPILED CODE; COMMENT STACK MARK FORMAT; ARRAY 2 LOGICAL PSI SYN 0; COMMENT INTERPRETER STATUS INFO; INTEGER PB SYN 8; COMMENT PROG SEG BASE IN BLOCK MARK; INTEGER FP SYN 16; COMMENT FREE POINTER IN BLOCK MARK; INTEGER RETA SYN 20; COMMENT RETURN ADDRESS IN BLOCK MARK; INTEGER DL SYN 24; COMMENT DYNAMIC LINK IN BLOCK MARK; BYTE THUNK SYN 28; COMMENT BIT 0 = 1 <=> IMPLICIT SUBR; SHORT INTEGER RCOUNT SYN 28, RCOUNT1 SYN 30, RCOUNT2 SYN 28; ARRAY 2 LOGICAL EXPSI SYN 32; COMMENT EDITOR STATUS FIELDS; COMMENT PROGRAM SEGMENT FORMAT; SHORT INTEGER DSEGCT SYN 16, DSEGNT SYN 18; SHORT INTEGER RELADD1 SYN 22, RELADD2 SYN 20; SHORT INTEGER CLN SYN 24, VARMAX SYN 26; SHORT INTEGER PROCTYPES SYN 28, NPARAM SYN 30; ARRAY 0 LOGICAL SFPD SYN 32; COMMENT STATIC PARAMETER INFO; EQUATE PAGELENGTH SYN #1000; COMMENT RECORD PAGE SIZE; EQUATE NULLREF SYN #FBFF0000, COMMENT VALUE OF NULL; XCPREF SYN #FBEE0000; COMMENT SYS INTERRUPT REFERENCE; INTEGER MP, LIM; ARRAY 18 INTEGER XFERVECTOR; COMMENT INTERFACE ENTRY ADDRESSES; LOGICAL XFERFLAGS SYN XFERVECTOR(0); COMMENT INTERFACE FLAGS; BYTE EOFFLAG SYN XFERFLAGS(0); COMMENT READER END-OF-FILE; BYTE TRACEFLAG SYN XFERFLAGS(1); COMMENT EXECUTION TRACE; BYTE DEBUGSW SYN XFERFLAGS(2); COMMENT DEBUG OPTIONS; INTEGER PAGELIM SYN XFERVECTOR(4); COMMENT PAGE OUTPUT LIMIT; INTEGER APUTLINE SYN XFERVECTOR(8); COMMENT WRITE ENTRY; BYTE CARRCONT SYN APUTLINE(0); COMMENT PRINT CONTROL CHAR; INTEGER AGETCARD SYN XFERVECTOR(12); COMMENT READ ENTRY; INTEGER AGETMAIN SYN XFERVECTOR(20); COMMENT GETMAIN ENTRY; INTEGER AFREEMAIN SYN XFERVECTOR(24); COMMENT FREEMAIN ENTRY; INTEGER AGETTIME SYN XFERVECTOR(28); COMMENT GETTIME ENTRY; INTEGER AGETCLOCK SYN XFERVECTOR(32); COMMENT READCLOCK ENTRY; LOGICAL TRACEPARM SYN XFERVECTOR(40); COMMENT TRACE LIMIT; INTEGER EDDIRBASE SYN XFERVECTOR(44); COMMENT EDIT CODE DIR; INTEGER IDDIRBASE SYN XFERVECTOR(48); COMMENT ID DIRECTORY; INTEGER IDLISTBASE SYN XFERVECTOR(52); COMMENT ID LIST; INTEGER EDITBASE SYN XFERVECTOR(56); COMMENT EDIT CODE; INTEGER ENTRYADDR SYN XFERVECTOR(64); COMMENT EXECUTION ENTRY PT; INTEGER RECTABBASE SYN XFERVECTOR(68); COMMENT RECORD TABLE ADDR; COMMENT THE FOLLOWING IS A COMMON WORK AREA; LOGICAL STFNLINK; BYTE STFN; COMMENT SET FOR INTERRUPT PROC.; ARRAY 10 LONG REAL WORKAREA; ARRAY 4 BYTE RUNFLAGS = (#00,#FF,#FF,#00); BYTE TERMFLAG SYN RUNFLAGS(0); COMMENT SET EXECUTION TERMINATED; BYTE READFLAG SYN RUNFLAGS(1); COMMENT READ NEW CARD; BYTE WRITEFLAG SYN RUNFLAGS(2); COMMENT START NEW LINE; BYTE TRACING SYN RUNFLAGS(3); COMMENT TRACE IN PROGRESS; INTEGER DELTALIMIT=#7FFF; LOGICAL FIXEDONE=#00000001, DOUBLEMASK=#FFFFFFF8, ALLONES=#FFFFFFFF; LOGICAL NULLCELL=NULLREF; LONG REAL UNDEFINED=#FBFBFBFBFBFBFBFBL; COMMENT "UNDEFINED"; LOGICAL UNDEF SYN UNDEFINED(0); LONG REAL FCONV1=#4E00000000000000L; INTEGER FCONV1LOW SYN FCONV1(4); LONG REAL FCONV2=#CE00000080000000L; LONG REAL PI=#413243F6A8885A31L; LONG REAL MAXREAL=#7FFFFFFFFFFFFFFFL; REAL SMAXREAL SYN MAXREAL; LONG REAL LONGEPSILON=#33FFFFFFFFFFFFFFL; REAL EPSILON=#3BFFFFFFR; INTEGER MAXINTEGER=#7FFFFFFF; INTEGER INTFIELDSIZE=14; ARRAY 10 LOGICAL INTREFS = ( 3(XCPREF), 2(NULLREF), 5(XCPREF) ); INTEGER XCPLIMIT SYN 4, XCPACTION SYN 8; BYTE XCPNOTED SYN 12, XCPMARK SYN 13; ARRAY 64 BYTE XCPMSG SYN 14; LOGICAL ARUNERR; COMMENT SET TO ADDRESS OF AWXERROR; LOGICAL LOINTREF, HIINTREF; COMMENT USED BY REFCHECK; INTEGER ARUNBASE; INTEGER REFTEMP; COMMENT USED FOR REFERENCE BINDING CHECK; ARRAY 6 SHORT INTEGER STRINGERR = (#07C1, #4100,#0001, #58F0,@ARUNERR, #07FF); SHORT INTEGER ERRCALL SYN STRINGERR(6); ARRAY 5 SHORT INTEGER REFBINDERR = (#0781, #4100,#0015, #47F0,@ERRCALL); ARRAY 10 SHORT INTEGER CASEERR = (#4720,@CASEERR(12), #4400,#1000, #4720,#1004, #4100,#0002, #47F0,@ERRCALL); ARRAY 10 SHORT INTEGER ARRAYERR = (#4720,@ARRAYERR(12), #4400,#1000, #47A0,#1004, #4100,#0003, #47F0,@ERRCALL); ARRAY 5 SHORT INTEGER NAMEERR = (#07B1, #4100,#0004, #47F0,@ERRCALL); ARRAY 5 SHORT INTEGER PARAMERR = (#0741, #4100,#000D, #47F0,@ERRCALL); ARRAY 4 SHORT INTEGER DESCERR = (#4100,#000E, #47F0,@ERRCALL); ARRAY 27 SHORT INTEGER MKDESC = (#4120,#200C, #5930,@DELTALIMIT, #4720,@DESCERR, #5030,#2000, #5830,#2004, #4C30,#2002, #1B43, #5830,#2008, #5B30,#2004, #5A30,@FIXEDONE, #47A0,@MKDESC(44), #1B33, #4C30,#2002, #4600,@MKDESC, #07F1); SHORT INTEGER MKDESC1 SYN MKDESC(12); ARRAY 13 SHORT INTEGER ALLOCATE = (#5820,@MP, #5850,@FP(R2), #1A05, #5900,@LIM, #07C3, #1813, #4100,#0005, #47F0,@ERRCALL); ARRAY 7 SHORT INTEGER ALLOCERR = (#5910,@LIM, #4720,@ALLOCATE(16), #5010,@FP(R2), #07F3); ARRAY 20 SHORT INTEGER ALLOCERR1 = (#5910,@LIM, #4720,@ALLOCATE(16), #5840,@FP(R2), #5010,@FP(R2), #1941, #07A3, #4100,#0008, #0610, #6800,@UNDEFINED, #6000,@B4, #8740,@ALLOCERR1(30), #07F3); ARRAY 256 CHARACTER BLANK = 256(" "); ARRAY 3 SHORT INTEGER ASSIGNVR = (#D200S,@B2,@B3); LOGICAL DECIMALONES = #1C1C1C0C; BYTE PL11 SYN DECIMALONES(0), PL1T SYN DECIMALONES(1), PL1F SYN DECIMALONES(2); COMMENT ***** END OF AREA KNOWN TO COMPILER *****************; FUNCTION DECR(6,#0600), ZONE(8,#96F0), RETURN(8,#47F0); LOGICAL FIXEDZERO = #00000000; ARRAY 33 LOGICAL MLINE; ARRAY 132 CHARACTER BLNK SYN BLANK; LONG REAL LRB2 SYN B2; REAL RB2 SYN B2; REAL FB1 SYN B1; LONG REAL LFB1 SYN B1; LONG REAL LRB1 SYN LFB1; REAL RB1 SYN FB1; ARRAY 0 SHORT INTEGER HB8 SYN B8; ARRAY 80 BYTE INBUF; INTEGER INPNT=80; BYTE EXPOSIGN=0,SIGN=0,TYPEFLAG=0,IMAGFLAG=0; ARRAY 7 LONG REAL POWER10 = (#41A0000000000000L, #4264000000000000L, #4427100000000000L, #475F5E1000000000L, #4E2386F26FC10000L, #5B4EE2D6D415B85BL, #76184F03E93FF9F5L); LONG REAL FCON3=#4E00000000000000L; LONG REAL FZERO=#0000000000000000; LONG REAL FCONV3=#4700000000000000; LONG REAL FDCONV = #4200000000000000L; LONG REAL PKDEC; ARRAY 5 INTEGER SAVEREG; INTEGER PTRSAVE; ARRAY 132 CHARACTER LINE; COMMENT OUTPUT LINE BUFFER; INTEGER TRACESTATE; LOGICAL TRACELIM; BYTE DEBUGFLAG, DUMPFLAG, COUNTFLAG, FETCHFLAG; INTEGER LMARGIN, TABSTOP; COMMENT SERIALLY REUSABLE VARIABLES; ARRAY 132 CHARACTER TBUF = 132(" "); INTEGER RMARGIN = @@TBUF(128); BYTE EMPTY = #FFX; INTEGER PARAMNUM, ASSERTCOUNT = 1; ARRAY 16 BYTE TRTABLE=("0123456789ABCDEF"); ARRAY 256 BYTE STBL SYN TRTABLE(_240); INTEGER LINENO=0; COMMENT LINES ON CURRENT PAGE; PROCEDURE WRITE(R14); COMMENT OUTPUT LINE AT (R0); BEGIN ARRAY 4 LOGICAL SAVE03; EXTERNAL PROCEDURE AWXERROR(R2); NULL; STM(R0,R3,SAVE03); R1 := R1-R1; IC(R1,CARRCONT); R2 := LINENO + 1; IF R1 = "0" THEN BEGIN IF R2 >= 60 THEN R1 := "1" ELSE R2 := R2 + 1; END; IF R1 = "1" THEN BEGIN R2 := PAGELIM - 1; PAGELIM := R2; IF < AND ~TERMFLAG THEN BEGIN R2 := MP; R14 := PB(R2); R0 := 17; AWXERROR; COMMENT NO RETURN; END; R2 := 1; END; LINENO := R2; IF R2 = 60 THEN MVI("1",CARRCONT) ELSE MVI(" ",CARRCONT); R3 := APUTLINE; BALR(R2,R3); COMMENT WRITE; LM(R0,R3,SAVE03); END; GLOBAL PROCEDURE AWXEDITR(R1); COMMENT INPUT: F0/F01 = VALUE, R0 = OPTION FLAGS, R2 = FIELDSIZE. OUTPUT: R2 = STRING ADDRESS, R3 = LENGTH; BEGIN LONG REAL NUM; INTEGER NHI SYN NUM(0), NLO SYN NUM(4); ARRAY 4 LOGICAL SAVEREG; BYTE SIGN SYN SAVEREG(0); BYTE BASEFLAG SYN SAVEREG(2), LONGFLAG SYN SAVEREG(3); INTEGER W SYN SAVEREG(8); ARRAY 17 CHARACTER MANTPATTERN=(" ",#21,7(#20),#21,7(#20)); ARRAY 4 CHARACTER EXPPATTERN=(" ",#21,2(#20)); ARRAY 22 CHARACTER BCD; STM(R0,R3,SAVEREG); MVC(22,BCD,BLANK); IF ~LONGFLAG THEN F0 := F0*1.0; IF F01 = 0L THEN BEGIN RESET(SIGN); R0 := _16; COMMENT FUDGE FOR BASE10; END ELSE BEGIN IF < THEN SET(SIGN) ELSE RESET(SIGN); F01 := ABS F01; NUM := F01; R0 := NHI SHRL 24-64 * #133S; IF < THEN R0 := R0 + 128; R0 := R0 SHRA 8 - 16; IF R0 < _75 THEN R0 := _75; R2 := ABS R0; R1 := R1-R1; F23 := 1L; WHILE R2 ~= 0 DO BEGIN SRDL(R2,1); LTR(R3,R3); IF < THEN F23 := F23*POWER10(R1); R1 := R1 + 8; END; IF R0 < 0 THEN BEGIN F01 := F01*F23; WHILE F01 < 1'15L DO BEGIN F01 := F01*10L; R0 := R0 - 1; END; END ELSE BEGIN F01 := F01/F23; WHILE F01 >= 1'16L DO BEGIN F01 := F01/10L; R0 := R0 + 1; END; END; IF LONGFLAG THEN F01 := F01 ++ #4E00000000000005L ELSE F01 := F01 ++ #4E0000001DCD6500L; COMMENT ROUND (WITH 5'8L) AND UNNORMALIZE; WHILE F01 >= 1'16L DO BEGIN F01 := F01 / 10L; R0 := R0 + 1; F01 := F01 ++ #4E00000000000000L; END; END; IF F01 = 0L AND ~BASEFLAG THEN BEGIN R1 := W; R2 := @BCD(R1-1); MVI("0",B2(0)); END ELSE BEGIN MVC(16,BCD(5),MANTPATTERN); NUM := F01; MVI(0,NUM); LM(R2,R3,NUM); R3 := R3/100000000; CVD(R2,NUM); ED(7,BCD(14),NUM(3)); CVD(R3,NUM); ED(9,BCD(5),NUM(3)); IF BASEFLAG THEN BEGIN R2 := @BCD; IF SIGN THEN MVI("-",BCD(6)); R0 := R0 + 16; MVC(3,BCD(2),EXPPATTERN); CVD(R0,NUM); ED(3,BCD(2),NUM(6)); IF R0 < 0 THEN MVI("-",BCD(3)) ELSE MVI("+",BCD(3)); END ELSE BEGIN R0 := R0 + 15; R2 := W - 7; IF R0 >= R2 OR R0 <= _5 THEN BEGIN COMMENT USE E-FORMAT; IF SIGN THEN MVI("-",BCD(1)); MVC(0,BCD(2),BCD(7)); MVI(".",BCD(3)); MVC(13,BCD(4),BCD(8)); R2 := @BCD(R2+3); MVC(3,B2,EXPPATTERN); CVD(R0,NUM); ED(3,B2,NUM(6)); MVI("'",B2); IF R0 < 0 THEN MVI("-",B2(1)) ELSE MVI("+",B2(1)); R2 := @BCD(1); END ELSE IF R0 >= 0 THEN BEGIN COMMENT USE F-FORMAT; IF SIGN THEN MVI("-",BCD(5)); R2 := R0; EX(R2,MVC(0,BCD(6),BCD(7))); R2 := @BCD(R2+7); MVI(".",B2); R2 := @BCD(5); END ELSE BEGIN COMMENT USE F-FORMAT, LEADING ZEROS; R2 := R0; R2 := @BCD(R2+5); IF SIGN THEN MVI("-",B2(0)); OC(4,B2(1),"0.000"); END; IF ~SIGN THEN R2 := @B2(1); END; END; R1 := W; R3 := @BCD(R1-1) - R2; R1 := SAVEREG(4); END; GLOBAL PROCEDURE AWXEDITP(R1); COMMENT INPUT: R3 = REFERENCE VALUE. OUTPUT: R2 = STRING ADDRESS, R3 = LENGTH; BEGIN LOGICAL SAVER1; ARRAY 14 CHARACTER NAME; SAVER1 := R1; IF R3 = NULLREF OR R3 = UNDEF THEN BEGIN MVC(3,NAME(10),"NULL"); R2 := @NAME(10); END ELSE IF R3 = XCPREF THEN BEGIN MVC(5,NAME(8),"SYSXCP"); R2 := @NAME(8); END ELSE BEGIN R0 := MEM(R3) AND #FFFF; CVD(R0,PKDEC); MVC(7,NAME(6),#4020202020202120L); R1 := @NAME(13); EDMK(7,NAME(6),PKDEC(4)); R2 := R1-1; MVI(".",B2(0)); R0 := R3 SHRL 24; R3 := IDDIRBASE; IF R3 = 0 THEN BEGIN R2 := R2-6; MVC(3,B2(0),"RCCL"); CVD(R0,PKDEC); UNPK(1,7,B2(4),PKDEC); ZONE(B2(5)); END ELSE BEGIN COMMENT NAME TABLE AVAILABLE; SHORT INTEGER IDLENGTH SYN B3(0), IDPOINT SYN B3(2); SHORT INTEGER NTLINK SYN 14, DRECIDNO SYN 2; R1 := R0 SHLA 4 + RECTABBASE; R1 := NTLINK(R1) + RECTABBASE; R1 := DRECIDNO(R1); R0 := @NAME(1) - R2; R0 := NEG R0; IF R0 > IDLENGTH(R1) THEN R0 := IDLENGTH(R1); R2 := R2 - R0 - 1; R1 := IDPOINT(R1) + IDLISTBASE; R3 := R0; EX(R3,MVC(0,B2,B1)); END; END; R3 := @NAME(13) - R2; R1 := SAVER1; END; PROCEDURE AWXSEDIT(R2); COMMENT *** PRINT ELAPSED TIME *** ; BEGIN ARRAY 13 INTEGER SAVEREG; STM(R2,R14,SAVEREG); MVC(131,LINE,BLANK); OI("0",CARRCONT); MVC(20,LINE(7),"SECONDS IN EXECUTION "); R3 := AGETTIME; BALR(R2,R3); R1 := R0*5/1920; CVD(R1,PKDEC); UNPK(4,2,LINE(1),PKDEC(5)); MVC(2,LINE(0),LINE(1)); ZONE(LINE(5)); MVI(".",LINE(3)); R0 := @LINE; WRITE; LM(R2,R14,SAVEREG); END; GLOBAL PROCEDURE AWXERROR(R2); COMMENT *** RUNERROR *** ; BEGIN LOGICAL SAVER1, SAVER2, SAVER3, SAVEL; INTEGER ERRKIND, ERRPLACE, ERRCOORD, SEGBASE; BYTE CONFUSED, SETIT, IMPRECISE; FUNCTION DECR(6,#0600), LTR(1,#1200), SRDA(9,#8E00); INTEGER REGISTER NTX SYN R4, COMMENT NAME TABLE POINTER; I SYN R5, COMMENT PSEUDO-REGISTER INDEX; N SYN R6, COMMENT STRING LENGTH; DI SYN R7, COMMENT STRING DESTINATION; IA SYN R8, COMMENT INSTRUCTION ADDRESS; SP SYN R9, COMMENT CURRENT SEGMENT POINTER; LINK SYN R10, COMMENT RETURN REGISTER; PP SYN R14; COMMENT CODE SEGMENT BASE; ARRAY 0 CHARACTER BDI SYN MEM(DI); PROCEDURE SETCOORDINATE(LINK); COMMENT INPUT: R0 = ADDRESS, PP = SEGMENT BASE. OUTPUT: R0 = COORDNO; IF PP <= 0 OR CONFUSED THEN R0 := _1 ELSE BEGIN SHORT INTEGER SEGDISPL SYN MEM(PP+8), COMMENT INSCOUNTER; COORDNO SYN MEM(PP+10); COMMENT COORDINATE; R0 := R0 AND #FFFFFF - PP; R1 := DSEGCT(PP); R2 := DSEGNT(PP) - 16; L: R3 := R1 + R2 SHRA 3 SHLA 2; COMMENT AVERAGE; IF R0 > SEGDISPL(R3+4) THEN R1 := R3 + 4 ELSE IF R0 <= SEGDISPL(R3) THEN R2 := R3 - 4 ELSE BEGIN R0 := COORDNO(R3); GOTO X; END; IF R1 <= R2 THEN GOTO L; R0 := _1; COMMENT FAILURE; X: END; PROCEDURE AWXSIMUL(R1); NULL; PROCEDURE AWXPMDMP(R3); AWXSEDIT; COMMENT PRINT ELAPSED TIME; PROCEDURE MSGSETUP(R3); BEGIN COMMENT PREPARE FOR MESSAGE OUTPUT; SAVER3 := R3; SAVEL := LINK; SEGBASE := R14; IF TERMFLAG THEN BEGIN COMMENT FLUSH PRINT BUFFER; IF ~EMPTY THEN BEGIN R0 := @TBUF; WRITE; END; R2 := PTRSAVE; R0 := @LINE; PTRSAVE := R0; IF R0 ~= R2 THEN WRITE; OI("0",CARRCONT); MVI("-",MLINE); MVC(130,MLINE(1),MLINE); R0 := @MLINE; WRITE; END; R2 := MP; TM(#80,RETA(R2)); IF OVERFLOW THEN BEGIN COMMENT INTERPRETING AT POINT OF ERROR; R1 := PB(R2); R0 := PSI(R2+4); RESET(CONFUSED); END ELSE BEGIN R1 := SEGBASE AND #00FFFFF8; IF R1 ~= SEGBASE THEN SET(CONFUSED) ELSE RESET(CONFUSED); IF STFN THEN R0 := STFNLINK ELSE R0 := ERRPLACE; END; SEGBASE := R1; PP := R1; SETCOORDINATE; ERRCOORD := R0; MVC(131,MLINE,BLNK); IF R0 <= 0 THEN MVC(18,MLINE(16),"AT UNKNOWN LOCATION") ELSE BEGIN MVC(14,MLINE(16),"NEAR COORDINATE"); CVD(R0,PKDEC); UNPK(3,7,MLINE(32),PKDEC); ZONE(MLINE(35)); MVC(3,MLINE(36),", IN"); R1 := PP + DSEGCT(PP); MVC(7,MLINE(41),B1); END; R3 := SAVER3; LINK := SAVEL; END; PROCEDURE RUNERR(R1); BEGIN SAVER1 := R1; SET(TERMFLAG); MSGSETUP; MVC(8,MLINE,"RUN ERROR"); MVI("-",MLINE(50)); R3 := ERRKIND; CASE R3 OF BEGIN MVC(17,MLINE(52),"SUBSTRING INDEXING"); MVC(22,MLINE(52),"CASE SELECTION INDEXING"); MVC(17,MLINE(52),"ARRAY SUBSCRIPTING"); MVC(27,MLINE(52),"ASSIGNMENT TO NAME PARAMETER"); MVC(17,MLINE(52),"DATA AREA OVERFLOW"); BEGIN MVC(52,MLINE(52), "ACTUAL-FORMAL MISMATCH IN PROCEDURE CALL, PARAMETER #"); R0 := PARAMNUM; CVD(R0,PKDEC); UNPK(3,7,MLINE(106),PKDEC); ZONE(MLINE(109)); END; MVC(27,MLINE(52),"RECORD STORAGE AREA OVERFLOW"); MVC(21,MLINE(52),"LENGTH OF STRING INPUT"); MVC(12,MLINE(52),"LOGICAL INPUT"); MVC(14,MLINE(52),"NUMERICAL INPUT"); MVC(14,MLINE(52),"REFERENCE INPUT"); MVC(9,MLINE(52),"READER EOF"); MVC(29,MLINE(52),"INCORRECT NUMBER OF PARAMETERS"); MVC(14,MLINE(52),"ARRAY TOO LARGE"); MVC(11,MLINE(52),"STRING INPUT"); MVC(26,MLINE(52),"NULL OR UNDEFINED REFERENCE"); MVC(21,MLINE(52),"PAGE ESTIMATE EXCEEDED"); MVC(21,MLINE(52),"TIME ESTIMATE EXCEEDED"); MVC(8,MLINE(52),"I/O ERROR"); BEGIN MVC(14,MLINE(52),"PROGRAM CHECK #"); UNPK(2,1,MLINE(68),B8(3)); MVI(" ",MLINE(70)); TR(1,MLINE(68),TRTABLE(_240)); END; MVC(28,MLINE(52),"INCOMPATIBLE FIELD DESIGNATOR"); BEGIN MVC(23,MLINE(52),"ASSERTION XXXXXXX FAILED"); R0 := ASSERTCOUNT; CVD(R0,PKDEC); UNPK(6,7,MLINE(62),PKDEC); ZONE(MLINE(68)); END; END; R0 := @MLINE; WRITE; AWXPMDMP; R1 := SAVER1; END; PROCEDURE SERVICE(R1); COMMENT SERVICE THE INTERRUPT. R2 CONTAINS THE REFERENCE; BEGIN INTEGER SAVER1; LONG REAL SETREG; ARRAY 94 BYTE MSG= ("INTEGER OVERFLOW", "UNDERFLOW", "INTEGER DIVISION BY ZERO", "SQRT ERROR", "EXP ERROR", "LN/LOG ERROR", "SIN/COS ERROR"); ARRAY 20 SHORT INTEGER MSGIDX= ( 15,0, 23,25, 7,8, 8,16, 1,80, 15,33, 9,49, 8,59, 11,68, 12,80 ); PROCEDURE WRITEIT(R1); COMMENT WRITE USER'S MESSAGE AND CARD NUMBER; BEGIN ARRAY 4 LOGICAL SAVE14; STM(R1,R4,SAVE14); MSGSETUP; LM(R3,R4,SAVE14(8)); MVC(14,MLINE,"***** EXCEPTION"); MVI("-",MLINE(50)); EX(R3,MVC(0,MLINE(52),B4)); R0 := @MLINE; WRITE; LM(R1,R2,SAVE14(0)); END; SAVER1 := R1; IF R2 = XCPREF THEN BEGIN SET(TERMFLAG); R2 := NEG R0; R3 := MSGIDX(R2); R4 := MSGIDX(R2+2); R4 := @MSG(R4); WRITEIT; END ELSE BEGIN MVI(1,XCPNOTED(R2)); R3 := 63; R4 := @XCPMSG(R2); R1 := XCPLIMIT(R2) -- 1; XCPLIMIT(R2) := R1; IF R1 < 0 THEN SET(TERMFLAG); CLI(1,XCPMARK(R2)); IF = OR R1 < 0 THEN WRITEIT; R3 := XCPACTION(R2); IF SETIT AND ~IMPRECISE THEN BEGIN R0 := MEM(R8+4) SHRL 30 SHLL 1; COMMENT 2*ILC; R1 := MEM(R8+4) -- R0; LH(R1,MEM(R1)); R1 := R1 AND #F0; R2 := @SETREG; EX(R1,#60002000); IF R3 = 1 THEN OC(7,SETREG,#7FFFFFFFFFFFFFFFL) ELSE IF R3 = 2 THEN MVC(7,SETREG,0L); EX(R1,#68002000); END; END; IF TERMFLAG THEN AWXPMDMP; R1 := SAVER1; END; IF R0 < 0 THEN BEGIN COMMENT ENTRY FROM STANDARD FUNCTION; ARRAY 3 LOGICAL SAVE35; LOGICAL EXITLOC; STM(R3,R5,SAVE35); SAVER2 := R2; R2 := NEG R0; R2 := INTREFS(R2); RESET(TERMFLAG); IF R2 ~= NULLREF THEN BEGIN ERRPLACE := R1; MVC(3,EXITLOC,RETA(R12)); RESET(SETIT); SERVICE; IF TERMFLAG THEN MVC(3,SAVER2,EXITLOC) ELSE R1 := XCPACTION(R2); END; LM(R3,R5,SAVE35); END ELSE IF R0 ~= 0 THEN BEGIN COMMENT ENTRY BY DIRECT BRANCH; MVC(3,SAVER2,RETA(R12)); ERRKIND := R0; ERRPLACE := R1; RUNERR; END ELSE BEGIN COMMENT ENTRY FROM INTERRUPT DECODER; SAVER2 := R2; R2 := R7 + 16; MVC(3,ERRPLACE,B8(4)); ERRKIND := R2; IF R7 = 0 THEN AWXSIMUL ELSE IF R7 ~= 4 THEN RUNERR ELSE BEGIN COMMENT PROGRAM INTERRUPTS; RESET(TERMFLAG); R7 := HB8(2); COMMENT INTERRUPT CODE; TM(#3F,B8(3)); IF = THEN BEGIN COMMENT 360/91 IMPRECISE INTERRUPT; SET(IMPRECISE); R0 := R7 SHLL 16; R7 := 4; WHILE R0 > 0 DO BEGIN R7 := R7 + 1; R0 := R0 SHLL 1; END; IF R7 >= 10 THEN R7 := R7 + 2; END ELSE RESET(IMPRECISE); IF R7 = 5 OR R7 = 6 THEN BEGIN R7 := 16; ERRKIND := R7; RUNERR; END ELSE IF R7 = 8 OR R7 = 9 THEN BEGIN COMMENT FIXED POINT EXCEPTIONS; R7 := R7 SHLL 2; R0 := 32 - R7; R2 := INTREFS(R7-32); RESET(SETIT); IF R2 ~= NULLREF THEN SERVICE; END ELSE IF R7 >= 12 AND R7 <= 15 THEN BEGIN COMMENT FLOATING POINT EXCEPTIONS; R7 := R7 SHLL 2; R0 := 40 - R7; R2 := INTREFS(R7-40); SET(SETIT); IF R2 ~= NULLREF THEN SERVICE; END ELSE RUNERR; COMMENT ALL OTHERS; END; END; R2 := SAVER2; IF ~TERMFLAG THEN R0 := R0-R0 ELSE BEGIN R0 := 1; R1 := R2; END; END; GLOBAL PROCEDURE AWXSL001(R1); COMMENT *** FORMALCALL *** ; COMMENT CHECKS PARAMETER CORRESPONDENCE FOR FORMAL PROCEDURE CALLS; BEGIN ARRAY 8 LOGICAL SAVEREGS SYN WORKAREA; INTEGER LAST; PROCEDURE EROR(R3); BEGIN PARAMNUM := R5; R1 := SAVEREGS(12); R0 := 6; AWXERROR; END; STM(R14,R5,SAVEREGS); TM(#20,SAVEREGS(20)); COMMENT BIT ON FOR PROC W/PARAMETERS; IF = THEN R3 := @FIXEDZERO(_28) ELSE BEGIN EX(R0,B3(4)); EX(R0,B3(8)); LM(R14,R15,SAVEREGS); END; IF R0 ~= NPARAM(R3) THEN BEGIN R0 := 13; AWXERROR; END; R2 := @SFPD(R3); COMMENT POINTER TO SFPD'S - BY 4'S; R5 := MP; TM(#80,RETA(R5)); IF OVERFLOW THEN R1 := PSI(R5+4); CLI(#18,B1(4)); IF = THEN R1 := @B1(10) ELSE R1 := @B1(12); COMMENT SAPD POINTER; R0 := R0 SHLA 2 + R2; LAST := R0; R3 := R3-R3; R4 := R3; R5 := R5-R5; COMMENT PARAMETER COUNT; WHILE R2 < LAST DO BEGIN R5 := R5 + 1; CLI(#00,B2); IF = THEN BEGIN COMMENT NAME OR PROCEDURE; CLC(2,B2(1),B1(1)); IF ~= THEN EROR; END ELSE BEGIN COMMENT VALUE,RESULT, OR VALUE RESULT; IC(R3,B2(3)); IC(R4,B1(3)); IF R3 >= 6 OR R4 >= 6 THEN BEGIN COMMENT TYPE IS NON ARITHMETIC; IF R3 ~= R4 THEN EROR; IF R3 = 7 THEN BEGIN COMMENT STRING - CHECK LENGTH COMPATIBILITIES; IC(R3,B2(2)); IC(R4,B1(2)); TM(#01,B2); IF OVERFLOW AND R3 < R4 THEN EROR; TM(#02,B2); IF OVERFLOW AND R3 > R4 THEN EROR; END; END ELSE BEGIN COMMENT TYPE IS ARITHMETIC - SAPD TYPE IN R4, SFPD TYPE IN R3 ; TM(#01,B2); IF OVERFLOW THEN BEGIN COMMENT VALUE; R0 := R4 AND #FE; COMMENT MASK OFF LENGTH BIT; IF R0 > R3 THEN EROR; END; TM(#02,B2); IF OVERFLOW THEN BEGIN COMMENT RESULT; R0 := R3 AND #FE; IF R0 > R4 THEN EROR; END; END; END; R2 := @B2(4); R1 := @B1(4); END; LM(R0,R5,SAVEREGS(8)); RETURN(B3(4)); END; GLOBAL PROCEDURE AWXSL002(R1); COMMENT *** FPARCONV *** ; COMMENT RUN TIME CONVERSION OF VALUE AND RESULT PARAMETERS. INPUTS: R3 = SOURCE ADDRESS, R0 NEGATED FOR RESULT. R0 = TYPES TO AND FROM (VALUE) OR TYPES FROM AND TO (RESULT); BEGIN LOGICAL SAVER1; ARRAY 2 LONG REAL LR SYN WORKAREA; ARRAY 2 REAL R SYN LR(0); INTEGER I SYN LR; REAL RB3 SYN B3, LRB3 SYN B3; ARRAY 6 BYTE TYPELENGTH = (#00X, 2(#03X), 2(#07X), #0FX); SAVER1 := R1; IF R0 >= 0 THEN BEGIN COMMENT VALUE; R1 := R0 AND #FF; R0 := R0 SHRL 8; END ELSE BEGIN COMMENT RESULT; R1 := NEG R0; R0 := R1 AND #FF; R1 := R1 SHRL 8; END; COMMENT R0 = DESTINATION TYPE, R1 = SOURCE TYPE; IF R0 = R1 THEN IC(R0,TYPELENGTH(R1)) ELSE BEGIN F01 := F01-F01; F23 := F01; CASE R1 OF BEGIN BEGIN COMMENT FROM INTEGER; R3 := B3 XOR #80000000; FCONV1LOW := R3; F01 := FCONV1 + FCONV2; END; F0 := RB3; COMMENT FROM REAL; F01 := LRB3; COMMENT FROM LONG REAL; BEGIN COMMENT FROM COMPLEX; F0 := RB3; F2 := RB3(4); END; BEGIN COMMENT FROM LONG COMPLEX; F01 := LRB3; F23 := LRB3(8); END; END; R1 := R0; IC(R0,TYPELENGTH(R1)); COMMENT RETURN R0; CASE R1 OF BEGIN I := R3; COMMENT TO INTEGER; R := F0; COMMENT TO REAL; LR := F01; COMMENT TO LONG REAL; BEGIN COMMENT TO COMPLEX; R(0) := F0; R(4) := F2; END; BEGIN COMMENT TO LONG COMPLEX; LR(0) := F01; LR(8) := F23; END; END; R3 := @LR; COMMENT REPLACE SOURCE ADDRESS; END; R1 := SAVER1; END; GLOBAL PROCEDURE AWXSL003(R1); COMMENT *** REFCHECK *** ; COMMENT RESETS PROGRAM MASK AS REQUIRED BY REFERENCE STORE, R0 = ADDRESS OF STORED REFERENCE ; IF R0 >= LOINTREF AND R0 <= HIINTREF THEN BEGIN LOGICAL SAVER1; COMMENT FIRST BYTE HAS CURRENT PRG MASK; ARRAY 6 BYTE MASKS = (#08X,2(#00X),#02X,#01X,#00X); SAVER1 := R1; R1 := R0; R0 := MEM(R1); R1 := R1 - LOINTREF SHRL 2; IC(R1,MASKS(R1)); IF R0 ~= NULLREF THEN EX(R1,OI(0,SAVER1)) ELSE BEGIN R1 := R1 XOR #FF; EX(R1,NI(0,SAVER1)); END; R1 := SAVER1; SPM(R1); END; GLOBAL PROCEDURE AWXSL004(R1); COMMENT *** RECORDCREATOR *** ; BEGIN EXTERNAL PROCEDURE AWXERROR(R2); NULL; DUMMY BASE R6; COMMENT RECORD TABLE FORMAT; ARRAY 64 LOGICAL RCT; INTEGER FRPC SYN RCT(0); COMMENT FREE PAGE CHAIN; INTEGER FRC SYN RCT(0), PC SYN RCT(4); SHORT INTEGER RL SYN RCT(8), NR SYN RCT(10), RN SYN RCT(12); INTEGER DFRC SYN 0, DPC SYN 4; SHORT INTEGER DRL SYN 8, DNR SYN 10, DRN SYN 12; CLOSE BASE; ARRAY 14 LOGICAL SAVEREG SYN WORKAREA; LOGICAL TEMP; BYTE NREC; INTEGER PAGELINK SYN 0, RCTLINK SYN 4; SHORT INTEGER RECNO SYN 2; COMMENT INPUT: R3 = RCT DISPLACEMENT. OUTPUT: R3 = RECORD ADDR; R3 := R3 + RECTABBASE; STM(R1,R2,SAVEREG(0)); CLI(#00,DFRC(R3)); IF = THEN BEGIN COMMENT NO FREE RECORD ON CHAIN, MUST GARBAGE COLLECT; PROCEDURE ALLOCATEPAGE(R2); COMMENT INPUT: R3 = ADDR OF RECTAB ENTRY, OUTPUT: R3 = ADDR OF RECTAB ENTRY, R4 = ADDR OF PAGE; BEGIN R4 := FRPC; IF R4 = 0 THEN BEGIN COMMENT NO FREE RECORD PAGES; R4 := LIM - PAGELENGTH; LIM := R4; R1 := MP; IF R4 < FP(R1) THEN BEGIN LM(R1,R12,SAVEREG(0)); R0 := 7; AWXERROR; END; R4 := R4 + 128; END ELSE BEGIN COMMENT R4 = FREE PAGE ADDRESS; R5 := PAGELINK(R4); FRPC := R5; END; R0 := DPC(R3); PAGELINK(R4) := R0; DPC(R3) := R4; END; PROCEDURE BUILDPAGE(R5); COMMENT INPUT/OUTPUT: R3 = ADDR OF RECTAB ENTRY, R4 = ADDR OF PAGE; BEGIN SAVEREG(48) := R5; RCTLINK(R4) := R3; R1 := R3 - RECTABBASE SHLL 20; R5 := DRL(R3); R0 := @B4(8) OR R1; DFRC(R3) := R0; R2 := R4 + PAGELENGTH - R5 OR R1; R1 := R0; R0 := R0 + R5; COMMENT R0 = ADDR OF 2ND RECORD, R1 = ADDR OF 1ST RECORD, R2 = ADDR OF LAST POSSIBLE RECORD; WHILE R0 <= R2 DO BEGIN B1 := R0; R1 := R0; R0 := R0 + R5; END; B1 := R4; COMMENT LAST RECORD POINTS TO TOP OF PAGE; R5 := SAVEREG(48); END; PROCEDURE FREEPAGE(R2); COMMENT INPUT: R3 = PAGE ADDR, R4 = ADDR OF PC LINK; BEGIN R5 := PAGELINK(R3); PAGELINK(R4) := R5; R1 := LIM + 128; IF R3 = R1 THEN BEGIN FR1: R1 := R1 + PAGELENGTH; R0 := RECTABBASE; R5 := FRPC; WHILE R5 ~= 0 DO IF R5 = R1 THEN BEGIN R3 := PAGELINK(R5); R5 := R0; PAGELINK(R5) := R3; GOTO FR1; END ELSE BEGIN R0 := R5; R5 := PAGELINK(R5); END; R1 := R1 - 128; LIM := R1; END ELSE BEGIN R5 := FRPC; PAGELINK(R3) := R5; FRPC := R3; END; END; PROCEDURE MARK(R9); COMMENT INPUT: R3 = NON-NULL REFERENCE VALUE; BEGIN R5 := R5-R5; COMMENT R5 = PREVIOUS REFERENCE ADDRESS; TM(#80,B3); IF = THEN BEGIN COMMENT RECORD IS UNMARKED; M1: R2 := R3 SHRL 20 AND #3F0; OI(#80,B3); R4 := NR(R2) SHLA 2; R4 := @B3(R4); COMMENT R4 = ADDR OF LAST REF FIELD; M2: TM(#90,B4); IF < COMMENT MIXED; THEN BEGIN R5 := R5 AND #FFFFFF; IF ~= THEN BEGIN R3 := R4; R4 := R5; R5 := B4; IC(R0,B4); B4 := R3; STC(R0,B4); R4 := R4 - 4; GOTO M2; END; END ELSE BEGIN CLI(#FB,B4); IF ~= THEN BEGIN COMMENT NON-NULL REFERENCE FIELD; R2 := B4; TM(#80,B2); IF = THEN BEGIN COMMENT UNMARKED; IC(R0,B4); B4 := R5; STC(R0,B4); R5 := R4; R3 := R2; GOTO M1; END; END; R4 := R4 - 4; GOTO M2; END; END; END; STM(R3,R12,SAVEREG(8)); R6 := RECTABBASE; COMMENT MARK EXCEPTION RECORDS; FOR R7 := 0 STEP 4 UNTIL 36 DO BEGIN R9 := INTREFS(R7); R8 := R9 SHRL 24; IF R8 ~= #FB THEN OI(#80,B9); END; COMMENT MARK RECORDS ROOTED IN LOCAL VARIABLES; R11 := MP; R8 := DL(R11); WHILE R8 ~= 0 DO BEGIN TM(#80,THUNK(R11)); COMMENT ON IF IMPLICIT SUBR; IF = THEN BEGIN R8 := R11; COMMENT MARK SIMPLE VARIABLES; R12 := RCOUNT1(R8) SHLA 2; IF ~= THEN BEGIN R10 := PB(R8); R10 := RELADD1(R10) + R11; R12 := @B10(R12); WHILE R10 < R12 DO BEGIN CLI(#FB,B10); IF ~= THEN COMMENT NON-NULL; BEGIN R3 := B10; MARK; END; R10 := @B10(4); END; END; COMMENT MARK ARRAY ELEMENTS; R9 := RCOUNT2(R8); IF R9 ~= 0 THEN BEGIN R7 := PB(R8); R7 := RELADD2(R7) + R11; WHILE R9 > 0 DO BEGIN TEMP := R9; R5 := R5-R5; IC(R5,B7); R10 := B7(R5); R12 := R10 + B7(R5+4); R7 := @B7(R5+8); WHILE R10 < R12 DO BEGIN CLI(#FB,B10); IF ~= THEN BEGIN R3 := B10; MARK; END; R10 := @B10(4); END; R9 := TEMP - 1; END; END; END; R11 := DL(R11); R8 := DL(R11); END; COMMENT LOCATE AND MARK PROTECTED RECORDS; FOR R7 := 16 STEP 16 UNTIL 240 DO BEGIN R9 := PC(R7); IF R9 = #FFFFFFFF THEN GOTO MR1; WHILE R9 ~= 0 DO BEGIN R10 := R9 + PAGELENGTH - RL(R7); R11 := @B9(8); WHILE R11 <= R10 DO BEGIN TM(#40,B11); IF OVERFLOW THEN BEGIN TM(#80,B11); IF = THEN BEGIN TEMP := R9; R3 := R7 SHLL 20 OR R11; MARK; R9 := TEMP; END; END; R11 := R11 + RL(R7); END; R9 := PAGELINK(R9); END; END; COMMENT ALL VALID RECORDS ARE NOW MARKED; MR1: FOR R7 := 16 STEP 16 UNTIL 240 DO BEGIN R9 := PC(R7); IF R9 = #FFFFFFFF THEN GOTO MR2; R3 := R7 SHLL 20; R1 := @FRC(R7); R4 := @PC(R7); WHILE R9 ~= 0 DO BEGIN R10 := R9 + PAGELENGTH - RL(R7); SET(NREC); TEMP := R1; R11 := @B9(8); WHILE R11 <= R10 DO BEGIN TM(#80,B11); IF = THEN BEGIN B11 := R1; R1 := R11 OR R3; END ELSE BEGIN NI(#7F,B11); RESET(NREC); END; R11 := R11 + RL(R7); END; IF NREC THEN BEGIN COMMENT NO RECORDS ON PAGE; R3 := R9; FREEPAGE; R1 := TEMP; R9 := R4; R3 := R7 SHLL 20; END; R4 := R9; R9 := PAGELINK(R4); END; FRC(R7) := R1; END; MR2: R3 := SAVEREG(8); CLI(#00,DFRC(R3)); IF = THEN BEGIN ALLOCATEPAGE; BUILDPAGE; END; LM(R3,R12,SAVEREG(8)); END; R1 := DFRC(R3); COMMENT R1 = ADDRESS OF NEXT RECORD; R0 := MEM(R1); DFRC(R3) := R0; R0 := DRN(R3) + 1; DRN(R3) := R0; RECNO(R1) := R0; R0 := 4; R2 := UNDEF; R3 := DRL(R3) - R0; WHILE > DO BEGIN B1(R3) := R2; R3 := R3 - R0; END; R3 := R1; LM(R1,R2,SAVEREG(0)); END; GLOBAL PROCEDURE AWXSL005(R1); COMMENT *** TRACE *** ; NULL; GLOBAL PROCEDURE AWXSL010(R1); COMMENT *** READIN *** ; BEGIN COMMENT READ IN NEXT CONSTANT OF TYPE INDICATED IN B1(2). IF READFLAG IS ON, READ A NEW CARD. VALUE IS LEFT IN A STANDARD LOCATION (REGISTER); LONG REAL REALPART SYN WORKAREA(0); ARRAY 2 INTEGER INTPART SYN REALPART; ARRAY 7 LOGICAL SAVEREG SYN WORKAREA(8); PROCEDURE NEXTCHAR(R6); BEGIN IF R5 >=79 THEN BEGIN LOGICAL SAVE23; STM(R2,R3,SAVE23); IF EOFFLAG THEN BEGIN R1 := SAVEREG(4); R0 := 12; AWXERROR; END; R0 := @INBUF; R3 := AGETCARD; BALR(R2,R3); IF ~= OR R0 < 0 THEN BEGIN SET(EOFFLAG); R0 := " "; END ELSE BEGIN IF TRACING THEN BEGIN LOGICAL SAVER14; SAVER14 := R14; MVC(131,MLINE,BLANK); MVC(79,MLINE(15),INBUF); MVC(14,MLINE(0),"INPUT RECORD: """); MVI("""",MLINE(96)); R0 := @MLINE; WRITE; R14 := SAVER14; END; R0 := R0-R0; R5 := R0; IC(R0,INBUF(0)); END; LM(R2,R3,SAVE23); END ELSE BEGIN R5 := R5 + 1; IC(R0,INBUF(R5)); END; END; PROCEDURE STRINGINPUT(R1); BEGIN COMMENT INPUT R0 = NON BLANK CHARACTER. INPUT R2 = LENGTH. INPUT R5 = INPUT BUFFER POINTER; IF R0 ~= """" THEN BEGIN R1 := SAVEREG(4); R0 := 15; AWXERROR; END; R3 := SAVEREG(0); EX(R2,MVC(0,B3,BLANK)); NEXTCHAR; R4 := 0; S1: WHILE R4 <= R2 AND R0 ~= """" DO BEGIN STC(R0,B3(R4)); R4 := R4 + 1; NEXTCHAR; END; IF R4 > R2 AND R0 ~= """" THEN BEGIN R1 := SAVEREG(4); R0 := 8; AWXERROR; END; IF R0 = """" THEN NEXTCHAR; IF R0 = """" THEN IF R4 > R2 THEN BEGIN R1 := SAVEREG(4); R0 := 8; AWXERROR; END ELSE BEGIN STC(R0,B3(R4)); R4 := R4 + 1; NEXTCHAR; GOTO S1; END; END; PROCEDURE LOGICALINPUT(R1); BEGIN COMMENT INPUT R0 = NON-BLANK CHARACTER. R5 = INPUT BUFFER POINTER; IF R0 = "T" THEN BEGIN NEXTCHAR; IF R0 = "R" THEN BEGIN NEXTCHAR; IF R0 = "U" THEN BEGIN NEXTCHAR; IF R0 = "E" THEN BEGIN NEXTCHAR; R0 := 1; GOTO L1; END; END; END; END ELSE IF R0 = "F" THEN BEGIN NEXTCHAR; IF R0 = "A" THEN BEGIN NEXTCHAR; IF R0 = "L" THEN BEGIN NEXTCHAR; IF R0 = "S" THEN BEGIN NEXTCHAR; IF R0 = "E" THEN BEGIN NEXTCHAR; R0 := R0 - R0; GOTO L1; END; END; END; END; END; R1 := SAVEREG(4); R0 := 9; AWXERROR; L1: END; PROCEDURE BITSINPUT(R1); BEGIN COMMENT R0 = NON BLANK CHARACTER. R5 = INPUT BUFFER POINTER; WHILE R0 ~= "#" DO NEXTCHAR; NEXTCHAR; R4 := R4 - R4; R2 := R4; WHILE R4 < 8 DO BEGIN IF R0 >= "A" AND R0 <= "F" THEN R0 := R0 - #B7 ELSE IF R0 < "0" THEN GOTO B1 ELSE R0 := R0 AND #F; R2 := R2 SHLL 4 OR R0; R4 := R4 + 1; NEXTCHAR; END; B1: R0 := R2; END; PROCEDURE NUMBERINPUT(R1); BEGIN COMMENT R0 = NON BLANK CHARACTER. R4 = TYPE DESIRED. R5 = INPUT BUFFER POINTER; INTEGER SCALE; BYTE SIGN, EXPOSIGN, IMAGFLAG, TYPEFLAG; PROCEDURE FIXLENGTH(R4); IF R0 = "L" THEN BEGIN MVI(3,TYPEFLAG); NEXTCHAR; END ELSE BEGIN CLI(3,TYPEFLAG); IF = THEN BEGIN LONG REAL TEMP; TEMP := F01; MVC(2,TEMP(1),#000000); F23 := F01 + TEMP; F01 := 0L; F0 := F2; END; END; INTEGER SAVER1, TYPE; SAVER1 := R1; TYPE := R4; RESET(IMAGFLAG); F01 := F01-F01; REALPART := F01; NUMBER: RESET(SIGN); MVI(1,TYPEFLAG); IF R0 = "+" THEN NEXTCHAR ELSE IF R0 = "-" THEN BEGIN SET(SIGN); NEXTCHAR; END; IF R0 = "'" THEN F01 := 1L ELSE F01 := 0L; R2 := 0; WHILE R0 >= "0" DO BEGIN R0 := R0 AND #F; STC(R0,FDCONV(1)); F01 := F01*10L + FDCONV; NEXTCHAR; END; IF R0 = "." THEN BEGIN MVI(3,TYPEFLAG); NEXTCHAR; WHILE R0 >= "0" DO BEGIN R0 := R0 AND #F; STC(R0,FDCONV(1)); F01 := F01*10L + FDCONV; R2 := R2-1; NEXTCHAR; END; END; IF R0 = "'" THEN BEGIN SCALE := R2; R2 := 0; MVI(3,TYPEFLAG); RESET(EXPOSIGN); NEXTCHAR; IF R0 = "+" THEN NEXTCHAR ELSE IF R0 = "-" THEN BEGIN SET(EXPOSIGN); NEXTCHAR; END; IF R0 < "0" THEN BEGIN R1 := SAVEREG(4); R0 := 10; AWXERROR; END; WHILE R0 >= "0" DO BEGIN R0 := R0 AND #F; R2 := R2*10S + R0; NEXTCHAR; END; IF EXPOSIGN THEN R2 := NEG R2; R2 := R2 + SCALE; END; IF R2 ~= 0 THEN BEGIN IF < THEN SET(EXPOSIGN) ELSE RESET(EXPOSIGN); R2 := ABS R2; F23 := 1L; R4 := 0; WHILE R2 ~= 0 DO BEGIN SRDL(R2,1); LTR(R3,R3); IF < THEN F23 := F23*POWER10(R4); R4 := R4 + 8; END; IF EXPOSIGN THEN F01 := F01/F23 ELSE F01 := F01*F23; END; IF IMAGFLAG AND R0 ~= "I" THEN BEGIN R1 := SAVEREG(4); R0 := 10; AWXERROR; END ELSE IF R0 = "I" THEN BEGIN NEXTCHAR; FIXLENGTH; MVI(5,TYPEFLAG); END ELSE BEGIN FIXLENGTH; IF R0 = "+" OR R0 = "-" THEN BEGIN SET(IMAGFLAG); IF SIGN THEN F01 := NEG F01; REALPART := F01; GOTO NUMBER; END; END; IF R0 ~= " " THEN BEGIN R1 := SAVEREG(4); R0 := 10; AWXERROR; END; CLI(5,TYPEFLAG); IF = THEN BEGIN IF SIGN THEN F23 := NEG F01 ELSE F23 := F01; F01 := REALPART; END ELSE IF SIGN THEN F01 := NEG F01; R3 := R3-R3; IC(R3,TYPEFLAG); R4 := TYPE; R0 := R4 OR #1; IF R0 < R3 THEN BEGIN COMMENT NOT ASSIGNMENT COMPATIBLE; R1 := SAVEREG(4); R0 := 10; AWXERROR; END; IF R4 = 1 THEN BEGIN F23 := ABS F01 ++ #4E00000000000000L; IF F23 > #4E0000007FFFFFFFL THEN BEGIN R1 := SAVEREG(4); R0 := 10; AWXERROR; END; REALPART := F23; R0 := INTPART(4); IF F01 < 0L THEN R0 := NEG R0; END ELSE IF R4 >= 4 AND R3 < 4 THEN F23 := 0L; R1 := SAVER1; END; STM(R0,R6,SAVEREG); CLI(#B1,B1); IF = THEN BEGIN COMMENT READCARD - STRING ADDRESS IN R0; R2 := R2-R2; IC(R2,B1(1)); CLI(#07,B1(3)); IF ~= OR R2 < 79 THEN BEGIN R0 := 8; AWXERROR; END; R3 := R0; EX(R2,MVC(0,B3,BLANK)); R3 := AGETCARD; IF ~EOFFLAG THEN BALR(R2,R3); IF ~= OR R0 < 0 OR EOFFLAG THEN BEGIN R0 := 12; AWXERROR; END; SET(READFLAG); END ELSE BEGIN TEST(READFLAG); IF = THEN BEGIN R5 := 80; NEXTCHAR; RESET(READFLAG); END ELSE BEGIN R0 := R0 - R0; R5 := INPNT; IC(R0,INBUF(R5)); END; WHILE R0 = " " DO NEXTCHAR; LH(R4,B1(2)); IF R4 <= 5 THEN NUMBERINPUT ELSE BEGIN R4 := R4 - 5; CASE R4 OF BEGIN LOGICALINPUT; BEGIN R2 := R2-R2; IC(R2,B1(1)); STRINGINPUT; END; BITSINPUT; BEGIN R0 := 11; AWXERROR; END; END; END; INPNT := R5; END; LM(R1,R6,SAVEREG(4)); RETURN(B1(4)); END; GLOBAL PROCEDURE AWXSL011(R1); COMMENT *** WRITEEDIT *** ; BEGIN COMMENT STANDARD FORMAT AND WRITE PROCEDURES; LONG REAL NUM, IMAG; INTEGER NHI SYN NUM(0), NLO SYN NUM(4); LONG REAL PKDEC SYN NUM; LOGICAL SAVER3 SYN WORKAREA(0); ARRAY 2 LOGICAL SAVE56 SYN WORKAREA(8); ARRAY 3 SHORT INTEGER MOVEIT=(#D200,@B4,@B3); ARRAY 3 SHORT INTEGER MOVE12 = (#D200S,@B1,@B2); ARRAY 23 BYTE STAR="*"; ARRAY 22 BYTE BCD SYN STAR(1); COMMENT STRING ASSEMBLY AREA; ARRAY 12 BYTE INTPATTERN=(" ",9(#20),#21,#20); ARRAY 12 BYTE FULLPATTERN=(" ",#21,10(#20)); PROCEDURE CHECKFIT(R6); BEGIN R0 := @LINE(130); R2 := R4 + R5; IF R2 > R0 THEN BEGIN R0 := @LINE; IF R4 ~= R0 AND ~TRACING THEN WRITE; R4 := R0; MVC(131,LINE,BLANK); END; END; PROCEDURE DUMPREAL(R6); BEGIN MVI(" ",BCD); MVC(20,BCD(1),BCD); NUM := F01; IF F01 ~= 0L THEN BEGIN IC(R0,NUM); R0 := R0 AND #7F - #40; IF < THEN MVI("-",BCD(3)) ELSE MVI("+",BCD(3)); R0 := ABS R0; STC(R0,NUM); END ELSE MVI("+",BCD(3)); UNPK(2,1,BCD(4),NUM); UNPK(14,7,BCD(7),NUM(1)); TR(16,BCD(4),TRTABLE(_240)); IF F01 < 0L THEN MVI("-",BCD(6)) ELSE MVI(" ",BCD(6)); END; STFNLINK := R1; SET(STFN); STM(R5,R6,SAVE56); CLI(#B0,B1(0)); IF = THEN BEGIN COMMENT WRITE, WRITEON - TYPE IN B1(2), LENGTH IN B1(1); IF ~EMPTY THEN BEGIN SET(EMPTY); R0 := LMARGIN; TABSTOP := R0; R0 := @TBUF; WRITE; MVC(131,TBUF,BLANK); END; R4 := PTRSAVE; IF WRITEFLAG THEN BEGIN R0 := @LINE; IF R4 ~= R0 THEN BEGIN IF ~TRACING THEN WRITE; R4 := R0; END; PTRSAVE := R0; RESET(WRITEFLAG); MVC(131,LINE,BLANK); END; LH(R2,B1(2)); CASE R2 OF BEGIN BEGIN COMMENT TYPE INTEGER; R5 := INTFIELDSIZE; IF R5 <= 0 OR R5 > 132 THEN R5 := 14; CHECKFIT; MVC(11,BCD,INTPATTERN); CVD(R3,PKDEC); R1 := @BCD(11); EDMK(11,BCD,PKDEC(2)); R2 := @BCD(12) - R1; IF R3 < 0 THEN BEGIN DECR(R1); MVI("-",B1); R2 := R2 + 1; END; IF R2 > R5 THEN BEGIN MVC(11,BCD,STAR); R2 := R5; END; R3 := @BCD(12) - R2; R4 := R4 + R5 -R2; DECR(R2); EX(R2,MOVEIT); R4 := @B4(R2+3); END; BEGIN COMMENT TYPE REAL; R5 := 14; CHECKFIT; R0 := R0-R0; R2 := R5; AWXEDITR; R1 := @B4(13) - R3; EX(R3,MOVE12); R4 := @B4(16); END; BEGIN COMMENT TYPE LONG REAL; R5 := 22; CHECKFIT; R0 := #FF; R2 := R5; AWXEDITR; R1 := @B4(21) - R3; EX(R3,MOVE12); R4 := @B4(24); END; BEGIN COMMENT TYPE COMPLEX; IMAG := F23; R5 := 30; CHECKFIT; R0 := R0-R0; R2 := 14; AWXEDITR; R1 := @B4(13) - R3; EX(R3,MOVE12); F01 := IMAG; IF F0 < 0.0 THEN MVI("-",B4(15)) ELSE MVI("+",B4(15)); R0 := R0-R0; R2 := 14; F0 := ABS F0; AWXEDITR; R1 := @B4(28) - R3; EX(R3,MOVE12); MVI("I",B4(29)); R4 := @B4(32); END; BEGIN COMMENT TYPE LONG COMPLEX; IMAG := F23; R5 := 46; CHECKFIT; R0 := #FF; R2 := 22; AWXEDITR; R1 := @B4(21) - R3; EX(R3,MOVE12); F01 := IMAG; IF F0 < 0.0 THEN MVI("-",B4(23)) ELSE MVI("+",B4(23)); R0 := #FF; R2 := 22; F01 := ABS F01; AWXEDITR; R1 := @B4(44) - R3; EX(R3,MOVE12); MVI("I",B4(45)); R4 := @B4(48); END; BEGIN COMMENT TYPE LOGICAL; R5 := 6; CHECKFIT; R3 := R3 AND #FF; IF = THEN MVC(4,B4(1),"FALSE") ELSE MVC(3,B4(2),"TRUE"); R4 := @B4(8); END; BEGIN COMMENT TYPE STRING; IC(R1,B1(1)); R1 := R1 AND #FF; R5 := R1 - 1; CHECKFIT; IF R1 > 131 THEN BEGIN R0 := @LINE; WHILE R1 > 131 DO BEGIN MVC(131,LINE,B3); WRITE; R1 := R1 - 132; R3 := R3 + 132; END; R4 := R0; MVC(131,LINE,BLANK); END; IF R1 >= 0 THEN BEGIN EX(R1,MOVEIT); R4 := @B4(R1+1); END; END; BEGIN COMMENT TYPES BITS; SAVER3 := R3; R5 := 14; CHECKFIT; UNPK(8,4,B4(6),SAVER3); MVI("#",B4(5)); TR(7,B4(6),TRTABLE(_240)); MVI(" ",B4(14)); R4 := @B4(16); END; BEGIN COMMENT TYPE REFERENCE; R5 := 14; CHECKFIT; AWXEDITP; R1 := @B4(13) - R3; EX(R3,MOVE12); R4 := @B4(16); END; END; PTRSAVE := R4; IF TRACING THEN BEGIN R0 := @LINE; IF R0 ~= R4 THEN WRITE; MVC(131,LINE,BLANK); END; END ELSE BEGIN COMMENT SYSACT AND NUMERIC TO STRING STANDARD FUNCTIONS; SAVER3 := R3; IC(R2,B1(0)); R2 := R2 AND #F; CASE R2 OF BEGIN NULL; COMMENT RESERVED FOR WRITECARD; BEGIN COMMENT IOCONTROL; LH(R2,B1(2)); IF R2 = 1 THEN BEGIN COMMENT ARGUMENT MUST BE INTEGER; IF R3 = 1 THEN SET(READFLAG) ELSE IF R3 = 2 OR R3 = 3 THEN BEGIN R0 := @LINE; R4 := PTRSAVE; IF R4 ~= R0 THEN BEGIN WRITE; PTRSAVE := R0; MVC(131,LINE,BLANK); END; IF R3 = 3 THEN MVI("1",CARRCONT); END; END; END; BEGIN COMMENT INTBASE10; CVD(R0,PKDEC); MVC(11,B3,FULLPATTERN); ED(11,B3,PKDEC(2)); IF R0 < 0 THEN MVI("-",B3(1)); END; BEGIN COMMENT INTBASE16; NHI := R0; UNPK(8,4,BCD,NHI); TR(7,BCD,TRTABLE(_240)); MVI(" ",B3); MVC(10,B3(1),B3); MVC(7,B3(4),BCD); END; BEGIN COMMENT BASE10; R0 := #FF00; R2 := 14; AWXEDITR; R3 := SAVER3; MVC(11,B3,B2(2)); END; BEGIN COMMENT BASE16; DUMPREAL; R3 := SAVER3; MVC(11,B3,BCD(1)); END; BEGIN COMMENT LONGBASE10; R0 := #FFFF; R2 := 22; AWXEDITR; R3 := SAVER3; MVC(19,B3,B2(2)); END; BEGIN COMMENT LONGBASE16; DUMPREAL; R3 := SAVER3; MVC(19,B3,BCD(1)); END; END; END; LM(R5,R6,SAVE56); R1 := STFNLINK; RESET(STFN); RETURN(B1(4)); END; GLOBAL PROCEDURE AWXSL015(R1); COMMENT *** ASSERTCHECK *** ; BEGIN R0 := R0 AND #1; IF ~= THEN BEGIN R0 := ASSERTCOUNT + 1; ASSERTCOUNT := R0; END ELSE BEGIN R0 := 22; AWXERROR; END; END; MVC(71,XFERVECTOR,B1); ARUNBASE := R15; BEGIN ARRAY 2 INTEGER STACKLIMS; CLI(1,DEBUGSW); IF >= THEN SET(DUMPFLAG) ELSE RESET(DUMPFLAG); R0 := #8000; R1 := #80000; R3 := AGETMAIN; BALR(R2,R3); STM(R0,R1,STACKLIMS); BEGIN COMMENT SET UP ERROR EXIT; R1 := @AWXERROR; ARUNERR := R1; R0 := @INTREFS(0); LOINTREF := R0; R0 := @INTREFS(20); HIINTREF := R0; END; R0 := #08000000; SPM(R0); RESET(STFN); R0 := @LINE; PTRSAVE := R0; MVI("1",CARRCONT); R5 := STACKLIMS(0); R0 := R5 + STACKLIMS(4) - 128; MP := R5; LIM := R0; R0 := @B5(32); R1 := 0; R2 := R1; R3 := #80000000; STM(R1,R2,PB(R5)); STM(R0,R3,FP(R5)); COMMENT SYSTEM STACK MARK; R14 := ENTRYADDR; BALR(R1,R14); COMMENT CALL COMPILED PROGRAM; R15 := ARUNBASE; R0 := @LINE; R4 := PTRSAVE; IF R0 ~= R4 THEN WRITE; LM(R0,R1,STACKLIMS); R3 := AFREEMAIN; BALR(R2,R3); IF ~TERMFLAG THEN BEGIN SET(TERMFLAG); R0 := R0-R0; AWXSEDIT; END; END; END. $TITLE ALGOL W LIBRARY - TIME FUNCTION GLOBAL PROCEDURE AWXSL006(R1); COMMENT *** TYME *** ; BEGIN COMMENT PARAMETER, RESULT IN R0; DUMMY BASE R13; ARRAY 18 LOGICAL OSSAVE; INTEGER MP, LIM; ARRAY 18 INTEGER XFERVECTOR; INTEGER AGETTIME SYN XFERVECTOR(28); COMMENT GETTIME ENTRY; INTEGER AGETCLOCK SYN XFERVECTOR(32); COMMENT GETCLOCK ENTRY; INTEGER STFNLINK; BYTE STFN; ARRAY 4 LOGICAL SAVEREG; STM(R0,R3,SAVEREG); IF R0 < 0 THEN R3 := AGETCLOCK ELSE R3 := AGETTIME; BALR(R2,R3); R2 := ABS SAVEREG(0); R1 := R0; R0 := R0-R0; IF R2 = 0 THEN R1 := R1/23040 ELSE IF R2 = 1 THEN R1 := R1/640; R0 := R1; LM(R1,R3,SAVEREG(4)); END. $TITLE ALGOL W LIBRARY - REAL EXPONENTIATION GLOBAL PROCEDURE AWXSL007(R1); COMMENT *** POWER *** ; COMMENT EXPONENTIATION (INTEGER, REAL CONVERTED TO LONG REAL). R0 = BP, WHERE B = REGISTER OF BASE, P = REGISTER OF POWER; BEGIN DUMMY BASE R13; ARRAY 18 LOGICAL OSSAVE; INTEGER MP, LIM; ARRAY 18 INTEGER XFERVECTOR; INTEGER STFNLINK; BYTE STFN; LONG REAL SF01, SF23; INTEGER BREG; BYTE SIGN; STFNLINK := R1; SET(STFN); SF23 := F23; RESET(SIGN); R1 := R0 AND #F0; BREG := R1; IF ~= THEN BEGIN SF01 := F01; R1 := R1 SHRL 4; EX(R1,#2800S); END; F23 := 1L; R1 := R0 AND #F; EX(R1,#1200S); COMMENT LTR; IF ~= THEN BEGIN IF < THEN BEGIN SET(SIGN); R0 := ABS R0; END; L: SRDL(R0,1); LTR(R1,R1); IF < THEN F23 := F23*F01; IF R0 ~= 0 THEN BEGIN F01 := F01*F01; GOTO L; END; END; IF SIGN THEN F01 := 1L/F23 ELSE F01 := F23; F23 := SF23; R1 := BREG; IF R1 ~= 0 THEN BEGIN EX(R1,#2800S); F01 := SF01; END; R1 := STFNLINK; RESET(STFN); END. $TITLE ALGOL W LIBRARY - EXPONENT FUNCTION GLOBAL PROCEDURE AWXSL008(R1); COMMENT *** EXPONENT *** ; COMMENT INPUT, OUTPUT: VALUE IN R3; BEGIN R3 := R3 AND #7FFFFFFF; IF ~= THEN R3 := R3 SHRL 24 - #40; END. $TITLE ALGOL W LIBRARY - REAL TO INTEGER CONVERSION GLOBAL PROCEDURE AWXSL009(R1); COMMENT *** REALINTEGER *** ; COMMENT TRUNCATE(1), ROUND(2), ENTIER(3). INPUT: R0 = VALUE OF REAL. OUTPUT: R3 = VALUE OF INTEGER; BEGIN FUNCTION DECR(6,#0600), RETURN(8,#47F0); DUMMY BASE R13; ARRAY 18 LOGICAL OSSAVE; INTEGER MP, LIM; ARRAY 18 INTEGER XFERVECTOR; INTEGER STFNLINK; BYTE STFN; LOGICAL ARG; COMMENT ARGUMENT; STFNLINK := R1; SET(STFN); ARG := R0; R0 := R0 AND #FFFFFF; IC(R3,ARG); R3 := R3 AND #7F SHLL 2 - 280; IF >= THEN BEGIN IF R3 > 32 THEN R3 := 32; R0 := R0 SHLA R3; END ELSE BEGIN R3 := NEG R3; IF R3 > 44 THEN R3 := 44; CLI(2,MEM(R1+1)); COMMENT SET CC TO SELECT OPERATOR; R1 := 0; SRDL(R0,B3); IF = THEN BEGIN COMMENT ROUND; LTR(R1,R1); IF < THEN R0 := R0 + 1; END ELSE IF > THEN BEGIN COMMENT ENTIER; TM(#80,ARG); IF OVERFLOW AND R1~=0 THEN R0 := R0 + 1; END; END; R3 := R0; TM(#80,ARG); IF OVERFLOW THEN R3 := NEG R3; R1 := STFNLINK; RESET(STFN); RETURN(B1(2)); END. $TITLE ALGOL W LIBRARY - ANALYTICAL FUNCTIONS (SHORT) GLOBAL PROCEDURE AWXSL012(R1); COMMENT *** ANALFN (SHORT) *** ; COMMENT STANDARD FUNCTIONS OF ANALYSIS (SINGLE PRECISION). ADAPTED FROM IBM FORTRAN IV H LIBRARY (RELEASE 17 LEVEL). INPUT, OUTPUT: VALUE IN F0 ; BEGIN EXTERNAL PROCEDURE AWXERROR(R2); NULL; FUNCTION DECR(6,#0600), RETURN(8,#47F0); DUMMY BASE R13; ARRAY 18 LOGICAL OSSAVE; INTEGER MP, LIM; ARRAY 18 INTEGER XFERVECTOR; INTEGER STFNLINK; BYTE STFN; REAL TEMP; INTEGER ITEMP SYN TEMP; REAL RPART; INTEGER IPART SYN RPART; ARRAY 2 SHORT INTEGER SIPART SYN IPART; REAL OCTNT; INTEGER IOCTNT SYN OCTNT; LOGICAL SAVE1; ARRAY 2 LOGICAL SAVE45; GLOBAL DATA AWXSD012 BASE R4; COMMENT CONSTANTS ONLY; PROCEDURE LNLOG(R3); BEGIN ARRAY 3 REAL DELTA = (#41100000R, #40400000R, #40100000R); ARRAY 8 BYTE TABLE = (#08X, 3(#04X), 4(#00X)); IF F0 <= 0.0 THEN BEGIN R1 := SAVE1; R0 := _32; COMMENT LNLOGERR; AWXERROR; IF R1 = 1 THEN F0 := #FFFFFFFFR ELSE F0 := 0.0; END ELSE BEGIN TEMP := F0; R0 := ITEMP; SRDL(R0,24); R1 := R1 SHRL 8; ITEMP := R1; MVI(#40,ITEMP); R0 := R0 SHLL 2 OR #46000000; IPART := R0; R2 := R2-R2; R1 := R1 SHRL 21; IC(R2,TABLE(R1)); F0 := TEMP; F2 := F0; F0 := F0 - DELTA(R2); F2 := F2 + DELTA(R2); F0 := F0/F2; TEMP := F0; F0 := F0*F0; F2 := #4048157BR * F0 + #4047973FR * F0 + #40667685R * F0 + #40AAAA71R * F0; F0 := TEMP; F2 := F2*F0 + F0 + F0; F0 := RPART; R2 := R2 SHRL 1 + 256; SIPART(2) := R2; F0 := F0 - RPART; F0 := F0*#40B17219R; COMMENT LOGE(2); F01 := F01 + F23; END; END; PROCEDURE SINCOS(R3); BEGIN ARRAY 2 REAL C0 = (#41100000R, #40C90FDBR), C1 = (#C04EF4E5R, #C014ABBCR), C2 = (#3F40EBD6R, #3EA32F62R), C3 = (#BE14E5E0R, #BD25B368R); TEMP := F0; F01 := 0L; F23 := F01; F0 := ABS TEMP; R0 := R0 OR #46000000; IOCTNT := R0; IF F0 >= #45C90FDBR THEN COMMENT PI * 2**18; BEGIN R1 := SAVE1; R0 := _36; COMMENT SINCOSERR; AWXERROR; F01 := F01 - F01; END ELSE BEGIN F01 := F01*#41145F306DC9C830L; COMMENT 4/PI; IF F0 > 1.0 THEN BEGIN F01 := F01 ++ #4600000000000000L; F2 := F0; F01 := F01 - F23; END; F2 := F2 ++ OCTNT; OCTNT := F2; TM(#01,OCTNT(3)); IF OVERFLOW THEN BEGIN F0 := F0 - 1.0; F0 := ABS F0; END; TM(#03,OCTNT(3)); IF ~= THEN R1 := R1-R1 ELSE R1 := 4; F4 := F0; F0 := F0*F0; F2 := F0; F0 := F0 * C3(R1) + C2(R1) * F2 + C1(R1) * F2 + C0(R1); IF R1 ~= 0 THEN F0 := F0*F4; TM(#04,OCTNT(3)); IF OVERFLOW THEN F0 := NEG ABS F0; END; END; SAVE1 := R1; LH(R1,MEM(R1)); CASE R1 OF BEGIN BEGIN COMMENT *** SHORT SQUARE ROOT FUNCTION *** ; FUNCTION HER(1,#3400); COMMENT HALVE FUNCTION; ARRAY 2 INTEGER A = (#01CE9FE0, #006DC57C), B = (#FFE6C37D, #FFFA82EB), C = (#FF44547E, #0E0A7419); IF F0 < 0R THEN BEGIN R1 := SAVE1; R0 := _24; COMMENT SQRTERROR; AWXERROR; IF R1 = 1 THEN F0 := ABS F0 ELSE F0 := F0 - F0; END; IF F0 ~= 0R THEN BEGIN TEMP := F0; R0 := ITEMP ++ #41000000; SRDL(R0,25); R0 := R0 SHLL 24; R2 := R0; IF R1 >= 0 THEN R2 := R2 + 4; R0 := B(R2); R1 := R1 SHRL 3 + C(R2); R1 := R1/R1 + A(R2) + R2; ITEMP := R1; F4 := F0; F0 := F0/TEMP + TEMP; HER(F0,F0); F4 := F4/F0 - F0; HER(F4,F4); F0 := F0 + F4; END; END; BEGIN COMMENT *** SHORT EXPONENTIAL FUNCTION *** ; STM(R4,R5,SAVE45); IF F0 > #42AEAC4FR THEN COMMENT X > 174.673; BEGIN R1 := SAVE1; R0 := _28; COMMENT EXPERR; AWXERROR; IF R1 = 1 THEN F0 := #7FFFFFFFR ELSE F0 := F0 - F0; END ELSE IF F0 < #C2B437E0R THEN F0 := F0 - F0 ELSE BEGIN TEMP := F0; R1 := ITEMP; SLDL(R0,8); R0 := R0 AND #7F; IF R0 <= #39S THEN F0 := 1R ELSE BEGIN R1 := R1 SHRL 1; R0 := R0 SHLL 2; R2 := NEG R0; R1 := R1 * #5C551D95; SRDL(R0,B2(287)); IF F0 > 0R THEN BEGIN R0 := R0 XOR #FFFFFFFF; R1 := R1 XOR #FFFFFFFF; END; R0 := R0 SHLL 24; R2 := R0; SLDL(R0,2); R3 := R0; R1 := R1 SHRL 4; ITEMP := R1; R1 := R1*R1; R5 := R0 * #B9059003; R0 := R0 + #576AE119; R5 := R0; R0 := #269F8E6B; R1 := R1/R5 - ITEMP SHRL 1 + #B05CFCE3 + R4; R4 := ITEMP SHRL 2; R5 := R5/R1 + #40000000; R5 := R5 SHRL R3 + #20S; IF R5 < #40000000 THEN R5 := R5 SHRL 6 OR #40000000 ELSE R5 := #41100000; R5 := R5 - R2; ITEMP := R5; F0 := TEMP; END; END; LM(R4,R5,SAVE45); END; BEGIN COMMENT *** SHORT LOG FUNCTION *** ; LNLOG; END; BEGIN COMMENT *** SHORT LOG10 FUNCTION *** ; LNLOG; F0 := F0 * #406F2DEDR; COMMENT LOG(10) E; END; BEGIN COMMENT *** SHORT SIN FUNCTION *** ; IF F0 >= 0R THEN R0 := R0-R0 ELSE R0 := 4; SINCOS; END; BEGIN COMMENT *** SHORT COS FUNCTION *** ; R0 := 2; SINCOS; END; BEGIN COMMENT *** SHORT ARCTAN FUNCTION *** ; ARRAY 4 REAL ADJ = (0R, #40860A92R, #411921FBR, #4110C152R); TEMP := F0; F0 := ABS F0; R1 := R1-R1; IF F0 > 1.0 THEN BEGIN F2 := 1.0/F0; F0 := F2; R1 := 8; END; IF F0 > #40449851R THEN BEGIN COMMENT EXCEEDS TAN(15); F2 := F0; F0 := F0*#40BB67AFR - 1.0 + F2; F2 := F2 + #411BB67BR; F0 := F0/F2; R1 := R1 + 4; END; F4 := F0; F0 := F0*F0; F2 := F0; F0 := F0*#3FD35F49R; F6 := F0; F2 := F2 + #41168A5ER; F0 := #408F239CR/F2 - F6 + #409A6524R; F0 := F0*F4; IF R1 >= 8 THEN F0 := NEG F0; F0 := F0 + ADJ(R1); TM(#80,ITEMP); IF OVERFLOW THEN F0 := NEG F0; END; END; R1 := SAVE1; RETURN(B1(2)); END. $TITLE ALGOL W LIBRARY - ANLYTICAL FUNCTIONS (LONG) GLOBAL PROCEDURE AWXSL013(R1); COMMENT *** ANALFN (LONG) *** ; COMMENT STANDARD FUNCTIONS OF ANALYSIS (DOUBLE PRECISION). ADAPTED FROM IBM FORTRAN IV H LIBRARY (RELEASE 17 LEVEL). INPUT, OUTPUT: VALUE IN F01; BEGIN EXTERNAL PROCEDURE AWXERROR(R2); NULL; FUNCTION DECR(6,#0600), RETURN(8,#47F0); DUMMY BASE R13; ARRAY 18 LOGICAL OSSAVE; INTEGER MP, LIM; ARRAY 18 INTEGER XFERVECTOR; INTEGER STFNLINK; BYTE STFN; LONG REAL LTEMP; ARRAY 2 INTEGER ITEMP SYN LTEMP; REAL RTEMP SYN LTEMP; LONG REAL LPART; REAL RPART SYN LPART; INTEGER IPART SYN RPART; ARRAY 2 SHORT INTEGER SIPART SYN IPART; INTEGER OCTNT; LOGICAL SAVE1; LOGICAL SAVE3; GLOBAL DATA AWXSD013 BASE R4; COMMENT CONSTANTS ONLY; PROCEDURE LNLOG(R3); BEGIN ARRAY 3 LONG REAL TABLE = (0L, #4080000000000000L, 1L); ARRAY 2 LONG REAL TABLE1 SYN TABLE(8); ARRAY 8 BYTE SHIFT = (#03X, #02X, 2(#01X), 4(#00X)); IF F01 <= 0L THEN BEGIN R1 := SAVE1; R0 := _32; COMMENT LNLOGERR; AWXERROR; IF R1 = 1 THEN F01 := #FFFFFFFFFFFFFFFFL ELSE F01 := 0L; END ELSE BEGIN SAVE3 := R3; LTEMP := F01; LM(R0,R1,ITEMP); R2 := R0; SRDL(R2,24); R2 := R2 SHLL 2 OR #46000000; IPART := R2; R2 := R2-R2; SLDL(R2,3); IC(R2,SHIFT(R2)); SLDL(R0,B2); STM(R0,R1,ITEMP); MVI(#40,LTEMP); F01 := LTEMP; IF F0 > #40B504F3R THEN R1 := 8 ELSE BEGIN R1 := R1-R1; R2 := R2 + 1; END; F23 := F01 + TABLE1(R1); F01 := F01 - TABLE(8) - TABLE(R1); F01 := F01/F23; LTEMP := F01; F01 := F01*F01; F23 := F01 * #4025E9B17CA9B973L + #40273337E26DBA7FL * F01 + #402E8CD32A425C06L * F01 + #4038E38A00083F6BL * F01 + #4049249251450212L * F01 + #40666666665EBAA3L * F01 + #40AAAAAAAAAAAD6CL * F01; F01 := LTEMP; F23 := F23*F01 + F01 + F01; F01 := 0L; F0 := RPART; R2 := R2 + 256; SIPART(2) := R2; F0 := F0 - RPART; F01 := F01 * #40B17217F7D1CF7BL + F23; R3 := SAVE3; END; END; PROCEDURE SINCOS(R3); BEGIN ARRAY 2 LONG REAL C7=(#B66C992E84B6AA37L,#3778FCE0E5AD1685L), C6=(#387E731045017594L,#B978C01C6BEF8CB3L), C5=(#BA69B47B1E41AEF6L,#3B541E0BF684B527L), C4=(#3C3C3EA0D06ABC29L,#BD265A599C5CB632L), C3=(#BE155D3C7E3C90F8L,#3EA335E33BAC3FBDL), C2=(#3F40F07C206D6AB1L,#C014ABBCE625BE41L), C1=(#C04EF4F326F91777L,#40C90FDAA22168C2L); LONG REAL PIOV4 SYN C1(8); F01 := ABS F01; IF F0 >= #4DC90FDAR THEN BEGIN R1 := SAVE1; R0 := _36; COMMENT SINCOSERR; AWXERROR; F01 := F01 - F01; END ELSE BEGIN F01 := F01/PIOV4; F23 := F01 ++ #4E00000000000000L; LTEMP := F23; F23 := 0L + LTEMP; F01 := F01 - F23; R0 := R0 ++ ITEMP(4); OCTNT := R0; TM(#01,OCTNT(3)); IF OVERFLOW THEN F01 := F01 - #4080000000000000L - #4080000000000000L; F45 := ABS F01; F01 := F01 * F01; F23 := F01; TM(#03,OCTNT(3)); IF ~= THEN R1 := R1-R1 ELSE R1 := 8; F01 := F01 * C7(R1) + C6(R1) * F23 + C5(R1) * F23 + C4(R1) * F23 + C3(R1) * F23 + C2(R1) * F23 + C1(R1); IF R1 ~= 0 THEN F01 := F01 * F45 ELSE F01 := F01*F23 + #4080000000000000L + #4080000000000000L; TM(#04,OCTNT(3)); IF OVERFLOW THEN F01 := NEG ABS F01; END; END; SAVE1 := R1; LH(R1,MEM(R1)); CASE R1 OF BEGIN BEGIN COMMENT *** LONG SQUARE ROOT FUNCTION *** ; FUNCTION HER(1,#3400), HDR(1,#2400); COMMENT HALVE FUNCTION; IF F0 < 0R THEN BEGIN R1 := SAVE1; R0 := _24; COMMENT SQRTERROR; AWXERROR; IF R1 = 1 THEN F01 := ABS F01 ELSE F01 := F01-F01; END; IF F01 ~= 0L THEN BEGIN RTEMP := F0; R0 := R0-R0; IC(R0,ITEMP); R0 := R0 + #41S; SRDL(R0,1); STC(R0,ITEMP); R2 := #4038E383; IPART := R2; STC(R0,IPART); F45 := F01; F0 := RTEMP*#40E38E39R + RPART; IF R1 >= 0 THEN BEGIN HER(F0,F0); HER(F0,F0); END; F2 := F4/F0; F0 := F0 + F2; HER(F0,F0); F2 := F4/F0; F0 := F0 + F2; HER(F0,F0); F23 := F45/F01; HDR(F23,F23); HDR(F01,F01); F01 := F01 + F23; F45 := F45/F01 -- F01; HDR(F45,F45); F01 := F01 + F45; END; END; BEGIN COMMENT *** LONG EXPONENTIAL FUNCTION *** ; FUNCTION HDR(1,#2400); COMMENT BCTR, HALVE; ARRAY 15 LONG REAL MCONST = (#40F5257D152486CCL, #40EAC0C6E7DD2439L, #40E0CCDEEC2A94E1L, #40D744FCCAD69D6BL, #40CE248C151F8481L, #40C5672A115506DBL, #40BD08A39F580C37L, #40B504F333F9DE65L, #40AD583EEA42A14BL, #40A5FED6A9B15139L, #409EF5326091A112L, #409837F0518DB8A9L, #4091C3D373AB11C3L, #408B95C1E3EA8BD7L, #4085AAC367CC487BL); IF F0 > #42AEAC4ER THEN COMMENT X > 174.6731; BEGIN R1 := SAVE1; R0 := _28; COMMENT EXPERR; AWXERROR; IF R1 = 1 THEN F01 := #7FFFFFFFFFFFFFFFL ELSE F01 := F01-F01; END ELSE IF F0 <= #C2B437DFR THEN F01 := F01 - F01 ELSE BEGIN F01 := F01/#40B17217F7D1CF79L; COMMENT DIV BY LN 2; RPART := F0; F2 := F0 ++ #45000000R; RTEMP := F2; F23 := F23 - F23; F2 := F2 + RTEMP; F01 := F01 - F23; R2 := ITEMP; TM(#80,RPART); IF = THEN COMMENT NON-NEGATIVE; BEGIN F01 := F01 - #4010000000000000L; R2 := NEG R2 - 1; END; R3 := R3 - R3; SRDL(R2,4); R3 := R3 SHRL 25; SRDL(R2,2); R2 := R2 SHLL 24; R0 := NEG R2; R2 := R2-R2; SLDL(R2,2); F23 := F01; F0 := F0 * #3D9E0F1ER; F01 := F01 + #3E575D42BB7276D4L * F23 + #3F276553A5F9BC94L * F23 + #3FE35846A61AEE7AL * F23 + #403D7F7BFF0289DEL * F23 + #40B17217F7D1CC79L * F23 + #4080000000000000L + #4080000000000000L; IF R3 ~= 0 THEN BEGIN IF F0 >= 1R THEN F01 := MCONST(R3-8) ELSE F01 := F01 * MCONST(R3-8); END; WHILE R2 > 0 DO BEGIN HDR(F01,F01); DECR(R2); END; LPART := F01; R0 := R0 + IPART; IPART := R0; F01 := 0L + LPART; END; END; BEGIN COMMENT *** LONG LOG FUNCTION *** ; LNLOG; END; BEGIN COMMENT *** LONG LOG10 FUNCTION *** ; LNLOG; F01 := F01 * #406F2DEC549B943AL; END; BEGIN COMMENT *** LONG SIN FUNCTION *** ; R0 := R0-R0; IF F0 < 0R THEN R0 := 4; SINCOS; END; BEGIN COMMENT *** LONG COS FUNCTION *** ; R0 := 2; SINCOS; END; BEGIN COMMENT *** LONG ARCTAN FUNCTION *** ; ARRAY 2 LONG REAL PO2M1 = (#40921FB54442D184L, #408C152382D73658L); ARRAY 4 LONG REAL ADJ = (0L, #40860A91C16B9B2DL, 1L, #4080000000000000L); RPART := F0; F01 := ABS F01; R1 := R1-R1; IF F0 >= 1.0 THEN BEGIN F23 := 1L/F01; F01 := F23; R1 := 16; END; IF F0 > #40449851R THEN BEGIN COMMENT EXCEEDS TAN(15); F23 := F01; F01 := F01 * #40BB67AE8584CAA8L; F01 := F01 - #4080000000000000L - #4080000000000000L + F23; F23 := F23 + #411BB67AE8584CABL; F01 := F01/F23; R1 := R1 + 8; END; F67 := F01; F01 := F01 * F01; F23 := F01 + #4114451896975D03L; F45 := #C0145A9C5C07FB43L/F23 + F01 + #41224D09A3EFF7ACL; F23 := #C1138256FCDD5CB6L/F45 + F01 + #4168C2DCB9C0437FL; F45 := #C1DD6E91F2AD24DFL/F23 + F01 + #414D42F041242098L; F23 := #C0D5F788DF6CB457L/F45; F01 := F01 * F23 * F67 + F67; IF R1 >= 16 THEN F01 := NEG F01 + PO2M1(R1-16); F01 := F01 + ADJ(R1); TM(#80,RPART); IF OVERFLOW THEN F01 := NEG F01; END; END; R1 := SAVE1; RETURN(B1(2)); END. $TITLE ALGOL W LIBRARY - COMPLEX ARITHMETIC GLOBAL PROCEDURE AWXSL014(R1); COMMENT *** CARITHFN *** ; COMMENT COMPLEX, LONG COMPLEX ARITHMETIC SUBROUTINES; BEGIN FUNCTION DECR(6,#0600), RETURN(8,#47F0); DUMMY BASE R13; ARRAY 18 LOGICAL OSSAVE; INTEGER MP, LIM; ARRAY 18 INTEGER XFERVECTOR; INTEGER STFNLINK; BYTE STFN; REAL RB1 SYN MEM(R1); LONG REAL LRB1 SYN MEM(R1); BYTE SIGN; LOGICAL TBP; ARRAY 2 LONG REAL AC; LONG REAL LR; REAL R SYN LR; REAL TEMP; INTEGER ITEMP SYN TEMP; STFNLINK := R1; SET(STFN); LH(R1,MEM(R1)); CASE R1 OF BEGIN BEGIN COMMENT *** COMPLEX MULTIPLICATION *** ; COMMENT ONE 0PERAND IN F0,F2. SECOND 0PERAND IN B0,B0(4) RESULT IN F0,F2; R1 := R0; F4 := RB1(4); F6 := F4; F4 := F4 * F2; F6 := F6 * F0; F0 := F0 * RB1 - F4; F2 := F2 * RB1 + F6; END; BEGIN COMMENT *** LONG COMPLEX MULTIPLICATION *** ; R1 := R0; F45 := LRB1(8); F67 := F45; F45 := F45 * F23; F67 := F67 * F01; F01:= F01* LRB1 - F45; F23 := F23 * LRB1 + F67; END; BEGIN COMMENT *** COMPLEX DIVISION *** ; COMMENT NUMERATOR IN F0,F2. DENOMINATOR IN B0,B0(4). RESULT IN F0,F2; R1 := R0; F4 := ABS RB1; F6 := ABS RB1(4); IF F4 >= F6 THEN BEGIN F4 := RB1(4)/RB1; F6 := RB1(4)*F4 + RB1; R := F4; F4 := F4*F2 + F0 / F6; F0 := F0*R; F2 := F2 - F0 / F6; F0 := F4; END ELSE BEGIN F4 := RB1/RB1(4); F6 := F4 * RB1 + RB1(4); R := F4; F4 := F4 * F0 + F2 / F6; F2 := F2 * R; F2 := F2 - F0 / F6; F0 := F4; END; END; BEGIN COMMENT *** LONG COMPLEX DIVISION *** ; R1 := R0; F45 := ABS LRB1; F67 := ABS LRB1(8); IF F45 >= F67 THEN BEGIN F45 := LRB1(8)/LRB1; F67 := LRB1(8)*F45 + LRB1; LR := F45; F45 := F45*F23 + F01 / F67; F01 := F01*LR; F23 := F23 - F01 / F67; F01 := F45; END ELSE BEGIN F45 := LRB1/LRB1(8); F67 := F45*LRB1 + LRB1(8); LR := F45; F45 := F45*F01 + F23 / F67; F23 := F23*LR; F23 := F23 - F01 / F67; F01 := F45; END; END; BEGIN COMMENT *** COMPLEX ABS *** ; COMMENT OPERAND IN F0, F2. RESULT IN F0; FUNCTION HER(1,#3400); GLOBAL DATA AWXSD014 BASE R4; ARRAY 2 INTEGER A = (#01CE9FE0, #006DC57C), B = (#FFE6C37D, #FFFA82EB), C = (#FF44547E, #0E0A7419); F0 := ABS F0; IF = THEN F0 := ABS F2 ELSE BEGIN F2 := ABS F2; IF ~= THEN BEGIN IF F0 > F2 THEN BEGIN F4 := F0; F0 := F2; F2 := F4; END; R := F2; F0 := F0/F2 * F0 + 1.0; TEMP := F0; R0 := ITEMP ++ #41000000; SRDL(R0,25); R0 := R0 SHLL 24; R2 := R0; IF R1 >= 0 THEN R2 := R2 + 4; R0 := B(R2); R0 := R1 SHRL 3 + C(R2); R1 := R1/R1 + A(R2) + R2; ITEMP := R1; F4 := F0; F0 := F0/TEMP + TEMP; HER(F0,F0); F4 := F4/F0 - F0; HER(F4,F4); F0 := F0 + F4; F0 := F0 * R; END; END; END; BEGIN COMMENT *** LONG COMPLEX ABS *** ; FUNCTION HER(1,#3400), HDR(1,#2400); F01 := ABS F01; IF = THEN F01 := ABS F23 ELSE BEGIN F23 := ABS F23; IF ~= THEN BEGIN IF F01 > F23 THEN BEGIN F45 := F01; F01 := F23; F23 := F45; END; LR := F23; F01 := F01/F23 * F01 + 1L; TEMP := F0; R0 := R0-R0; IC(R0,ITEMP); R0 := R0 + #41S; SRDL(R0,1); STC(R0,ITEMP); F45 := F01; F0 := TEMP * #40E38E39R; R2 := #4038E383; ITEMP := R2; STC(R0,ITEMP); F0 := F0 + TEMP; IF R1 >= 0 THEN BEGIN HER(F0,F0); HER(F0,F0); END; F2 := F4/F0; F0 := F0 + F2; HER(F0,F0); F2 := F4/F0; F0 := F0 + F2; HER(F0,F0); F23 := F45/F01; HDR(F23,F23); HDR(F01,F01); F01 := F01 + F23; F45 := F45/F01 -- F01; HDR(F45,F45); F01 := F01 + F45; F01 := F01 * LR; END; END; END; BEGIN COMMENT COMPLEX, LONG COMPLEX EXPONENTIATION. R0 = T0P, WHERE T = TYPE OF BASE, P = REGISTER OF POWER; RESET(SIGN); TBP := R0; R1 := R0 SHRL 8; IF R1 = 4 THEN BEGIN COMMENT CONVERT TO LONG COMPLEX; F0 := F0 * 1.0; F2 := F2 * 1.0; END; R1 := TBP AND #F; EX(R1,#1800S); IF R0 < 0 THEN BEGIN R0 := NEG R0; SET(SIGN); END; F45 := 1L; AC := F45; F45 := F45 - F45; AC( 8):= F45; AG: SRDL(R0,1); LTR(R1,R1); IF < THEN BEGIN F45 := AC( 8)* F01; F67 := AC * F23 + F45; F45 := AC( 8)* F23; AC( 8):= F67; F67 := AC * F01 - F45; AC := F67; END; IF R0 ~= 0 THEN BEGIN F45 := F23 * F23; F23 := F23 * F01 + F23; F01 := F01 * F01 - F45; GOTO AG; END; IF SIGN THEN BEGIN F45 := AC( 8)* F45; F67 := AC * F67 + F45; F01 := AC/F67; F23 := NEG AC( 8)/ F67; END ELSE BEGIN F01 := AC; F23 := AC(8); END; END; END; R1 := STFNLINK; RESET(STFN); RETURN(B1(2)); END.