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); ARRAY 448 INTEGER FLOWCOUNTS; COMMENT STATEMENT FREQUENCY COUNTS; 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; GLOBAL PROCEDURE AWXSEDIT(R2); COMMENT *** SOURCE CODE EDITOR *** ; BEGIN ARRAY 13 INTEGER SAVEREG; STM(R2,R14,SAVEREG); BEGIN SEGMENT BASE R11; FUNCTION SIGN(8,#960C); COMMENT SETS DECIMAL SIGN; INTEGER REGISTER T SYN R2, TOKEN SYN R3, N SYN R4, SI SYN R5, DI SYN R6, II SYN R7, LINK SYN R8, LINK0 SYN R9; ARRAY 0 CHARACTER BSI SYN MEM(SI), BDI SYN MEM(DI), BII SYN MEM(II); LOGICAL PROGPOINT; COMMENT DYNAMIC PROGRAM COORDINATES; SHORT INTEGER COUNTINDEX SYN PROGPOINT(0); SHORT INTEGER COORDNO SYN PROGPOINT(2); INTEGER ERRLOC; LOGICAL PKCOUNT; INTEGER PSTOP; COMMENT INDEX OF CLOSE OF PROC DECL; ARRAY 8 INTEGER PSSTACK; INTEGER PSINDEX; INTEGER TABSTOP; ARRAY 260 BYTE WORK; ARRAY 132 BYTE HOLD SYN MLINE; COMMENT SERIALLY REUSABLE VARIABLES; ARRAY 132 CHARACTER BUFFER = 132(" "); INTEGER DTAB = 3, DIMAX = @@BUFFER(120); ARRAY 4 INTEGER MARK = 4(0), MARKCOORD = 4(0); INTEGER PARENLEVEL = 0; BYTE EMPTY=#FFX, NEWTAB=#00X, NEWCOUNT, ERRSTATE=#00X; ARRAY 0 BYTE EDITCODE SYN 0; ARRAY 0 LOGICAL IDDIR SYN B12; SHORT INTEGER IDLENGTH SYN IDDIR(0); SHORT INTEGER IDPOINT SYN IDDIR(2); GLOBAL DATA AWXSCODE BASE R10; INTEGER BEGINCODE = #97, SEMICOLCODE = #70, ENDCODE = #6F, STOPCODE = #92; SHORT INTEGER IDCODE = #65S, NUMBERCODE = #77S, SITYPECODE = #64S, RTABCODE = #FES, LTABCODE = #FAS, JPD = #ECS, JLOOPCODE = #EFS, VRSTOP = #EES, PVCODE = #02S, FDCODE = #EDS, METACODE = #A6S; ARRAY 256 BYTE INPUTSW = (2(#0E), #0C, 8, 97(0), 3, 1, #14, #10, 1, #10, 4(1), #18, #1C, 6(1), 5, 2(1), #40, 6(1), 6, 12(1), 7, 4(1), #44, 3(1), #48, 2(1), #44, 8(1), #48, 3(1), 26(0), 9(2), 7(0), 9(2), #27, #20, #4C, 5(0), 8(2), #2A, #2E, #2A, #2C, #24, #32, 10(4), #23, #3B, 3(#37), #3F); ARRAY 20 BYTE CNTRL1 = (3(0),21,17,18,9,3(16),15,9,15,16,20,19,23,22,2(9)), CNTRL2 = (3(0),9,3(1),10,12,9,2(13),9,11,12,11,2(1),10,14); ARRAY 208 CHARACTER SYMBOLLIST = ("", ",", ")", "REFERENCE(", ",", "(", "ALGOL", "FORTRAN", "::", "ARRAY", "END", ";", "PROCEDURE", "VALUE", "RESULT", "*", "RECORD", "|", "", "IF", "THEN", "ELSE", "CASE", "OF", "IS", "+", "-", "OR", "", "NULL", "/", "DIV", "REM", "AND", "~", "SHL", "SHR", "TRUE", "FALSE", "LONG", "ABS", "", "<", "=", ">", ".", "DO", "GOTO", "<=", ">=", "BEGIN", "ASSERT", ":", ":=", "FOR", "STEP", "UNTIL", "WHILE", "SHORT", "~=", "**", " "); CHARACTER RPARENSYMBOL SYN SYMBOLLIST(5); CHARACTER ELSESYMBOL SYN SYMBOLLIST(83); ARRAY 134 BYTE SYMBOLDIR = (( 0,0), COMMENT ; ( 0,3), ( 4,0), ( 5,0), ( 6,9), ( 16,0), ( 17,0), ( 18,4), ( 23,6), ( 30,1), ( 32,4), ( 37,2), ( 40,0), ( 41,8), ( 50,4), ( 55,5), ( 61,0), ( 62,5), ( 68,0), ( 69,7), ( 77,1), ( 79,3), ( 83,3), ( 87,3), ( 91,1), ( 93,1), ( 95,0), ( 96,0), ( 97,1), ( 99,7), (107,3), (111,0), (112,2), (115,2), (118,2), (121,0), (122,2), (125,2), (128,3), (132,4), (137,3), (141,2), (144,8), (153,0), (154,0), (155,0), (156,0), (157,1), (159,3), (163,1), (165,1), (167,4), (172,5), (178,0), (179,1), (181,2), (184,3), (188,4), (193,4), (198,4), (203,1), (205,1), (207,0), ( 40,0), ( 95,0), ( 96,0), (207,0)); ARRAY 67 BYTE SYMBOLINDEX SYN SYMBOLDIR(_200); ARRAY 67 BYTE SYMBOLLEN SYN SYMBOLDIR(_199); ARRAY 134 BYTE SYMBOLLAYOUT = ((0,1), (0,0), (0,4), (0,0), (0,0), (0,4), (0,0), (1,1), (1,1), (1,1), (0,1), (9,0),(0,12), (0,1), (0,1), (0,1), (0,0), (0,1), (0,0), (0,0), (9,2), (2,8), (2,8), (0,2), (2,8), (1,1), (1,1), (1,1), (2,2), (0,0), (0,0), (0,0), (1,1), (1,1), (2,2), (1,0), (1,1), (1,1), (0,0), (0,0), (1,1), (1,1), (0,0), (1,1), (1,1), (1,1), (0,0), (2,8), (0,1), (1,1), (1,1), (9,8), (0,2), (0,2), (1,1), (9,2), (2,2), (2,2), (9,2), (1,1), (1,1), (0,0), (0,0),(0,12), (0,0), (0,0), (0,0)); ARRAY 67 BYTE SPACESBEFORE SYN SYMBOLLAYOUT(_200); ARRAY 67 BYTE SPACESAFTER SYN SYMBOLLAYOUT(_199); ARRAY 6 BYTE METADIR = ((0,6), (7,10), (18,21)); ARRAY 4 BYTE METAINDEX SYN METADIR(0), METALEN SYN METADIR(1); ARRAY 40 CHARACTER METALIST = ("", "", ""); ARRAY 39 CHARACTER TYPELIST = ("INTEGER", "LONG REAL", "LONG COMPLEX", "LOGICAL", "BITS"); ARRAY 16 BYTE TYPEDIR = (( 0,6), (12,3), ( 7,8), (21,6), (16,11), (28,6), ( 0,0), (35,3)); ARRAY 8 BYTE TYPEINDEX SYN TYPEDIR(_2); ARRAY 8 BYTE TYPELEN SYN TYPEDIR(_1); ARRAY 9 CHARACTER PATTERN = (" ",5(#20X),#21X,#20X,")"); CLOSE BASE; PROCEDURE CLEARBUFFER(LINK0); BEGIN DI := TABSTOP; RESET(NEWTAB); IF ~EMPTY THEN BEGIN R0 := @BUFFER; WRITE; MVC(131,BUFFER,BLANK); SET(EMPTY); R0 := R0-R0; MARK(12) := R0; MARK(8) := R0; MARK(4) := R0; END; TM(#01,ERRSTATE); IF OVERFLOW THEN BEGIN NI(#FE,ERRSTATE); MVI("-",BUFFER(0)); MVC(130,BUFFER(1),BUFFER); MVC(6,BUFFER(4)," ERROR "); R0 := @BUFFER; WRITE; MVC(131,BUFFER,BLANK); END; R0 := COORDNO; IF TOKEN = BEGINCODE THEN DECR(R0); CVD(R0,PKDEC); UNPK(3,7,BUFFER(0),PKDEC); ZONE(BUFFER(3)); END; PROCEDURE SHIFTBUFFER(LINK0); COMMENT R0 = NEW COORDINATE, R1 = SHIFT BREAK; BEGIN CVD(R0,PKDEC); MARK(0) := R1; T := DI - R1 - 1; EX(T,MVC(0,HOLD,B1)); EX(T,MVC(0,B1,BLANK)); R0 := @BUFFER; WRITE; MVC(131,BUFFER,BLANK); DI := TABSTOP; EX(T,MVC(0,BDI,HOLD)); R0 := MARK(0) - DI; DI := @BDI(T+1); RESET(EMPTY); FOR R1 := 4 STEP 4 UNTIL 12 DO BEGIN T := MARK(R1); IF T > MARK(0) THEN T := T - R0 ELSE T := 0; MARK(R1) := T; END; UNPK(3,7,BUFFER(0),PKDEC); ZONE(BUFFER(3)); END; PROCEDURE SETPUNC(LINK0); BEGIN R1 := TABSTOP - 18; IF NEWCOUNT THEN BEGIN RESET(NEWCOUNT); T := COUNTINDEX; T := FLOWCOUNTS(T); PKCOUNT := T; SIGN(PKCOUNT(3)); MVC(7,B1(0),PATTERN); ED(7,B1(0),PKCOUNT); MVC(2,B1(8),".--"); END; MVI("|",B1(11)); END; PROCEDURE GET(LINK); COMMENT LOCATE NEXT INPUT SYMBOL. SET TOKEN, II, N; BEGIN R1 := R1-R1; N := R1; CYCLE: DECR(SI); IC(TOKEN,EDITCODE(SI)); T := T-T; IC(T,INPUTSW(TOKEN)); IF T >= #C THEN BEGIN COMMENT CHARACTERS WITH CONTROL SIGNIFICANCE; R0 := T AND #3; SI := SI - R0; T := T SHRL 2; IF TRACING THEN IC(T,CNTRL1(T)) ELSE IC(T,CNTRL2(T)); END; CASE T OF BEGIN BEGIN COMMENT 1 => STANDARD PROCESSING; T := TOKEN SHLA 1; IC(N,SYMBOLLEN(T)); IC(R1,SYMBOLINDEX(T)); II := @SYMBOLLIST(R1); END; BEGIN COMMENT 2 => LETTER; TOKEN := IDCODE; II := SI; END; BEGIN COMMENT 3 => IDENTIFIER; SI := SI-2; IC(R1,EDITCODE(SI)); R1 := R1 SHLL 8; IC(R1,EDITCODE(SI+1)); R1 := R1 SHLA 2; N := IDLENGTH(R1); II := IDLISTBASE + IDPOINT(R1); END; BEGIN COMMENT 4 => DIGIT; TOKEN := NUMBERCODE; II := SI; END; BEGIN COMMENT 5 => NUMBER; DECR(SI); IC(N,BSI(0)); SI := SI-N-1; II := SI; END; BEGIN COMMENT 6 => STRING; DECR(SI); IC(N,BSI(0)); SI := SI-N-1; R1 := """"; STC(R1,WORK(0)); EX(N,MVC(0,WORK(1),BSI)); STC(R1,WORK(N+2)); N := N + 2; II := @WORK; END; BEGIN COMMENT 7 => BIT SEQUENCE; MVI("#",WORK); SI := SI-4; UNPK(8,4,WORK(1),BSI); TR(7,WORK(1),TRTABLE(_240)); N := 8; II := @WORK; END; BEGIN COMMENT 8 => SIMPLE TYPE; SI := SI-2; T := 0; IC(T,BSI(0)); IF T ~= 7 THEN BEGIN SI := @BSI(1); IC(T,BSI(0)); T := T SHLA 1; IC(N,TYPELEN(T)); IC(R1,TYPEINDEX(T)); II := @TYPELIST(R1); END ELSE BEGIN IC(T,BSI(1)); CVD(T,PKDEC); R1 := @WORK(11); II := R1; MVC(8,WORK(4),PATTERN); EDMK(7,WORK(4),PKDEC(4)); N := II - R1 + 8; II := R1 - 7; MVC(6,BII,"STRING("); END; TOKEN := SITYPECODE; END; BEGIN COMMENT 9 => NO-OP; GOTO CYCLE; END; COMMENT *** CODES 10 - 14 => ~TRACING *** ; BEGIN COMMENT 10 => COORDNO INCREMENT; T := COORDNO + 1; COORDNO := T; IF T = ERRLOC THEN BEGIN CLI(#00,ERRSTATE); IF = THEN BEGIN MVI(#02,ERRSTATE); T := T + 1; ERRLOC := T; END; OI(#01,ERRSTATE); SET(NEWTAB); END; T := TOKEN SHLA 1; IC(N,SYMBOLLEN(T)); IC(R1,SYMBOLINDEX(T)); II := @SYMBOLLIST(R1); END; BEGIN COMMENT 11 => SET COUNT, TAB; IF TOKEN >= RTABCODE THEN BEGIN R0 := TABSTOP + DTAB; TABSTOP := R0; END; CLEARBUFFER; R1 := R1-R1; SET(NEWCOUNT); MVC(1,COUNTINDEX,EDITCODE(SI)); GOTO CYCLE; END; BEGIN COMMENT 12 => CLEAR TAB; R0 := TABSTOP - DTAB; TABSTOP := R0; SET(NEWTAB); IF TOKEN = LTABCODE THEN BEGIN SET(NEWCOUNT); MVC(1,COUNTINDEX,EDITCODE(SI)); END; GOTO CYCLE; END; BEGIN COMMENT 13 => DECLARATION CODES; CLEARBUFFER; IF TOKEN = FDCODE THEN R0 := SI + 1 ELSE R0 := SI + 3; IF R0 = PSTOP THEN BEGIN OI("0",CARRCONT); R1 := PSINDEX - 4; T := PSSTACK(R1+4); PSTOP := T; PSINDEX := R1; END; IF TOKEN = JPD THEN BEGIN R1 := PSINDEX + 4; T := PSTOP; PSSTACK(R1) := T; PSINDEX := R1; T := T-T; IC(T,BSI(0)); T := T SHLL 8; IC(T,BSI(1)); R1 := EDITBASE - T; PSTOP := R1; DI := TABSTOP; OI("0",CARRCONT); END; R1 := R1-R1; GOTO CYCLE; END; BEGIN COMMENT 14 => INDENT; R0 := TABSTOP + DTAB; TABSTOP := R0; GOTO CYCLE; END; COMMENT *** CODES 15 - 23 => TRACING; BEGIN COMMENT 15 => JUMP; IF N = PARENLEVEL THEN BEGIN T := T-T; IC(T,EDITCODE(SI)); T := T SHLL 8; IC(T,EDITCODE(SI+1)); SI := EDITBASE - T; IF TOKEN = JLOOPCODE THEN TOKEN := STOPCODE; END; IF TOKEN ~= STOPCODE THEN GOTO CYCLE; END; BEGIN COMMENT 16 => STOP; IF N ~= PARENLEVEL THEN GOTO CYCLE; TOKEN := STOPCODE; END; BEGIN COMMENT 17 => LEFT PAREN; T := PARENLEVEL + 1; PARENLEVEL := T; T := TOKEN SHLA 1; IC(N,SYMBOLLEN(T)); IC(R1,SYMBOLINDEX(T)); II := @SYMBOLLIST(R1); END; BEGIN COMMENT 18 => RIGHT PAREN; T := PARENLEVEL - 1; IF < THEN TOKEN := STOPCODE ELSE BEGIN PARENLEVEL := T; II := @RPARENSYMBOL; END; END; BEGIN COMMENT 19 => RTAB'; T := PARENLEVEL + 1; PARENLEVEL := T; GOTO CYCLE; END; BEGIN COMMENT 20 => LTAB'; T := PARENLEVEL - 1; IF < THEN TOKEN := STOPCODE ELSE BEGIN PARENLEVEL := T; GOTO CYCLE; END; END; BEGIN COMMENT 21 => METAPHRASE; IF TOKEN ~= PVCODE THEN BEGIN T := T-T; IC(T,EDITCODE(SI)); T := T SHLL 8; IC(T,EDITCODE(SI+1)); SI := EDITBASE - T; END; T := TOKEN SHLA 1; IC(N,METALEN(T)); IC(T,METAINDEX(T)); II := @METALIST(T); TOKEN := METACODE; END; BEGIN COMMENT 22 => DO, := ; TM(#80,PROGPOINT); IF OVERFLOW THEN TOKEN := STOPCODE ELSE BEGIN T := TOKEN SHLA 1; IC(N,SYMBOLLEN(T)); IC(R1,SYMBOLINDEX(T)); II := @SYMBOLLIST(R1); END; END; BEGIN COMMENT 23 => ELSE ; IF N = PARENLEVEL THEN TOKEN := STOPCODE ELSE BEGIN II := @ELSESYMBOL; N := 3; END; END; END; END; TOKEN := 0; RESET(NEWCOUNT); R12 := IDDIRBASE; IF ~TRACING THEN BEGIN COMMENT OUTPUT FLOW SUMMARY. R0 = COORDINATE OF RUN ERROR (0 IF NORMAL TERMINATION); ERRLOC := R0; MVI(#00,ERRSTATE); 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; IF ~COUNTFLAG THEN GOTO Z; MVI("1",CARRCONT); MVC(24,BUFFER,"=> EXECUTION FLOW SUMMARY"); R0 := @BUFFER; WRITE; MVC(131,BUFFER,BLANK); MVI("0",CARRCONT); R0 := _4; PSINDEX := R0; PSTOP := R0; R0 := 0; COORDNO := R0; SI := EDITBASE; DI := @BUFFER(22); TABSTOP := DI; TOKEN := 0; END ELSE BEGIN COMMENT OUTPUT PHRASE FOR TRACING. R0(0:15) = COUNT INDEX, R0(16:31) = COORDNO. R1(0:7) = TAB OFFSET, R1(8:31) = EDITINDEX (OUTPUT ALSO); SI := R1; R1 := R1 -- 1; IC(TOKEN,EDITCODE(R1)); R1 := R1 SHRL 24; DI := @BUFFER(R1+22); TABSTOP := DI; PROGPOINT := R0; IF R0 >= 0 THEN SET(NEWCOUNT) ELSE BEGIN MVI("(",BDI); DI := @BDI(1); END; R0 := R0 AND #FFFF; CVD(R0,PKDEC); UNPK(3,7,BUFFER(0),PKDEC); ZONE(BUFFER(3)); IF TOKEN = SEMICOLCODE THEN DECR(SI); END; X1: IF NEWTAB THEN CLEARBUFFER; IF TOKEN = ENDCODE THEN SET(NEWTAB); GET; IF TOKEN = STOPCODE THEN GOTO X2; R0 := R0-R0; IF NEWTAB THEN BEGIN T := TOKEN SHLA 1; IC(R0,SPACESAFTER(T)); IF R0 < 4 THEN CLEARBUFFER; R0 := R0-R0; END; T := TOKEN SHLA 1; IC(R0,SPACESBEFORE(T)); IF R0 = 9 THEN BEGIN IF ~TRACING THEN CLEARBUFFER; R0 := 0; END; IF EMPTY THEN SETPUNC; L: T := R0 + N; R1 := @BDI(T+1); IF R1 <= DIMAX THEN BEGIN DI := DI + R0; EX(N,MVC(0,BDI,BII)); DI := @BDI(N+1); END ELSE IF ~EMPTY THEN BEGIN INTEGER SAVE; SAVE := R0; R0 := 0; R1 := 12; WHILE R1 > 0 DO IF R0 = MARK(R1) THEN R1 := R1 - 4 ELSE BEGIN R0 := MARKCOORD(R1); R1 := MARK(R1); GOTO X; END; X: IF R1 = DI OR R1 = 0 THEN CLEARBUFFER ELSE SHIFTBUFFER; SETPUNC; R0 := SAVE; GOTO L; END ELSE BEGIN DI := DI + R0; WHILE N >= 0 DO BEGIN IF DI >= DIMAX THEN BEGIN CLEARBUFFER; MVI("&",BUFFER(8)); DI := @BUFFER(28); END; IC(R1,BII(0)); STC(R1,BDI(0)); RESET(EMPTY); II := @BII(1); DI := @BDI(1); DECR(N); END; IF DI < TABSTOP THEN DI := TABSTOP; END; RESET(EMPTY); T := TOKEN SHLA 1; IC(R0,SPACESAFTER(T)); IF R0 < 4 THEN DI := DI + R0 ELSE BEGIN T := R0; R0 := R0 SHRA 2; DI := DI + R0; MARK(T) := DI; R0 := COORDNO; MARKCOORD(T) := R0; END; GOTO X1; X2: IF ~TRACING THEN BEGIN T := COORDNO + 1; COORDNO := T; IF T = ERRLOC THEN MVI(#03,ERRSTATE); END ELSE BEGIN TM(#80,PROGPOINT); IF OVERFLOW THEN BEGIN R1 := @BDI(1); IF R1 > DIMAX THEN CLEARBUFFER; MVI(")",BDI); RESET(EMPTY); END; END; CLEARBUFFER; R1 := SI; Z: END; LM(R2,R14,SAVEREG); END; GLOBAL PROCEDURE AWXERROR(R2); COMMENT *** RUNERROR *** ; BEGIN ARRAY 16 LOGICAL GPR; COMMENT MACHINE REGISTER IMAGE; ARRAY 16 LOGICAL SAVEAREA; COMMENT LOCAL REGISTER DUMP; ARRAY 8 SHORT INTEGER IR; COMMENT INSTRUCTION REGISTER; LOGICAL RESTARTLOC; SEGMENT BASE R11; LOGICAL SAVER1, SAVER2, SAVER3, SAVEL; INTEGER ERRKIND, ERRPLACE, ERRCOORD, SEGBASE; BYTE CONFUSED, SETIT, IMPRECISE; 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); SHORT INTEGER NTLINK SYN 14; COMMENT NTLINK IN RECTAB ENTRY; SHORT INTEGER DIDNO SYN 0, DNTLEN SYN 2; COMMENT NAME TABLE ENTRY FORMAT; SHORT INTEGER IDLOC2 SYN 0, IDNO SYN 2; BYTE TYPE SYN 4, NDIMEN SYN 5, NFIELDS SYN 5; SHORT INTEGER SIMTYPECODES SYN 6; BYTE SIMTYPE SYN 6, SIMTYPEINFO SYN 7; ARRAY 48 LOGICAL REGSTATUSINFO; ARRAY 48 LOGICAL RSILOC SYN REGSTATUSINFO; COMMENT SYMBOLIC REGISTER DESCRIPTOR (RSI) FORMAT; BYTE RSICODE SYN 0; COMMENT TYPE BITS; INTEGER RSIPOINTER SYN 8; COMMENT STACK/RECORD POINTER; SHORT INTEGER RSIOFFSET SYN 2; COMMENT DISPL; SHORT INTEGER RSITYPES SYN 2; COMMENT TYPE/LEN (IMMEDIATE); INTEGER RSIINDEX SYN 4; COMMENT ARRAY INDEX VALUE; BYTE RSISUBSTR SYN 1; COMMENT SUBSTRING ORIGIN; ARRAY 132 BYTE WORKAREA SYN MLINE; ARRAY 12 CHARACTER WBUF; ARRAY 3 SHORT INTEGER MOVESTRING = (#D200S,@BDI,@B2), MOVEINDEX = (#D200S,@BDI,@B1), MOVEIMAG = (#D200S,@BDI(2),@B2), DEFTEST = (#D500S,@B2(1),@B2); ARRAY 10 BYTE FIELDSIZE = (0,12,14,22,30,46,6,0,10,15); ARRAY 10 BYTE SITYPELEN = (0,3,3,7,7,15,0,0,3,3); ARRAY 12 CHARACTER INTPATTERN = (" ",9(#20),#21,#20); ARRAY 0 LOGICAL IDDIR SYN B12; SHORT INTEGER IDLENGTH SYN IDDIR(0); SHORT INTEGER IDPOINT SYN IDDIR(2); 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 CLEAR(LINK); BEGIN SET(EMPTY); R0 := LMARGIN; TABSTOP := R0; R0 := @TBUF; WRITE; MVC(131,TBUF,BLANK); END; PROCEDURE GETSPACE(LINK); BEGIN DI := TABSTOP; R0 := DI + N; IF R0 > RMARGIN AND ~EMPTY THEN BEGIN LOGICAL T; T := LINK; CLEAR; LINK := T; DI := LMARGIN; R0 := DI + N; END; TABSTOP := R0; RESET(EMPTY); END; PROCEDURE EDITINDEX(R3); BEGIN CVD(R0,PKDEC); MVC(11,WBUF,INTPATTERN); R1 := @WBUF(11); EDMK(11,WBUF,PKDEC(2)); IF R0 < 0 THEN BEGIN DECR(R1); MVI("-",B1); END; R2 := @WBUF(11) - R1; EX(R2,MOVEINDEX); DI := DI + R2; END; PROCEDURE DUMPVALUE(LINK); COMMENT R1 = (TYPE,LENGTH), R2 = ADDR OF VALUE; BEGIN INTEGER SAVER2; LONG REAL SF01, SF23; REAL RB2 SYN B2; LONG REAL LRB2 SYN B2; CLI(#FB,B2); IF = THEN BEGIN COMMENT CHECK FOR UNDEFINED VALUE; R3 := R1 AND #FF; IF ~= THEN BEGIN COMMENT ALL TRAILING BYTES MUST AGREE; DECR(R3); EX(R3,DEFTEST); END; IF = THEN BEGIN MVI("?",BDI(0)); GOTO X; END; END; R3 := R1 SHRL 8; COMMENT SIMPLE TYPE; CASE R3 OF BEGIN BEGIN COMMENT INTEGER; R0 := B2(0); EDITINDEX; END; BEGIN COMMENT REAL; SF01 := F01; SF23 := F23; F0 := RB2(0); R0 := R0-R0; R2 := 14; AWXEDITR; EX(R3,MOVESTRING); F01 := SF01; F23 := SF23; DI := DI + R3; END; BEGIN COMMENT LONG REAL; SF01 := F01; SF23 := F23; F01 := LRB2(0); R0 := #FF; R2 := 22; AWXEDITR; EX(R3,MOVESTRING); F01 := SF01; F23 := SF23; DI := DI + R3; END; BEGIN COMMENT COMPLEX; SF01 := F01; SF23 := F23; SAVER2 := R2; F0 := RB2(0); R0 := R0-R0; R2 := 14; AWXEDITR; EX(R3,MOVESTRING); DI := @BDI(R3+2); R2 := SAVER2; F0 := RB2(4); IF F0 < 0.0 THEN MVI("-",BDI(0)) ELSE MVI("+",BDI(0)); F0 := ABS F0; R0 := R0-R0; R2 := 14; AWXEDITR; EX(R3,MOVEIMAG); DI := @BDI(R3+3); MVI("I",BDI(0)); F01 := SF01; F23 := SF23; END; BEGIN COMMENT LONG COMPLEX; SF01 := F01; SF23 := F23; SAVER2 := R2; F01 := LRB2(0); R0 := #FF; R2 := 22; AWXEDITR; EX(R3,MOVESTRING); DI := @BDI(R3+2); R2 := SAVER2; F01 := LRB2(8); IF F01 < 0L THEN MVI("-",BDI(0)) ELSE MVI("+",BDI(0)); F01 := ABS F01; R0 := #FF; R2 := 22; AWXEDITR; EX(R3,MOVEIMAG); DI := @BDI(R3+3); MVI("I",BDI(0)); F01 := SF01; F23 := SF23; END; BEGIN COMMENT LOGICAL; CLI(#01,B2(0)); IF = THEN BEGIN MVC(3,BDI(0),"TRUE"); DI := @BDI(3); END ELSE BEGIN MVC(4,BDI(0),"FALSE"); DI := @BDI(4); END; END; BEGIN COMMENT STRING; LOGICAL LSAVE; LSAVE := LINK; N := R1 AND #FF; COMMENT LENGTH; R1 := RMARGIN - DI - 3; COMMENT MAX LENGTH THIS LINE; IF R1 < N THEN BEGIN CLEAR; DI := LMARGIN; RESET(EMPTY); END; MVI("""",BDI); DI := @BDI(1); R1 := RMARGIN - DI - 1; IF R1 > N THEN R1 := N; EX(R1,MOVESTRING); DI := @BDI(R1+1); IF DI >= RMARGIN THEN BEGIN R2 := @B2(R1+1); CLEAR; DI := LMARGIN; N := N-R1-1; R1 := RMARGIN - LMARGIN - 1; WHILE N >= R1 DO BEGIN EX(R1,MOVESTRING); CLEAR; R2 := @B2(R1+1); N := N-R1-1; DI := LMARGIN; END; IF N >= 0 THEN BEGIN EX(N,MOVESTRING); DI := @BDI(N+1); END; RESET(EMPTY); R0 := RMARGIN; TABSTOP := R0; END; MVI("""",BDI); LINK := LSAVE; END; BEGIN COMMENT BITS; UNPK(8,4,BDI(1),B2(0)); TR(7,BDI(1),TRTABLE(_240)); MVI("#",BDI(0)); MVI(" ",BDI(9)); DI := @BDI(8); END; BEGIN COMMENT REFERENCE; R3 := B2(0); AWXEDITP; EX(R3,MOVESTRING); DI := DI+R3; END; END; X: END; PROCEDURE EDITRSI(LINK); COMMENT DISPLAY CONTENTS OF CELL DEFINED BY RSI(I). R0 = EDITING CODE, I = RSI INDEX, NTX = NAME TABLE PTR; BEGIN LOGICAL LSAVE; SHORT INTEGER TYPES; BYTE PRIME; INTEGER SUBLEN, SUBLOC, SUBSTRLEN, SUBSTRLOC, OPCODE, PREFIX; LSAVE := LINK; OPCODE := R0; IF R0 >= 0 THEN N := R0 + 6 ELSE BEGIN R1 := NEG R0; COMMENT PREFIX NTX; PREFIX := R1; R2 := IDNO(R1); N := IDLENGTH(R2) + 9; END; TM(#40,RSICODE(I)); IF = THEN BEGIN R2 := IDNO(NTX); N := N + IDLENGTH(R2); TM(#20,TYPE(NTX)); IF = THEN RESET(PRIME) ELSE BEGIN SET(PRIME); N := N + 1; END; END; DI := @WORKAREA; IC(R0,RSICODE(I)); R0 := R0 AND #0C; IF R0 = #08 THEN BEGIN COMMENT ARRAY ELEMENT; INTEGER POLYVAL, IMAX, ISAVE, R2SAVE; COMMENT DEFINE ARRAY DESCRIPTOR (BASE R2); INTEGER ORG SYN B2; INTEGER DELTA SYN B2(4); INTEGER LB SYN B2(8), UB SYN B2(12); ISAVE := I; R0 := R0-R0; IC(R0,NDIMEN(NTX)); R0 := R0-2 * 12S; IMAX := R0; R2 := RSIPOINTER(I) + RSIOFFSET(I); COMMENT @DESCR; R0 := RSIINDEX(I); SRDA(R0,32); R1 := R1/DELTA(0); POLYVAL := R1; SUBLOC := DI; R2SAVE := R2; FOR I := 0 STEP 12 UNTIL IMAX DO BEGIN R0 := R0-R0; R1 := DELTA(I+12)/DELTA(I); R3 := R1; R0 := POLYVAL - LB(I); SRDA(R0,32); R1 := R1/R3; IF R0 < 0 THEN BEGIN R0 := R0 + R3; DECR(R1); END; POLYVAL := R1; R0 := R0 + LB(I); EDITINDEX; MVI(",",BDI(1)); DI := @BDI(2); R2 := R2SAVE; END; R0 := POLYVAL; EDITINDEX; R1 := DI - SUBLOC; SUBLEN := R1; DI := @BDI(1); N := N + R1 + 3; I := ISAVE; END ELSE IF R0 = #04 THEN BEGIN R3 := RSIPOINTER(I); AWXEDITP; SUBLOC := R2; SUBLEN := R3; N := N + R3 + 3; END; TM(#01,RSICODE(I)); IF OVERFLOW THEN BEGIN COMMENT SUBSTR, LENGTH IMPLICIT IN INSTRUCTION; SUBSTRLOC := DI; R0 := R0-R0; IC(R0,RSISUBSTR(I)); EDITINDEX; MVI("|",BDI(1)); DI := @BDI(2); R1 := OPCODE; IF R1 >= 0 THEN BEGIN COMMENT LENGTH IN L1 FIELD OF INSTRUCTION; IC(R0,IR(1)); N := N + R0 + 4; END ELSE BEGIN COMMENT LENGTH IN FPAR NT ENTRY; R1 := PREFIX; IC(R0,SIMTYPEINFO(R1)); END; R1 := R0 OR #0700; TYPES := R1; R0 := R0 + 1; EDITINDEX; R1 := DI - SUBSTRLOC; SUBSTRLEN := R1; N := N + R1 + 3; END ELSE BEGIN TM(#40,RSICODE(I)); IF = THEN R0 := SIMTYPECODES(NTX) ELSE R0 := RSITYPES(I); TYPES := R0; R1 := OPCODE; IF R1 >= 0 THEN BEGIN R1 := R0 SHRL 8; IF R1 ~= 7 THEN IC(R1,FIELDSIZE(R1)) ELSE R1 := R0 AND #FF + 4; N := N + R1; END; END; GETSPACE; R0 := OPCODE; IF R0 < 0 THEN BEGIN R1 := PREFIX; R2 := IDNO(R1); R1 := IDLENGTH(R2); R2 := IDPOINT(R2) + IDLISTBASE; EX(R1,MOVESTRING); DI := @BDI(R1+1); MVC(1,BDI(1),":-"); DI := @BDI(4); END; TM(#40,RSICODE(I)); IF OVERFLOW THEN MVI("#",BDI(0)) ELSE BEGIN R2 := IDNO(NTX); R1 := IDLENGTH(R2); R2 := IDPOINT(R2) + IDLISTBASE; EX(R1,MOVESTRING); DI := @BDI(R1); IF PRIME THEN BEGIN MVI("'",BDI(1)); DI := @BDI(1); END; END; TM(#0C,RSICODE(I)); IF ~= THEN BEGIN MVI("(",BDI(1)); DI := @BDI(2); R1 := SUBLEN; R2 := SUBLOC; EX(R1,MOVESTRING); DI := @BDI(R1+1); MVI(")",BDI); END; TM(#01,RSICODE(I)); IF OVERFLOW THEN BEGIN MVI("(",BDI(1)); DI := @BDI(2); R1 := SUBSTRLEN; R2 := SUBSTRLOC; EX(R1,MOVESTRING); DI := @BDI(R1+1); MVI(")",BDI); END; IF R0 >= 0 THEN BEGIN IF = THEN MVI("=",BDI(2)) ELSE MVC(1,BDI(2),":="); DI := @BDI(4) + R0; R2 := RSIPOINTER(I); TM(#40,RSICODE(I)); IF = THEN R2 := R2 + RSIOFFSET(I); TM(#08,RSICODE(I)); IF OVERFLOW THEN R2 := MEM(R2) + RSIINDEX(I); TM(#01,RSICODE(I)); IF OVERFLOW THEN BEGIN IC(R0,RSISUBSTR(I)); R2 := R2 + R0; END; R1 := TYPES; DUMPVALUE; END; LINK := LSAVE; END; PROCEDURE EDITPROCVALUE(LINK); COMMENT I = PROCEDURE BASE ADDRESS; BEGIN R1 := PROCTYPES(I); IF R1 ~= 0 THEN BEGIN LOGICAL LSAVE; INTEGER PROCID; ARRAY 2 LONG REAL FLR; REAL FL SYN FLR; LSAVE := LINK; R2 := DSEGNT(I) + I; R2 := DIDNO(R2); PROCID := R2; N := IDLENGTH(R2) + 6; R0 := NPARAM(I); IF R0 ~= 0 THEN N := N + 4; R1 := R1 SHRL 8; IF R1 ~= 7 THEN IC(R1,FIELDSIZE(R1)) ELSE BEGIN IC(R1,PROCTYPES(I+1)); R1 := R1 + 4; END; N := N + R1; GETSPACE; R2 := PROCID; R1 := IDLENGTH(R2); R2 := IDPOINT(R2) + IDLISTBASE; EX(R1,MOVESTRING); DI := @BDI(R1+1); R0 := NPARAM(I); IF R0 ~= 0 THEN BEGIN MVC(3,BDI,"(..)"); DI := @BDI(4); END; MVI("=",BDI(1)); DI := @BDI(3); R1 := PROCTYPES(I); R2 := R1 SHRL 8; IF R0 = 0 OR R2 = 6 OR R2 = 7 THEN R2 := GPR(12) ELSE IF R2 = 1 OR R2 > 5 THEN R2 := @GPR(12) ELSE BEGIN FLR(0) := F01; IF R2 = 4 THEN FL(4) := F2 ELSE FLR(8) := F23; R2 := @FLR; END; DUMPVALUE; LINK := LSAVE; END; END; GLOBAL PROCEDURE AWXSIMUL(R1); BEGIN COMMENT TRACING SIMULATOR OF S/360 PROCESSOR; ARRAY 256 BYTE OPSWITCH = (4(0),1,#6F,1,#CA,8(0),8(1),#13,12(1),3(0),13(1),3(0),8(1), 1,#41,3,2,#B,#8D,#FF,9,5(1),0,2(1), 3,3(0),2,1,2(2),#A2,5(2),7,1,2(3,7(0),6(2),2(1)), 6(0),#FF,#C,13(1),2,2(1),#21,39(0), 17(0),1,4,2(1),5,2(1),4(0),4(1),16(0), 0,3(1),4(0),2(1),#12,3(1),2(0)); ARRAY 16 BYTE ILC = (4(2), 8(4), 4(6)); BYTE LHV SYN 6, SUBSTR SYN 8, LIBRCALL SYN 13, INLINE SYN 14, NPACCESS SYN 16, NPCALL SYN 17, COMMA SYN 20, FORSUBR SYN 21, FOREXIT SYN 22, FORMALPROC SYN 23; ARRAY 0 SHORT INTEGER PROGRAM SYN MEM; COMMENT MEMORY; ARRAY 0 INTEGER DISPLAY SYN 40; COMMENT MIN DISPLAY OFFSET; SHORT INTEGER PSI2 SYN PSI(2); SHORT INTEGER CCNTINDEX SYN EXPSI(0), CCORD SYN EXPSI(2); BYTE TAB SYN EXPSI(4); INTEGER EDITIA SYN EXPSI(4); SHORT INTEGER EDITLOC SYN 0; COMMENT EDITCODE INDEX BY BB; BYTE LTAB1 SYN #FB; INTEGER DPDORG=40; SHORT INTEGER INDEXCHECK=@ARRAYERR, CASECHECK=@CASEERR; SHORT INTEGER TRUEINCR=@PL1T, FALSEINCR=@PL1F; SHORT INTEGER COUNTBASE=@FLOWCOUNTS; ARRAY 4 BYTE CCMASK = (#80,#40,#20,#10); FUNCTION SETCC(6,#0500), POINT(6,#0500); FUNCTION BRANCH(8,#47F0); FUNCTION AP(10,#FA00), CP(10,#F900); ARRAY 3 SHORT INTEGER MOVEPARM = (#D200S,@B2,@PROGRAM(IA)), RESTART = (#5810S,@RESTARTLOC, #07F1); ARRAY 2 SHORT INTEGER ORXBYTE = (#9600S,@IR(1)); PROCEDURE EXECUTE(LINK); BEGIN STM(R14,R12,SAVEAREA); SPM(IA); LM(R0,R15,GPR); EX(R0,IR); STM(R0,R15,GPR); LM(R14,R12,SAVEAREA); SETCC(R1); SLDL(R0,8); STC(R0,PSI(SP+4)); END; PROCEDURE MAKERSI(LINK); COMMENT I = RSI INDEX, R1(16:31) = (B,D) ADDRESS; BEGIN R3 := R1 AND #FFF; RSIOFFSET(I) := R3; R1 := R1 SHRL 12 AND #F; R2 := R1 SHLA 2; R2 := GPR(R2); RSIPOINTER(I) := R2; IF R1 >= CLN(PP) THEN BEGIN IF = AND R3 >= VARMAX(PP) THEN MVI(#80,RSICODE(I)) ELSE BEGIN MVI(#00,RSICODE(I)); MVI(#00,RSIPOINTER(I)); END; END ELSE BEGIN CLI(#00,RSIPOINTER(I)); IF ~= THEN MVI(#04,RSICODE(I)) ELSE MVI(#80,RSICODE(I)); END; END; PROCEDURE FETCHSTORE(LINK); COMMENT R0 = EDITING CODE, R1(16:31) = (B,D) ADDRESS; BEGIN LOGICAL LSAVE; LSAVE := LINK; R2 := R1 SHRL 12 AND #F; IF R2 >= 13 THEN GOTO FAIL; R2 := R2*12S; I := @RSILOC(R2); R2 := R1 AND #FFF; IF ~= THEN MAKERSI; TM(#80,RSICODE(I)); IF OVERFLOW THEN GOTO FAIL; TM(#40,RSICODE(I)); IF OVERFLOW THEN GOTO SUCCEED; R1 := RSIOFFSET(I); R2 := RSIPOINTER(I); R3 := R2 SHRL 24; IF R3 ~= #FB THEN BEGIN IF R3 = 0 THEN BEGIN R2 := PB(R2); R2 := R2 + DSEGNT(R2); R3 := DNTLEN(R2); NTX := @B2(4); R3 := @B2(R3+4); END ELSE BEGIN R2 := RECTABBASE; R3 := R3 SHLA 4 + R2; R2 := R2 + NTLINK(R3); R3 := R3-R3; IC(R3,NFIELDS(R2)); R3 := R3 SHLA 3; NTX := @B2(8); R3 := @B2(R3); END; FOR NTX := NTX STEP 8 UNTIL R3 DO IF R1 = IDLOC2(NTX) THEN BEGIN TM(#0C,RSICODE(I)); IF = THEN BEGIN IC(R1,TYPE(NTX)); R1 := R1 AND #F; IF ~= AND R1 ~= 6 AND R0 >= 0 THEN GOTO FAIL; END; GOTO SUCCEED; END; END; GOTO FAIL; SUCCEED: EDITRSI; PP := PB(SP); MVI(";",BDI(1)); DI := @BDI(4); TABSTOP := DI; FAIL: LINK := LSAVE; END; PROCEDURE PROCID(LINK); COMMENT R1 = STACK POINTER, DI = BUFFER POINTER. PP RESET; BEGIN PP := PB(R1); R0 := CLN(PP); TM(#80,THUNK(R1)); IF OVERFLOW THEN R1 := DISPLAY(R1+4); R3 := NPARAM(PP) SHLA 3 + R1; WHILE R0 <= 12 DO BEGIN IF < THEN R1 := DISPLAY(R3) ELSE R1 := GPR(48); PP := PB(R1); R2 := PP + DSEGNT(PP); R2 := DIDNO(R2); TM(#80,THUNK(R1)); IF = AND R2 ~= 0 THEN GOTO X; R0 := R0 + 1; R3 := @B3(4); END; X: R3 := IDLENGTH(R2); R2 := IDPOINT(R2) + IDLISTBASE; EX(R3,MOVESTRING); DI := @BDI(R3+1); R0 := R0-R0; WHILE R1 ~= 0 DO BEGIN IF PP = PB(R1) THEN BEGIN TM(#80,THUNK(R1)); IF = THEN R0 := R0 + 1; END; R1 := DL(R1); END; IF R0 > 1 THEN BEGIN LOGICAL LSAVE; LSAVE := LINK; MVC(5,BDI(1),"(DEPTH"); DI := @BDI(8); EDITINDEX; MVI(")",BDI(1)); DI := @BDI(2); LINK := LSAVE; END; END; PROCEDURE PROCESSSWITCH(LINK); BEGIN PP := PB(SP); R0 := #80; STC(R0,RSILOC(24)); FOR R1 := 48 STEP 12 UNTIL 180 DO STC(R0,RSILOC(R1)); END; PROCEDURE SETTAB(LINK); BEGIN R1 := R1-R1; IC(R1,TAB(SP)); R1 := @TBUF(R1+23); LMARGIN := R1; TABSTOP := R1; END; PROCEDURE JUMPBACK(LINK); COMMENT PRINTS MESSAGE TO CLOSE LOOP; BEGIN LOGICAL LSAVE; LSAVE := LINK; IF ~EMPTY THEN CLEAR; PP := PB(SP); R1 := R1-R1; IC(R1,TAB(SP)); R1 := R1-3; STC(R1,TAB(SP)); R0 := @TBUF(R1+23); LMARGIN := R0; TABSTOP := R0; R0 := PSI(SP+4) ++ 2; SETCOORDINATE; R0 := R0 OR #80000000; R1 := EXPSI(SP+4); AWXSEDIT; LINK := LSAVE; END; PROCEDURE NAMEPARAMETER(LINK); BEGIN LOGICAL LSAVE; INTEGER PARMNTX, FORMALTYPE; LSAVE := LINK; PP := PB(SP); IC(R0,PSI2(SP)); R0 := R0 SHRL 4 AND #F - CLN(PP) SHLA 2; R1 := NPARAM(PP) SHLA 3 + R0 + SP; R2 := DISPLAY(R1); COMMENT SEGMENT OF FORMAL ID; R2 := PB(R2); R2 := R2 + DSEGNT(R2); NTX := PSI2(SP) AND #FFF - DPDORG + R2 + 4; IC(R0,TYPE(NTX)); R0 := R0 AND #F; FORMALTYPE := R0; IF ~= AND R0 ~= 2 THEN MVI(#80,RSILOC(36)) ELSE BEGIN PARMNTX := NTX; COMMENT NAME TABLE INDEX; TM(#C0,PSI(SP)); IF < THEN MVI(#40,RSILOC(36)); R0 := NEG NTX; R1 := #3000; FETCHSTORE; NTX := PARMNTX; I := @RSILOC(36); TM(#40,RSICODE(I)); IF OVERFLOW THEN BEGIN COMMENT PARAMETER IS EXPR; R0 := R0-R0; IC(R0,PSI(SP+1)); R1 := FORMALTYPE; IF R1 = 2 THEN MVI(#80,RSILOC(36)) ELSE IF R0 = 0 THEN R0 := SIMTYPECODES(NTX) ELSE BEGIN CLI(#07,SIMTYPE(NTX)); IF = THEN R0 := R0 OR #0700 ELSE IF R0 > 5 THEN R0 := SIMTYPECODES(NTX) ELSE ######## BEGIN R1 := R0; R0 := R0 SHLL 8; IC(R0,SITYPELEN(R1)); END; END; RSITYPES(I) := R0; R0 := GPR(12); RSIPOINTER(I) := R0; END; END; LINK := LSAVE; END; PROCEDURE CHECKLINE(LINK); BEGIN R0 := @LINE; IF R0 ~= PTRSAVE THEN BEGIN CLC(131,LINE,BLANK); IF ~= THEN BEGIN WRITE; MVC(131,LINE,BLANK); PP := PB(SP); END; END; END; PROCEDURE TOPROCEDURE(LINK); COMMENT R2 = IDNO OF PROCEDURE TO BE CALLED; BEGIN LOGICAL LSAVE; LSAVE := LINK; N := IDLENGTH(R2) + 7; GETSPACE; MVC(1,BDI,"->"); R1 := IDLENGTH(R2); R2 := IDPOINT(R2) + IDLISTBASE; EX(R1,MVC(0,BDI(3),B2)); DI := @BDI(R1+4); MVI(";",BDI); LINK := LSAVE; END; PROCEDURE FROMPROCEDURE(LINK); COMMENT RESTORE STATUS, OUTPUT PROC VALUE; BEGIN LOGICAL LSAVE; LSAVE := LINK; SET(TRACING); SP := R2; PROCESSSWITCH; MVI(#80,RSILOC(36)); CHECKLINE; IF EMPTY THEN SETTAB; I := GPR(56); R1 := PROCTYPES(I); IF R1 ~= 0 THEN BEGIN EDITPROCVALUE; PP := PB(SP); MVI(";",BDI(1)); DI := @BDI(4); TABSTOP := DI; END; LINK := LSAVE; END; COMMENT AT ENTRY FROM INTERRUPTION, R8 = ADDR OF PSW, R9 = ADDR OF REGISTER IMAGE; MVC(63,GPR,B9); SP := MP; R0 := R0-R0; R1 := MEM(R8+4); STM(R0,R1,PSI(SP)); OI(#80,RETA(SP)); COMMENT SET INTERPRETING FLAG; CHECKLINE; IF ~EMPTY THEN CLEAR; OI("0",CARRCONT); R12 := IDDIRBASE; SAVEAREA(4) := R15; STM(R11,R12,SAVEAREA(52)); PROCESSSWITCH; MVI(#80,RSILOC(36)); SET(TRACING); R1 := PSI(SP+4); CLC(1,PROGRAM(R1+6),#9812S); IF ~= THEN BEGIN MVC(9,TBUF(0),"=> TRACING"); DI := @TBUF(11); R1 := SP; PROCID; MVI(":",BDI(0)); CLEAR; END; PP := PB(SP); ICYCLE: IA := PSI(SP+4); MVC(5,IR,PROGRAM(IA)); R1 := R1-R1; IC(R1,IR(0)); R0 := R1; R1 := R1 SHRL 4; IC(R1,ILC(R1)); IA := IA ++ R1; PSI(SP+4) := IA; R1 := R0; XCYCLE: IC(R1,OPSWITCH(R1)); IF R1 > #20 THEN BEGIN COMMENT ALGOL W CLICHE, CLASSIFY BY CONTEXT; R2 := R1 SHRL 5; R1 := R1 AND #1F; COMMENT R1 = DEFAULT; CASE R2 OF BEGIN BEGIN COMMENT LM (#98); R0 := IR(0) AND #FF; IF R0 = #34 THEN R1 := @NPACCESS; END; BEGIN COMMENT LA (#41); R0 := IR(2) AND #F000; IF ~= THEN BEGIN R0 := IR(0) AND #000F; IF ~= THEN R1 := @SUBSTR ELSE R1 := @LHV; END; END; BEGIN COMMENT BALR (#05); TM(#04,PSI(SP)); COMMENT TEST FOR FORMAL PROC; IF OVERFLOW THEN R1 := @FORMALPROC ELSE BEGIN R0 := IR(0); IF R0 = #051F THEN BEGIN COMMENT ALGOLRUN SUBROUTINE; IC(R1,PROGRAM(IA)); IC(R1,OPSWITCH(R1)); IF R1 = 0 THEN R1 := @INLINE ELSE R1 := @LIBRCALL; END ELSE IF R0 = #0513 THEN R1 := @NPCALL; END; END; BEGIN COMMENT BAL (#45); R0 := IR(2); IF R0=INDEXCHECK OR R0=CASECHECK THEN R1 := @INLINE ELSE BEGIN R0 := R0 AND #F000; IF R0 >= #E000 THEN R1 := @FORSUBR; END; END; BEGIN COMMENT L (#58) *** TEMPORARY FUDGE *** ; R0 := PROGRAM(IA+4) AND #FFFF; CLI(#E0,IR(1)); IF = OR R0 = #8720 OR R0 = #4700 THEN R1 := 1; END; BEGIN COMMENT BCR (#07); R0 := IR(0); IF R0 = #0700 THEN GOTO ICYCLE; IF R0 = #0701 THEN R1 := @COMMA; IF R0 = #07F2 THEN R1 := @FOREXIT; END; END; END; CASE R1 OF BEGIN BEGIN COMMENT 1 => ADMINISTRATIVE FUNCTIONS, RR OPERATORS; EXECUTE; END; BEGIN COMMENT 2 => RX, SI FORMAT FETCH; IF FETCHFLAG THEN BEGIN R0 := 0; R1 := IR(2); FETCHSTORE; END; EXECUTE; END; BEGIN COMMENT 3 => RX FORMAT STORE; EXECUTE; R0 := 1; R1 := IR(2); FETCHSTORE; END; BEGIN COMMENT 4 => SS FORMAT FETCH/STORE; IF FETCHFLAG THEN BEGIN R0 := 0; R1 := IR(4); FETCHSTORE; END; EXECUTE; R0 := 1; R1 := IR(2); FETCHSTORE; END; BEGIN COMMENT 5 => SS FORMAT FETCH/FETCH; IF FETCHFLAG THEN BEGIN R0 := 0; R1 := IR(2); FETCHSTORE; R0 := 0; R1 := IR(4); FETCHSTORE; END; EXECUTE; END; BEGIN COMMENT 6 => LA (SIMPLE VARIABLE OR FIELD ADDRESS); R1 := IR(0) SHRL 2 AND #3C * 3S; I := @RSILOC(R1); R1 := IR(2) AND #FFFF; IF R1 >= #D000 THEN MVI(#80,RSICODE(I)) ELSE MAKERSI; EXECUTE; END; BEGIN COMMENT 7 => AL (ARRAY ADDRESS GENERATION); R1 := IR(0) SHRL 2 AND #3C; R0 := GPR(R1); R1 := R1*3S; I := @RSILOC(R1); MVI(#08,RSICODE(I)); RSIINDEX(I) := R0; R1 := IR(2); R0 := R1 AND #FFF; RSIOFFSET(I) := R0; R1 := R1 SHRL 10 AND #3C; R1 := GPR(R1); RSIPOINTER(I) := R1; EXECUTE; END; BEGIN COMMENT 8 => LA (SUBSTRING ADDR GENERATION); R1 := IR(0) SHRL 2 AND #3C * 3S; I := @RSILOC(R1); R1 := IR(2) AND #FFF; IF = THEN BEGIN COMMENT COPY EXISTING RSI; R1 := IR(2) SHRL 10 AND #3C * 3S; R1 := @RSILOC(R1); MVC(11,RSICODE(I),RSICODE(R1)); END ELSE BEGIN COMMENT MUST SET UP RSI; R1 := IR(2); MAKERSI; END; OI(#01,RSICODE(I)); R1 := IR(0) AND #F SHLA 2; R0 := GPR(R1); STC(R0,RSISUBSTR(I)); EXECUTE; END; BEGIN COMMENT 9 => BC; IC(R1,PSI(SP+4)); R1 := R1 SHRL 4 AND #3; COMMENT CC; IC(R1,CCMASK(R1)); R0 := IR(0) AND R1; IF = THEN R1 := IA ELSE BEGIN COMMENT SUCCESSFUL BRANCH; R1 := IR(0) AND #F; IF ~= THEN BEGIN COMMENT CASE INDEX; R1 := R1 SHLA 2; R2 := GPR(R1); SAVEAREA(16) := R2; N := 12; GETSPACE; MVC(2,BDI,"* ="); DI := @BDI(4); R0 := R2 SHRA 2; EDITINDEX; MVI(";",BDI(1)); DI := @BDI(4); TABSTOP := DI; R1 := IR(2) AND #1FFF + GPR(56) + SAVEAREA(16); MVC(3,IR,PROGRAM(R1)); COMMENT INDIRECT; END; R1 := IR(2) AND #1FFF + GPR(56); IC(R2,PSI(SP+4)); PSI(SP+4) := R1; STC(R2,PSI(SP+4)); END; CLI(#FA,PROGRAM(R1)); IF = THEN BEGIN COMMENT TEST FOR LOGICAL RESULT; R1 := PROGRAM(R1+4); IF R1 = TRUEINCR THEN BEGIN N := 11; GETSPACE; MVC(8,BDI,"* = TRUE;"); END ELSE IF R1 = FALSEINCR THEN BEGIN N := 12; GETSPACE; MVC(9,BDI,"* = FALSE;"); END; END ELSE BEGIN R1 := PSI(SP+4); R0 := PROGRAM(R1); IF R0 = #47F0 THEN BEGIN R2 := R1; COMMENT UPDATED IA; IF SP ~= MP THEN BEGIN SP := MP; PROCESSSWITCH; END; R1 := PROGRAM(R2+2) AND #1FFF + GPR(56); PSI(SP+4) := R1; R2 := R2 SHRL 24; STC(R2,PSI(SP+4)); END ELSE IF R1 < IA THEN JUMPBACK; END; END; BEGIN COMMENT 10 => BCR; TM(#08,PSI(SP)); IF OVERFLOW THEN BEGIN COMMENT IMPLICIT SUBROUTINE; N := 2; GETSPACE; MVC(1,BDI,">>"); CLEAR; SP := GPR(8); PROCESSSWITCH; SETTAB; NAMEPARAMETER; END ELSE BEGIN COMMENT PROCEDURE; R2 := GPR(8); TM(#80,RETA(R2)); IF = THEN BEGIN N := 3; GETSPACE; MVC(2,BDI,"..."); RESET(TRACING); END; IF ~EMPTY THEN CLEAR; OI("0",CARRCONT); EXECUTE; END; END; BEGIN COMMENT 11 => EXECUTE; R2 := IR(0) SHRL 2 AND #3C; IF ~= THEN R2 := GPR(R2); COMMENT BYTE TO 'OR'; R0 := IR(2); R1 := R0 SHRL 10 AND #3C; R1 := GPR(R1); R0 := R0 AND #FFF; R1 := R1 + R0; MVC(5,IR,B1); EX(R2,ORXBYTE); R1 := R1-R1; IC(R1,IR(0)); GOTO XCYCLE; END; BEGIN COMMENT 12 => BXLE (BXLE 2,0,... ONLY); R0 := GPR(8) + GPR(0); GPR(8) := R0; IF R0 <= GPR(4) THEN BEGIN R1 := IR(2) AND #1FFF + GPR(56); IC(R0,PSI(SP+4)); PSI(SP+4) := R1; STC(R0,PSI(SP+4)); JUMPBACK; END; END; BEGIN COMMENT 13 => ALGOLRUN SUBR (BAL OR BALR); R0 := PSI(SP+4); SPM(R0); EXECUTE; END; BEGIN COMMENT 14 => ALGOLRUN SUBR (INLINE PARAMETER INFO); R1 := R1-R1; IC(R1,IR(0)); IF R1 = #05 THEN R2 := @IR(2) ELSE R2 := @IR(4); IC(R1,PROGRAM(IA)); R1 := R1 SHRL 6; IF R1 >= 2 THEN DECR(R1); R1 := R1 SHLA 1 + 1; EX(R1,MOVEPARM); R2 := @B2(R1+1); MVC(5,B2,RESTART); R1 := R1+1 ++ PSI(SP+4); PSI(SP+4) := R1; SPM(R1); POINT(R1); R1 := @B1(20); COMMENT *** ADDR OF X *** ; RESTARTLOC := R1; STM(R14,R12,SAVEAREA); LM(R0,R15,GPR); BRANCH(IR); X: STM(R0,R15,GPR); LM(R14,R12,SAVEAREA); END; BEGIN COMMENT 15 => ALGOL PROCEDURE CALL (BALR); R2 := GPR(56); R2 := R2 + DSEGNT(R2); R2 := DIDNO(R2); IF R2 ~= 0 THEN TOPROCEDURE; RESET(TRACING); LM(R0,R15,GPR); EX(R0,IR); COMMENT CALL PROCEDURE; STM(R0,R15,GPR); R15 := SAVEAREA(4); LM(R11,R12,SAVEAREA(52)); FROMPROCEDURE; END; BEGIN COMMENT 16 => NAME PARAMETER ACCESS (LM 3,4,...); EXECUTE; COMMENT DPD INFO TO GPR; R1 := IR(2); PSI2(SP) := R1; COMMENT SAVE ADDRESS; TM(#20,GPR(12)); IF OVERFLOW THEN OI(#04,PSI(SP)) ELSE BEGIN R2 := GPR(12); CLC(1,PROGRAM(R2+4),#5830S); IF = THEN OI(#04,PSI(SP)) ELSE BEGIN COMMENT NOT AN ACTUAL PROCEDURE; MVZ(0,PSI(SP),GPR(12)); COMMENT PQ BITS; MVC(0,PSI(SP+1),GPR(16)); COMMENT TYPE/LEN; TM(#80,GPR(12)); COMMENT TEST P BIT; IF = THEN BEGIN COMMENT ADDRESS; TM(#40,GPR(12)); COMMENT TEST Q BIT; IF = THEN BEGIN COMMENT SIMPLE VARIABLE; R1 := GPR(12) AND #FFFFFF; R2 := SP; X: TM(#80,RCOUNT(R2)); IF OVERFLOW OR R2>R1 THEN BEGIN R2 := DL(R2); GOTO X; END; I := @RSILOC(36); MVI(#00,RSICODE(I)); R1 := R1 - R2; RSIPOINTER(I) := R2; RSIOFFSET(I) := R1; END; NAMEPARAMETER; END; END; END; END; BEGIN COMMENT 17 => NAME PARAMETER CALL (BALR); IF EMPTY THEN MVC(3,TBUF(0),BLANK) ELSE CLEAR; GPR(4) := IA; IA := GPR(12); COMMENT DO ALLOCATION; X: MVC(3,IR,PROGRAM(IA)); EXECUTE; IA := IA ++ 4; CLI(#50,IR(0)); IF ~= THEN GOTO X; SP := MP; R0 := #08000000; PSI(SP) := R0; PSI(SP+4) := IA; PROCESSSWITCH; OI(#80,RETA(SP)); COMMENT SET INTERPRETING FLAG; R2 := DL(SP); IC(R0,TAB(R2)); STC(R0,TAB(SP)); N := 73; GETSPACE; MVC(14,BDI(0),"<< PARAMETER IN"); DI := @BDI(16); R1 := GPR(16); PROCID; PP := PB(SP); MVC(1,BDI(1),"AT"); R0 := PSI(SP+4); R1 := GPR(56); SETCOORDINATE; CVD(R0,PKDEC); UNPK(3,7,BDI(4),PKDEC); ZONE(BDI(7)); MVI(":",BDI(8)); DI := @BDI(11); TABSTOP := DI; END; BEGIN COMMENT 18 => AP; R1 := IR(2) AND #FFF + GPR(52); OI(#0C,B1(3)); EX(R0,IR); CP(3,3,B1,TRACELIM); IF > THEN BEGIN TM(#08,PSI(SP)); IF = THEN BEGIN COMMENT NO TRACE FOR NEXT BASIC BLOCK; N := 3; GETSPACE; MVC(2,BDI,"..."); CLEAR; OI("0",CARRCONT); RESET(TRACING); GPR(4) := IA; NI(#7F,RETA(SP)); SPM(IA); LM(R0,R15,GPR); BRANCH(B1); END; END ELSE IF < THEN NI(#F0,B1(3)); IF ~EMPTY THEN CLEAR; PP := PB(SP); R0 := PSI(SP+4) ++ 2; SETCOORDINATE; R1 := IR(2)-COUNTBASE; R2 := R1 SHLL 16; R0 := R0 OR R2; R1 := R1 SHRA 1 + EDDIRBASE; R2 := EDITBASE - EDITLOC(R1); MVC(0,TAB(SP),B2(2)); CLI(LTAB1,B2(3)); IF ~= THEN BEGIN IC(R1,B2(2)); R1 := R1 SHLL 24 OR R2; TM(#01,B2(3)); IF = THEN BEGIN STM(R0,R1,EXPSI(SP)); AWXSEDIT; IC(R0,TAB(SP)); EDITIA(SP) := R1; STC(R0,TAB(SP)); END ELSE AWXSEDIT; END; SETTAB; END; BEGIN COMMENT 19 => LR; IC(R1,IR(1)); R2 := R1 SHRL 4 AND #F; IF R2 < 13 THEN BEGIN R2 := R2*12S; R2 := @RSILOC(R2); R1 := R1 AND #F * 12S; R1 := @RSILOC(R1); MVC(11,RSICODE(R2),RSICODE(R1)); END; EXECUTE; END; BEGIN COMMENT 20 => COMMA (#0701); IF ~EMPTY THEN CLEAR; PP := PB(SP); R0 := PSI(SP+4); SETCOORDINATE; CCORD(SP) := R0; LM(R0,R1,EXPSI(SP)); AWXSEDIT; IC(R0,TAB(SP)); EDITIA(SP) := R1; STC(R0,TAB(SP)); END; BEGIN COMMENT 21 => BAL 1,... (FOR LIST SUBR); GPR(4) := IA; IC(R0,PSI(SP+4)); R1 := IR(2) AND #1FFF + GPR(56); PSI(SP+4) := R1; STC(R0,PSI(SP+4)); END; BEGIN COMMENT 22 => BR 2 (FOR LIST RETURN); R0 := GPR(8); PSI(SP+4) := R0; JUMPBACK; END; BEGIN COMMENT 23 => FORMAL PROCEDURE CALL; NI(#FB,PSI(SP)); IC(R2,PSI2(SP)); R2 := R2 SHRL 2 AND #3C; R2 := GPR(R2); R3 := PB(R2); R3 := R3 + DSEGNT(R3); NTX := PSI2(SP) AND #FFF - DPDORG + R3 + 4; LM(R1,R2,GPR(12)); TM(#20,GPR(12)); COMMENT X BIT; IF = THEN R1 := PROGRAM(R1+6) ELSE R1 := PROGRAM(R1+10); R1 := R1 AND #1FFF + PB(R2); R2 := MEM(R1); COMMENT ACTUAL ENTRY ADDRESS; R2 := R2 + DSEGNT(R2); R2 := DIDNO(R2); R3 := IDNO(NTX); N := IDLENGTH(R2) + IDLENGTH(R3) + 9; GETSPACE; N := IDLENGTH(R3); R1 := IDPOINT(R3) + IDLISTBASE; EX(N,MVC(0,BDI,B1)); DI := @BDI(N+2); MVC(1,BDI,":-"); N := IDLENGTH(R2); R1 := IDPOINT(R2) + IDLISTBASE; EX(N,MVC(0,BDI(3),B1)); DI := @BDI(N+4); MVI(";",BDI); TOPROCEDURE; RESET(TRACING); LM(R0,R15,GPR); EX(R0,IR); COMMENT CALL PROC; STM(R0,R15,GPR); R15 := SAVEAREA(4); LM(R11,R12,SAVEAREA(52)); FROMPROCEDURE; END; END; GOTO ICYCLE; END; GLOBAL PROCEDURE AWXPMDMP(R1); IF DUMPFLAG THEN BEGIN BYTE FOOTNOTE; ARRAY 5 INTEGER TAB; INTEGER TABINDEX; INTEGER SEGID, OLDSEGID; PROCEDURE IDWRITE(LINK); BEGIN R2 := IDPOINT(R1) + IDLISTBASE; R1 := IDLENGTH(R1); EX(R1,MOVESTRING); DI := @BDI(R1+1); END; PROCEDURE ALIGNTAB(LINK); BEGIN DI := @BDI(4); R1 := TABINDEX; L: R1 := R1 + 4; IF R1 > 20 THEN R1 := 4; IF DI <= TAB(R1-4) OR DI > TAB(R1) THEN GOTO L; TABINDEX := R1; DI := TAB(R1); TABSTOP := DI; END; R12 := IDDIRBASE; STM(R0,R14,SAVEAREA); RESET(TRACING); R0 := ERRCOORD; AWXSEDIT; MVC(131,TBUF,BLANK); OI("0",CARRCONT); RESET(FOOTNOTE); R0 := @TBUF(4); LMARGIN := R0; FOR R1 := 0 STEP 4 UNTIL 16 DO BEGIN TAB(R1) := R0; R0 := R0 + 32; END; R0 := @TBUF(132); RMARGIN := R0; CLEAR; OI("0",CARRCONT); MVC(26,TBUF(0),"=> TRACE OF ACTIVE SEGMENTS"); CLEAR; SP := MP; R1 := PB(SP); IF R1 ~= SEGBASE THEN BEGIN OI("0",CARRCONT); MVC(4,TBUF(2),". . ."); CLEAR; END; R1 := PB(SP); R2 := R1 + DSEGNT(R1); R1 := DIDNO(R2); SEGID := R1; S: OI("0",CARRCONT); MVC(15,TBUF(0),"=> SEGMENT NAME:"); DI := @TBUF(18); R1 := SEGID; OLDSEGID := R1; IDWRITE; CLEAR; OI("0",CARRCONT); TM(#80,THUNK(SP)); IF = THEN BEGIN COMMENT BLOCK OR PROCEDURE, HAS LOCAL NT; INTEGER NTLIMIT; BYTE FORTAG; RESET(FORTAG); R2 := PB(SP); R2 := R2 + DSEGNT(R2); R0 := DNTLEN(R2); COMMENT R0 = MAX NT INDEX; R2 := @B2(4); R0 := R0 + R2; NTLIMIT := R0; R0 := R0-R0; R1 := R0; TABINDEX := R0; FOR NTX := R2 STEP 8 UNTIL NTLIMIT DO BEGIN IC(R0,TYPE(NTX)); R0 := R0 AND #1F; IF R0 < #F THEN R1 := R1 + 1; END; IF R1=0 THEN MVC(17,TBUF(2),"NO LOCAL VARIABLES") ELSE MVC(25,TBUF(2),"VALUES OF LOCAL VARIABLES:"); CLEAR; IF R1 > 0 THEN BEGIN RSILOC(8) := SP; COMMENT POINTER FOR RSI(0); FOR NTX := R2 STEP 8 UNTIL NTLIMIT DO BEGIN R0 := R0-R0; IC(R0,TYPE(NTX)); R0 := R0 AND #1F; IF = THEN BEGIN COMMENT SIMPLE VARIABLE; I := @RSILOC(0); MVI(#00,RSICODE(I)); R1 := IDLOC2(NTX); RSIOFFSET(I) := R1; R0 := R0-R0; EDITRSI; ALIGNTAB; END ELSE IF R0 = 2 THEN BEGIN COMMENT ARRAY QUANTITY; INTEGER IMAX, INCR, LIMIT, LAST; COMMENT DOPE VECTOR FORMAT (BASED ON R1); INTEGER ORG SYN B1(0); SHORT INTEGER DELTA SYN B1(6); INTEGER LB SYN B1(8), UB SYN B1(12); IF ~EMPTY THEN CLEAR; R1 := SP + IDLOC2(NTX); R0 := R0-R0; R2 := ORG; IF R2 = UNDEF THEN GOTO X; IC(R0,NDIMEN(NTX)); R0 := R0-1 * 12S; IMAX := R0; R2 := 0; R3 := 0; FOR I := 0 STEP 12 UNTIL IMAX DO BEGIN R0 := LB(I)*DELTA(I); R2 := R2 + R0; R0 := UB(I)*DELTA(I); R3 := R3 + R0; END; R0 := ORG AND #FFFFFF + R3; IF R0 > LIM OR R2 > R3 THEN GOTO X; I := @RSILOC(0); MVI(#08,RSICODE(I)); R0 := IDLOC2(NTX); RSIOFFSET(I) := R0; LAST := R3; R3 := DELTA(0); INCR := R3; R0 := 0; R1 := 32/R3 - 2; IF R1 < 0 THEN R1:=0 ELSE IF R1 > 6 THEN R1:=6; R1 := R1*INCR + R2; IF R1 >= LAST THEN R1 := LAST-INCR; LIMIT := R1; WHILE R2 <= LIMIT DO BEGIN RSIINDEX(I) := R2; R0 := R0-R0; EDITRSI; ALIGNTAB; R2 := RSIINDEX(I) + INCR; END; IF R2 < LAST THEN BEGIN R1 := DI-4; MVC(2,B1,"..."); R2 := LAST; END; RSIINDEX(I) := R2; R0 := R0-R0; EDITRSI; CLEAR; X: END ELSE IF R0 = 6 THEN BEGIN COMMENT CONTROL IDENTIFIER; R2 := SP + IDLOC2(NTX); CLI(#99,B2); IF = THEN BEGIN SET(FORTAG); R0 := B2(0) SHLL 8 SHRA 8; B2(0) := R0; END; I := @RSILOC(0); MVI(#00,RSICODE(I)); R1 := IDLOC2(NTX); RSIOFFSET(I) := R1; R0 := R0-R0; EDITRSI; IF FORTAG THEN BEGIN SET(FOOTNOTE); RESET(FORTAG); MVI("*",BDI(2)); END; ALIGNTAB; END; END; IF ~EMPTY THEN CLEAR; END; END; R1 := DL(SP); TM(#80,RETA(R1)); IF = THEN R0 := RETA(SP) ELSE R0 := PSI(R1+4); PP := PB(R1); SETCOORDINATE; IF R0 >= 0 THEN BEGIN CVD(R0,PKDEC); DI := @TBUF(2); R1 := OLDSEGID; IDWRITE; TM(#80,THUNK(SP)); IF = THEN MVC(17,BDI(1),"WAS ACTIVATED FROM") ELSE MVC(17,BDI(1),"WAS REENTERED FROM"); DI := @BDI(20); R1 := DL(SP); PP := PB(R1); R2 := PP + DSEGNT(PP); R1 := DIDNO(R2); SEGID := R1; IDWRITE; MVC(16,BDI(0),", NEAR COORDINATE"); UNPK(3,7,BDI(18),PKDEC); ZONE(BDI(21)); TM(#80,THUNK(SP)); IF OVERFLOW THEN MVC(22,BDI(22),", TO ACCESS A PARAMETER"); CLEAR; SP := DL(SP); GOTO S; END; IF FOOTNOTE THEN BEGIN OI("0",CARRCONT); MVC(54,TBUF(1), "* LAST VALUE OF CONTROL IDENTIFIER PRIOR TO NORMAL EXIT"); CLEAR; END; LM(R0,R12,SAVEAREA); END; 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; SEGMENT 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; IF TRACING THEN R12 := GPR(48); 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 *** ; BEGIN CLI(2,DEBUGSW); IF > THEN BEGIN IF R3 < 0 THEN R3 := TRACEPARM; IF R3 ~= TRACESTATE THEN BEGIN LOGICAL SAVER1; FUNCTION CLR(1,#1500); SAVER1 := R1; TRACESTATE := R3; IF R3 > 9999999 THEN R3 := 9999999; CVD(R3,PKDEC); MVC(3,TRACELIM,PKDEC(4)); R3 := TRACELIM; R0 := #0000000C; FOR R2 := 0 STEP 4 UNTIL 1788 DO BEGIN R1 := FLOWCOUNTS(R2) OR R0; CLR(R1,R3); IF < THEN R1 := R1 XOR R0; FLOWCOUNTS(R2) := R1; END; R1 := SAVER1; END; END; END; 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); CLI(2,DEBUGSW); IF >= THEN BEGIN SET(COUNTFLAG); IF = THEN R0 := #0000000C ELSE BEGIN CLI(4,DEBUGSW); IF = THEN SET(FETCHFLAG) ELSE RESET(FETCHFLAG); R0 := TRACEPARM; TRACESTATE := R0; IF R0 > 9999999 THEN R0 := 9999999; CVD(R0,PKDEC); MVC(3,TRACELIM,PKDEC(4)); IF R0 = 0 THEN R0 := #0000000C ELSE R0 := #00000000; END; R1 := R0; R2 := R0; R3 := R0; R4 := @FLOWCOUNTS; R5 := R4 + 1776; FOR R4 := R4 STEP 16 UNTIL R5 DO STM(R0,R3,B4); END; 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 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.