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" ! ! 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 ! !----------------------------------------------------------------------- ! ROUTINE MYVVWRITE(LONGINTEGER N, PLACES) VVPRINTSTRING(SWRITE(N, PLACES)) 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 MYVVWRITE(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