$PAGELENGTH(66) DEBUG XREF PRINT(:LP:) ; ; LLL BASIC INTERPRETER - RUN MODULE ; ; REVISED CHARLES CHERNACK 12/22/77 ; ; NAME BASIC2 EXTRN ZROL,LADD,LMUL,LDIV,LSUB,SUBS EXTRN DFXL,LMCM,CONV,FINPT,PTVAL EXTRN READY,QUITT,CHK1,ERROR,ICP2,ICP4,ICP7 EXTRN ICP8,ALPHA,SYMSRT,CVB,NSRCH,FSYM,STPNT EXTRN MEMFUL,PAD,NUMB,WRIT,WRIT1 EXTRN TTYIN,FORM9,FOR10,FOR11,FOR12,ERLN PUBLIC INP PUBLIC OUTR PUBLIC RUN,CHKLC MEMST EQU 3200H ;MUST BE ON PAGE BOUNDARY IBUF EQU MEMST+1 ;SAME AREA STLINE EQU MEMST+111Q PL4 EQU MEMST+135Q SBSAV EQU PL4 ;RETURN ADD. SAVE FOR CALL STMT. PL6 EQU MEMST+137Q NXTSP EQU MEMST+131Q STSPAC EQU MEMST+113Q LPNT EQU MEMST+122Q KLEN EQU MEMST+130Q CPNT EQU MEMST+133Q KFPNT EQU MEMST+126Q FREG2 EQU MEMST+200Q CREG EQU MEMST+204Q HLINP EQU MEMST+206Q GREG EQU MEMST+167Q FREG1 EQU MEMST+174Q SCR EQU MEMST+146Q MODE EQU MEMST+205Q MESCR EQU MEMST+210Q ;DEFINE MEMORY SCR AREA PNTR VARAD EQU MEMST+212Q ;TEMP SPACE FOR INP. STMT. VNAME EQU MEMST+214Q ;TEMP SPACE FOR 'FOR-NEXT' VLOC EQU MEMST+216Q ;TEMP SPACE FOR 'FOR-NEXT' FLIMT EQU MEMST+220Q ;TEMP SPACE FOR 'FOR-NEXT' NEST EQU MEMST+224Q ;NESTING STACK-POINTER STAC EQU MEMST+226Q ;FOR-NEXT NESTING STACK STSIZ SET 20 ;STACK SIZE, ALLOWS 10 NESTED FOR-NEXT TOPNS EQU STAC ;TOP OF STACK BOTNS EQU STAC+STSIZ ;BOTTOM OF STACK VEND EQU MEMST+252Q ;DEF. END OF VAR. STORAGE AREA $EJECT TITLE(' BASIC RUN MODULE 12/22/77') CSEG RUN: LHLD STSPAC XCHG CALL CHKLC ; ADJUST START OF SYMBOL TABLE SO IT ; DOES NOT CROSS PAGE BOUNDARY XCHG SHLD STSPAC SHLD NXTSP LXI H,BOTNS ;INIT SP FOR NESTING STACK SHLD NEST LXI H,READY ;PRECAUTION, IN CASE RETURN IS PUSH H ;EXECUTED BEFORE A GOSUB PUSH H LHLD STLINE ;START OF SOURCE ILOOP: CALL QUITT ;CHECK FOR INTERRUPTION CALL CHK1 ;HL=-1 => NO MORE SOURCE JNC SORCE MVI A,1 JMP ERROR ;ERROR 1, NO END STMT. SORCE: SHLD LPNT PUSH H LXI H,LPNT ;DEFINE VALUES OF CALL PTVAL ;KBIN,KFPNT,KLEN LDA KLEN ;CHAR'S IN LINE TO C MOV C,A INR C POP H ;MOVE PNTR. TO 1ST CHAR INX H ;IN SOURCE REC. INX H INX H INX H L1: CALL ICP2 ;INCR. H,L DCR C CALL ALPHA ;FIND FIRST LETTER JNC L1 XRA A INR A ;LETTER FOUND CALL SYMSRT ;DETERMINE KEYWORD CPI 377Q JNZ GKEY MVI A,2 ;BAD KEYWORD JMP ERROR GKEY: SHLD CPNT LXI H,JTBL ;LOAD JUMP TABLE PNTR. ADD A ;DOUBLE A MOV E,A MVI D,0 DAD D ;PNT. TO PROPER PROC. MOV A,M ;ADD. IN JUMP TABLE INX H ;GET PROC. ADD. MOV H,M MOV L,A PCHL ;INDIRECT JUMP TO PROC. JTBL: DW LET ;JMP TABLE DW PRI DW IEND ;REM STMT. - NO ACTION DW READY ;STOP STMT.-RETURN TO EDIT MODE DW ENDD DW GOTO DW IFRT DW INPUT DW DIM DW CALLP DW GOSUB DW RETRN DW FOR DW NEXT ENDD: LHLD KFPNT ;CHECK TO SEE IF MORE CALL CHK1 ;SOURCE AFTER END JC READY MVI A,3 ;MORE SOURCE ERROR 3 JMP ERROR GOTO: LHLD CPNT ;GOTO STMT. PROC. GSENT: INX H ;INCREMENT PAST KEYWORD INX H INX H CALL ICP4 ;POSSIBLE ERROR 4 GTRA: CALL CVB ;GET DESTINATION ORA A ;MAKE SURE IT WAS OK JNZ OKN MVI A,4 JMP ERROR OKN: CALL NSRCH ;GET NEXT LPNT JNC ILOOP ;MAKE SURE IT EXISTED MVI A,5 JMP ERROR ;NON-EXISTENT DIM: LHLD CPNT ;DIM STMT. PROC. INX H ;PNT TO FIRST VAR. INX H INX H DLOOP: CALL ALPHA ;CHECK IF IT IS A VAR. JC OKLET ER6: MVI A,6 ;ERROR 6 JMP ERROR OKLET: MOV B,M CALL ICP7 ;INCR.CPNT MVI A,250Q ;CHECK FOR ( CMP M JNZ ER6 CALL ICP7 ;INCR. CPNT CALL CVB ;CONV. TO BIN NO. ADD L ;UPDATE CPNT MOV L,A ;ED CONTAIN ARRAY LEN. MVI A,0 ADC H ;C CONT. NO. CHARS LEFT MOV H,A ;IN LINE MVI A,251Q ;CHECK FOR ) CMP M JNZ ER6 PUSH H PUSH B ;SAVE B,C,H,L MOV C,B ;SET UP FOR CALL TO FSYM MVI B,0 CALL FSYM JNC NDOU POP B POP H MVI A,11H ;ERROR 11 JMP ERROR ;DUPLICATE ARRAY DEF. NDOU: PUSH D ;SAVE DIM. LENGTH XCHG ;ADD. OF LAST SYM. TAB. ENTRY TO DE LHLD NXTSP ;GET ADD. OF AVAILABLE MEM. XCHG ;SET UP FOR CALL CALL CKDIM ; CHECK START OF 'DIM' ARRAY CALL STPNT ;STORE NEW PNTR XCHG ;NXTSP TO HL POP D ;RESTORE D MVI M,0 INX H ;INSERT VAR IN SYMB. TAB. MOV M,C INX H MVI M,377Q ;FPNT TO -1 INX H MVI M,377Q INX H ;PNTS TO FIRST DATA MOV A,D ;GET ONE'S COMPLEMENT OF CMA ;NUMBER OF ELEMENTS MOV C,A ;IN ARRAY TO B,C MOV A,E CMA MOV B,A CONT: CALL ZROL ;ZEROE OUT ELEMTS. INX H ; OF ARRAY INX H INX H INX H INX B PUSH H CALL MEMFUL ;MEMORY FULL? MOV H,B MOV L,C CALL CHK1 POP H JNC CONT SHLD NXTSP ;NEW VALUE OF NXTSP. POP B ;RESTORE REG@S POP H INX H DCR C ;MORE ELEMTS IN LINE? JZ IEND DCR C JZ ER6 MVI A,254Q ;NEXT ELEMENT A , CMP M INX H JZ DLOOP JMP ER6 ;ROUTINE TO COPY CONTENTS PNTED TO ;BY DE TO LOCATION H,L COPDH: PUSH PSW ;SAVE REGISTERS PUSH B PUSH D PUSH H MVI B,4 ;COUNT COPD1: LDAX D ;GET FROM SOURCE MOV M,A ;PUT TO DESTINATION INX D ;BUMP PNTRS, CNT INX H DCR B JNZ COPD1 POP H ;RESTORE REGISTERS POP D POP B POP PSW RET ;OUTR PADS OUTPUT FROM CONV INTO ;OUTPUT BUFFER USING ROUTINE PAD ;ALL REG'S MAINTAINED OUTR: PUSH B ;SAVE REG B MVI B,1 ;PAD ONCE CALL PAD ;DO IT POP B ;RESTORE B AND RET. RET ;VALUE RETURNS IN D(H),E(L) PNTR. ;TO THE VALUE OF A TOKEN ;C,H,L ARE UPDATED ;A,B ARE DESTROYED VALUE: CALL VAR ;IS IT A VARIABLE? RC ;YES - ALL DONE MVI A,3 ;NO CHEK IF A FUNC. CALL SYMSRT CPI 377Q JZ KONT ;NOT A FUNCTION - CPI 1 ;WAS IT PUT(--)? JNZ GET ;NO - OK JMP ER10 ;ILLEGAL USE OF FUNCTION GET: INX H ;OK, IT'S GET(--) INX H ;UPDATE H,L INX H MOV A,C ;CHECK FOR PREMATURE EOL ORA A JZ ER8 MVI A,250Q ;CHEK FOR ( CMP M JNZ ER8 CALL ICP8 ;BUMP PNTR'S CALL EVAL ;GET PORT = PUSH H ;SAVE REG H,L LXI H,FREG1 CALL COPDH ;COPY IT XCHG POP H ;RESTORE H,L CALL FIX ;FIX IT INX D INX D ;GET LOWEST BYTE TO INX D ;REG D LDAX D MOV D,A MOV A,C ;EOL? ORA A JZ ER8 MVI A,251Q ;CHECK FOR ) CMP M JNZ ER8 INX H ;BUMP PNTR'S DCR C PUSH H ;SAVE H,L,B,C PUSH B ;STORE PROGRAM SEGMENT LXI B,GREG ;IN RAM,START AT GREG LXI H,RINST ;ADD. OF INST'S MVI E,5 ;NUMB. OF BYTES V1: MOV A,M ;GET BYTE STAX B ;STORE IN RAM INX H INX B DCR E ;BUMP PNTR'S,DCR CNT JNZ V1 LXI H,GREG+1 ;STORE PORT = MOV M,D ;IN RAM JMP GREG ;OK - TRANSFER HOME: LXI H,GREG+2 ;SET UP FOR FLOAT MOV M,A ;STORE AWAY INPUT DCX H XRA A ;ZERO OUT HIGHER BYTES MOV M,A ;BUT CHAR. DOESN'T MATTER DCX H MOV M,A CALL DFXL ;FLOAT IT LXI D,GREG ;FIX D,E RESTORE C,H,L POP B POP H RET RINST: IN 0 ;RAM INSTRUCTIONS JMP HOME KONT: CALL NUMB ;NUMBER JC OKK MVI A,256Q ;DEC. PNT.? CMP M JNZ ER8 OKK: MVI A,1 ;MODE=1, IE. INPUT FROM SOURCE CALL RDKON ;READ CONSTANT TO GREG JC ER9 ;IF ERROR THEN CY=1 LXI D,GREG ;PNTS. TO CONSTANT RET ;THIS ROUTINE READS A CONSTANT INTO GREG FROM ASCII ;CHARACTERS POINTED TO BY HL AND C ;ENTER WITH A=0 => DATA FROM TTY ;ENTER WITH A=1 => DATA FROM SOURCE ;RETURN WITH CY=1 => ERROR IN CONVERSION RDKON: STA MODE ;SAVE MODE FOR ROUT. INP SHLD HLINP ;SAVE HL FOR ROUT. INP MOV A,C STA CREG ;SAVE C FOR ROUT. INP LXI H,GREG ;WHER VALUE WILL GO MVI C,SCR AND 377Q ;SET UP AND CALL FINPT CALL FINPT LHLD HLINP ;RETORE H,L AND C LDA CREG MOV C,A RET ;DONE ER9: MVI A,9 JMP ERROR ;VAR DECIDES WHETHER A TOKEN IS ;A VARIABLE IF SO CY=1 AND ;ADDRESS IS COMPUTED,(SUBSCRIPT IS ;EVALUATED ETC.), RETURNS WITH DE PNTING ;TO VAR. REFERENCED H,L,C,UPDATED ;A,B DESTROYED ;IF NOT A VARIBLE CY=0 ;H,L,C ARE LEFT UNTOUCHED VAR: CALL ALPHA ;1ST CHAR A LETTER? RNC ;NO-NOT VAR. INX H ;BUMP PNTR'S DCR C JNZ MORE ;MORE TO LINE SC1: PUSH B ;SAVE B,EOL MVI C,0 ;SET FOR CALL TO FSYM DCX H ;GET SINGLE LETTER MOV B,M ;VAR TO B INX H JMP SCALR MORE: CALL ALPHA ;2ND A LETTER? JNC SFSG ;SO FAR SO GOOD PUSH B ;SAVE C MVI A,2 ;CHECK FOR DELIMITER CALL SYMSRT POP B ;RESTORE C INR A ;FOUND? JNZ SC1 ;YES INR C ;NOT A VAR. DCX H ;BACK UP PNTR'S ORA A ;CY=0 AND RET RET SFSG: CALL NUMB ;TEST FOR NUMBER JNC ARCK ;MAYBE AN ARRAY INX H ;ITS A SCALAR DCR C ;BUMP PNTR'S JZ SLOAD ;EOL PUSH B ;SAVE C MVI A,2 ;SET UP FOR SYMSRT CALL SYMSRT ;TEST FOR LEGAL POP B ;GET C BACK INR A ;DELIMITER FOUND? JZ ER8 ;NO, ERROR SLOAD: DCX H ;MOVE BACK, PUSH B ;SAVE C, MOV C,M ;GET VAR. INTO DCX H ;B,C FOR FSYM MOV B,M INX H INX H SCALR: XCHG ;SAVE H,L IN D,E CALL FSYM ;GET PNTR TO VALUE XCHG ;RESTORE H,L PNTR TO DE POP B ;GET C REG BACK STC ;SET CY,RET RET ARCK: MOV A,M ;ARRAY CHEK, GET CHARACTER CPI 250Q ;IS IT (? JZ ARYES ;YES,ITS AN ARRAY MVI A,2 ;NO-CHEK FOR LEGAL DELIM. PUSH B ;SAVE C CALL SYMSRT POP B ;RESTORE C INR A ;DELIMITER FOUND? JZ ER8 JMP SC1 ;1 CHAR. SCALAR VAR. ARYES: DCX H ;YES-WE HAVE ARRAY MOV A,M ;GET VAR. INX H PUSH PSW ;SAVE VAR. CALL ICP8 ;BUMP PNTR'S CALL EVAL ;EVALUATE SUBSCRIPT PUSH H ;SAVE REG H,L LXI H,FREG1 CALL COPDH ;COPY IT XCHG POP H ;RESTORE H,L CALL FIX ;FIX VALUE MVI A,251Q ;CHECK FOR ) CMP M JNZ ER8 INX H DCR C ;BUMP PNTR'S INX D ;PNT TO LOWER 2 BYTES INX D LDAX D MOV B,A ;H-BYTE TO B INX D ;PNT TO LOW BYTE LDAX D ;LOW BYTE TO A ORA A ;KILL CY RAL ;START MULT OF OFFSET MOV E,A ;BY 4(BYTES/FLTPT =) MOV A,B ;GET H BYTE RAL MOV D,A ;DE IS OFFSET*2 MOV A,E ;GET LOW ORA A ;KILL CARRY RAL MOV E,A MOV A,D RAL MOV D,A POP PSW ;DE CONTAIN OFFSET*4 PUSH B ;GET VAR., SAVE C MOV C,A MVI B,0 ;SETUP TO CALL FSYM PUSH H ;SAVE H,L CALL FSYM ;GET START ADD. JC AFOND MVI A,12H ;ERROR 12 JMP ERROR ;ARRAY REF. NOT DIM'ED. AFOND: DAD D ;H,L NOW PNT TO START OF XCHG ;ARRAY, ADD OFFSET, EXCHG POP H ;RESTORE PNTR'S AND RET. POP B STC ;SET CY RET ;ROUTINE TO FIX FLOATING POINT ;NUMBERS, ALL REG'S BUT A ARE ;MAINTAINED. DE PNT TO 4 BYTES ;OF = TO BE FIXED FIX: PUSH B PUSH H PUSH D ;SAVE REG'S INX D INX D INX D ;PNT TO 4TH BYTE LDAX D PUSH PSW ;SAVE CHAR. (FOR SIGN) ANI 177Q RAL ;CHEK IF EXP SIGN IS - RAL JC MINSE RAR RAR ;RESTORE CHAR CPI 30Q ;IS IT TOO BIG? JC GOOD MVI A,13H ;ERROR 13 JMP ERROR ;FIX = TOO BIG MINSE: RAR RAR GOOD: STAX D ;ABSOLUTE VALUE DCX D DCX D DCX D ;MOV PNTR BACK LXI H,FREG1 CALL COPDH ;COPY TO FREG1 LXI H,FREG2 ;STORE .5*2**24 IN LXI D,FDAT ;FREG2 CALL COPDH ;COPY IT LXI H,FREG1 ;SET UP TO CALL LADD MVI B,FREG2 AND 377Q MVI C,SCR AND 377Q CALL LADD ;ADD THEM,RESULT IN FREG1 LXI H,FREG1 POP PSW ;GET SIGN AND ADD. POP D RAL MVI A,0 ;GET SIGN ONLY RAR MOV B,M ;GET BYTE1 STAX D ;STORE BYTE 1 OF FIX MOV A,B ANI 177Q ;CLEAR HIGH BIT (FROM ADD) INX D INX H MOV B,M ;GET BYTE 2 STAX D ;STORE BYTE 2 OF FIX INX D MOV A,B INX H MOV B,M ;GET BYTE 3 STAX D ;STORE BYTE 3 OF FIX MOV A,B INX D STAX D ;STORE BYTE 4 OF FIX DCX D ;FIX D PNTR DCX D DCX D POP H POP B RET FDAT: DB 200Q,0,0,30Q ;INP SAVES ALL REG'S ;SERVES AS BUFFER BETWEEN FINPT AND ;DATA INPUT. IF MODE=0, DATA COMES FROM TTY ;IF MODE=1 DATA COMES FROM SOURCE STMTS. ;IN ALL CASES HL,C ARE UPDATED FROM HLINP, AND ;CREG AND RETURNED TO THOSE LOCATIONS INP: PUSH H ;SAVE ALL REG'S PUSH D PUSH B LHLD HLINP ;GET PNTR'S LDA CREG MOV C,A ORA A ;CHECK FOR EOL JNZ CHKMD ;NO CHECK MODE SPACE: MVI A,240Q ;SEND A SPACE IDONE: POP B ;RESTORE REG'S POP D POP H RET ;AND RETURN CHKMD: LDA MODE ;GET MODE DCR A ;CHECK IT JZ MODE1 ;MODE IS 1 MOV A,M ;MODE 0, GET CHAR. CPI ',' OR 200Q ;IS IT A ','? JZ SPACE ;YES - SEND A SPACE JMP BMPTR ;NO - SEND IT MODE1: CALL NUMB ;NUMBER? (ALSO LOADS IT TO A) JC BMPTR ;YES - SEND IT AND BUMP PNTR'S CPI 256Q ;DEC. PNT.? JZ BMPTR CPI 305Q ;E? JZ BMPTR CPI 253Q ;+? JZ CHEKE CPI 255Q ;-? JNZ SPACE ;SEND A SPACE CHEKE: MOV B,A ;CHEK IF E PRECEDES +,- DCX H ;BACK UP AND GET PRE- MOV A,M ;CEDING CHARACTER CPI 305Q ;IS IT E? JNZ SPACE ;NO,+OR- WAS DELIMITTER MOV A,B ;YES,GET + OR - INX H ;RESTORE H,L BMPTR: INX H ;BUMP AND STORE PNTR'S DCR C SHLD HLINP LXI H,CREG MOV M,C JMP IDONE ;RESTORE REG'S AND RETURN ;THIS ROUTINE WILL EVALUATE UNARY AND/OR ;BINARY EXPRESIONS CALLED WITH H AND L ;POINTING TO FIRST CHAR. OF EXP.,C CONTAINS ;NUMBER OF CHAR'S LEFT IN LINE. RETURNS ;D(H) AND E(L) POINTING TO THE ANSWER ;THIS ROUTINE CALLS ITSELF RECURSIVELY ;IN ORDER TO EVALUATE SUBSCRIPT ;EXPRESIONS. REG A,B DESTROYED ;C,H,L ARE UPDATED EVAL: MVI A,255Q ;IS IT UNARY - CMP M ;Z=1 => YES PUSH PSW ;Z=0 => NO JNZ ECAV CALL ICP8 ;BUMP POINTER ECAV: CALL VALUE ;GET PNTR. TO VALUE PUSH H ;GET VALUE TO FREG1 LXI H,FREG1 CALL COPDH XCHG POP H POP PSW ;GET SIGN JNZ DOL ;SHALL WE NEGATE? INX D ;YES, POINT TO CHAR. INX D INX D LDAX D ;AND LOAD TO A RAL ;ROTATE SIGN TO CY CMC ;COMPLEMENT IT RAR ;ROTATE BACK STAX D ;STORE AWAY DCX D ;AND FIX PNTR. DCX D DCX D DOL: MOV A,C ;IS THIS END OF LINE? ORA A RZ ;YES-RETURN PUSH B ;SAVE C MVI A,2 ;NO SET UP TO CALL CALL SYMSRT ;SYMSRT AND CALL POP B ;RESTORE C INR A ;DELIMITER FOUND? JZ ER8 ;NO, ERROR SUI 10 ;CHECK FOR EXPRESSION RC ;DELIMITER PUSH PSW ;SAVE OVERATION CALL ICP8 ;BUMP PNTR'S ORA A ;CLEAR CY AGA: PUSH H ;GET BYTES OF NUMBER LDAX D ;AND PLACE ON STACK MOV L,A INX D LDAX D INX D MOV H,A ;2 BYTES TO H,L XTHL ;XCHANGE, RESTORES H,L CMC JC AGA ;ANOTHER PASS? CALL VALUE ;GET 2ND VALUE MOV A,C ;CHECK FOR END OF LINE ORA A ;IF SO => WELL FORMED JZ WFOR PUSH B ;SAVE C MVI A,2 ;ELSE CALL SYMSRT TO CALL SYMSRT ;CHEK FOR EXP. DEL. POP B ;RECOVER IT CPI 10 JC WFOR ;YES, WELL FORMED ER8: MVI A,8 ;ILL-FORMED EXP. JMP ERROR WFOR: PUSH B ;SAVE C, AND H,L PUSH H LXI H,FREG2 ;COPY 2ND VALUE TO CALL COPDH ;FREG2 POP D ;GET BYTES FROM STACK POP B POP H ;INTO FREG1+2 SHLD FREG1+2 POP H ;AND NEXT 2 BYTES SHLD FREG1 ;FROM STACK TO FREG1 XCHG POP PSW ;GET OPERATION ;THIS ROUTINE PERFORMS BINARY OPERATIONS ON OPERANDS IN FREG1 AND FREG2 ;B,C,H,L ARE LEFT UNDISTURBED. A IS DESTROYED ;D,E PNT TO RESULT ;OPERATIONS ARE SPECIFIED BY A REGISTER AS FOLLOWS: ; ; A=0 => FREG1 * FREG2 ; A=1 => FREG1 / FREG2 ; A=2 => FREG1 + FREG2 ; A=3 => FREG1 - FREG2 ; ;IN CASE OF ARITHMETIC ERROR A MESSAGE IS SENT TO USER. ;IF A CONTAINS ILLEGAL OPERATION REQUEST ERROR IS SENT TO USER ;(ERROR 8) AND THE INTERPRETER IS ABORTED. BINOP: PUSH B ;SAVE REG'S PUSH H LXI H,FREG1 ;SET UP PNTR'S TO MVI B,FREG2 AND 377Q ;FREG'S AND SCR AREA MVI C,SCR AND 377Q ;AND DO OPERATION DCR A JM FMULT ;0,1=>* OR / JZ DIV ;2,3=>+ OR - DCR A JZ ADDD DCR A JZ SUBB JMP ER8 ;ILLEGAL OPER. ADDD: CALL LADD ;DO ADDITION ASBC: MOV D,H ;FIX PNTR'S FOR RET. MOV E,L FPERR: ORA A ;SET FLAGS JZ NFPER ;NO ERROR PUSH D ;SAVE DE PUSH PSW ;SAVE A CALL WRIT ;DUMP BUFFER POP PSW ;GET A BACK LXI H,WFPER ;RETURN ADDRESS PUSH H ;SAVE ON STACK RAL ;UNDERFLOW? JC FOR12 ;YES RAL ;OVERFLOW? JC FOR11 ;YES JMP FOR10 ;NO - ITS ZERODIVIDE WFPER: CALL ERLN ;PRINT 'IN LINE --' (USE PART OF ERROR POP D ;RESTORE REG'S NFPER: POP H POP B RET SUBB: CALL LSUB ;DO SUBTRACTION JMP ASBC FMULT: CALL LMUL ;DO MULT. JMP MDBC DIV: CALL LDIV ;DO DIV. MDBC: MOV D,H ;AND FIX PNTR'S FOR RET. MOV E,C JMP FPERR ;CHECK FOR ERROR ; ------------ CUT HERE ----------------- ;PRINT PROCESSOR PRI: LHLD CPNT INX H ;INCR. PAST KEYWORD INX H INX H CALL ICP7 INX H ;BUMP PNTRS DCR C MVI B,0 ;SET CHAR CNT JNZ PLOOP ;CONTINUE IF MORE INR B ;NOTHING MORE, PAD A NULL MVI A,0 CALL PAD JMP PEND ;WRITE IT AND CONTINUE PLOOP: MOV A,M ;GET CHARACTER CPI '"'+200Q ;IS IT "? JNZ EXPRE ;NO QUOTE: CALL ICP7 ;GET CHARACTER TO A MOV A,M CPI '"'+200Q ;IS IT "? JZ QCHEK QOTOK: INR B ;INCREMENT CNT MOV D,B ;SAVE IN D MVI B,1 ;PAD ONCE CALL PAD MOV B,D ;RESTORE CNT JMP QUOTE ;AGAIN QCHEK: INX H ;BUMP PNTRS DCR C JZ PEND ;EOL MOV A,M CPI '"'+200Q ;ANOTHER "? JZ QOTOK JMP SCOLN EXPRE: CALL ALPHA ;IS IT A LETTER JC PRTIT ;YES, EVALUATE AND PRINT CALL NUMB ;IS IT A NUMB? JC PRTIT ;YES, EVALUATE AND PRINT MOV A,M CPI '.'+200Q ;IS IT A DECIMAL PNT? JZ PRTIT ;YES EVALUATE, PRINT CPI '-'+200Q ;IS IT A -? JNZ SCOLN ;NO, CHECK FOR ; PRTIT: PUSH B ;SAVE CNT CALL EVAL ;EVALUATE EXPRESION PUSH B ;SAVE C,H,L PUSH H XCHG ;DE TO HL MVI C,SCR AND 377Q ;SET UP, CONVERT CALL CONV POP H ;RESTORE REG'S POP B MOV A,C POP B MOV C,A ORA A ;CHECK EOL JZ PEND MVI A,11 ;UPDATE CNTR ADD B MOV B,A MOV A,M ;GET CHAR. SCOLN: CPI ';'+200Q ;IS IT ;? JZ SONWD ;YES CPI ','+200Q ;IS IT ,? JNZ ER6 ;NO-UNEXPECTED CHAR. XRA A ;ZERO A ADFLD: ADI 13 ;ADD FIELD LENGTH CMP B ;COMPARE TO CNT JZ $+6 JNC FLDFD CPI 52 ;LAST FLD? JNZ ADFLD CALL WRIT ;YES-WRITE LINE MVI B,0 ;RESET CNT INX H ;BUMP PNTRS DCR C JZ PEND JMP PLOOP FLDFD: SUB B ;FOUND FIELD MOV D,B ;DETERMIN OF SPACES TO PAD MOV E,A ;SET UP TO CALL PAD MOV B,A MVI A,240Q CALL PAD ;PAD SPACES MOV A,D ADD E ;NEW CNT MOV B,A ;SAVE IN B SONWD: INX H ;CHECK EOL DCR C JNZ PLOOP MVI D,1 ;SUPPRESS CR/LF CALL WRIT1 JMP $+6 PEND: CALL WRIT ;DUMP BUFFER, CONTINUE JMP IEND ;INPUT PROCESSOR - READS VALUES FROM TTY ;THEY MUST BE DELIMITED BY COMMAS ONLY INPUT: MOV A,C ;IN CASE OF ERROR STA PL6 ;SAVE INPER: LHLD CPNT ;INPUT LINE (V-STRING) PNTR INX H ;ADJUST PNTR'S INX H INX H CALL ICP7 CALL ICP7 PRMPT: PUSH B ;SAVE PNTR'S PUSH H MVI B,1 ;SEND PROMPT MVI A,':' MOV D,B ;TO SUPPRESS CR/LF CALL PAD ;PAD IT CALL WRIT1 ;WRITE IT LXI H,IBUF ;ADD. OF INPUT BUFFER CALL TTYIN ;READ A LINE XCHG ;ADD. OF K-STRING TO DE POP H ;ADD. OF V-STRING POP B ;V-STRING CNT TO C MOV B,A ;K-STRING CNT TO B CALL STRIN ;TRANSFER CONSTANTS TO VARIBLES JZ INPOK ;NO ERROR CALL FORM9 CALL WRIT LDA PL6 ;GET V-STRING CNT MOV C,A JMP INPER ;START AGAIN INPOK: JC PRMPT ;NEED MORE CONSTANTS IEND: LHLD KFPNT ;ALL OK - GET NEW PNTR. JMP ILOOP ;CONTINUE ;THIS ROUTINE TRANSFERS THE FLOATING POINT VALUES ;OF AN ASCII STRING OF CONSTANTS TO THE LOCATIONS ;SPECIFIED BY AN ASCII STRING OF VARIBLES ;POINTER AND LINE CNT OF VAR. STRING ARE IN HL,C ;POINTER AND LINE CNT OF CONST. STRING ARE IN DE,B ;ON RETURN: ; Z=0 AND CY=0 ALL OK ; Z=0 AND CY=1 NEED MORE CONSTANTS ; Z=1 ERROR IN CONVERSION ;ALL POINTERS AND LINE CNT'S ARE RETURNED UPDATED STRIN: MOV A,C ;GET V-STRING CNT ORA A ;TEST FOR EOL RZ ;DONE, CY=0 =) ALL OK MOV A,M ;GET CHAR. CPI ',' OR 200Q ;IS IT A ,? JNZ STOKV ;IT'S NOT A , INX H ;COMMA, BUMP PNTR'S DCR C JZ ERRET ;POSSIBLE ERROR (IF EOL) STOKV: MOV A,B ;GET K-STRING LENGTH ORA A ;TEST FOR EOL STC ;IN CASE IT'S EOL RZ ;RET, CY=1 => NEED MORE CONSTANTS LDAX D ;GET CHAR CPI ',' OR 200Q ;TEST FOR , JNZ STOKK ;NOT A , - READY TO GO INX D ;BUMP PNTR'S DCR B JZ ERRET ;POSSIBLE ERROR (IF EOL) STOKK: PUSH B ;SAVE K-STRING CNT PUSH D ;SAVE K-STRING PNTR CALL VAR ;ADD. TO VARIBLE TO DE XCHG ;VAR. ADD TO H,L SHLD VARAD ;SAVE POP H ;ADDRESS OF K-STRING MOV A,C ;V-STRING CNT TO A POP B ;K-STRING CNT TO B MOV C,B ;K-STRING CNT TO C PUSH PSW ;SAVE V-STRING CNT PUSH D ;SAVE V-STRING ADD. MVI A,0 ;A=0 => DATA FROM TTY CALL RDKON ;GET CONSTANT TO GREG JNC STNER POP H ;EMPTY STACK POP H ERRET: XRA A ;ERROR INR A RET STNER: PUSH H ;SAVE K-STRING PNTR. LHLD VARAD ;GET VAR. ADD LXI D,GREG ;ADD. TO CONST. CALL COPDH ;COPY IT TO VARIABLE LOC. POP D ;K-STING PNTR. TO DE MOV B,C ;K-STRING LENGTH TO B POP H ;V-STRING PNTR. TO HL POP PSW ;V-STRING LENGTH TO C MOV C,A JMP STRIN ;LOOP ;LET STMT. PROCESSOR LET: LHLD CPNT ;GET PNTR. INX H ;FIX PNTR. INX H INX H MOV A,C ;CHECK FOR EOL ORA A JNZ LOK ER7: MVI A,7 JMP ERROR LOK: CALL VAR ;GET ADDRESS TO VAR. JC SAVV ;IT'S A VARIABLE MVI A,3 ;NO-CHEK FOR FUNC. CALL SYMSRT CPI 377Q JZ ER8 ;DON'T KNOW WHAT IT IS DCR A JNZ ER10 ;ILLEGAL USE OF FUNC. INX H ;IT'S PUT,UPDATE H,L INX H INX H MOV A,C ;EOL CHK ORA A JZ ER8 MOV A,M ;CHEK FOR ( CPI 250Q JNZ ER8 CALL ICP8 ;BUMP PNTRS CALL EVAL ;EVALUATE AND FIX PUSH H ;SAVE H,L LXI H,FREG1 CALL COPDH ;COPY IT XCHG POP H CALL FIX INX D INX D INX D LDAX D ;GET LOWEST BYTE PUSH PSW ;PORT = IS SAVED MOV A,M CPI 251Q ;CHECK FOR ) JNZ ER8 CALL ICP8 ;BUMP PNTR'S MVI D,377Q MOV E,D SAVV: PUSH D ;KEEP ADDRESS MOV A,M ;CHEK FOR = CPI 275Q JNZ ER8 CALL ICP8 ;BUMP PNTRS CALL EVAL ;EVALUATE EXPRESSION POP H ;GET ADDRESS CALL CHK1 JC PTFIN ;IT WAS A PUT CALL COPDH ;COPY TO ADDRESS JMP IEND ;CONTINUE PTFIN: LXI H,FREG1 ;COPY VALUE TO FREG1 CALL COPDH XCHG CALL FIX ;FIX THE VALUE INX D INX D INX D LDAX D MOV C,A ;SAVE IN C LXI H,PINST ;ADD OF BYTES TO GO TO LXI D,GREG ;RAM AT GREG MVI B,5 ;BYTE CNT PRI1: MOV A,M ;STORE PROG. SEG. IN STAX D ;RAM INX H INX D DCR B JNZ PRI1 POP PSW ;GET PORT = LXI H,GREG+1 MOV M,A ;STORE MOV A,C ;GET DATA OUT TO A DCX H ;TRANSFER PCHL PINST: OUT 0 ;RAM INSTRUCTIONS JMP IEND ER10: MVI A,10H JMP ERROR ;IF STMT. PROCESSOR IFRT: LHLD CPNT ;GET PNTR., ADJUST INX H INR C ;CHECK EOL CALL ICP7 CALL EVAL ;EVALUATE EXPRESSION MOV A,C ORA A ;CHECK EOL JZ ER7 IAGA: PUSH H ;SAVE H,L, PUT VALUE ON STK LDAX D INX D MOV L,A LDAX D INX D MOV H,A XTHL ;RESTORE H,L CMC JC IAGA ;ANOTHER PASS? MVI A,2 CALL SYMSRT ;CHEK TYPE OF RELATION CPI 4 ;WAS IT LEGAL? JC II1 ER14: MVI A,14H JMP ERROR II1: CPI 2 ;WAS IT A ,? JZ ER14 INR A ;ALL OK, INC,SAVE PUSH PSW INR C CALL ICP7 ;BUMP PNTRS MVI A,2 ;CALL SYMSRT CALL SYMSRT CPI 377Q ;FOUND ANYTHING? JZ RELAT ;DONE CPI 2 JZ ER14 ;IT WAS A , CPI 4 JNC ER14 ;NOT LEGAL INR A MOV B,A INR C CALL ICP7 POP PSW ;GET SECOND RELATION ADD B ;ADD THEM PUSH PSW ;AND SAVE CPI 10Q ;TEST FOR == JZ ER14 ;RELATION IS STORED ON TOP OF STACK (PUSH PSW> ACCORDING TO ;THE FOLLOWING ; ; 1 =) < ; 2 => > ; 3 => <> ; 4 => = ; 5 => <= ; 6 => >= ; RELAT: CALL EVAL ;EVALUATE PUSH H ;SAVE H,L LXI H,FREG2 ;COPY TO FREG2 CALL COPDH POP H ;GET H,L POP PSW ;AND RELATION XTHL ;GET 2ND 2 BYTES SHLD FREG1+2 ;STORE POP H ;GET 1ST 2 BYTES,STORE XTHL SHLD FREG1 PUSH B PUSH PSW ;SAVE A,B,C CALL FCOMP ;COMPARE NUMBERS MOV D,A ;SAVE RESULT IN D POP PSW ;GET RELATION,B,C POP B CMP D ;SAME? JZ TRUE ;YES SUI 4 JP NOT3 ;NOT RELATION 3 INR A ;IS IT RELATION 3? JNZ FALSE ;NO, ITS FALSE MVI A,4 ;IT IS, CHECK FOR INEQUALITY CMP D JNZ TRUE JMP FALSE NOT3: CMP D ;RELATION 5,6 TRUE? JZ TRUE ;YES MVI A,4 ;IT WAS, CHECK FOR EQUALITY CMP D JZ TRUE FALSE: POP H ;CONTINUE JMP IEND TRUE: POP H MVI B,4 THEN: CALL ICP7 ;INCREMENT PAST THEN DCR B JNZ THEN JMP GTRA ;TRANSFER TO GOTO ;ROUTINE FCOMP COMPARES 2 FLOATING POINT ='S. THEY ARE ASSUMED ;TO BE IN FREG1 AND FREG2. ;ALL REGISTERS ARE DESTROYED. ;THE VALUE RETURNED IN REG A IS RESULT OF COMPARISON. ;RESULTS ARE AS FOLLOWS: ; ; A=1 => FREG1 < FREG2 ; A=2 => FREG1 > FREG2 ; A=4 => FREG1 = FREG2 ; FCOMP: LXI H,FREG1+3 ;PNTS TO CHAR OF 1ST LXI D,FREG2+3 ;PNTS TO CHAR OF 2ND MOV A,M ;GET 1 CHAR MVI B,200Q ;MASK TO B ANA B ;GET SIGN, 1 MOV C,A ;SAVE IN C LDAX D ;GET CHAR 2 ANA B ;GET SIGN 2 XRA C JZ SINEQ ;SAME SIGNS MOV A,C ;OPPISITE SIGNS,GET 1 SIGN RAL ;ROTATE TO CY MVI A,1 RC ;FREG1 < FREG2 => A=1 INR A ;ELSE FREG1 > FREG2 RET ;AND A=2 SINEQ: PUSH B ;SAVE SIGN DCX H ;PNTR TO 1 IN H,L DCX H DCX H MOV B,E ;PNTR TO 2 IN B DCR B DCR B DCR B CALL LMCM ;COMPARE MAGNITUDES ;AT THIS POINT Z=1 => =, CY=1 => 1<2 POP B ;GET SIGN BACK JNZ $+6 MVI A,4 ;EQUAL => A=4 RET MOV A,C ;GET SIGN TO A INR A ;SET SIGN BIT MVI A,1 JM $+6 ;SIGN IS NEGATIVE RC ;SIGN=+ AND ABS(FREG1)ABS(FREG2) RET RNC ;SIGN=- AND ABS(FREG1)>ABS(FREG2) INR A ;ABS(FREG1) LOOP DONE INX H ;LOOP NOT DONE INX H ;PNT TO TRANSFER ADD. INX H INX H MOV E,M ;GET IT TO H,L INX H MOV D,M XCHG JMP ILOOP NXTDN: LXI H,NEST ;POP NEST STACK INR M INR M JMP IEND ;CONTINUE ER16: MVI A,16H ;'=' EXPECTED(NOTE: NO ARRAY ELEMENTS JMP ERROR ;FOR INDICES< ER17: MVI A,17H ;BAD SYNTAX NEAR 'TO' OR 'STEP' JMP ERROR ;IN FOR STATEMENT ER18: MVI A,18H ;FOR'S NESTED TOO DEEPLY JMP ERROR ER19: MVI A,19H ;'NEXT' EXECUTED BEFORE A 'FOR' JMP ERROR ER20: MVI A,20H ;NESTING ERROR, 'FOR'-'NEXT' JMP ERROR ER21: MVI A,21H ;BAD INDEX IN FOR-NEXT JMP ERROR ; ; THIS SUB CHECKS FOR PAGE BOUNDARY CROSSING ; OF VARIABLE STORAGE BEFORE UPDATING ; FORWARD POINTER ; D-E POINT TO CURRENT LOCATION OF NEXT VARIABLE ; H-L POINT TO PREVIOUS VARIABLE LOCATION ; ; MODIFY D-E ( IF NECESSARY ) SO VARIABLE WILL NOT CROSS PAGE BOUNDARY ; CHKLC: PUSH PSW PUSH D ; SEE IF CURRENT VARIABLE MVI A,7 ; STORAGE 8 WORD BLOCK ADD E ; WILL CROSS PAGE BOUNDARY JC CH0VL ; OK - DOES NOT CROSS PAGE POP D POP PSW RET ; PAGE BOUNDARY CROSSED - SET D-E TO START OF NEXT PAGE CH0VL: POP D INR D MVI E,0 POP PSW RET ; ; THIS SUB IS CALLED FROM 'DIM' PROCESSOR ; REGS. 'D-E' POINT TO NEXT AVAILABLE WORD OF VARIABLE STORAGE ; THIS SUB MAKES SURE THAT STORAGE STARTS ON A 4-WORD ; BOUNDARY SO FLT. PT. NUMBER WILL NOT CROSS PAGE ; CKDIM: MOV A,E ANI 3 RZ MOV A,E ANI 374Q ADI 4 MOV E,A MOV A,D ACI 0 MOV D,A RET END