SYSTEMROUTINE READ(INTEGER TYPEBND,ADR)
!***********************************************************************
!* THIS ROUTINE IS THE IMP IMPLICITLY SPECIFIED ROUTINE WITH A *
!* %NAME PARAMETER. TYPEBND AND ADR ARE A 64 BIT DESCRIPTOR TO *
!* THE ACTUAL PARAMETER. THE BND FIELD HAS THE TYPE CODE IN IT *
!* (=1 FOR INTEGER =2 FOR REAL). FOR %SHORT %INTEGER, THE *
!* PARAMETER WILL BE A STRING DESCRIPTOR OF LENGTH 2. *
!* *
!* 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. *
!***********************************************************************
INTEGER TYPE,PREC,FLAG,CURSYM; ! FLAG= 0FOR'-',1 FOR '+'
INTEGER IVALUE,PARTYPE
LONGINTEGER LIVALUE
LONGLONGREAL RWORK,SCALE
SWITCH RL(5:7)
FLAG=1; TYPE=0
IF TYPEBND=X'58000002' THEN START
PARTYPE = 1
PREC = 4
FINISH ELSE START
PARTYPE = TYPEBND&7
PREC = (TYPEBND>>27)&7
FINISH
IF TYPEBND=X'20000001' THEN TYPEBND = X'58000002'
CURSYM = NEXT SYMBOL; ! CARE NOT TO READ TERMINATOR
! NOW IGNORE LEADING SPACES
WHILE CURSYM=' ' OR CURSYM=NL CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
REPEAT
IF CURSYM=X'19' THEN SIGNALEVENT 9,1
! RECORD INITIAL MINUS
IF CURSYM='-' THEN FLAG=0 AND CURSYM='+'
! MOVE OVER SIGN ONCE IT HAS
! BEEN RECORDED IN FLAG
IF CURSYM='+' THEN START
CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
REPEAT UNTIL CURSYM#' '
FINISH
IF '0'<=CURSYM AND CURSYM<='9' THEN START
RWORK=CURSYM-'0'; ! KEEP TOTAL IN RWORK
TYPE=1; ! VALID DIGIT
CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
EXIT UNLESS '0'<=CURSYM AND CURSYM<='9'
RWORK=R'41A00000000000000000000000000000'*RWORK C
+(CURSYM-'0');! CONTINUE EVALUATING
REPEAT
FINISH ELSE RWORK=0
IF CURSYM='.' AND PARTYPE=2 THEN START
SCALE=R'41A00000000000000000000000000000'
CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
EXIT UNLESS '0'<=CURSYM AND CURSYM<='9'
TYPE=1
RWORK=RWORK+(CURSYM-'0')/SCALE
SCALE=R'41A00000000000000000000000000000'*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 (CURSYM='@' OR CURSYM='&') AND PARTYPE=2 THEN START
IF TYPE=0 THEN TYPE=1 AND RWORK=1
SKIP SYMBOL; ! MOVE PAST THE '@'
READ(X'29000001',ADDR(IVALUE));! RECURSIVE CALL TO FIND EXPONENT
IF IVALUE=-99 THEN RWORK=0 ELSE C
RWORK=RWORK*R'41A00000000000000000000000000000'**IVALUE
FINISH
SIGNALEVENT 4,1 IF TYPE=0; ! NO VALID DIGIT FOUND
!
! KNOCK NUMBER INTO RIGHT FORM
!
IF PARTYPE=1 THEN START
IF PREC = 6 THEN START
LIVALUE = LINT(RWORK)
IF FLAG=0 THEN LIVALUE = - LIVALUE
*LSD_LIVALUE
*ST_(TYPEBND)
RETURN
FINISH
IVALUE= INT(RWORK)
IF FLAG=0 THEN IVALUE=-IVALUE
! If %HALF %INTEGERs were signed, we would have to include
! the following code to recognise 'capacity exceeded':
! %IF PREC=4 %THEN %START
! %IF X'0001FFFF'#IVALUE>>15#0 %THEN %START
! ! Force 'capacity exceeded':
! IVALUE = IVALUE ! X'FFFF0000'
! %FINISH %ELSE %START
! ! Avoid 'capacity exceeded' if it's negative:
! IVALUE = IVALUE & X'0000FFFF'
! %FINISH
! %FINISH
!
*LSS_IVALUE
*ST_(TYPEBND)
RETURN
FINISH
IF PARTYPE#2 THEN PSYSMES (X'80000000',338)
IF FLAG=0 THEN RWORK=-RWORK
IF PREC<5 THEN PREC = 5
-> RL(PREC)
RL(5): ! 32 BIT REAL
*LSD_=X'7F'; *USH_=25
*OR_=1; *USH_=31; ! ACC=X'7F00000080000000'
*AND_RWORK; *RAD_RWORK; ! SOFTWARE ROUND
*STUH_(TYPEBND)
RETURN
RL(6): ! 64 BIT REAL
*LSD_=X'7F'; *USH_=56; *AND_RWORK
*SLSD_=1; *USH_=55; *AND_RWORK+8
*LUH_TOS ; *RAD_RWORK; ! SOFTWARE ROUND
*STUH_(TYPEBND)
RETURN
RL(7): ! 128 BIT REAL
*LSQ_RWORK
*ST_(TYPEBND)
!
! %MONITOR (N) == FORCE FAULT NO N
! N=16 REAL INSTEAD OF INTEGER IN DATA
! N=14 SYMBOL IN DATA
!
END
! %CONSTLONGREAL IMAX=2147483647; ! MAX INTEGER FOR 32 BIT WORD
! NEEDS CHANGING FOR OTHER WLENGT
CONSTLONGREAL DZ=0
SYSTEMLONGREALFN FRACPT(LONGREAL X)
!***********************************************************************
!* RETURNS (X-INTPT(X)) AS THE RESULT *
!***********************************************************************
RESULT =X-INTPT(X)
END
ROUTINESPEC PRINTFL(LONGREAL X,INTEGER N)
SYSTEMROUTINE PRINT(LONGREAL X,INTEGER N,M)
!***********************************************************************
!* PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL *
!* POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES *
!* UNLESS (M=0) WHEN (N+1) PLACES ARE REQUIRED. *
!* *
!* A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY *
!* AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS *
!***********************************************************************
LONGREAL ROUND
LONGLONGREAL Y,Z
STRING (127)S
INTEGER I,J,L,SIGN,SPTR
M=M&63; ! DEAL WITH STUPID PARAMS
IF N<0 THEN N=1 ELSE START
IF N>31 THEN START
SPACES (N-31)
N = 31
FINISH
FINISH
X=X+DZ; ! NORMALISE
SIGN=' '; ! '+' IMPLIED
IF X<0 THEN SIGN='-'
Y=MOD(X); ! ALL WORK DONE WITH Y
IF Y>1@15 OR N=0 THEN START ; ! MEANINGLESS FIGURES GENERATED
IF N>M THEN M=N; ! FOR FIXED POINT PRINTING
PRINT FL(X,M); ! OF ENORMOUS NUMBERS
RETURN ; ! SO PRINT IN FLOATING FORM
FINISH
IF M<=20 THEN ROUND=1/(2*TENPOWERS(M)) ELSE C
ROUND= 0.5/R'41A00000000000000000000000000000'**M;! ROUNDING FACTOR
Y=Y+ROUND
->FASTPATH IF N+M<=16 AND Y<TENPOWERS(N)
I=0;Z=1
CYCLE ; ! COUNT LEADING PLACES
I=I+1;Z=10*Z; ! NO DANGER OF OVERFLOW HERE
REPEAT UNTIL Z>Y
SPTR=1
WHILE SPTR<=N-I CYCLE
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=SIGN
SPTR=SPTR+1
J=I-1; Z=R'41A00000000000000000000000000000'**J
CYCLE
CYCLE
L=INT PT(Y/Z); ! OBTAIN NEXT DIGIT
Y=Y-L*Z;Z=Z/10; ! AND REDUCE TOTAL
CHARNO(S,SPTR)=L+'0'
SPTR=SPTR+1
J=J-1
REPEAT UNTIL J<0
IF M=0 THEN EXIT ; ! NO DECIMAL PART TO BE O/P
CHARNO(S,SPTR)='.'
SPTR=SPTR+1
J=M-1; Z=R'41A00000000000000000000000000000'**(J-1)
M=0
Y=10*Y*Z
REPEAT
LENGTH(S)=SPTR-1
-> OPUT
FASTPATH: ! USE SUPK WITHOUT SCALING
L=M+N+2; ! NO OF BYTES TO BE OPUT
IF M=0 THEN L=L-1
Y=Y*TENPOWERS(M); ! CONVERT TO INTEGER
J=N-1
I=30-M-N; ! FOR DECIMAL SHIFT
*LSQ_Y
*FIX_B
*MYB_4
*ISH_B
*CDEC_0
*LD_S
*LB_L
*MVL_L =1; ! LENGTH INTO STRING
*DSH_I
*CPB_B ; ! SET CC=0 FOR SUPK
*LDB_J
*JAT_11,6; ! TILL SUPK FIXED!
*SUPK_L =DR ,0,32; ! UNPACK WITH LEADING SPACES
*JCC_7,<DESSTACKED>
*STD_TOS ; ! FOR SIGN INSERTION
DESSTACKED:
*LDB_2
*SUPK_L =1,0,32
*SUPK_L =1,0,48; ! FORCE ZERO BEFORE DP
*SLD_TOS
*LB_SIGN
*STB_(DR ); ! INSERT SIGN
*LB_46; ! ISO DECIMAL POINT
*LD_TOS
*LDB_M
*JAT_11,<NOFRPART>; ! INTEGER PRINTING
*STB_(DR )
*INCA_1
*SUPK_L =DR ,0,48; ! ZEROFILL
NOFRPART:
*LDB_(S)
*INCA_1
*ANDS_L =DR ,0,63; ! FORCE ISO ZONE CODES
OPUT:
J=IOCP(15,ADDR(S))
END ; ! OF ROUTINE PRINT
!8
SYSTEMROUTINE WRITE(INTEGER VALUE,PLACES)
STRING (16)S
INTEGER D0,D1,D2,D3,L
IF PLACES>14 THEN START
SPACES (PLACES-14)
PLACES = 14
FINISH
*LSS_VALUE; *CDEC_0
! Acc is now 64 bits, holding the value as a packed decimal
! number, i.e. 15 decimal digits coded in binary in 4 bits
! each, followed by a 'sign' quartet at the least significant
! end. The largest possible absolute value would be 2**31
! which is 2,147,483,648. Hence at least the first five
! quartets must be zero.
*LD_S; *INCA_1; *STD_TOS
! *LD_S gets a byte vector descriptor to the whole of S -
! the bound will be 17 and the address will point to the
! 'length byte'. So DR (and TOS) now point to the text
! field of the IMP string.
*CPB_B ; ! SET CC=0
*SUPK_L =15,0,32; ! UNPACK & SPACE FILL
! Acc is now zero except for the sign quartet which is
! unchanged at the least significant end. The first
! 15 text bytes of S now have the value in unpacked
! decimal format (unsigned). CC will be zero if the
! value is zero, and non-zero otherwise. The unpacked
! decimal string in S will have no leading zeros: leading
! bytes will be X'20' (ISO space) - but the digits will
! be in EBCDIC form, i.e. X'Fn'. If the number is zero,
! then all fifteen bytes will be spaces. If it is not, then
! a descriptor will have been planted on TOS which points
! to the byte immediately preceding the first digit (i.e.,
! to the last of the leading spaces).
!
! D2 will get a (zero length) descriptor to the byte immediately
! after the fifteenth digit - i.e., to the last byte of S.
*STD_D2; *JCC_8,<WASZERO>
!
! If the value was not zero -
! copy the descriptor-to-last-leading-space into D0:
*LD_TOS ; *STD_D0; ! FOR SIGN INSERTION
! restore the descriptor to the first byte of text:
*LD_TOS
! convert digits to ISO:
! (this uses the MASK to clear the top two bits of each byte,
! thus leaving the spaces - X'20' - unchanged, but coverting
! EBCDIC digits X'Fn' to their ISO equivalents X'3n'.)
*MVL_L =15,63,0; ! FORCE ISO ZONE CODES
IF VALUE<0 THEN BYTEINTEGER(D1)='-'; ! D0 is a descriptor
! to the appropriate place for a sign, and D1 is the
! address word of that descriptor.
L=D3-D1; ! L is the number of bytes occupied by significant
! digits with a leading space or sign.
OUT: IF PLACES>=L THEN L=PLACES+1
! D3=D3-L-1
! BYTEINTEGER(D3)=L
! D3=IOCP(15,D3)
! Since we know the characters are all valid, we can use IOCP
! entry point 19 to avoid the checking involved in IOCP 15
! (which is PRINT STRING, i.e. simulating repeated PRINT
! SYMBOLs).
D3 = D3 - L
D2 = L
! D2, D3 are a descriptor to the stuff to be printed. IOCP
! does not mind that the TYPE fields are zero.
D3 = IOCP (19,ADDR(D2))
RETURN
WASZERO:
BYTEINTEGER(D3-1)='0'
L=2; -> OUT
END ; !OF WRITE
!*
SYSTEMROUTINE PRINTFL(LONGREAL XX,INTEGER N)
!***********************************************************************
!* PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE *
!* DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS. *
!* CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X *
!***********************************************************************
STRING (47)S
LONGLONGREAL ROUND,FACTOR,LB,UB,X,Y
INTEGER COUNT,INC,SIGN,L,J
N=N&31
IF N<=20 THEN Y=TENPOWERS(N) ELSE C
Y=TENPOWERS(20)*TENPOWERS(N-20)
ROUND=R'41100000000000000000000000000000'/(2*Y)
LB=1-ROUND; UB=10-ROUND
SIGN=' '
X=XX+DZ; ! NORMALISE
IF X=0 THEN COUNT=-99 ELSE START
IF X<0 THEN X=-X AND SIGN='-'
INC=1; COUNT=0
FACTOR=R'4019999999999999999999999999999A'
IF X<=1 THEN FACTOR=10 AND INC=-1
! FORCE INTO RANGE 1->10
WHILE X<LB OR X>=UB CYCLE
X=X*FACTOR; COUNT=COUNT+INC
REPEAT
FINISH
X=X+ROUND
IF N>16 THEN START ; ! TOO BIG FOR CDEC WITHOUT SCALING
LENGTH(S)=N+4
CHARNO(S,1)=SIGN
L=INTPT(X)
CHARNO(S,2)=L+'0'
CHARNO(S,3)='.'
J=1
WHILE J<=N CYCLE
X=(X-L)*10
L=INTPT(X)
CHARNO(S,J+3)=L+'0'
J=J+1
REPEAT
FINISH ELSE START
X=X*Y
J=30-N
*LSQ_X
*FIX_B
*MYB_4
*ISH_B ; ! NOCHECKING NEEDED AS N LIMITED
*CDEC_0; ! GIVES 128 BIT DECIMAL N0
*LB_N
*ADB_4
*LD_S
*MVL_L =1; ! LENGTH INTO STRING
*DSH_J
*LB_SIGN
*MVL_L =1; ! SIGN INTO STRING
*SUPK_L =1,0,48; ! FIRST DIGIT INTO STRING
*MVL_L =1,0,46; ! DOT INTO STRING
*LDB_N
*SUPK_L =DR ,0,48; ! UNPACK FR PT &ZEROFILL
*LDB_(S)
*INCA_1
*ANDS_L =DR ,0,63; ! FORCE ISO ZONE CODES
FINISH
CHARNO(S,N+4)='@'
J=IOCP(15,ADDR(S))
WRITE(COUNT,2)
END ; ! OF ROUTINE PRINTFL