!Modified RRM 24/6/82 to remove functions which are common to
!ALGOL and IMP. These are now in a file with name AIROUTnnS, which must
!be used in conjuction with this. The functions moved are:
!S#ISIN,S#ICOS,S#ILOG,S#ISQRT,S#IEXP,S#ITAN
!***********************************************************************
!* NOTE WELL *
!* AFTER COMPILING THIS FILE THE FOLLOWING ALIASES MUST BE ADDED *
!* S#PRINT1900=ICL9CEPRINT1900 & S#READ1900=ICL9CEREAD1900 *
!***********************************************************************
!* MODIFIED 28.4.80 TO ALLOW FOR EBCDIC STRINGS
!* MODIFIED 10.3.80 TO REMOVE SQ AND DA
!* MODIFIED 6.3.80 BY LCG WITH PDS'S READ1900 AND WRITETEXT ROUTINES
!* MODIFIED 03/05/79 MLIBERR INSERTED
!* MODIFIED 16/04/79 LENGTH CHANGED
!* MODIFIED 17/01/79 NEW VERSION OF WRITETEXT
!* MODIFIED 20/02/78 ERROR MESSAGE VALUES
!* MODIFIED 8/11/77 READ1900 IGNORES MULTIPLE SP & NL AFTER EXP CHAR
!* MODIFIED 13/01/77 SET MARGINS
!* MODIFIED 03/12/76 NEW VERSIONS OF READ1900,WRITETEXT
!******** MODIFIED 02:07:76 15.15 LCG (ALGLRTS,MATHFNS CONCATONATED
! ,COMPLEX ROUTINES
! & DUPLICATES FOR FORTRAN)
SYSTEMROUTINESPEC SSERR(INTEGER I)
SYSTEMINTEGERFNSPEC IOCP(INTEGER A,B)
SYSTEMINTEGERMAPSPEC COMREG(INTEGER N)
SYSTEMROUTINESPEC MLIBERR(INTEGER N)
CONSTBYTEINTEGERARRAY ITOETAB(0 : 255) = C
X'00',X'01',X'02',X'03', X'37',X'2D',X'2E',X'2F',
X'16',X'05',X'25',X'0B', X'0C',X'0D',X'0E',X'0F',
X'10',X'11',X'12',X'13', X'3C',X'3D',X'32',X'26',
X'18',X'19',X'3F',X'27', X'1C',X'1D',X'1E',X'1F',
X'40',X'4F',X'7F',X'7B', X'5B',X'6C',X'50',X'7D',
X'4D',X'5D',X'5C',X'4E', X'6B',X'60',X'4B',X'61',
X'F0',X'F1',X'F2',X'F3', X'F4',X'F5',X'F6',X'F7',
X'F8',X'F9',X'7A',X'5E', X'4C',X'7E',X'6E',X'6F',
X'7C',X'C1',X'C2',X'C3', X'C4',X'C5',X'C6',X'C7',
X'C8',X'C9',X'D1',X'D2', X'D3',X'D4',X'D5',X'D6',
X'D7',X'D8',X'D9',X'E2', X'E3',X'E4',X'E5',X'E6',
X'E7',X'E8',X'E9',X'4A', X'E0',X'5A',X'5F',X'6D',
X'79',X'81',X'82',X'83', X'84',X'85',X'86',X'87',
X'88',X'89',X'91',X'92', X'93',X'94',X'95',X'96',
X'97',X'98',X'99',X'A2', X'A3',X'A4',X'A5',X'A6',
X'A7',X'A8',X'A9',X'C0', X'6A',X'D0',X'A1',X'07',
X'20',X'21',X'22',X'23', X'24',X'15',X'06',X'17',
X'28',X'29',X'2A',X'2B', X'2C',X'09',X'0A',X'1B',
X'30',X'31',X'1A',X'33', X'34',X'35',X'36',X'08',
X'38',X'39',X'3A',X'3B', X'04',X'14',X'3E',X'E1',
X'41',X'42',X'43',X'44', X'45',X'46',X'47',X'48',
X'49',X'51',X'52',X'53', X'54',X'55',X'56',X'57',
X'58',X'59',X'62',X'63', X'64',X'65',X'66',X'67',
X'68',X'69',X'70',X'71', X'72',X'73',X'74',X'75',
X'76',X'77',X'78',X'80', X'8A',X'8B',X'8C',X'8D',
X'8E',X'8F',X'90',X'9A', X'9B',X'9C',X'9D',X'9E',
X'9F',X'A0',X'AA',X'AB', X'AC',X'AD',X'AE',X'AF',
X'B0',X'B1',X'B2',X'B3', X'B4',X'B5',X'B6',X'B7',
X'B8',X'B9',X'BA',X'BB', X'BC',X'BD',X'BE',X'BF',
X'CA',X'CB',X'CC',X'CD', X'CE',X'CF',X'DA',X'DB',
X'DC',X'DD',X'DE',X'DF', X'EA',X'EB',X'EC',X'ED',
X'EE',X'EF',X'FA',X'FB', X'FC',X'FD',X'FE',X'FF'
CONSTBYTEINTEGERARRAY ETOITAB(0 : 255) = 0,
1, 2, 3, 156, 9, 134, 127, 151, 141, 142,
11, 12, 13, 14, 15, 16, 17, 18, 19, 157,
133, 8, 135, 24, 25, 146, 143, 28, 29, 30,
31, 128, 129, 130, 131, 132, 10, 23, 27, 136,
137, 138, 139, 140, 5, 6, 7, 144, 145, 22,
147, 148, 149, 150, 4, 152, 153, 154, 155, 20,
21, 158, 26, 32, 160, 161, 162, 163, 164, 165,
166, 167, 168, 91, 46, 60, 40, 43, 33, 38,
169, 170, 171, 172, 173, 174, 175, 176, 177, 93,
36, 42, 41, 59, 94, 45, 47, 178, 179, 180,
181, 182, 183, 184, 185, 124, 44, 37, 95, 62,
63, 186, 187, 188, 189, 190, 191, 192, 193, 194,
96, 58, 35, 64, 39, 61, 34, 195, 97, 98,
99, 100, 101, 102, 103, 104, 105, 196, 197, 198,
199, 200, 201, 202, 106, 107, 108, 109, 110, 111,
112, 113, 114, 203, 204, 205, 206, 207, 208, 209,
126, 115, 116, 117, 118, 119, 120, 121, 122, 210,
211, 212, 213, 214, 215, 216, 217, 218, 219, 220,
221, 222, 223, 224, 225, 226, 227, 228, 229, 230,
231, 123, 65, 66, 67, 68, 69, 70, 71, 72,
73, 232, 233, 234, 235, 236, 237, 125, 74, 75,
76, 77, 78, 79, 80, 81, 82, 238, 239, 240,
241, 242, 243, 92, 159, 83, 84, 85, 86, 87,
88, 89, 90, 244, 245, 246, 247, 248, 249, 48,
49, 50, 51, 52, 53, 54, 55, 56, 57, 250,
251, 252, 253, 254, 255;
CONSTLONGREAL R1=R'41C98867F42983DF'
CONSTLONGREAL R2=R'C2562FB2813C6014'
CONSTLONGREAL R3=R'C1146D547FED8A3D'
CONSTLONGREAL R4=R'C0157BD961F06C89'
CONSTLONGREAL S1=R'421B189E39236635'
CONSTLONGREAL S2=R'4168EE1BDE0C3700'
CONSTLONGREAL S3=R'41224E7F3CBDFE41'
CONSTLONGREAL S4=R'41144831DAFBF542'
CONSTLONGREAL RT3=R'411BB67AE8584CAA'
CONSTLONGREAL PIBY6=R'40860A91C16B9B2C'
CONSTLONGREAL PIBY2M1=R'40921FB54442D184'
CONSTLONGREAL RT3M1=R'40BB67AE8584CAA7'
CONSTLONGREAL TANPIBY12=R'404498517A7B3559'
CONSTLONGREAL PIBY4=R'40C90FDAA22168C2'
CONSTLONGREAL A1=R'40C0000000000000'
CONSTLONGREAL A2=R'3F90FDAA22168C23'
CONSTLONGREAL DEFALLT=R'40B504F333F9DE65'
CONSTLONGREAL MAX=R'4DC90FDAA22168C2'
CONSTLONGREAL GREATEST=R'7FFFFFFFFFFFFFFF'
!*
ROUTINE SELECTINPUT(INTEGER CH)
INTEGER I
I=IOCP(21,CH)
END
ROUTINE SELECTOUTPUT(INTEGER CH)
INTEGER I
I=IOCP(22,CH)
END
SYSTEMLONGREALFN AARCTAN(LONGREAL X1)
LONGREAL XX1, XSQ, CONSTANT
INTEGER SIGN, INV
! CONSTANT=0
! %IF X1<0 %THEN SIGN=1 %AND XX1=-X1 %ELSE SIGN=0 %AND XX1=X1
! %IF XX1>R'4110000000000000' %C
! %THEN XX1=1.0/XX1 %AND INV=1 %ELSE INV=0
! %IF XX1>TANPIBY12 %THEN XX1=(RT3M1*XX1-1.0+XX1)/(XX1+RT3) %AND %C
! CONSTANT=PIBY6
! XSQ=XX1*XX1
! XX1=XX1*(R1/(XSQ+S1+(R2/(XSQ+S2+(R3/(XSQ+S3+(R4/(XSQ+S4))))))) %C
! )+CONSTANT
! %IF INV=1 %THEN XX1=1.0-XX1+PIBY2M1
! %IF SIGN=1 %THEN XX1=-XX1
! %RESULT =XX1
*LSD_0; *ST_CONSTANT; *ST_SIGN
*LB_1; *LSD_X1; *JAF_6,<POS>
*STB_SIGN; *AND_X'7FFFFFFFFFFFFFFF'
POS: *RCP_R'4110000000000000'; *JCC_12,<NOTGZ>
*STB_INV; *RRDV_R'4110000000000000'
NOTGZ: *RCP_TANPIBY12; *JCC_12,<NTP>
*LD_PIBY6; *STD_CONSTANT; ! USE DR SO XX1 STAYS IN ACC
*ST_XX1; *RMY_RT3M1; *RSB_1.0; *RAD_XX1
*SLSD_XX1; *RAD_RT3; *RRDV_TOS
NTP: *ST_XX1; *RMY_XX1; *ST_XSQ
*RAD_S4; *RRDV_R4; *RAD_S3; *RAD_XSQ
*RRDV_R3; *RAD_S2; *RAD_XSQ
*RRDV_R2; *RAD_S1; *RAD_XSQ
*RRDV_R1; *RMY_XX1; *RAD_CONSTANT
*LB_INV; *JAT_12,<INVZ>; *RRSB_1.0; *RAD_PIBY2M1
INVZ: *LB_SIGN; *JAT_12,<SIGNZ>; *RRSB_0
SIGNZ: *EXIT_-64
END
SYSTEMROUTINE ININTEGER(INTEGER CH, INTEGERNAME VAL)
LONGREAL X
IF CH#COMREG(22) THEN SELECT INPUT(CH)
READ(X)
SKIP SYMBOL
VAL=INT(X)
END
SYSTEMROUTINE INREAL(INTEGER CH, LONGREALNAME VAL)
LONGREAL X
IF CH#COMREG(22) THEN SELECT INPUT(CH)
READ(X)
SKIP SYMBOL
VAL=X
END
SYSTEMROUTINE OUTINTEGER(INTEGER CH, VALUE)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
WRITE(VALUE, 10)
PRINTSTRING(";
")
END
SYSTEMROUTINE OUTREAL(INTEGER CH, LONGREAL VALUE)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
PRINTFL(VALUE, 15)
PRINTSTRING(";
")
END
SYSTEMROUTINE OUTTERMINATOR(INTEGER CH)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
PRINTSTRING(";
")
END
SYSTEMLONGREALFN ABS(LONGREAL VALUE)
RESULT =MOD(VALUE)
END
SYSTEMINTEGERFN IABS(INTEGER VALUE)
RESULT =IMOD(VALUE)
END
SYSTEMINTEGERFN SIGN(LONGREAL VALUE)
IF VALUE>0 THENRESULT =1
IF VALUE<0 THENRESULT =-1
RESULT =0
END
SYSTEMLONGREALFN MAXREAL
RESULT =GREATEST
END
SYSTEMLONGREALFN MINREAL
RESULT =R'0010000000000000'
END
SYSTEMINTEGERFN MAXINT
RESULT =X'7FFFFFFF'
END
SYSTEMLONGREALFN EPSILON
RESULT =R'3410000000000000'
END
SYSTEMLONGREALFN ALREAD
LONGREAL X
READ(X)
SKIP SYMBOL
RESULT =X
END
SYSTEMINTEGERFN ANXTSY
RESULT =NEXT SYMBOL
END
SYSTEMINTEGERFN EANXTSY
RESULT =ITOETAB(NEXT SYMBOL)
END
SYSTEMROUTINE APRSYM(INTEGER SYM)
PRINTSYMBOL(SYM)
END
SYSTEMROUTINE EAPRSYM(INTEGER SYM)
PRINTSYMBOL(ETOITAB(SYM&255))
END
SYSTEMROUTINE ARDSYM(INTEGERNAME SYM)
INTEGER S
READSYMBOL(S)
*LSS_S; *LD_SYM; *ST_(DR );
END
SYSTEMROUTINE EARDSYM(INTEGERNAME SYM)
INTEGER S
READSYMBOL(S)
S=ITOETAB(S)
*LSS_S; *LD_SYM; *ST_(DR )
END
SYSTEMROUTINE ALGPTH
NEWPAGE
END
SYSTEMROUTINE PRSTNG(STRINGNAME S)
STRING (255)P, Q
P=S
P=P." ".Q WHILE P->P.("_").Q
P=P."
".Q WHILE P->P.("¬").Q
PRINTSTRING(P)
END
SYSTEMROUTINE EPRSTNG(LONGINTEGER EBSTRING)
INTEGER I,J,L,AD
L=EBSTRING>>32&X'FFFF'
AD<-EBSTRING
RETURN IF L=0
CYCLE I=0,1,L-1
J=ETOITAB(BYTEINTEGER(AD+I))
IF J='_' THEN J=' '
IF J='¬' THEN J=NL
PRINTCH(J)
REPEAT
END
SYSTEMROUTINE ASELIN(INTEGER CH)
SELECT INPUT(CH)
END
SYSTEMROUTINE ASELOU(INTEGER CH)
SELECT OUTPUT(CH)
END
SYSTEMROUTINE ALGNWL
NEWLINE
END
SYSTEMROUTINE ALGSPC
SPACE
END
SYSTEMROUTINE ALGNLS(INTEGER N)
NEWLINES(N)
END
SYSTEMROUTINE ALGSPS(INTEGER N)
SPACES(N)
END
SYSTEMINTEGERFN LENGTH(STRINGNAME S)
RESULT = BYTEINTEGER(ADDR(S))
END
SYSTEMINTEGERFN ELENGTH(LONGINTEGER EBSTRING)
INTEGER I
I=EBSTRING>>32&X'FFFF'
RESULT =I
END
SYSTEMROUTINE INSYMBOL(INTEGER CH,STRINGNAME S, INTEGERNAME CHAR)
STRING (1)ITEM
STRING (65)S1, S2
INTEGER I
IF CH#COMREG(22) THEN SELECT INPUT(CH)
READ ITEM(ITEM)
IF S->S1.(ITEM).S2 THEN CHAR=LENGTH(S1)+1 ANDRETURN
I=CHARNO(ITEM, 1)
IF (' '<=I<='Z' AND I#34) OR I=92 OR I=95 OR I=126 OR C
I=10 THEN CHAR=-I ELSE CHAR=0
END
SYSTEMROUTINE EINSYMBOL(INTEGER CH,LONGINTEGER EBSTRING, C
INTEGERNAME CHAR)
INTEGER I,L,ITEM,EITEM,AD
IF CH#COMREG(22) THEN SELECT INPUT(CH)
READ SYMBOL(ITEM)
EITEM=ITOETAB(ITEM)
L=EBSTRING>>32&X'FFFF'
I=0; AD<-EBSTRING
WHILE I<L CYCLE
IF EITEM=BYTEINTEGER(AD+I) THEN CHAR=I+1 AND RETURN
I=I+1
REPEAT
IF (' '<=ITEM<='Z' AND ITEM#34) OR ITEM=92 OR ITEM=95 OR C
ITEM=126 OR ITEM=10 THEN CHAR=-EITEM ELSE CHAR=0
END
SYSTEMROUTINE OUTSYMBOL(INTEGER CH,STRINGNAME S, INTEGER CHAR)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
IF 1<=CHAR<=LENGTH(S) THEN PRINTSYMBOL(CHARNO(S, CHAR)) C
ELSE PRINTSYMBOL(-CHAR)
END
SYSTEMROUTINE EOUTSYMBOL(INTEGER CH,LONGINTEGER EBSTRING, C
INTEGER CHAR)
INTEGER L,AD,J
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
L=EBSTRING>>32&X'FFFF'
AD<-EBSTRING
IF 1<=CHAR<=L THEN J=BYTEINTEGER(AD+CHAR-1) ELSE J=(-CHAR)&255
PRINTSYMBOL(ETOITAB(J))
END
SYSTEMINTEGERFN AICODE(STRINGNAME S)
INTEGER I
I=CHARNO(S, 1)
IF I='_' THEN I=' '
IF I='¬' OR S="EL" THEN I=NL
IF S="SS" THEN I='%'
RESULT =I
END
SYSTEMINTEGERFN EAICODE(LONGINTEGER EBSTRING)
INTEGER I,J,L,AD
L=EBSTRING>>32&X'FFFF'
AD<-EBSTRING
I=BYTEINTEGER(AD)
J=BYTEINTEGER(AD+1)
IF I=C'_' THEN RESULT =C' '
IF I=C'¬' OR (L=2 AND I=C'E' AND J=C'L') THEN C
RESULT =ITOETAB(NL)
IF L=2 AND I=J=C'S' THEN RESULT =C'%'
RESULT =I
END
SYSTEMROUTINE OUTSTRING(INTEGER CH,STRINGNAME S)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
PRSTNG(S)
END
SYSTEMROUTINE EOUTSTRING(INTEGER CH,LONGINTEGER EBSTRING)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
EPRSTNG(EBSTRING)
END
SYSTEMROUTINE WRITE TEXT(STRINGNAME TEXT)
CONSTBYTEINTEGERARRAY SUBSTRCH(0:127)=0(48),1(10),0(6),
0(3),2,0(12),3,4,0,5,0,6,0,0,7,8,0(6),
0(3),2,0(12),3,4,0,5,0,6,0,0,7,8,0(6);
CONSTSTRING (3)ARRAY OCHAR(2:8)="
","","'('"," ","')'","{","}";
! C==NEWLINE (CODE=2)
! P==NEWPAGE (CODE=3)
! Q==OPENQUOTE '(' (CODE=4)
! S==SPACE (CODE=5)
! U==UNQUOTE ')' (CODE=6)
! X==OPENQUOTE { (CODE=7)
! Y==CLOSEQUOTE } (CODE=8)
INTEGER I, R, SUCCESS, SYM, TRSYM
BYTEINTEGERARRAY SA(0:255)
STRING (255)S, S1, S3
STRING (3)QU
STRINGNAME S2
STRING (1)BR1, BR2
BR1="{"
BR2="}"
SUCCESS=0
START:
S=TEXT
SA(0)=0
S2==STRING(ADDR(SA(0)))
NEXT:
UNLESS S->S1.(BR1).S2.(BR2).S3 THEN ->FAIL
UNLESS 0<SA(0)<=7 THEN ->ILLEGAL
CYCLE I=1,1,SA(0)
SYM=SA(I); TRSYM=SUBSTRCH(SYM)
->ILLEGAL IF TRSYM=0
REPEAT
SUCCESS=1
PRINTSTRING(S1)
S=S3
R=0
CYCLE I=1, 1, SA(0)
SYM=SA(I); TRSYM=SUBSTRCH(SYM)
IF TRSYM=1 THEN START
R=10*R+SYM-'0'
FINISH ELSE START
QU=OCHAR(TRSYM)
UNTIL R<=0 CYCLE
R=R-1
IF QU="" THEN NEWPAGE ELSE PRINTSTRING(QU)
REPEAT
R=0
FINISH
REPEAT
->NEXT
ILLEGAL: ! SUBSTRING HAS ILLEGAL CONTENTS
PRINTSTRING(S1.BR1.S2.BR2)
S=S3; SUCCESS=1; ->NEXT
FAIL:
IF SUCCESS=1 THEN PRINTSTRING(S) ELSESTART
BR1="<"
BR2=">"
SUCCESS=1
->START
FINISH
END
SYSTEMROUTINE EWRITE TEXT(LONGINTEGER EBSTRING)
INTEGER L,AD,I,LL
STRING (255)S
AD<-EBSTRING
L=EBSTRING>>32&X'FFFF'
AGN:
LL=L
IF LL>255 THEN LL=255
CYCLE I=1,1,LL
CHARNO(S,I)=ETOITAB(BYTEINTEGER(AD+I-1))
REPEAT
CHARNO(S,0)=LL
WRITE TEXT(S)
L=L-LL
AD=AD+LL
->AGN IF L>0
END
SYSTEMLONGREALFN READ1900
!***********************************************************************
!* THIS ROUTINE IS THE 1900 IMPLICITLY SPECIFIED ROUTINE *
!* *
!* THE METHOD USED IS SIMPLE REPEATED MULTIPLICATION USING LONG *
!* REAL VARIABLES. SOME ROUNDING ERRORS ARE INTRODUCED WHICH *
!* COULD BE AVOIDED BY USING PACKED DECIMAL INSTNS WITH NECESSARY*
!* SCALING. *
!***********************************************************************
INTEGERFNSPEC NEXT
INTEGERFNSPEC CHECK EXP
LONGREALFNSPEC GET(INTEGER LEVEL)
INTEGER CURSYM
RESULT =GET(1)
LONGREALFN GET(INTEGER LEVEL)
INTEGER TYPE, IVALUE, FLAG
! FLAG= 0FOR'-',1 FOR '+'
LONGREAL RWORK, SCALE
FLAG=1; TYPE=0
START:CURSYM=NEXT; ! CARE NOT TO READ TERMINATOR
! NOW IGNORE LEADING SPACES
UNLESS LEVEL>1 START
CYCLE
EXITIF '0'<=CURSYM<='9' OR CURSYM='+' OR CURSYM='-' C
OR CURSYM='.' OR CURSYM='@' OR CURSYM='&' C
OR CURSYM=''''
CURSYM=NEXT
REPEAT
FINISH ELSE START
CURSYM = NEXT WHILE CURSYM = NL OR CURSYM = ' '
FINISH
! RECORD INITIAL MINUS
IF CURSYM='-' THEN FLAG=0 AND CURSYM='+'
! MOVE OVER SIGN ONCE IT HAS
! BEEN RECORDED IN FLAG
IF CURSYM='+' THEN CURSYM=NEXT
CURSYM=NEXT WHILE CURSYM=' '
IF '0'<=CURSYM AND CURSYM<='9' THENSTART
RWORK=CURSYM-'0'; ! KEEP TOTAL IN RWORK
TYPE=1; ! VALID DIGIT
CYCLE
CURSYM=NEXT
EXITUNLESS '0'<=CURSYM AND CURSYM<='9'
RWORK=10*RWORK+(CURSYM-'0')
! CONTINUE EVALUATING
REPEAT
FINISHELSE RWORK=0
IF LEVEL>1 THEN ->RETEXP
IF CURSYM='.' THENSTART
SCALE=10
CYCLE
CURSYM=NEXT
EXITUNLESS '0'<=CURSYM AND CURSYM<='9'
TYPE=1
RWORK=RWORK+(CURSYM-'0')/SCALE
SCALE=10*SCALE
REPEAT
FINISH
!
! THE VALUE HAS NOW BEEN READ
! INTO RWORK. THERE MIGHT BE
! AN EXPONENT
! E.G. '1.7@ 10' IS VALID
! DATA FOR READ
!
IF CHECKEXP#0 THENSTART
IF TYPE=0 AND RWORK=0 THEN RWORK=1
IVALUE=INT(GET(2)); ! CALL TO FIND EXPONENT
IF IVALUE = -99 THEN RWORK = 0 ELSE C
RWORK=RWORK*10.0**IVALUE
TYPE=1
FINISH
IF TYPE=0 THEN ->START
RETEXP:
IF FLAG=0 THEN RWORK=-RWORK
RESULT =RWORK
END
INTEGERFN NEXT
INTEGER S
READ SYMBOL(S)
IF S=' ' THEN READ SYMBOL(S)
RESULT =S
END
INTEGERFN CHECKEXP
INTEGER S
RESULT =1 IF CURSYM='@' OR CURSYM='&' OR CURSYM='E'
RESULT =0 UNLESS CURSYM='''' AND NEXTSYMBOL='1'
SKIP SYMBOL; READ SYMBOL(S)
RESULT =0 UNLESS S='0' AND NEXT SYMBOL=''''
SKIP SYMBOL
RESULT =1
END
END
SYSTEMROUTINE PRINT1900(LONGREAL X, INTEGER M, N)
PRINT(X, M, N); SPACES(2)
END
SYSTEMROUTINE OUTPUT(LONGREAL X)
PRINT(X, 0, 10)
PRINTSYMBOL(';')
NEWLINE
END
SYSTEMINTEGERFN READ BOOLEAN
BYTEINTEGERARRAY TORF(0:6)
STRINGNAME S
INTEGER I
S==STRING(ADDR(TORF(0)))
FINDQ:
READSYMBOL(I) UNTIL I=''''
FOUNDQ:
CYCLE I=1, 1, 6
READSYMBOL(TORF(I))
->OUT IF TORF(I)=''''
REPEAT
OUT:
TORF(0)=I
RESULT =-1 IF S="TRUE'"
RESULT =0 IF S="FALSE'"
IF TORF(I)='''' THEN ->FOUNDQ ELSE ->FINDQ
END
SYSTEMROUTINE WRITE BOOLEAN(INTEGER B)
IF B#0 THEN PRINTSTRING("'TRUE' ") ELSE PRINTSTRING("'FALSE' ")
END
SYSTEMROUTINE COPYTEXT(STRINGNAME TEXT)
INTEGER I, J, K, L
L=LENGTH(TEXT)
BEGIN
BYTEINTEGERARRAY T(1:L*2), T1(0:L)
STRINGNAME S
S==STRING(ADDR(T1(0)))
S=TEXT
CYCLE I=1, 2, L*2-1
T(I)=I+2
READSYMBOL(T(I+1))
REPEAT
T(I)=1
I=1
J=1
NEXT:
CYCLE K=1, 1, L
IF T1(K)#T(I+1) THEN ->OUT
I=T(I)
REPEAT
->RET
OUT:
I=T(J)
PRINTSYMBOL(T(J+1))
READSYMBOL(T(J+1))
J=I
->NEXT
RET:
END
RETURN
END
SYSTEMROUTINE ECOPY TEXT(LONGINTEGER EBSTRING)
INTEGER I,AD,L
STRING (255)S
AD<-EBSTRING
L=EBSTRING>>32&X'FFFF'
L=255 IF L>255
CYCLE I=1,1,L
CHARNO(S,I)=ETOITAB(BYTEINTEGER(AD+I-1))
REPEAT
CHARNO(S,0)=L
COPY TEXT(S)
END
SYSTEMINTEGERFN ALRDCH
INTEGER CH
READCH(CH)
RESULT =CH
END
SYSTEMINTEGERFN ALNXCH
RESULT =IOCP(18, 0)
END
SYSTEMROUTINE ALPRCH(INTEGER CH)
PRINTCH(CH)
END
SYSTEMROUTINE ALSKCH
INTEGER CH
READCH(CH)
END
SYSTEMINTEGERFN EALRDCH
INTEGER CH
READCH(CH)
RESULT =ITOETAB(CH)
END
SYSTEMINTEGERFN EALNXCH
RESULT =ITOETAB(IOCP(18,0))
END
SYSTEMROUTINE EALPRCH(INTEGER EBCH)
PRINTCH(ETOITAB(EBCH))
END
SYSTEMROUTINE ALGMON
MONITOR
END
SYSTEMROUTINE CLOSE STREAM(INTEGER STREAM)
INTEGER I
IF STREAM > 98 OR STREAM < 1 OR COMREG(22) = STREAM C
OR COMREG(23) = STREAM THEN SSERR(29)
I=IOCP(16,STREAM)
END
!*
SYSTEMROUTINE AFAULT(STRINGNAME MESSAGE,LONGREAL VALUE)
!*
!*THIS ENABLES AN ALGOL PROGRAM TO TERMINATE WITH A MESSAGE
!* AND DIAGNOSIS AS PER ALGOL 60M REPORT
!*
SELECT OUTPUT(107)
PRINTSTRING("
ALGOL FAULT ".MESSAGE."
PARAMETER = ")
PRINTFL(VALUE,15)
NEWLINE
MONITOR
STOP
END
!
SYSTEMROUTINE EAFAULT(LONGINTEGER EBSTRING,LONGREAL VALUE)
SELECT OUTPUT(107)
PRINTSTRING("
ALGOL FAULT ")
EPRSTNG(EBSTRING)
PRINTSTRING("
PARAMETER = ")
PRINTFL(VALUE,15)
NEWLINE
MONITOR
STOP
END
ENDOFFILE