EXTERNALROUTINE CALCULATOR(STRING (255)S)
!
INTEGER LAST J, J, CH, DEPTH
STRING (1)CHS
STRING (255)PIECE, LINE
LONGREAL CONVERT
!
INTEGER COMMAND NO
CONSTINTEGER TOP COMMAND = 28
CONSTSTRING (7)ARRAY COMMAND(1 : TOP COMMAND) = C
"Q", "QUIT", "?", "HELP", "CLEAR",
"+", "-", "*", "/", "REV", "**",
"DUP", "NEG", "SQRT", "EXP", "LOG", "SIN", "COS", "TAN",
"ARCSIN", "ARCCOS", "ARCTAN",
"HYPSIN", "HYPCOS", "HYPTAN",
"RADIUS", "NOT", "<<"
!
CONSTINTEGER TOP WORK = 8
BYTEINTEGERARRAY WTYPE(1 : TOP WORK)
LONGINTEGERARRAY WI(1 : TOP WORK)
LONGREALARRAYFORMAT WRF(1 : TOP WORK)
LONGREALARRAYNAME WR
!
CONSTINTEGER TOP STACK = 100
BYTEINTEGERARRAY TYPE(0 : TOP STACK)
! 0 = integer
! 1 = real
INTEGER TOS
LONGINTEGERARRAY I(0 : TOP STACK)
LONGREALARRAYFORMAT RF(0 : TOP STACK)
LONGREALARRAYNAME R
!
!
!
CONSTINTEGER TOP ERROR = 21
CONSTSTRING (40)ARRAY ERROR(0 : TOP ERROR) = C
" ",
"workspace is W1 to W8",
"no digits in number!",
"number in wrong format",
"number too big",
"no numbers on stack",
"need at least two numbers on the stack",
"workspace location not initialised",
"SQRT arg negative",
"EXP arg out of range",
"LOG arg negative or zero",
"SIN arg out of range",
"COS arg out of range",
"TAN arg out of range",
"Stack full!!!",
"ARCSIN arg out of range",
"ARCCOS arg out of range",
"ARCTAN args zero",
"HYPSIN arg out of range",
"HYPCOS arg out of range",
"Must be an integer on TOS",
"???"
!
!
!
INTEGER TOPITEM, ITEMCOUNT
BYTEINTEGERARRAY STARTITEM(1 : 32)
BYTEINTEGERARRAY LENGTHITEM(1 : 32)
!
CONSTINTEGER TOPDEPTH = 4
BYTEINTEGERARRAY LEFT(1 : TOPDEPTH)
INTEGERARRAY RIGHT(1 : TOPDEPTH)
!
!
!
ONEVENT 1,5,10 START
TOS = TOS + 1 UNLESS COMMAND NO = 19; ! tan, ie leave operands on stack
J = 4
-> CHECK
FINISH
!
!
!
SYSTEMROUTINESPEC C
ETOI(INTEGER ADR, LEN)
EXTERNALLONGREALFNSPEC C
EXPTEN(LONGREAL X)
SYSTEMSTRING (8)FNSPEC C
HTOS(INTEGER VALUE, PLACES)
DYNAMICLONGREALFNSPEC C
HYPCOS(LONGREAL X)
DYNAMICLONGREALFNSPEC C
HYPSIN(LONGREAL X)
DYNAMICLONGREALFNSPEC C
HYPTAN(LONGREAL X)
SYSTEMSTRINGFNSPEC C
ITOS(INTEGER N)
SYSTEMLONGINTEGERFNSPEC C
LINTPT(LONGLONGREAL X)
EXTERNALLONGREALFNSPEC C
LOGTEN(LONGREAL X)
SYSTEMROUTINESPEC C
MOVE(INTEGER LEN, FROM, TO)
SYSTEMINTEGERFNSPEC C
PSTOI(STRING (63)S)
SYSTEMROUTINESPEC C
UCTRANSLATE(INTEGER ADR, LEN)
!
CONSTSTRINGNAME DATE = X'80C0003F'
CONSTSTRINGNAME TIME = X'80C0004B'
!
!
!
INCLUDE "CONLIB.VVP_VVPSPECS"
INCLUDE "CONLIB.VVP_VVPFORMATS"
!
!
CONSTLONGREAL DZ=0
CONSTLONGREALARRAY TENPOWERS (0:20) = 1,10,100,1000,1@4,1@5,1@6,
1@7,1@8,1@9,1@10,1@11,1@12,
1@13,1@14,1@15,1@16,1@17,
1@18,1@19,1@20
!
STRINGFN SWRITE(LONGINTEGER VALUE,PLACES)
STRING (32)S
INTEGER D0,D1,D2,D3,L
STRING (255)W
W = ""
WHILE PLACES > 19 CYCLE
PLACES = PLACES - 1
W = W . " "
REPEAT
!
*LSD_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 =31,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 =31,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
RESULT = W . STRING(D3)
WASZERO:
BYTEINTEGER(D3-1)='0'
L=2; -> OUT
END ; ! SWRITE
!
!-----------------------------------------------------------------------
!
STRINGFN SPRINTFL(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)='@'
!
RESULT = S . SWRITE(COUNT, 2)
END ; ! SPRINTFL
!
!-----------------------------------------------------------------------
!
STRINGFN SPRINT(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
STRING (255)W
W = ""; ! initialise result string
M=M&63; ! DEAL WITH STUPID PARAMS
IF N<0 THEN N=1 ELSE START
WHILE N > 31 CYCLE
N = N - 1
W = W . " "
REPEAT
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
RESULT = SPRINTFL(X,M); ! OF ENORMOUS NUMBERS
! 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:
RESULT = W . S
END ; ! SPRINT
!
!-----------------------------------------------------------------------
!
ROUTINE VVWRITE(LONGINTEGER N, PLACES)
VVPRINTSTRING(SWRITE(N, PLACES))
END
!
!
!
ROUTINE VVPRINT(LONGREAL X, INTEGER N, M)
VVPRINTSTRING(SPRINT(X, N, M))
END
!
!
!
ROUTINE VVPRINTFL(LONGREAL X, INTEGER N)
VVPRINTSTRING(SPRINTFL(X, N))
END
!
!
INTEGERFN STRING TO NUMBER(STRING (255)S, LONGINTEGERNAME I,
LONGREALNAME R)
!
! result is 0 a long integer returned
! 1 a long real
! 2 no digits!
! 3 bad characters
! 4 too big
INTEGER J, SIGN, N, L, CH, ESIGN, EXP, DOT
LONGREAL LR
LONGLONGREAL LLR, SCALE
BYTEINTEGERARRAYNAME B
BYTEINTEGERARRAYFORMAT BF(0:255)
B == ARRAY(ADDR(S), BF)
L = LENGTH(S)
SIGN = 0; ! no sign as yet seen
DOT = 0; ! no decimal point etc, treat number as integer
N = 0; ! count digits
I = 0
J = 1; ! to index along B
CHECK SIGN:
IF J <= L AND B(J) = '+' START
RESULT = 3 UNLESS SIGN = 0
SIGN = 1
J = J + 1
-> CHECK SIGN
FINISH
!
IF J <= L AND B(J) = '-' START
RESULT = 3 UNLESS SIGN = 0
SIGN = -1
J = J + 1
-> CHECK SIGN
FINISH
!
RESULT = 2 IF J > L
!
IF L = J + 1 AND B(J) = 'P' AND B(L) = 'I' START
R = PI
R = -R IF SIGN < 0
RESULT = 1
FINISH
!
IF B(J) = 'X' START ; ! hex?
J = J + 1
RESULT = 2 IF J > L
WHILE J <= L CYCLE
CH = B(J)
J = J + 1
RESULT = 3 UNLESS '0' <= CH <= '9' OR 'A' <= CH <= 'F'
IF N = 0 START
N = 1 UNLESS CH = '0'
FINISH ELSE START
N = N + 1
RESULT = 4 IF N > 16
FINISH
I = I << 4 + 9 * CH >> 6 + CH & 15
REPEAT
!
IF SIGN < 0 START
RESULT = 4 IF I = X'8000000000000000'
I = -I
FINISH
!
RESULT = 0; ! a good long integer
FINISH
!
IF '0' <= B(J) <= '9' START
LLR = B(J) - '0'
J = J + 1
N = N + 1
CYCLE
-> NO MORE IF J > L
EXIT UNLESS '0' <= B(J) <= '9'
N = N + 1
LLR = LLR * 10.0 + B(J) - '0'
J = J + 1
REPEAT
FINISH ELSE LLR = 0; ! integer part
!
IF B(J) = '.' START ; ! add in the fractional part
DOT = 1; ! decimal point encountered
SCALE = 10.0
J = J + 1
CYCLE
-> NO MORE IF J > L
EXIT UNLESS '0' <= B(J) <= '9'
N = N + 1
LLR = LLR + (B(J) - '0') / SCALE
SCALE = SCALE * 10.0
J = J + 1
REPEAT
FINISH
!
RESULT = 3 IF N = 0; ! no digits so far
!
IF B(J) = '@' START ; ! appears to be an exponent
ESIGN = 0
EXP = 0
J = J + 1
CHECKESIGN:
IF J <= L AND B(J) = '+' START
RESULT = 3 UNLESS ESIGN = 0
ESIGN = 1
J = J + 1
-> CHECKESIGN
FINISH
!
IF J <= L AND B(J) = '-' START
RESULT = 3 UNLESS ESIGN = 0
ESIGN = -1
J = J + 1
-> CHECKESIGN
FINISH
!
RESULT = 2 IF J > L; ! no digits in exponent
!
WHILE J <= L CYCLE
CH = B(J)
J = J + 1
RESULT = 3 UNLESS '0' <= CH <= '9'
EXP = EXP * 10 + CH - '0'
REPEAT
EXP = -EXP AND DOT = 1 IF ESIGN < 0
!
IF EXP = -99 C
THEN LLR = 0 C
ELSE LLR = LLR * 10 ** EXP
FINISH
NO MORE:
IF DOT = 0 AND LLR < 10**15 START ; ! treat as an integer
I = LINTPT(LLR + 0.1)
I = -I IF SIGN < 0
RESULT = 0
FINISH
!
LLR = -LLR IF SIGN < 0
!
*LSD_X'7F'
*USH_56
*AND_LLR
*SLSD_1
*USH_55
*AND_LLR+4
*LUH_TOS
*RAD_LLR
*STUH_LR
R = LR
!
RESULT = 1
END ; ! STRING TO NUMBER
!
!
!
LIST
!-----------------------------------------------------------------------
!
!
ROUTINE PRI(INTEGER X, Y, STRING (255) TXT)
VVGOTO(X, Y)
VVPRINTSTRING(TXT)
END ; ! PRI
!
!
!
ROUTINE WRITE(LONGINTEGER I, LONGREAL R, INTEGER TYPE)
LONGINTEGER LI
LONGREAL LR
IF TYPE = 0 OR I = 0 C {integer}
THEN VVWRITE(I, 19) C
ELSE START
LR = R
LR = -LR IF LR < 0
IF 1 <= LR <= 10**15 START
LI = LINTPT(LR)
VVPRINT(R, 19, 0) AND RETURN IF LI = LR
FINISH
LI = -1
LI = LINTPT(LOGTEN(LR)) IF LR > 0.5
VVPRINTSTRING(" ")
IF 0 <= LI < 16 C
THEN VVPRINT(R, LI+1, 15-LI) C
ELSE VVPRINTFL(R, 11)
FINISH
END ; ! WRITE
!
!
!
ROUTINE INITIALISE
INTEGER L
VVPRINTCH(CLR SCREEN CHAR)
PRI(0, 0, "EMAS Reverse Polish Calculator")
PRI(3, 2, "stack:")
PRI(40, 2, "workspace:")
!
PRI(73, 3, "=Wn Wn")
PRI(73, 4, "+ - * /")
PRI(73, 5, "** SQRT")
PRI(73, 6, "DUP NEG")
PRI(73, 7, "REV SIN")
PRI(73, 8, "COS TAN")
PRI(73, 9, "EXP LOG")
PRI(73, 10, "ARCSIN")
PRI(73, 11, "ARCCOS")
PRI(73, 12, "ARCTAN")
PRI(73, 13, "HYPSIN")
PRI(73, 14, "HYPCOS")
PRI(73, 15, "HYPTAN")
PRI(73, 16, "RADIUS")
PRI(73, 17, "CLEAR")
PRI(73, 18, "HELP ?")
PRI(73, 19, "QUIT Q")
!
PRI(40, 15, "Numbers can be typed as:")
PRI(40, 16, "1 -2 3.4 5@-6 pi")
PRI(40, 18, "Separate items with:")
PRI(40, 19, ", ; or space")
!
CYCLE L = 1, 1, 8
VVGOTO(40, L+3)
VVPRINTSTRING("W" . ITOS(L))
!
VVGOTO(43, L+3)
WRITE(WI(L), WR(L), WTYPE(L)) UNLESS WTYPE(L) = 255
REPEAT
!
PRI(0, 15, "hex:")
END ; ! INITIALISE
!
!
!
ROUTINE ITOR
RETURN IF TYPE(TOS) = 1; ! already real
R(TOS) = I(TOS)
TYPE(TOS) = 1
END ; ! ITOR
!
!
!
INTEGERFN CHECKTYPES
TOS = TOS - 1
RESULT = 0 IF TYPE(TOS) = TYPE(TOS+1) = 0; ! both integers
!
IF TYPE(TOS) = 0 START
R(TOS) = I(TOS)
TYPE(TOS) = 1
FINISH
!
R(TOS+1) = I(TOS+1) IF TYPE(TOS+1) = 0
RESULT = 1; ! reals
END ; ! CHECKTYPES
!
!
!
ROUTINE DISPLAY STACK
INTEGER L, N, J, AD, LNBHERE, ACR
STRING (21)LINE
PRI(63, 0, DATE)
PRI(72, 0, TIME)
!
*STLN_LNBHERE
ACR = (INTEGER(LNBHERE+4)) << 8 >> 28
IF ACR < 5 START
AD = INTEGER(INTEGER(X'80C0001C') + 42<<2) + 8 + 19 + 41
LENGTH(LINE) = 21
MOVE(21, AD, ADDR(LINE)+1)
ETOI(ADDR(LINE)+1, 21)
PRI(59, 1, LINE)
FINISH
!
N = 8; ! number of items to print
N = TOS + 1 IF TOS < 8
!
CYCLE L = 4, 1, 11; ! print top 8 items
VVGOTO(0, L)
IF N >= 12 - L START
IF N = 12 - L C
THEN VVPRINTSTRING("-> ") C
ELSE VVPRINTSTRING(" ")
J = TOS - L + 12 - N
WRITE(I(J), R(J), TYPE(J))
FINISH ELSE VVPRINTSTRING(" ")
REPEAT
!
VVGOTO(0, 13)
IF TOS > 7 C
THEN VVPRINTSTRING("+...") C
ELSE VVPRINTSTRING(" ")
!
VVGOTO(6, 15)
IF TOS < 0 C
THEN VVPRINTSTRING(" ") C
ELSE VVPRINTSTRING(HTOS(INTEGER(ADDR(I(TOS))),8) . " " . HTOS(INTEGER(ADDR(I(TOS))+4), 8))
END ; ! DISPLAY STACK
!
!
!
ROUTINE HELP
STRING (255)S
VVPRINTCH(CLR SCREEN CHAR)
PRI(0, 0, "EMAS Reverse Polish Calculator")
PRI(63, 0, DATE)
PRI(72, 0, TIME)
PRI(0, 1, "This is a 'Reverse Polish' calculator so you put the operands on the stack")
PRI(0, 2, "before giving the operator or function, for example:")
PRI(0, 3, " instead of 3+4 type 3 4 +")
PRI(0, 4, " sqrt(5) 5 sqrt")
PRI(0, 5, " (6+7)*(8+9) 6 7 + 8 9 + *")
PRI(0, 6, "Operators and operands must be separated by space, comma or semi-colon.")
PRI(0, 7, "")
PRI(0, 8, "Numbers are held as integers where appropriate ie when the do not contain a")
PRI(0, 9, "decimal point and are less than 10**15. The sequence PI represents 3.14159....")
PRI(0, 10, "When you type numbers they are put on top of the stack. The stack can hold")
PRI(0, 11, "a lot of numbers but only the top 8 are displayed. The internal, hex, ")
PRI(0, 12, "representation of the number on top of the stack is shown in the 'hex window'.")
PRI(0, 13, "")
PRI(0, 14, "Arithmetic operators + - * / and ** together with REV, ARCTAN and RADIUS,")
PRI(0, 15, "require (at least) two operands on the stack. CLEAR clears the stack.")
PRI(0, 16, "")
PRI(0, 17, "Any comments/queries to A.Gibbons@2972 via MAIL please.")
PRI(0, 18, "")
PRI(0, 19, "Press 'return' to continue")
!
S = ""
VVRSTRG(S)
INITIALISE
END ; ! HELP
!
!
!
INTEGERFN PROCESS(STRINGNAME S)
!
! result = 0 OK
! 1 error
! -1 quit
SWITCH C(-1 : TOP COMMAND)
LONGREAL LR
LONGINTEGER LI
!
!
INTEGER J
CYCLE COMMAND NO = 1, 1, TOP COMMAND
-> C(COMMAND NO) IF S = COMMAND(COMMAND NO)
REPEAT
!
IF LENGTH(S) > 1 AND CHARNO(S, 1) = 'W' START
S -> ("W") . S
J = PSTOI(S)
-> C(0) IF 0 < J <= TOPWORK
RESULT = 1; ! error
FINISH
!
IF LENGTH(S) > 2 AND CHARNO(S, 1) = '=' AND CHARNO(S, 2) = 'W' START
S -> ("=W") . S
J = PSTOI(S)
-> C(-1) IF 0 < J <= TOPWORK
RESULT = 1; ! error
FINISH
!
IF S = "(" START
DEPTH = DEPTH + 1
LEFT(DEPTH) = ITEMCOUNT
RIGHT(DEPTH) = -1
RESULT = 0
FINISH
!
IF LENGTH(S) > 1 AND CHARNO(S, 1) = ')' START
RESULT = 21 IF DEPTH = 0; ! no left bracket
S -> (")") . S
J = PSTOI(S)
RESULT = 22 UNLESS 0 < J; ! format is )n
IF RIGHT(DEPTH) < 0 C {first time encountered}
THEN RIGHT(DEPTH) = J - 1 C
ELSE RIGHT(DEPTH) = RIGHT(DEPTH) - 1
IF RIGHT(DEPTH) <= 0 C {count exhausted}
THEN DEPTH = DEPTH - 1 C
ELSE ITEM COUNT = LEFT(DEPTH)
RESULT = 0
FINISH
!
J = STRING TO NUMBER(S, LI, LR)
RESULT = J UNLESS J < 2; ! 1=real, 0=integer
RESULT = 14 IF TOS = TOP STACK; ! stack full
!
TOS = TOS + 1
TYPE(TOS) = J
IF J = 0 THEN I(TOS) = LI ELSE R(TOS) = LR
RESULT = 0
!
!
!
C(-1): ! =Wj
RESULT = 5 IF TOS < 0
WI(J) = I(TOS)
WTYPE(J) = TYPE(TOS)
TOS = TOS - 1
VVGOTO(43, J+3)
WRITE(WI(J), WR(J), WTYPE(J))
RESULT = 0
C(0): ! Wj
RESULT = 7 IF WTYPE(J) = 255; ! unassigned
RESULT = 14 IF TOS = TOP STACK
TOS = TOS + 1
I(TOS) = WI(J)
TYPE(TOS) = WTYPE(J)
RESULT = 0
C(1): ! Q
C(2): ! QUIT
RESULT = -1
C(3): ! ?
C(4): ! HELP
HELP
RESULT = 0
C(5): ! CLEAR
TOS = -1
RESULT = 0
C(6): ! +
RESULT = 6 UNLESS TOS > 0
IF CHECKTYPES = 0 C
THEN I(TOS) = I(TOS) + I(TOS+1) C
ELSE R(TOS) = R(TOS) + R(TOS+1)
RESULT = 0
C(7): ! -
RESULT = 6 UNLESS TOS > 0
IF CHECKTYPES = 0 C
THEN I(TOS) = I(TOS) - I(TOS+1) C
ELSE R(TOS) = R(TOS) - R(TOS+1)
RESULT = 0
C(8): ! *
RESULT = 6 UNLESS TOS > 0
IF CHECKTYPES = 0 C
THEN I(TOS) = I(TOS) * I(TOS+1) C
ELSE R(TOS) = R(TOS) * R(TOS+1)
RESULT = 0
C(9): ! /
RESULT = 6 UNLESS TOS > 0
IF CHECKTYPES = 0 C
THEN I(TOS) = I(TOS) // I(TOS+1) C
ELSE R(TOS) = R(TOS) / R(TOS+1)
RESULT = 0
C(10): ! REV
RESULT = 6 UNLESS TOS > 0
LI = I(TOS)
I(TOS) = I(TOS-1)
I(TOS-1) = LI
J = TYPE(TOS)
TYPE(TOS) = TYPE(TOS-1)
TYPE(TOS-1) = J
RESULT = 0
C(11): ! **
RESULT = 6 UNLESS TOS > 0
ITOR
LR = R(TOS)
TOS = TOS - 1
ITOR
R(TOS) = R(TOS) ** LR
RESULT = 0
C(12): ! DUP
RESULT = 5 UNLESS TOS >= 0
TOS = TOS + 1
I(TOS) = I(TOS-1)
TYPE(TOS) = TYPE(TOS-1)
RESULT = 0
C(13): ! NEG
RESULT = 5 UNLESS TOS >= 0
IF TYPE(TOS) = 0 START
RESULT = 4 IF I(TOS) = X'8000000000000000'
I(TOS) = -I(TOS)
FINISH ELSE R(TOS) = -R(TOS)
RESULT = 0
C(14): ! SQRT
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 8 IF R(TOS) < 0
R(TOS) = SQRT(R(TOS))
RESULT = 0
C(15): ! EXP
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 9 UNLESS R(TOS) < 174.6
R(TOS) = EXP(R(TOS))
RESULT = 0
C(16): ! LOG
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 10 IF R(TOS) <= 0
R(TOS) = LOG(R(TOS))
RESULT = 0
C(17): ! SIN
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 11 UNLESS MOD(R(TOS)*CONVERT) < 628
R(TOS) = SIN(R(TOS))
RESULT = 0
C(18): ! COS
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 12 UNLESS MOD(R(TOS)*CONVERT) < 628
R(TOS) = COS(R(TOS))
RESULT = 0
C(19): ! TAN
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 13 UNLESS MOD(R(TOS)*CONVERT) < 628
R(TOS) = TAN(R(TOS))
RESULT = 0
C(20): ! ARCSIN
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 15 UNLESS MOD(R(TOS)) <= 1
R(TOS) = ARCSIN(R(TOS)) / CONVERT
RESULT = 0
C(21): ! ARCCOS
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 16 UNLESS MOD(R(TOS)) <= 1
R(TOS) = ARCCOS(R(TOS)) / CONVERT
RESULT = 0
C(22): ! ARCTAN
RESULT = 6 UNLESS TOS > 0
ITOR
LR = R(TOS)
TOS = TOS - 1
ITOR
TOS = TOS + 1 AND RESULT = 17 IF LR = 0 = R(TOS)
R(TOS) = ARCTAN(R(TOS), LR) / CONVERT
C(23): ! HYPSIN
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 18 UNLESS MOD(R(TOS)) < 172.6
R(TOS) = HYPSIN(R(TOS))
RESULT = 0
C(24): ! HYPCOS
RESULT = 5 UNLESS TOS >= 0
ITOR
RESULT = 19 UNLESS MOD(R(TOS)) < 172.6
R(TOS) = HYPCOS(R(TOS))
RESULT = 0
C(25): ! HYPTAN
RESULT = 5 UNLESS TOS >= 0
ITOR
R(TOS) = HYPTAN(R(TOS))
RESULT = 0
C(26): ! RADIUS
RESULT = 6 UNLESS TOS > 0
ITOR
LR = R(TOS)
TOS = TOS - 1
ITOR
R(TOS) = RADIUS(R(TOS), LR)
RESULT = 0
C(27): ! NOT
RESULT = 5 UNLESS TOS >= 0
I(TOS) = ¬ I(TOS)
TYPE(TOS) = 0; ! force to integer
RESULT = 0
C(28): ! <<
RESULT = 6 UNLESS TOS > 0
RESULT = 20 UNLESS TYPE(TOS) = 0
LI = I(TOS)
TOS = TOS - 1
I(TOS) = I(TOS) << LI
TYPE(TOS) = 0
RESULT = 0
C(*):
RESULT = 999
END ; ! PROCESS
!
!
!
ROUTINE READLINE
INTEGER J, J0, CH
READ:
DISPLAY STACK
PRI(0, 22, "Calc: ")
VV UPDATE SCREEN
LINE = ""
VVRSTRG(LINE)
-> READ IF LINE = ""
UCTRANSLATE(ADDR(LINE)+1, LENGTH(LINE))
LINE = LINE . " "; ! put a separator on the end
PRI(6, 21, LINE . TOSTRING(CLR ROL CHAR))
TOPITEM = 0; ! number of items found
J0 = 1; ! start of first item
J = 0
L:
J = J + 1
CH = CHARNO(LINE, J)
IF CH = ' ' OR CH = ',' OR CH = ';' OR CH = '(' OR CH = ')' START
IF J > J0 START ; ! non null item before separator
TOPITEM = TOPITEM + 1
STARTITEM(TOPITEM) = J0
LENGTHITEM(TOPITEM) = J - J0
FINISH
IF J = LENGTH(LINE) START ; ! got to the end
RETURN IF TOPITEM > 0
-> READ
FINISH
IF CH = '(' START ; ! treat as an item
TOPITEM = TOPITEM + 1
STARTITEM(TOPITEM) = J
LENGTHITEM(TOPITEM) = 1
FINISH
J0 = J + 1; ! start of next item
J0 = J IF CH = ')'
FINISH
-> L
END ; ! READLINE
!
!
!
STRINGFN GETITEM(INTEGER N)
INTEGER A, B
STRING (255)W
W = LINE
A = STARTITEM(N)
B = ADDR(W) + A - 1
BYTEINTEGER(B) = LENGTHITEM(N)
RESULT = STRING(B)
END ; ! GETITEM
!
!
!
VVINIT(J)
UNLESS J = 0 START
PRINTSTRING("Calc can be used only on terminals suitable ")
PRINTSTRING("for VVP - see User Note 30 'Virtual Video Package'")
RETURN
FINISH
!
VV DEFINE TRIGGERS(3, 0, 0)
!
R == ARRAY(ADDR(I(0)), RF)
TOS = -1; ! stack clear
!
WR == ARRAY(ADDR(WI(1)), WRF)
CYCLE J = 1, 1, TOP WORK
WTYPE(J) = 255
REPEAT
!
LAST J = 0
CONVERT = 1
!
INITIALISE; ! format screen
READ:
READLINE
DEPTH = 0; ! degree of nesting of brackets
ITEMCOUNT = 1
NEXTITEM:
PIECE = GETITEM(ITEMCOUNT)
J = PROCESS(PIECE)
CHECK:
-> OUT IF J < 0; ! quit
J = TOP ERROR UNLESS 0 <= J <= TOP ERROR
PRI(0, 23, ERROR(0)) IF LAST J > 0
PRI(0, 23, ERROR(J)) IF J > 0
LAST J = J
-> READ IF J > 0
!
-> READ IF ITEMCOUNT >= TOPITEM
ITEMCOUNT = ITEMCOUNT + 1
-> NEXTITEM
OUT:
VV DEFINE TRIGGERS(-2, 0, 0)
END
ENDOFFILE