CP/M

home *** CD-ROM | disk | FTP | other *** search

/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug011.ark / BASIC_5.ASM next >

Wrap

Assembly Source File | 1984-04-29 | 75.8 KB | 4,627 lines

; HAMPSHIRE COLLEGE 5K BASIC ; ========================== ; ; ; KEVIN JORDAN'S CP/M ADAPTATION OF PROCESSOR TECH ; 5K BASIC. ; ; THIS IS VERSION Z1.0 FROM JEFF ZURKOW, WITH THE FOLLOWING ; ADDITIONAL FEATURES: ; ; 1. THE BEAM AND DRAW STATEMENTS FOR TEKTRONIX TERMINALS. ; 2. LLIST COMMAND AND LPRINT STATEMENT FOR LINE PRINTER OUTPUT. ; 3. ARRAYS CLEARED ONLY WHEN DIMENSION STATEMENT EXECUTED, ; ONLY USED SYMBOL TABLE SPACE CLEARED. (ORIGINAL VERSION ; CLEARED ALL OF NON-PROGRAM MEMORY EACH TIME A STATEMENT ; WAS TYPED IN). ; ; ; ; ; SYSTEM GLOBAL EQUATES ; ORG 100H SYSTEM EQU 5 ;ENTRY TO CP/M TFCB EQU 5CH ;DEFAULT FCB ADDR TBUFF EQU 80H ;DEFAULT DMA ADDR NR EQU TFCB+32 ;NEXT RECORD INDEX FPSIZ EQU 5 LINLEN EQU 80 ;# CHARS IN LEGAL INPUT LINE FP123 EQU FPSIZ-2 FPNIB EQU FP123*2 DIGIT EQU FPNIB/2 CR EQU 15Q NULL EQU 0 LF EQU 12Q ESC EQU 3Q ;CONTROL-C RUBOUT EQU 7FH CNTRU EQU 15H ;CONTROL-U EOF EQU 1 ;END OF FILE BELL EQU 7 ;BELL CHARACTER STESIZ EQU 2+FPSIZ ;SYMBOL TABLE ELEMENT SIZE OPBASE EQU '(' FTYPE EQU 1 ;CONTROL STACK FOR ENTRY TYPE FORSZ EQU FPSIZ*2+2+2+1 ;'FOR' CONTROL STACK ENTRY SIZE GTYPE EQU 2 ;CONTROL STACK GOSUB ENTRY TYPE ETYPE EQU 0 ;CONTROL STACK UNDERFLOW TYPE UMINU EQU 61Q ;UNARY MINUS ; ; STARTUP BASIC SYSTEM ; START: LXI SP,CMNDSP XRA A STA NULLCT ;INITIALIZE NULL COUNT STA PFLAG ;TURN OF LINE-PRINTER FLAG INR A STA DIRF ;INITIALIZE DIRECT INPUT FLAG LXI H,MEMTOP+2 ;FIRST FREE BYTE AFTER INTERPRETTER SHLD BOFA ;START OF USER ASSIGNED MEMORY LHLD SYSTEM+1 ;ADDRESS OF BDOS DCX H ;SET LAST POSSIBLE FREE BYTE BEFORE BDOS SHLD MEMTOP ;END OF ASSIGNED MEMORY POINTER SHLD STB ;INITIALIZE END OF SYMBOL TABLE CALL CSCR ;INITIALIZE FREE-SPACE CALL CRLF LXI H,HEAD ;OUTPUT HEADER MESSAGE CALL PRNT CALL CRLF CALL CRLF2 LXI H,TFCB+1;TEST FOR FILE NAME IN BASIC INVOCATION MOV A,M CPI ' ' JZ ST0 ;IF NO FILE NAME LXI D,WSIDN MVI C,8 CALL COPY MOV A,M ;TEST FOR FILE TYPE SPECIFIED CPI ' ' JNZ STRT1 ;IF TYPE SPECIFIED LXI H,WSIDD+8 ;DEFAULT TYPE STRT1: LXI D,WSIDT MVI C,3 CALL COPY ;SET FILE TYPE JMP COLD3 ;FETCH THE FILE ; ; COPY - COPIES NUMBER OF BYTES IN C ; FROM ADDRESS IN HL TO ADDR IN DE ; COPY: MOV A,M STAX D INX H INX D DCR C JNZ COPY RET ; ST0: LXI H,PLS ;'NEW OR OLD' MESSAGE CALL PRNT STAR1: CALL INLINE LDA IBUF CPI 'N' ;IS IT A 'NEW' COMMAND? JZ CNEW1 ;IF 'NEW' COMMAND CPI 'O' JZ COLD1 ;IF 'OLD' COMMAND JMP ST0 ; COLD: CALL CSCR ;CLEAR WORK-SPACE CALL GC ;FIND FIRST NON-BLANK CPI CR JNZ COLD2 ;IF FILE NAME IN-LINE COLD1: LXI H,OPN ;PRINT 'OLD PROGRAM NAME: ' CALL PRNT CALL INLINE ;GET THE WSID LXI H,IBUF SHLD TXA COLD2: CALL WSID ;GET THE WORK-SPACE ID COLD3: CALL FETCH ;LOAD THE PROGRAM JMP ST4 ; CNEW: CALL CSCR ;CLEAR WORK-SPACE CALL GC CPI CR JNZ CNEW2 ;IF FILE NAME IN-LINE CNEW1: LXI H,NPN ;PRINT 'NEW PROGRAM NAME: ' CALL PRNT CALL INLINE ;GET THE WSID LXI H,IBUF SHLD TXA CNEW2: CALL WSID ;SAVE IT ST4: MVI A,2*FPNIB STA INFES ; ; INITIALIZE RANDOM NUMBER ; LXI D,FRAND LXI H,RANDS CALL VCOPY ;FRAND=RANDOM NUMBER SEED ; ; COMMAND PROCESSOR ; CMND1: CALL CRLF2 LXI H,RDYS ;PRINT READY MESSAGE CALL PRNT CMNDR: MVI A,1 ;SET DIRECT INPUT FLAG STA DIRF LXI SP,CMNDSP CALL CRLF CMND2: CALL INLINE ;GET INPUT FROM OPERATOR CALL PP ;PRE-PROCESS IT JC CMND3 CALL LINE ;LINE NUMBER . . . GO EDIT CALL CCLEAR JMP CMND2 ; CMND3: CALL CMND4 JMP CMNDR ; CMND4: LXI H,IBUF ;POINT TO COMMAND OR STATEMENT SHLD TXA CALL GC ANI 240Q CPI 240Q ;CHECK FOR COMMAND LXI D,CMNDD JZ ISTA1 ;PROCESS COMMAND CALL ISTAT ;PROCESS STATEMENT (IF ALLOWED) CALL GCI CPI CR RZ E1: LXI H,SYNTX JMP ERROR ; ; ERROR MESSAGE PRINTOUT ; E3: LXI H,ARGUM JMP ERROR ; E4: LXI H,CSTAK JMP ERROR ; E5: LXI H,BOUND JMP ERROR ; E6: LXI H,DIMEN ; ERROR: PUSH H LDA DIRF ;CHECK INPUT MODE ORA A JNZ ERRO1 ;IF DIRECT INPUT MODE LHLD TRPSP ;CHECK FOR TRAPS SET LXI B,-TRPSTK DAD B MOV A,H ORA L JZ ERRO1 ;IF TRAP STACK EMPTY LHLD TRPSP ;POP LINE NUMBER INX H MOV E,M INX H MOV D,M SHLD TRPSP CALL FINDLN ;FIND THE LINE INX H ;ADVANCE POINTER BEYOND LINE # AND COUNT INX H INX H SHLD TXA ;UPDATE TXA LXI SP,CMNDSP ;CLEAN UP JMP ILOOP ;CONTINUE EXECUTION FROM TRAP LINE ; ERRO1: CALL CRLF POP H CALL PRNT LXI H,ERS ERM1: CALL PRNT LDA DIRF ORA A JNZ CMND1 LXI H,INS CALL PRNT ; ; FIND LINE NUMBER ; LHLD BOFA ERM2: MOV B,H MOV C,L MOV E,M MVI D,0 DAD D XCHG LXI H,TXA CALL DCMP XCHG JC ERM2 INX B LDAX B MOV L,A INX B LDAX B MOV H,A LXI D,IBUF ;USE IBUF TO ACCUMULATE LINE NO. STRING CALL CNS MVI A,CR STAX D LXI H,IBUF CALL PRNTCR JMP CMND1 ; ; LINE EDITOR ; LINE: LHLD BOFA ;CHECK FOR EMPTY FILE FIN: MOV A,M ;CHECK IF APPENDING LINE AT END DCR A JZ APP XCHG INX D LHLD IBLN ;GET INPUT LINE NUMBER XCHG CALL DCMP ;COMPARE WITH FILE LINE NUMBER DCX H JC INSR ;LESS THAN JZ INSR ;EQUAL MOV A,M ;LENGTH OF LINE CALL ADR ;JUMP FORWARD JMP FIN ; ; APPEND LINE AT END CASE ; APP: LDA IBCNT ;DONT APPEND NULL LINE CPI 4 RZ CALL FULL ;CHECK FOR ROOM IN FILE LHLD EOFA ;PLACE LINE IN FILE CALL IMOV MVI M,EOF SHLD EOFA RET ; ; INSERT LINE IN FILE CASE ; INSR: MOV B,M ;OLD LINE COUNT SHLD INSA ;INSERT LINE POINTER LDA IBCNT ;NEW LINE COUNT JC LT ;JMP IF NEW LINE #<>OLD LINE # SUI 4 JZ LT1 ;TEST IF SHOULD DELETE NULL LINE ADI 4 LT1: SUB B JZ LIN1 ;LINE LENGTHS EQUAL JC GT ; ; EXPAND FILE FOR NEW OR LARGER LINE ; LT: MOV B,A LDA IBCNT CPI 4 ;DON'T INSERT NULL LINE RZ MOV A,B CALL FULL LHLD INSA CALL NMOV LHLD EOFA XCHG SHLD EOFA INX B CALL RMOV JMP LIN1 ; ; CONTRACT FILE FOR SMALLER LINE ; GT: CMA INR A CALL ADR CALL NMOV XCHG LHLD INSA CNZ LMOV MVI M,EOF SHLD EOFA ; ; INSERT CURRENT LINE INTO FILE ; LIN1: LHLD INSA LDA IBCNT CPI 4 RZ ; ; INSERT CURRENT LINE AT ADDR HL ; IMOV: LXI D,IBCNT LDAX D MOV C,A MVI B,0 ; ; COPY BLOCK FROM BEGINNING ; HL IS DESTIN ADDR, DE IS SOURCE ADDR, BC IS COUNT ; LMOV: LDAX D MOV M,A INX D INX H DCX B MOV A,B ORA C JNZ LMOV RET ; ; COPY BLOCK STARTING AT END ; HL IS DESTIN ADDR, DE IS SOURCE ADDR, BC IS COUNT ; RMOV: LDAX D MOV M,A DCX H DCX D DCX B MOV A,B ORA C JNZ RMOV RET ; ; COMPUTE FILE MOVE COUNT ; ; BC GETS (EOFA)-(HL), RET Z SET MEANS ZERO COUNT ; NMOV: LDA EOFA SUB L MOV C,A LDA EOFA+1 SBB H MOV B,A ORA C RET ; ; ADD A TO HL ; ADR: ADD L MOV L,A RNC INR H RET ; ; CHECK FOR FILE OVERFLOW, LEAVES NEW EOFA IN DE ; A HAS INCREASE IN SIZE ; FULL: LHLD EOFA CALL ADR XCHG LXI H,MEMTOP CALL DCMP JNC E8 RET ; ; COMMANDS ; CSCR: LHLD BOFA MVI M,EOF SHLD EOFA ; ; 'CLEAR' ; CCLEAR: LHLD EOFA ;CLEAR FROM EOFA TO MEMTOP INX H SHLD MATA LHLD STB XCHG LXI H,MEMTOP;END OF ASSIGNED MEMORY CCLR1: XRA A STAX D CALL DCMP INX D JNZ CCLR1 LHLD MEMTOP SHLD STB LXI H,CSTKL+CSTKSZ-1 MVI M,ETYPE SHLD CSTKA LXI H,ASTKL+ASTKSZ+FPSIZ-1 SHLD ASTKA RET ; ; 'NULL' ; CNULL: CALL INTGER JC E3 ;NO ARGUMENT SUPPLIED MOV A,L STA NULLCT JMP CMND1 ; ; 'LIST' ; CLIST: CALL GC CPI CR LXI D,0 JZ CL0 ;JUMP IF NO ARGUMENT SUPPLIED CALL INTGER ;ERROR DEFAULT IS LIST CL0: LHLD BOFA CL1: MOV A,M DCR A RZ INX H CALL DCMP DCX H ;POINT TO COUNT CHAR AGAIN JC CL2 JZ CL2 ; ; INCREMENT TO NEXT LINE ; MOV A,M CALL ADR JMP CL1 CL2: PUSH D LXI D,IBUF ;AREA TO UNPREPROCESS TO CALL UPPL INX H PUSH H LXI H,IBUF CALL PRNTCR CALL PCHECK CALL CRLF POP H POP D JMP CL1 ; ; 'LLIST' ; LLIST: MVI A,1 ;SWITCH OUTPUT TO LINE PRINTER STA PFLAG CALL CRLF2 CALL CLIST ;CALL NORMAL LIST ROUTINE CALL CRLF2 XRA A ;SWITCH OUTPUT BACK TO CONSOLE STA PFLAG RET ; ; 'RUN' ; CRUN: CALL CCLEAR LHLD BOFA MOV A,M DCR A ;CHECK FOR NULL PROGRAM JZ CEND INX H INX H INX H SHLD TXA SHLD RTXA ;POINTER FOR 'READ' STATEMENT XRA A STA DIRF ;CALL DIRECT FLAG AND FALL THRU TO DRIVER CALL CRLF ; ; INTERPRETTER DRIVER ; ILOOP: CALL PCHECK CALL ISTAT ;INTERPRET CURRENT STATEMENT CALL JOE ;TEST FOR JUNK ON END JNC ILOOP ;CONTINUE IF NOT AT END OF PROGRAM JMP CEND ;EXECUTE END STATEMENT ; ; INTERPRET STATEMENNT LOCATED BY TXA ; ISTAT: CALL GC ;GET FIRST NON BLANK ORA A JM ISTA0 ;IF RW CPI CR JZ CMND1 ;OUTPUT 'READY' IF BLANK LINE JMP LET ;MUST BE 'LET' IF NOT RW OR CR ; ISTA0: CPI IRWLIM ;IS IT AN INITIAL RW JNC E1 LXI D,STATD ;STATEMENT DISPATCH TABLE BASE ISTA1: CALL GCI ;ADVANCE TEXT POINTER ANI 37Q RLC ;MULTIPLY BY TWO PREPARING FOR TABLE LOOKUP MOV L,A MVI H,0 DAD D CALL LHLI PCHL ;BRANCH TO STATEMENT OR COMMAND ; ; STATEMENTS ; ; 'LET' ; LET: CALL VAR ;CHECK FOR VARIABLE JC E1 PUSH H ;SAVE VALUE ADDRESS MVI B,EQRW CALL EATC CALL EXPRB POP D ;DESTINATION ADDRESS CALL POPA1 ;COPY EXPRESSION VALUE TO VARIABLE RET ; ; 'FOR' ; SFOR: CALL DIRT CALL VAR ;CONTROL VARIABLE JC E1 PUSH H ;CONTROL VARIABLE VALUE ADDRESS MVI B,EQRW CALL EATC CALL EXPRB ;INITIAL VALUE POP D ;VARIABLE VALUE ADDRESS PUSH D ;SAVE CALL POPA1 ;SET INITIAL VALUE MVI B,TORW ;RW FOR 'TO' CALL EATC CALL EXPRB ;LIMIT VALUE COMPUTATION CALL GC ;CHECK NEXT CHARACTER FOR POSSIBLE STEP EXPRESSION CPI STEPRW JZ FOR1 ; ; USE STEP OF 1 ; LXI D,FPONE CALL PSHA1 JMP FOR2 ; ; COMPUTE STEP VALUE ; FOR1: CALL GCI ;EAT THE STEP RW CALL EXPRB ;THE STEP VALUE ; ; HERE THE STEP AND LIMIT ARE ON ARG STACK ; FOR2: LXI D,-2 ;PREPARE TO ALLOCATE 2 BYTES ON CONTROL STACK CALL PSHCS ;RETURNS ADDRESS OF THOSE 2 BYTES IN HL XCHG CALL JOE ;TEST FOR JUNK ON END JC E4 ;NO 'FOR' STATEMENT AT END OF PROGRAM XCHG ;DE HAS LOOP TEXT ADDR, HL HAS CONTROL STACK ADDR MOV M,D ;HIGH ORDER TEXT ADDRESS BYTE DCX H MOV M,E ;LOW ORDER TEXT ADDRESS BYTE LXI D,-FPSIZ;ALLOCATE SPACE FOR LIMIT ON CONTROL STACK CALL PSHCS PUSH H ;ADDR ON CONTROL STACK FOR LIMIT LXI D,-FPSIZ;ALLOCATE SPACE FOR STEP ON CONTROL STACK CALL PSHCS CALL POPAS ;COPY STEP VALUE TO CONTROL STACK POP D ;CONTROL STACK ADDR FOR LIMIT VALUE CALL POPA1 ;LIMIT VALUE TO CONTROL STACK LXI D,-3 ;ALLOCATE SPACE FOR TEXT ADDR AND CS ENTRY CALL PSHCS POP D ;CONTROL VARIABLE ADDR MOV M,D ;HIGH ORDER BYTE OF CONTROL VARIABLE ADDR DCX H MOV M,E ;LOW ORDER BYTE OF CONTROL VARIABLE ADDR DCX H MVI M,FTYPE ;SET CONTROL STACK ENTRY TYPE FOR 'FOR' JMP NEXT5 ;GO FINISH OFF CAREFULLY ; ; 'NEXT' ; NEXT: CALL DIRT LHLD CSTKA ;CONTROL STACK ADDR MOV A,M ;STACK ENTRY TYPE BYTE DCR A ;MUST BE FOR TYPE ELSE ERROR JNZ E4 ;IMPROPER NESTING ERROR INX H ;CONTROL STACK POINTER TO CONTROL VARIABLE ADDR PUSH H CALL VAR ;CHECK VARIABLE, IN CASE USER WANTS JC NEXT1 ;SKIP CHECK IF VAR NOT THERE XCHG POP H ;CONTROL VARIABLE ADDRESS PUSH H ;SAVE IT AGAIN CALL DCMP JNZ E4 ;IMPROPER NESTING IF NOT THE SAME NEXT1: POP H ;CONTROL VARIABLE ADDR PUSH H PUSH H LXI D,FPSIZ+2-1 ;COMPUTE ADDR TO STEP VALUE DAD D XTHL ;NOW ADDR TO VAR IN HL CALL LHLI ;VARIABLE ADDR MOV B,H ;COPY VAR ADDR TO BC MOV C,L POP D ;STEP VALUE ADDR PUSH D CALL FADD ;DO INCREMENT POP H ;STEP VALUE DCX H ;POINT TO SIGN OF STEP VALUE MOV A,M ;SIGN 0=POS, 1=NEG LXI D,FPSIZ+1 DAD D ;PUTS LIMIT ADDR IN HL XCHG POP H ;VARIABLE ADDR CALL LHLI ;GET ADDR PUSH D ;SAVE CONTROL STACK POINTER TO GET TEXT ADDR ORA A ;SET CONDITIONS BASED ON SIGN OF STEP VALUE JZ NEXT2 ;REVERSE TEST ON NEGATIVE STEP VALUE XCHG NEXT2: MOV B,H ;SET UP ARGS FOR COMPARE MOV C,L CALL RELOP ;TEST <= POP D ;TEXT ADDR JM NEXT3 ;STILL SMALLER? JZ NEXT3 ;JUMP IF WANT TO CONTINUE LOOP ; ; TERMINATE LOOP ; LXI H,3 ;REMOVE CSTACK ENTRY DAD D SHLD CSTKA RET ; NEXT3: INX D ;TEXT ADDR XCHG CALL LHLI ;GET TEXT ADDR IN HL ; ; ITERATE, SKIPPING NORMAL JUNK ON END TEST AT ILOOP ; NEXT4: XCHG ;SAVE NEW TEXT ADDR IN DE CALL JOE XCHG NEXT6: SHLD TXA NEXT5: LXI H,ILOOP XTHL RET ;TO DISPATCHER SKIPPING JOE CALL THERE ; ; 'IF' ; SIF: MVI B,1 ;SPECIFY PRINCIPAL OPERATOR IS RELATIONAL CALL EXPB1 LHLD ASTKA ;ADDR OF BOOLEAN VALUE ON ARG STACK INR M ;SETS ZERO CONDITION IF RELATIONAL WAS TRUE PUSH PSW ;SAVE CONDITIONS TO TEST LATER CALL POPAS ;REMOVE VALUE FROM ARG STACK COPY TO SELF POP PSW JNZ REM ;IF TEST FALSE TREAT REST OF STATEMENT AS REM ; ; TEST SUCCEEDED ; MVI B,THENRW CALL EATC CALL INTGER ;CHECK IF LINE NUMBER IS DESIRED ACTION JC ISTAT JMP GOTO1 ; ; 'GOTO' ; SGOTO: XRA A STA DIRF ;CLEAR DIRECT STATEMENT FLAG CALL INTGER ;RETURNS INTEGER IN HL IF LINE NUMBER PRESENT JC E1 ;SYNTAX ERROR, NO LINE NUMBER GOTO1: XCHG ;LINE IN DE CALL FINDLN ;RETURNS TEXT ADDR POINTS TO COUNT VALUE GOTO2: INX H INX H INX H ;ADVANCE TEXT POINTER PAST LINE NUMBER AND COUNT JMP NEXT4 ; ; 'GOSUB' ; GOSUB: CALL DIRT LXI D,-3 ;CREATE CONTROL STACK ENTRY CALL PSHCS PUSH H ;SAVE STACK ADDRESS CALL INTGER JC E1 XCHG ;LINE NUMBER TO DE CALL JOE MOV B,H MOV C,L POP H ;STACK ADDR MOV M,B ;STACK RETURN ADDR RETURNED BY JOE DCX H MOV M,C DCX H MVI M,GTYPE ;MAKE CONTROL STACK ENTRY TYPE 'GOSUB' CALL FINDLN INX H INX H INX H JMP NEXT6 ; ; 'RETURN' ; RETRN: CALL DIRT STA DIRF ;CLEARS DIRF IF ACC IS CLEAR LHLD CSTKA RET1: MOV A,M ORA A ;CHECK FOR STACK EMPTY JZ E4 CPI GTYPE ;CHECK FOR GOSUB TYPE JZ RET2 ; ; REMOVE FOR TYPE ENTRY FROM STACK ; LXI D,FORSZ DAD D JMP RET1 ; ; FOUND A GTYPE STACK ENTRY ; RET2: INX H MOV E,M ;LOW ORDER TEXT ADDR INX H MOV D,M ;HIGH ORDER TEXT ADDR INX H ;ADDR OF PREVIOUS CONTROL STACK ENTRY SHLD CSTKA XCHG ;PUT TEXT ADDR IN HL MOV A,M ;ADDR POINTS TO EOF IF GOSUB WAS LAST LINE DCR A ;END OF FILE? JNZ NEXT4 JMP CEND ; ; 'DATA' AND 'REM' ; DATA: CALL DIRT ;DATA STATEMENT ILLEGAL AS DIRECT REM: CALL GCI CPI CR JNZ REM DCX H ;BACKUP POINTER SO NORMAL JOE WILL WORK SHLD TXA RET ; ; 'DIMENSION' ; DIM: CALL NAME ;LOOK FOR VARIABLE NAME JC E1 MOV A,C ;PREPARE TURN ON 200Q BIT TO SIGNIFY MATRIX ORI 200Q MOV C,A CALL STLK JNC E6 ;ERROR IF NAME ALREADY EXISTS PUSH H ;SYMBOL TABLE ADDR MVI B,LPARRW CALL EATC CALL EXPRB MVI B,')' CALL EATC CALL PFIX ;RETURN INTEGER IN DE LXI H,MATUB ;MAX SIZE FOR MATRIX CALL DCMP JNC E6 POP H ;SYMBOL TABLE ADDR CALL DIMS CALL GC ;SEE IF MORE TO DO CPI ',' RNZ CALL GCI ;EAT THE COMMA JMP DIM ; ; 'STOP' ; STOP: CALL DIRT STOP1: CALL CRLF2 LXI H,STOPS JMP ERM1 ; ; 'END' ; CEND EQU CMND1 ; ; 'READ' ; READ: CALL DIRT LHLD TXA PUSH H ;SAVE TXA TEMPORARILY LHLD RTXA ;THE 'READ' TXA READ0: SHLD TXA CALL GCI CPI ',' JZ READ2 ;PROCESS INPUT VALUE CPI DATARW JZ READ2 DCR A JZ READ4 ; ; SKIP TO NEXT LINE ; CALL REM ;LEAVES ADDR OF LAST CR IN HL INX H MOV A,M DCR A JZ READ4 INX H INX H INX H ;HL NOW POINTS TO FIRST BYTE OF NEXT LINE JMP READ0 ; ; PROCESS VALUE ; READ2: CALL EXPRB CALL GC CPI ',' ;SKIP JOE TEST IF COMMA JZ READ3 ; ; JUNK ON END TEST ; CALL JOE READ3: LHLD TXA SHLD RTXA ;SAVE NEW 'READ' TEXT ADDR POP H SHLD TXA CALL VAR JC E1 CALL POPAS ;PUT READ VALUE INTO VARIABLE CALL GC CPI ',' ;CHECK FOR ANOTHER VARIABLE RNZ CALL GCI ;EAT THE COMMA JMP READ ; READ4: POP H ;PROGRAM TXA SHLD TXA LXI H,RDERR JMP ERROR ; ; 'RESTORE' ; RESTOR: LHLD BOFA ;BEGINNING OF FILE POINTER INX H INX H INX H SHLD RTXA RET ; ; 'LPRINT' ; LPRINT: MVI A,1 ;SWITCH OUTPUT TO LINE PRINTER STA PFLAG CALL PRINT ;CALL NORMAL PRINT ROUTINE XRA A ;SWITCH OUTPUT BACK TO CONSOLE STA PFLAG RET ; ; 'PRINT' ; PRINT: CALL GC CPI CR ;CHECK FOR STAND ALONE PRINT JZ CRLF PRIN0: CPI '"' JZ PSTR ;PRINT THE STRING CPI TABRW JZ PTAB ;TABULATION CPI '%' JZ PFORM ;SET FORMAT CPI CR RZ CPI ';' RZ CALL EXPRB ;MUST BE EXPRESSION TO PRINT LXI D,FPSINK CALL POPA1 ;POP VALUE TO FPSINK LDA PHEAD LXI H,LWID CMP M CNC CRLF ;IF PRINT HEAD PAST LINE WIDTH LIMIT LXI H,FPSINK CALL FPOUT MVI B,' ' CALL CHOUT PR1: CALL GC ;GET DELIMITER CPI ',' JNZ CRLF PR0: CALL GCI CALL GC JMP PRIN0 ; PSTR: CALL GCI ;GOBBLE THE QUOTE CALL PRNT ;PRINT UP TO DOUBLE QUOTE INX H SHLD TXA JMP PR1 ; PFORM: MVI A,2*FPNIB STA INFES CALL GCI ;GOBBLE PREVIOUS CHARACTER PFRM1: CALL GCI LXI H,INFES CPI '%' ;DELIMITER JZ PR1 MVI B,200Q CPI 'Z' ;TRAILING ZEROES? JZ PF1 MVI B,1 CPI 'E' ;SCIENTIFIC NOTATION? JZ PF1 CALL NMCHK JNC E1 SUI '0' ;NUMBER OF DECIMAL PLACES RLC MOV B,A MOV A,M ANI 301Q MOV M,A PF1: MOV A,M ORA B MOV M,A JMP PFRM1 ; PTAB: CALL GCI ;GOBBLE TAB RW MVI B,LPARRW CALL EATC CALL EXPRB MVI B,')' CALL EATC CALL PFIX PTAB1: LDA PHEAD CMP E JNC PR1 MVI B,' ' CALL CHOUT JMP PTAB1 ; ; 'INPUT' ; INPUT: CALL GC CPI '"' ;CHECK FOR USER-DEFINED PROMPT JNZ INPU1 ;IF NO PROMPT CALL GCI CALL PRNT ;OUTPUT PROMPT INX H ;UPDATE TXA SHLD TXA CALL GC INPU1: CPI ',' JZ NCRLF CALL CRLF INP0: MVI B,'?' CALL CHOUT LINP: CALL INLINE LXI D,IBUF IN1: PUSH D ;SAVE FOR FPIN CALL VAR JC E1 POP D MVI B,0 LDAX D CPI '+' ;LOOK FOR LEADING PLUS OR MINUS ON INPUT JZ IN2 CPI '-' JNZ IN3 MVI B,1 IN2: INX D IN3: PUSH B PUSH H CALL FPIN ;INPUT FP NUMBER JC INERR POP H DCX H POP PSW MOV M,A CALL GC CPI ',' RNZ ;DONE IF NO MORE CALL GCI ;EAT THE COMMA MOV A,B ;GET THE TERMINATOR TO A CPI ',' JZ IN1 ;GET THE NEXT INPUT VALUE FROM STRING ; ; GET NEW LINE FROM USER ; MVI B,'?' CALL CHOUT JMP INP0 ; NCRLF: CALL GCI JMP LINP ;NOW GET LINE ; INERR: LXI H,INPER JMP ERROR ; ; ; - TPUT - ROUTINE TO OUTPUT CHARACTER FROM C TO TEKTRONIX ; TPUT: IN 3 ANI 1 JZ TPUT MOV A,C OUT 2 RET ; ; ; - TEKOUT - ROUTINE TO OUTPUT X OR Y ADDRESS FROM DE TO ; TEKTRONIX. ; ; TEKOUT: MOV A,D RLC RLC RLC ANI 18H ORI 20H MOV D,A MOV A,E RLC RLC RLC ANI 7H ORA D MOV D,A MOV A,E ANI 1FH ORA B MOV E,A MOV C,D CALL TPUT MOV C,E CALL TPUT RET ; ; BEAM: MVI C,29 CALL TPUT ;PUT TEK IN GRAPH MODE DRAW: CALL EXPRB CALL PFIX PUSH D ;SAVE X VALUE MVI B,',' CALL EATC CALL EXPRB CALL PFIX MVI B,60H CALL TEKOUT POP D MVI B,40H CALL TEKOUT RET ; ; ; ; - CPUSH - ROUTINE TO PUSH 16-BIT INTEGERS ON ; MACHINE LANGUAGE LINKAGE STACK ; CPUSH: CALL EXPRB ;EVALUATE EXPRESSION CALL PFIX ;CONVERT RESULT TO INTEGER LHLD MACSP ;SET UP FOR BOUNDS CHECK LXI B,-(MACSTK-MACSIZ) CALL ARGPSH ;PUSH INTEGER ON STACK (IF ROOM) SHLD MACSP ;UPDATE STACK POINTER CALL EATCOM ;CHECK FOR MORE JMP CPUSH ;IF MORE ; ; - STRAP - ROUTINE TO PUSH LINE NUMBERS ON TRAP STACK ; STRAP: CALL INTGER ;GET LINE NUMBER JC E1 ;IF INVALID XCHG LHLD TRPSP ;SET UP BOUNDS CHECK LXI B,-(TRPSTK-TRPSIZ) CALL ARGPSH ;PUSH LINE NUMBER (IF ROOM) SHLD TRPSP ;UPDATE STACK POINTER CALL EATCOM ;CHECK FOR MORE JMP STRAP ;IF MORE ; ; - CPOKE - ROUTINE TO WRITE BYTES INTO MEMORY ; CPOKE: CALL EXPRB ;EVALUATE ADDR EXPRESSION CALL PFIX ;CONVERT TO INTEGER PUSH D ;SAVE ADDR MVI B,'[' ;FIND '[' CALL EATC CPOK1: CALL BYTARG ;CONVERT NEXT EXPRESSION TO BYTE POP H ;RETRIEVE ADDR MOV M,E ;WRITE BYTE INX H PUSH H ;SAVE NEW ADDR LXI H,CPOK2 ;SET UP RETURN ADDR IF NEXT NON-BLANK<>',' PUSH H CALL EATCOM POP H ;CHAR=',' JMP CPOK1 ; CPOK2: MVI B,']' ;TEST FOR ']' CALL EATC POP H ;CLEAN OUT STACK IN CASE DONE CALL EATCOM PUSH H JMP CPOKE ; ; - COUT - ROUTINE TO OUTPUT BYTES TO OUTPUT DEVICES ; COUT: CALL BYTARG ;GET PORT NUMBER MOV A,E STA COUT3+1 ;SET UP OUTPUT INSTRUCTION MVI B,'[' ;FIND '[' CALL EATC COUT1: CALL BYTARG ;GET OUTPUT BYTE MOV A,E CALL COUT3 ;OUTPUT IT LXI H,COUT2 ;IN CASE NEXT NON-BLANK<>',' PUSH H CALL EATCOM POP H JMP COUT1 ; COUT2: MVI B,']' ;TEST FOR ']' CALL EATC CALL EATCOM JMP COUT ; COUT3: OUT 0 RET ; ; - BYTARG - ROUTINE TO EVALUATE TEXT EXPRESSIONS, CONVERT ; RESULT TO INTEGER, AND MAKE SURE INTEGER IS A ; BYTE VALUE ; BYTARG: CALL EXPRB BYTAR1: CALL PFIX XRA A ORA D RZ JMP E3 ; ; - ARGPSH - ROUTINE TO PUSH 16-BIT VALUES ON STACKS ; AND DO BOUNDS CHECKING ON STACKS ; ENTRY - HL IS STACK POINTER, BC IS NEGATIVE OF UPPER LIMIT ; OF STACK ; EXIT - HL IS UPDATED STACK POINTER ; ARGPSH: PUSH H ;SAVE SP DAD B ;DO BOUNDS CHECK MOV A,H ORA L JNZ ARPS1 ;IF ROOM ON STACK LXI H,ISTAK JMP ERROR ; ARPS1: POP H ;RETRIEVE SP MOV M,D ;PUSH WORD DCX H MOV M,E DCX H RET ; ; - EATCOM - ROUTINE TO CHECK NEXT NON-BLANK FOR ',' ; IF ',' THEN EAT IT AND ADVANCE TO NEXT NON-BLANK ; RETURN TO CALLER ; IF NOT ',' THEN POP ONE WORD OFF STACK AND RETURN ; TO CALLER OF CALLER ; EATCOM: CALL GC CPI ',' JZ ETCO1 POP H RET ; ETCO1: CALL GCI CALL GC RET ; ; EVALUATE AN EXPRESSION FROM TEXT ; HL TAKE OP TABLE ADDR OF PREVIOUS OPERATOR (NOT CHANGED) ; RESULT VALUE LEFT ON TOP OF ARG STACK, ARGF LEFT TRUE ; EXPRB: MVI B,0 EXPB1: LXI H,OPBOL XRA A STA RELTYP ; ; ZERO IN B MEANS PRINCIPAL OPERATOR MAY NOT BE RELATIONAL ; EXPR: PUSH B PUSH H ;PUSH OPTBA XRA A STA ARGF EXPR1: LDA ARGF ORA A JNZ EXPR2 CALL VAR ;LOOK FOR VARIABLE PERHAPS SUBSCRIPTED CNC PSHAS JNC EXPR2 CALL CONST JNC EXPR2 CALL GC CPI LPARRW LXI H,OPLPAR JZ XLPAR ; ; ISN'T OR SHOULDN'T BE AN ARGUMENT ; EXPR2: CALL GC CPI 340Q ;CHECK FOR RESERVED WORD OPERATOR JNC XOP CPI 300Q ;CHECK FOR BUILT IN FUNCTION JNC XBILT ; ; ILLEGAL EXPRESSION CHARACTER ; POP H ;GET OPTABA LDA ARGF ORA A JZ E1 XDON1: POP PSW LXI H,RELTYP;CHECK IF LEGAL PRINCIPAL OPERATOR CMP M RZ JMP E1 ; XOP: ANI 37Q ;CLEANS OFF RW BITS LHLD ARGF ;TEST FOR ARGF TRUE DCR L JZ XOP1 ; ; ARGF WAS FALSE, UNARY OPS ONLY POSSIBILITY ; CPI '-'-OPBASE JZ XOPM CPI '+'-OPBASE JNZ E1 CALL GCI ;EAT THE '+' JMP EXPR1 ; XOPM: MVI A,UMINU-OPBASE XOP1: CALL OPADR POP D ;PREVIOUS OPTBA LDAX D CMP M JNC XDON1 ;NON-INCREASING PRECEDENCE ; ; INCREASING PRECEDENCE CASE ; PUSH D ;SAVE PREVIOUS OPTBA PUSH H ;SAVE CURRENT OPTBA CALL GCI ;TO GOBBLE OPERATOR POP H PUSH H MVI B,0 ;SPECIFY NON-RELATIONAL CALL EXPR POP H ; ; HL HAS OPTBA ADDR ; SET UP ARGS AND PERFORM OPERATION ACTION ; XOP2: PUSH H MOV A,M LHLD ASTKA MOV B,H MOV C,L ANI 1 JNZ XOP21 ; ; DECREMENT SP BY 1 VALUE BINARY CASE ; LXI D,FPSIZ DAD D SHLD ASTKA MOV D,H MOV E,L XOP21: LXI H,EXPR1 XTHL ;CHANGE RETURN LINK INX H ;SKIP OVER PRECEDENCE CALL LHLI ;LOAD ACTION ADDR PCHL ; ; ACTION ROUTINE CONVENTION ; DE LEFT ARG AND RESULT FOR BINARY ; BC RIGHT ARG FOR BINARY, ARG AND RESULT FOR UNARY ; BUILT IN FUNCTION PROCESSING ; XBILT: CALL GCI ;EAT TOKEN ANI 77Q ;CLEAN OFF RW BITS LHLD ARGF ;BUILT IN FUNCTION MUST COME AFTER OPERATOR DCR L JZ E1 CALL OPADR ;OPTBA TO HL XLPAR: PUSH H MVI B,LPARRW CALL EATC CALL EXPRB MVI B,')' CALL EATC POP H ;CODE FOR BUILT IN FUNCTION JMP XOP2 ; ; COMPUTE OP TABLE ADDR FOR OPERATOR IN ACC ; OPADR: MOV C,A MVI B,0 LXI H,OPTAB DAD B DAD B DAD B ;OPTAB ENTRY ADDR IS 3*OP+BASE RET ; ; PREPROCESSOR, UN-PREPROCESSOR ; PREPROCESS LINE IN IBUF BACK INTO IBUF ; SETS CARRY IF LINE HAS NO LINE NUMBER ; LEAVES CORRECT LENGTH OF LINE AFTER PREPROCESSING IN IBCN ; IF THERE IS A LINE NUMBER, IT IS LOCATED AT IBLN=IBUF-2 ; TXA IS CLOBBERED ; PP: LXI H,IBUF ;FIRST CHARACTER OF INPUT LINE SHLD TXA ;SO GCI WILL WORK CALL INTGER ;SETS CARRY IF NO LINE NUMBER SHLD IBLN ;STORE LINE NUMBER VALUE (EVEN IF NONE) PUSH PSW ;SAVE STATE OF CARRY BIT LHLD TXA ;ADDRESS OF NEXT CHARACTER IN IBUF MVI C,4 ;SET UP INITIAL VALUE FOR COUNT LXI D,IBUF ;INITIALIZE WRITE POINTER ; ; COME HERE TO CONTINUE PREPROCESSING LINE ; PPL: PUSH D LXI D,RWT ;BASE OF RWT PPL1: PUSH H ;SAVE TEXT ADDRESS LDAX D ;RW VALUE FOR THIS ENTRY IN RWT MOV B,A ;SAVE IN B IN CASE OF MATCH PPL2: INX D ;ADVANCE ENTRY POINTER TO NEXT BYTE LDAX D ;GET NEXT CHARACTER FROM ENTRY CMP M ;COMPARE WITH CHARACTER IN TEXT JNZ PPL3 INX H ;ADVANCE TEXT POINTER JMP PPL2 ; ; COME HERE WHEN COMPARISON OF BYTE FAILED ; PPL3: ORA A JM PPL6 ;JUMP IF FOUND MATCH ; ; SCAN TO BEGINNING OF NEXT ENTRY ; PPL4: INX D ;ADVANCE ENTRY POINTER LDAX D ;NEXT BYTE IS EITHER CHARACTER OR RW BYTE ORA A JP PPL4 ;KEEP SCANNING IF NOT RW BYTE ; ; NOW SEE IF AT END OF TABLE, AND FAIL OR RETURN CONDITION ; POP H ;RECOVER ORIGINAL TEXT POINTER XRI 377Q ;CHECK FOR END OF TABLE BYTE JNZ PPL1 ;CONTINUE SCAN OF TABLE ; ; DIDN'T FIND AN ENTRY AT THE GIVEN TEXT ADDR ; POP D MOV A,M ;GET TEXT CHARACTER CPI CR ;CHECK FOR END OF LINE JZ PPL8 ;GO CLEAN UP AND RETURN STAX D INX D INR C INX H ;ADVANCE TEXT POINTER CPI '"' ;CHECK FOR QUOTED STRING POSSIBILITY JNZ PPL ;RESTART RWT SEARCH AT NEXT CHARACTER POSITION ; ; HERE WE HAVE A QUOTED STRING, SO EAT TILL ENDQUOTE ; PPL5: MOV A,M ;NEXT CHARACTER CPI CR JZ PPL8 ;NO STRING ENDQUOTE, LET INTERPRETTER WORRY STAX D INX D INR C INX H ;ADVANCE TEXT POINTER CPI '"' JZ PPL ;BEGIN RWT SCAN FROM NEW CHARACTER POSITION JMP PPL5 ; ; FOUND MATCH SO PUT RW VALUE IN TEXT ; PPL6: POP PSW ;REMOVE UNNEEDED TEST POINTER FROM STACK POP D MOV A,B STAX D INX D INR C ANI 240Q ;TEST FOR COMMAND RW CPI 240Q JNZ PPL ;IF NOT COMMAND MOV A,B ;TEST FOR BIT 6 SET ANI 100Q JNZ PPL ;IF SET JMP PPL5 ;END PREPROCESSING OF COMMAND LINE ; ; COME HERE WHEN DONE ; PPL8: MVI A,CR STAX D LXI H,IBCNT ;SET UP COUNT IN CASE LINE OF LINE NUMBER MOV M,C POP PSW ;RESTORE CARRY (LINE NUMBER FLAG) RET ; ; UN-PREPROCESS LINE ADDRESSES IN HL TO DE BUFFER ; RETURN SOURCE ADDRESS OF CR IN HL ON RETURN ; UPPL: INX H ;SKIP OVER COUNT BYTE PUSH H ;SAVE SOURCE TEXT POINTER CALL LHLI ;LOAD LINE NUMBER VALUE CALL CNS ;CONVERT LINE NUMBER MVI A,' ' STAX D ;PUT BLANK AFTER LINE NUMBER INX D ;INCREMENT DESTINATION POINTER POP H INX H ;INCREMENT H PAST LINE NUMBER UPP0: INX H MOV A,M ;NEXT TOKEN IN SOURCE ORA A JM UPP1 ;JUMP IF TOKEN IS RW STAX D ;PUT CHARACTER IN BUFFER CPI CR ;CHECK FOR DONE RZ INX D ;ADVANCE DESTINATION BUFFER ADDRESS JMP UPP0 ; ; COME HERE WHEN RW BYTE DETECTED IN SOURCE ; UPP1: PUSH H ;SAVE SOURCE POINTER LXI H,RWT ;BASE OF RWT UPP2: CMP M ;SEE IF RW MATCHED RWT ENTRY INX H ;ADVANCE RWT POINTER JNZ UPP2 ;CONTINUE LOOKING IF NOT FOUND ; ; FOUND MATCH, ENTRY POINTER LOCATES FIRST CHARACTER ; UPP3: MOV A,M ;CHARACTER OF RW ORA A ;CHECK FOR DONE JM UPP4 STAX D INX D INX H JMP UPP3 ; ; COME HERE IF DONE WITH RW TRANSFER ; UPP4: POP H ;SOURCE POINTER JMP UPP0 ; ; CONSTANTS AND TABLES ; HEAD: DB 'BASIC/5 INTERACTIVE INTERPRETER V Z1.0 10/16/77"' RDYS: DB 'READY"' RNING: DB 'RUNNING"' PLS: DB 'NEW OR OLD? "' ; ; TABLE OF ERROR MESSAGES ; ARGUM: DB 'ARGUMENT "' SYNTX: DB 'SYNTAX "' CSTAK: DB 'CONTROL STACK "' ISTAK: DB 'INTERNAL STACK "' DIRIN: DB 'DIRECT INPUT "' DIMEN: DB 'DIMENSION "' FLOAT: DB 'FLOATING POINT "' INPER: DB 'INPUT "' LENGT: DB 'LINE OVERFLOW "' LNUMB: DB 'LINE NUMBER "' NGSQR: DB 'NEGATIVE SQUARE ROOT "' BOUND: DB 'BOUNDS "' RDERR: DB 'READ "' STOVL: DB 'STORAGE OVERFLOW "' FSERR: DB 'FILE SPACE "' DSERR: DB 'DIRECTORY SPACE "' FSIZE: DB 'FILE SIZE "' FNAME: DB 'FILE NAME "' RNDER: DB 'RANDOM ACCESS FILE "' ; ; ERS: DB 'ERROR"' INS: DB ' IN LINE "' STOPS: DB 'STOP"' OPN: DB 'OLD PROGRAM NAME: "' NPN: DB 'NEW PROGRAM NAME: "' ; DB 0FFH ;FLAGS END OF SINE COEFFICIENT LIST DB 0 DB 1*16 DW 0 DB 0 FPONE: DB 129 ;EXPONENT ; ; SINE COEFFICIENT LIST ; NOTE: THE FLOATING PNT 1 ABOVE IS A PART OF THIS TABLE ; DB 1*16+6 DB 6*16+6 DB 6*16+7 DB 1 DB 128 ;-.166667 E 0 (-1/3 FACTORIAL) DB 8*16+3 DB 3*16+3 DB 3*16+3 DB 0 DB 128-2 ;.833333 E-2 (1/5 FACT) DB 1*16+9 DB 8*16+4 DB 1*16+3 DB 1 DB 128-3 ;-.198413 E-3 (-1/7 FACT) DB 2*16+7 DB 5*16+5 DB 7*16+3 DB 0 DB 128-5 ;.275573 E-5 (1/9 FACT) DB 2*16+5 DB 0*16+5 DB 2*16+1 DB 1 SINX: DB 128-7 ;-.250521 E-7 (-1/11 FACT) ; ; COSINE COEFFICIENT LIST ; DB 0FFH ;MARKS END OF LIST DB 0 DB 1*16+0 DB 0 DB 0 DB 0 DB 128+1 ;.100000 E 1 (1/1 FACT) DB 5*16+0 DB 0 DB 0 DB 1 MATUB: DB 128 ;-.500000 E 0 (-1/2 FACT) DB 4*16+1 DB 6*16+6 DB 6*16+7 DB 0 RANDS: DB 128-1 ;.416667 E-1 (1/4 FACT) DB 1*16+3 DB 8*16+8 DB 8*16+9 DB 1 DB 128-2 ;.138889 E-2 (-1/6 FACT) DB 2*16+4 DB 8*16+0 DB 1*16+6 DB 0 DB 128-4 ;.248016 E-4 (1/8 FACT) DB 2*16+7 DB 5*16+5 DB 7*16+3 DB 1 COSX: DB 128-6 ;.275573 E-6 (-1/10 FACT) DB 2*16 DW 0 DB 0 FPTWO: DB 129 DB 1*16+5 DB 7*16+0 DB 8*16+0 DB 0 PIC2: DB 128+1 ;PI/2 .157080 E 1 DB 6*16+3 DB 6*16+6 DB 2*16+0 DB 0 PIC1: DB 128 ;2/PI .636620 E 0 LCSTKA: DW CSTKL ; ; COMMAND TABLE ; CMNDD: DW CRUN ;0 DW LLIST ;1 LIST ON LINE PRINTER DW CNULL ;2 DW CSCR ;3 DW CNEW ;4 SET UP MEMORY BOUNDS DW SAVE ;5 DISK SAVE BASIC PROGRAM DW COLD ;6 LOAD BASIC PROGRAM FROM DISK DW CSYS ;7 RETURN TO CP/M SYSTEM DW CNAME ;8 RENAME OR OUTPUT NAME OF WS DW ERA ;9 ERASE FILE DW CLIST ;10 LIST ; ; STATEMENT TABLE ; STATD: DW LET ;0 DW NEXT ;1 DW SIF ;2 DW SGOTO ;3 DW GOSUB ;4 DW RETRN ;5 DW READ ;6 DW DATA ;7 DW SFOR ;8 DW LPRINT ;9 DW INPUT ;10 DW DIM ;11 DW STOP ;12 DW CEND ;13 DW RESTOR ;14 DW REM ;15 DW CCLEAR ;16 DW CPUSH ;17 DW CPOKE ;18 DW COUT ;19 DW STRAP ;20 DW BEAM ;21 DW DRAW ;22 DW PRINT ;23 ; ; R/W WORD TABLE FORMAT IS RESERVED WORD FOLLOWED BY CHR ; OF RESERVED WORD. LAST ENTRY IS FOLLOWED BY A 377Q ; RW'S THAT ARE SUBSTRINGS OF OTHER RW'S (E. G. >) MUST ; FOLLOW THE LARGER WORD. ; RWT: DB 200Q DB 'LET' DB 201Q DB 'NEXT' DB 202Q DB 'IF' DB 203Q DB 'GOTO' DB 204Q DB 'GOSUB' DB 205Q DB 'RETURN' DB 206Q DB 'READ' DB 207Q DB 'DATA' DATARW EQU 207Q DB 210Q DB 'FOR' DB 211Q DB 'LPRINT' DB 211Q DB ':' DB 212Q DB 'INPUT' DB 213Q DB 'DIM' DB 214Q DB 'STOP' DB 215Q DB 'END' DB 216Q DB 'RESTORE' DB 217Q DB 'REM' DB 220Q DB 'CLEAR' CLRRW EQU 220Q DB 221Q DB 'PUSH' DB 222Q DB 'POKE' DB 223Q DB 'OUT' DB 224Q DB 'TRAP' DB 225Q DB 'BEAM' DB 226Q DB 'DRAW' DB 227Q DB 'PRINT' IRWLIM EQU 230Q ;LAST INITIAL RESERVED WORD VALUE+1 ; ; DB 237Q DB 'STEP' STEPRW EQU 237Q DB 236Q DB 'TO' TORW EQU 236Q DB 235Q DB 'THEN' THENRW EQU 235Q DB 234Q DB 'TAB' TABRW EQU 234Q ; ; COMMANDS ; DB 240Q DB 'RUN' RUNRW EQU 240Q DB 241Q DB 'LLIST' DB 242Q DB 'NULL' NULLRW EQU 242Q DB 243Q DB 'SCR' SCRRW EQU 243Q DB 244Q DB 'NEW' NEWRW EQU 244Q DB 245Q DB 'SAVE' DB 246Q DB 'OLD' DB 247Q DB 'SYSTEM' DB 250Q DB 'NAME' DB 251Q DB 'ERA' DB 251Q DB 'UNSAVE' DB 252Q DB 'LIST' LISTRW EQU 252Q ; ; LPARRW EQU '('-OPBASE+340Q DB LPARRW DB '(' DB '*'-OPBASE+340Q DB '*' PLSRW EQU '+'-OPBASE+340Q DB PLSRW DB '+' MINRW EQU '-'-OPBASE+340Q DB MINRW DB '-' DB '/'-OPBASE+340Q DB '/' DB 67Q-OPBASE+340Q DB '>=' DB 70Q-OPBASE+340Q DB '<=' DB 71Q-OPBASE+340Q DB '<>' DB 62Q-OPBASE+340Q DB '=>' DB 63Q-OPBASE+340Q DB '=<' DB '<'-OPBASE+340Q DB '<' EQRW EQU '='-OPBASE+340Q DB EQRW DB '=' DB '>'-OPBASE+340Q DB '>' DB 301Q DB 'ABS' DB 306Q DB 'INT' DB 314Q DB 'ARG' DB 315Q DB 'CALL' DB 316Q DB 'RND' DB 322Q DB 'SGN' DB 323Q DB 'SIN' DB 304Q DB 'SQR' DB 327Q DB 'TAN' DB 330Q DB 'COS' DB 331Q DB 'POP' DB 332Q DB 'PEEK' DB 333Q DB 'INP' DB 334Q DB 'UNTRAP' DB 377Q ;END OF TABLE ; ; OPERATION TABLE ; OPTAB: DB 15 OPLPAR EQU OPTAB DW ALPAR DB 15 DW AABS DB 10 DW AMUL DB 6 DW AADD DB 15 DW ASQR DB 6 DW ASUB DB 15 DW AINT DB 10 DW ADIV OPBOL: DB 1 DW 0 DB 13 DW ANEG DB 4 DW AGE DB 4 DW ALE DB 15 DW AARG DB 15 DW ACALL DB 15 DW ARND DB 4 DW AGE DB 4 DW ALE DB 4 DW ANE DB 15 DW ASGN DB 15 DW ASIN DB 4 DW ALT DB 4 DW AEQ DB 4 DW AGT DB 15 DW ATAN DB 15 DW ACOS DB 15 DW APOP DB 15 DW APEEK DB 15 DW AINP DB 15 DW AUNTRP ; ; ACTION ROUTINES FOR RELATIONAL OPEATORS ; AGT: CALL RELOP JZ RFALSE JM RTRUE RFALSE: XRA A STAX D RET ALT: CALL RELOP JZ RFALSE JM RFALSE RTRUE: MVI A,377Q STAX D RET AEQ: CALL RELOP JZ RTRUE JMP RFALSE ; ANE: CALL RELOP JZ RFALSE JMP RTRUE ; AGE: CALL RELOP JZ RTRUE JM RTRUE JMP RFALSE ; ALE: CALL RELOP JZ RTRUE JM RFALSE JMP RTRUE ; ; COMMON ROUTINE FOR RELATIONAL OPERATOR ACTION ; ; LEFT ARG ADDR IN DE, SAVED ; RIGHT ARG ADDR IN BC ; ON RETURN, SIGN SET=GT, ZERO SET=EQUAL ; RELOP: PUSH D DCX B DCX D MOV H,B MOV L,C LDAX D SUB M INX H INX D JNZ RLOP1 ;TEST SIGNS OF ARGS IF DIFFERENT THEN RET LXI B,FPSINK CALL FSUB LDA FPSINK ;CHECK FOR ZERO RESULT ORA A JZ RLOP1 LDA FPSINK-1;SIGN OF FPSINK RLC DCR A RLOP1: MVI A,1 STA RELTYP ;SET RELTYPE TRUE POP D RET ; ; ACTION ROUTINES FOR ARITHMETIC OPERATORS ; (CODE WASTERS) ; AADD: MOV H,B MOV L,C MOV B,D MOV C,E AADD1: CALL FADD JMP FPETST ; ASUB: MOV H,B MOV L,C MOV B,D MOV C,E ASUB1: CALL FSUB JMP FPETST ; AMUL: MOV H,B MOV L,C MOV B,D MOV C,E AMUL1: CALL FMUL JMP FPETST ; ADIV: MOV H,B MOV L,C MOV B,D MOV C,E ADIV1: CALL FDIV FPETST: XRA A STA RELTYP LDA ERRI ORA A RZ LHLD ASTKA ;ZERO RESULT ON UNDERFLOW FPET1: MVI M,0 ALPAR: RET ; ; UNARY AND BUILT IN FUNCTION ACTION ROUTINES ; ANEG: LDAX B ORA A JZ ANEG1 DCX B LDAX B XRI 1 STAX B ANEG1: XRA A STA RELTYP RET ; AABS: DCX B XRA A STAX B JMP ANEG1 ; ASGN: CALL ANEG1 MOV D,B MOV E,C LDAX B ;GET EXPONENT ORA A JNZ ASGN1 STAX D ;MAKE ARGUMENT ZERO RET ; ASGN1: DCX B LDAX B ORA A LXI H,FPONE JZ VCOPY LXI H,FPNONE JMP VCOPY ; ; COMPUTE SINE(X) X=TOP OF ARG STACK ; RETURN RESULT IN PLACE OF X ; ASIN: CALL QUADC ;COMPUTE QUADRANT LHLD ASTKA MOV D,H MOV E,L LXI B,FTEMP CALL AMUL1 ;FTEMP = X*X POP PSW PUSH PSW ;A=QUADRANT RAR JC SIN10 ;QUAD ODD. COMPUTE COSINE ; ; COMPUTE X*P(X*X) -- SINE ; LXI D,FTEM1 LHLD ASTKA CALL VCOPY ;FTEM1=X*X LXI B,SINX CALL POLY ;P(X*X) CALL PREPOP LXI H,FTEM1 CALL AMUL1 ;X*P(X*X) ; ; COMPUTE SIGN OF RESULT ; POSITIVE FOR QUADRANT 0,1. NEGATIVE FOR 2,3 ; NEGATE ABOVE FOR NEGATIVE ARGUMENTS ; SIN5: POP PSW ;QUADRANT MOV B,A POP PSW ;SIGN RLC ;SIGN, 2 TO THE 1ST BIT XRA B ;QUADRANT, MAYBE MODIFIED FOR NEGATIVE ARG LHLD ASTKA DCX H ;PTR TO SIGN SUI 2 RM ;QUADRANT 0 OR 1 INR M ;ELSE SET RESULT NEGATIVE RET ; ; COMPUTE P(X*X) -- COSINE ; SIN10: LXI B,COSX CALL POLY ;P(X*X) JMP SIN5 ; ; COMPUTE COS(X) X=TOP OF ARGUMENT STACK ; RETURN RESULT IN PLACE OF X ; COS(X)=SIN(X+PI/2) ; ACOS: CALL PREPOP LXI H,PIC2 ;PI/2 CALL AADD1 ;TOS=TOS+PI/2 JMP ASIN ; ; COMPUTE TAN(X) X=TOP OF ARGUMENT STACK ; RETURN RESULT IN PLACE OF X ; TAN(X)=SIN(X)/COS(X) ; ATAN: LHLD ASTKA CALL PSHAS ;PUSH COPY OF X ONTO ARG STACK CALL ACOS ;COS(X) LXI D,FTEM2 CALL POPA1 ;FTEM2=COS(X) CALL ASIN CALL PREPOP LXI H,FTEM2 JMP ADIV1 ;SIN(X)/COS(X) ; ; COMPUTE SQR(X) X=TOP OF ARGUMENT STACK ; RETURN RESULT IN PLACE OF X ; ASQR: LHLD ASTKA LXI D,FTEMP CALL VCOPY ;SAVE X IN FTEMP ; ; COMPUTE EXPONENT OF FIRST GUESS AS EXPONENT OF X/2 ; LHLD ASTKA MOV A,M ORA A RZ ; X=0 SUI 128 JM SQR5 ;NEGATIVE EXPONENT RRC ANI 127 JMP SQR6 ; SQR5: CMA INR A RRC ANI 127 CMA INR A SQR6: ADI 128 MOV M,A ; ; TEST FOR NEGATIVE ARGUMENT DCX H MOV A,M LXI H,NGSQR ORA A JNZ ERROR ;NEG ARG ; ; DO NEWTON ITERATIONS ; NEWGUESS=(X/OLDGUESS+OLDGUESS)/2 ; MVI A,6 ;DO 6 ITERATIONS SQR20: PUSH PSW ;SET NEW ITERATION COUNT LXI B,FTEM1 LXI D,FTEMP ;FTEMP IS 'X' LHLD ASTKA ;GUESS CALL ADIV1 ;FTEM1 = X/GUESS LXI D,FTEM1 LHLD ASTKA MOV B,H MOV C,L CALL AADD1 ;TOS=(X/GUESS)+GUESS CALL PREPOP LXI H,FPTWO CALL ADIV1 ;TOS=(X/GUESS+GUESS)/2 POP PSW DCR A ;DECREMENT COUNT JNZ SQR20 ;DO ANOTHER ITERATION RET ; ; COMPUTE RND(X) X=TOP OF ARG STACK ; FRAMD IS UPDATED TO NEW RANDOM VALUE ; A RANDOM NUMBER IN THE RANGE 0<RND<1 IS RETURNED IN PLACE ; ARND: CALL PREPOP LXI D,FRAND LXI H,FRAND CALL AMUL1 ;TOS= FRAND*FRAND ; ; SET EXPONENT = 0 ; LHLD ASTKA MVI M,128 ;EXPONENT=128 (0 IN EXTERNAL FORM) ; ; PERMUTE DIGITS OF X AS ; 123456 INTO 345612 ; LXI B,-4 DAD B MOV B,M ;SAVE 12 INX H INX H CALL PERMU ;56=12 CALL PERMU ;34=56 CALL PERMU ;12=34 ; ; NORMALIZE NUMBER ; RND5: LHLD ASTKA ;TOS LXI B,-FPSIZ+1 DAD B MOV A,M ;FIRST DIGIT PAIR ANI 15*16 JNZ RND10 ;NUMBER IS NORMALIZED ; ; SHIFT LEFT 1 DIGIT ; LHLD ASTKA MOV A,M ;EXPONENT DCR A STA EXP CALL LOAD ;TOS INTO TEMP MVI B,4 CALL LEFT ;SHIFT LEFT CALL PREPOP CALL STORE JMP RND5 ;TEST IF NORMALIZED ; ; SAVE NEW RANDOM NUMBER FRAND CELL ; RND10: LXI D,FRAND LHLD ASTKA CALL VCOPY ;FRAND=TOS RET ; ; PERMUTE PAIR OF DIGIT PAIRS ; PERMU: MOV A,M MOV M,B MOV B,A DCX H RET ; ; EVALUATE P(X) USING HORNERS METHOD (X IS IN FTEMP) ; COEFFICIENT LIST POINTER IS IN BC ; RESULT REPLACES NUMBER ON TOP OF ARG STACK (Y) ; POLY: LHLD ASTKA XCHG ; DE=PTR TO Y MOV H,B MOV L,C ;HL PTR TO COEFFICIENT LIST CALL VCOPY ;Y=FIRST COEFFICIENT ; ; MULTIPLY BY X ; POLY1: PUSH H ;SAVE COEFF. LIST POINTER CALL PREPOP LXI H,FTEMP CALL AMUL1 ;Y=Y*X ; ; ADD NEXT COEFFICIENT ; CALL PREPOP POP H PUSH H ;HL=COEFF. LIST POINTER CALL AADD1 ;Y=Y+COEFF ; ;BUMP POINTER TO NEXT COEFFICIENT ; POP H ;COEFF POINTER LXI B,-FPSIZ-1 DAD B ;NEXT COEFF SIGN MOV A,M INX H ;PTR TO EXPONENT ORA A JP POLY1 ;PROCESS NEXT COEFF RET ; NEGATIVE SIGN (-1) ENDS LIST ; ; PREPARE FOR OPERATION ; PREPOP: LHLD ASTKA XCHG ; DE=ASTKA MOV B,D MOV C,E RET ; ; QUADRANT COMPUTATION ; POPS TOP OF ARGUMENT STACK ; COMPUTE/GETS SIGN OF ARGUMENT,QUADRANT OF ARGUMENT ; AND INDEX INTO QUADRANT ; ; EXITS WITH ; SP POINTING TO QUADRANT,MOD 4 ; SP+2 POINTING TO SIGN OF ARGUMENT ; TOP OF ARGUMENT STACK HAS INDEX INTO QUADRANT ; QUADC: LHLD ASTKA DCX H ;POINT TO SIGN MOV B,M XRA A MOV M,A ;ARG SIGN=0 MOV H,B XTHL ; PUT SIGN ON STACK, POP RETURN PUSH H ;PUSH RETURN ; ; COMPUTE QUADRANT OF ABS(X) ; LHLD ASTKA CALL PSHAS ;PUT COPY OF ARG ONTO STACK CALL PREPOP LXI H,PIC1 ;2/PI CALL AMUL1 ;TOS=X*2/PI CALL PREPOP CALL AINT ;TOS=INT(X*2/PI) LHLD ASTKA CALL PSHAS ;ANOTHER COPY CALL PFIX ;POPS TOS TO DE MOV A,E PUSH PSW ;QUADRANT CALL PREPOP LXI H,PIC2 CALL AMUL1 ;TOS=INT(X*2/PI) LXI D,FTEMP CALL POPA1 ;FTEMP=TOS CALL PREPOP LXI H,FTEMP CALL ASUB1 ;TOS=TOS-FTEMP POP PSW ANI 3 ;MOD 4 POP H PUSH PSW ;SAVE QUADRANT ON STACK PCHL ; RETURN ; ; SET UP ARG FOR USER CALL ; AARG: CALL PFIX XCHG SHLD CALLA LXI D,FPSINK JMP PSHA1 ;PUTS BACH THE ARG VALUE ON ARG STACK ; ; USED TO CALL USER ROUTINE ; ACALL: CALL PFIX ;GET THE ADDRESS LHLD CALLA ;GET THE USER ARGUMENT LXI B,ACAL1 ;RETURN LINK FOR USER ROUTINE PUSH B MOV B,H ;MOVE ARG TO BC (PL/M CONVENTION) MOV C,L LHLD MACSP ;GET MACHINE LANGUAGE LINKAGE SP XCHG PCHL ACAL1: MOV H,B ;CONVERT FROM PL/M TO BASIC MOV L,A LXI D,CALST CALL CNS MVI A,CR STAX D LXI D,CALST LXI H,FPSINK CALL FPIN LXI D,FPSINK JMP PSHA1 ;PUT THE RETURNED USER VALUE ON ARG STACK ; ; - AUNTRP - FUNCTION TO POP LINE NUMBERS FROM TRAP STACK ; AUNTRP: CALL PFIX ;GET POP COUNT LHLD TRPSP ;SET TRAP SP AUNT1: LXI B,-TRPSTK ;SET UP BOUNDS CHECK CALL ARGPOP ;POP LINE NUMBER INTO BC SHLD TRPSP ;UPDATE TRAP SP CALL ARGPA ;PUSH LINE NUMBER ON ARG STACK IF COUNT=0 JMP AUNT1 ;LOOP TILL COUNT=0 ; ; - APOP - FUNCTION TO POP 16-BIT INTEGERS FROM MACHINE ; LANGUAGE LINKAGE STACK ; APOP: CALL PFIX ;GET POP COUNT LHLD MACSP ;SET MACHINE LANGUAGE LINKAGE SP APOP1: LXI B,-MACSTK ;SET UP BOUNDS CHECK CALL ARGPOP ;POP A PARAMETER INTO BC SHLD MACSP ;UPDATE SP CALL ARGPA ;PUSH PARAM ONTO ARG STACK IF COUNT=0 JMP APOP1 ;LOOP TILL COUNT=0 ; ; - ARGPOP - SUBROUTINE TO POP 16-BIT WORDS FROM STACKS ; AND DO BOUNDS CHECKING ON STACKS ; ENTRY - HL IS STACK POINTER, BC IS NEGATIVE OF STACK BASE ; EXIT - BC IS POPPED WORD, HL IS UPDATED STACK POINTER ; ARGPOP: PUSH H ;SAVE VALUE OF SP DAD B ;CHECK FOR STACK EMPTY XRA A ORA H JM ARGP1 ;IF STACK NOT EMPTY LXI H,ISTAK JMP ERROR ; ARGP1: POP H ;RETRIEVE SP INX H ;POP WORD MOV C,M INX H MOV B,M RET ; ; - ARGPA - ARGPOP AUXILIARY SUBROUTINE ; DECREMENTS A COUNT IN DE ; JUMPS TO ACAL1 IF COUNT=0, RETURNS IF NOT ; ENTRY - BC CONTAINS WORD TO PASS TO ACAL1, DE IS COUNT ; EXIT - BA CONTAINS WORD ; ARGPA: DCX D MOV A,D ORA E RNZ MOV A,C POP H JMP ACAL1 ; ; - APEEK - FUNCTION TO READ CONTENTS OF MEMORY ; APEEK: CALL PFIX ;SET MEMORY ADDR LDAX D ;FETCH BYTE MVI B,0 JMP ACAL1 ;PUT BYTE ON ARGUMENT STACK ; ; - AINP - FUNCTION TO INPUT BYTE FROM PORT ; AINP: CALL BYTAR1 ;GET PORT ADDR MOV A,E STA AINP1+1 ;SET UP INPUT INSTRUCTION AINP1: IN 0 MVI B,0 JMP ACAL1 ;PUT BYTE ON ARG STACK ; ; INT FUNCTION ACTION ROUTINE ; AINT: LDAX B SUI 129 JP AINT1 ; ; ZERO IF VALUE LESS THAN ONE ; MVI D,FPSIZ XRA A AINT0: STAX B DCX B DCR D JNZ AINT0 RET ; ; EXP>0 ; AINT1: SUI FPNIB-1 RNC MOV D,A ;COUNT DCX B AINT2: DCX B LDAX B ANI 360Q STAX B INR D RZ XRA A STAX B INR D JNZ AINT2 RET ; ; DIMENSION MATRIX ; SYMTAB ADDR IN HL, HL NOT CLOBBERED ; DE CONTAINS SIZE IN NUMBER OF ELEMENTS ; DIMS: PUSH H INX D PUSH D LXI H,0 MVI C,FPSIZ CALL RADD ;MULTIPLY NELTS BY BYTES PER VALUE XCHG LHLD MATA ;HL = MATRIX BASE ADDRESS MOV B,H ;COPY HL TO BC MOV C,L PUSH H DAD D ;HL = ADDR. OF 1ST LOC. AFTER THIS MATRIX MATCLR: XRA A ;ZERO STORAGE FOR THIS MATRIX STAX B INX B MOV A,C ;END LOOP WHEN BC=HL SUB L MOV A,B SBB H JNZ MATCLR CALL STOV ;CHECK THAT STORAGE NOT EXHAUSTED SHLD MATA ;UPDATA MATRIX FREE POINTER POP B ;BASE ADDR POP D ;NELTS POP H ;SYMTAB ADDR PUSH H MOV M,D DCX H MOV M,E DCX H MOV M,B DCX H MOV M,C ;SYMTAB ENTRY NOW SET UP POP H RET ; ; FIND VARIABLE OPTIONALLY SUBSCRIPTED IN TEXT ; SETS CARRY IF NOT FOUND ; RETURNS ADDR OF VARIABLE IN HL ; UPDATES TXA IF FOUND ; VAR: CALL ALPHA RC CALL NAME2 CALL GC CPI LPARRW JZ VAR1 ;TEST IF SUBSCRIPTED ; ; MUST BE SCALAR VARIABLE ; CALL STLK ;RETURNS ENTRY ADDR IN HL ORA A ;CLEAR CARRY RET ; ; MUST BE SUBSCRIPTED ; VAR1: CALL GCI ;GOBBLE LEFT PAREN MVI A,200Q ORA C MOV C,A ;SET TYPE TO MATRIX CALL STLK PUSH H ;SYMBOL TABLE LXI D,10 ;DEFAULT MATRIX SIZE CC DIMS ;DEFAULT DIMENSION MATRIX CALL EXPRB ;EVALUATE SUBSCRIPT EXPRESSION CALL PFIX ;DE NOW HAS INTEGER MVI B,')' CALL EATC ;GOBBLE RIGHT PAREN POP H DCX H CALL DCMP ;BOUNDS CHECK INDEX JNC E5 DCX H DCX H CALL LHLI ;GET BASE ADDR MVI C,FPSIZ INX D ;BECAUSE BASE ADDR IS TO ELEMENT -1 CALL RADD ;ADD INDEX, CLEAR CARRY RET ; ; JUNK ON END OF STATEMENT, TEST IF AT END OF FILE ; DOES NOT CLOBBER DE ; EATS CHARACTER AND LINE COUNT AFTER CR ; LEAVES NEW TXA IN HL ; SETS CARRY IF END OF FILE ; JOE: CALL GCI CPI ';' RZ CPI CR JNZ E1 MOV A,M DCR A JZ JOE2 INX H INX H INX H ;SKIP OVER COUNT AND LINE NUMBER JOE1: SHLD TXA RET ; JOE2: STC JMP JOE1 ; ; GET NAME FROM TEXT ; SETS CARRY IF NAME NOT FOUND ; IF SUCCEEDS RETURNS NAME IN BC, C=0 IF NO DIGIT IN NAME ; NAME: CALL ALPHA RC NAME2: MOV B,A MVI C,0 CALL DIG CMC RNC MOV C,A ORA A ;CLEAR CARRY RET ; ; SYMBOL TABLE LOOKUP ; BC CONTAIN NAME AND CLASS ; IF NOT FOUND THEN CREATE ZERO'ED ENTRY AND SET CARRY ; HL HAS ADDRESS ON RET ; STLK: LHLD MEMTOP LXI D,-STESIZ;SET UP BASE AND INCREMENT FOR SEARCH LOOP STLK0: MOV A,M ORA A JZ STLK2 ;TEST IF END OF TABLE CMP B JNZ STLK1 ;TEST IF ALPHA COMPARES DCX H MOV A,M ;LOOK FOR DIGIT CMP C DCX H RZ ;CARRY CLEAR SO RET INX H INX H STLK1: DAD D ;DIDN'T COMPARE, DECREMENT POINTER JMP STLK0 ; ; ADD ENTRY TO SYMTAB ; STLK2: MOV M,B DCX H MOV M,C INX H XCHG DAD D SHLD STB ;STORE NEW END OF SYMTAB POINTER DCX D DCX D XCHG STC RET ; ; GOBBLES NEXT CHARACTER IF ALPHABETIC ; SETS CARRY IF NOT ; NEXT CHAR IN ACC ON FAILURE ; ALPHA: CALL GC CPI 'A' RC CPI 'Z'+1 CMC RC JMP DIGT1 ; ; GOBBLES NEXT TEXT CHAR IF DIGIT ; SETS CARRY IF NOT ; NEXT CHAR IN ACC ON FAILURE ; DIG: CALL GC CPI '0' RC CPI '9'+1 CMC RC DIGT1: INX H SHLD TXA RET ; ; COPYS FPSIZ BYTES AT ADDR HL TO ADDR DE ; ON EXIT HL POINTS TO ADR-1 OF LAST BYTE COPIED ; VCOPY: MVI C,FPSIZ VCOP1: MOV A,M STAX D DCX H DCX D DCR C JNZ VCOP1 RET ; ; PUSH VALUE ADDRESSED BY HL ONTO ARG STACK ; SETS ARGF, CLEARS CARRY ; PSHAS: XCHG PSHA1: LHLD ASTKA LXI B,-FPSIZ DAD B SHLD ASTKA ;DECREMENT ARG STACK POINTER XCHG CALL VCOPY MVI A,1 STA ARGF ;CLEAR ARGF ORA A ;CLEAR CARRY RET ; ; POP ARG STACK ; HL CONTAINS ADDRESS TO PUT POPPED VALUE AT ; POPAS: XCHG POPA1: LHLD ASTKA PUSH H LXI B,FPSIZ DAD B SHLD ASTKA ;INCREMENT STACK POINTER POP H JMP VCOPY ; ; PUSH FRAME ONTO CONTROL STACK ; TAKES MINUS AMOUNT TO SUB FROM CSTKA IN DE ; DOES OVERFLOW TEST AND RETURNS OLD CSTKA-1 ; PSHCS: LHLD CSTKA PUSH H DAD D SHLD CSTKA XCHG LXI H,LCSTKA;ADDR CONTAINS CSTKL CALL DCMP JC E4 POP H DCX H RET ; ; STORAGE OVERFLOW TEST ; TEST THAT VALUE IN HL IS BETWEEN MATA AND STB ; DOES NOT CLOBBER HL ; STOV: XCHG LXI H,MATA CALL DCMP JC E8 LXI H,STB CALL DCMP XCHG RC E8: LXI H,STOVL JMP ERROR ; ; INCREMENT TXA IF NEXT NON-BLANK CHAR IS EQUAL TO B ; ELSE SYNTAX ERROR ; EATC: CALL GCI CMP B RZ JMP E1 ; ; GET NEXT NON-BLANK CHAR INTO ACC ; INCREMENT PAST BLANKS ONLY ; GC: CALL GCI DCX H SHLD TXA RET ; ; GET NEXT NON-BLANK TEXT CHAR AND INCREMENT TXA ; DOES NOT CLOBBER DE, BC ; RETURN CHAR IN ACC ; GCI: LHLD TXA GCI0: MOV A,M INX H CPI ' ' JZ GCI0 SHLD TXA RET ; ; REPEAT ADD ; ADDS DE TO HL C TIMES ; RADD: DAD D DCR C JNZ RADD RET ; ; PRINT MESSAGE ADDRESSED BY HL ; ENDS WITH CHARACTER PROVIDED IN C ; RETURN IN HL ADDRESS OF TERMINATOR ; PRNTCR: MVI C,CR JMP PRN1 ; PRNT: MVI C,'"' PRN1: MOV A,M ;GET NEXT CHAR MOV B,A ;FOR CHOUT CMP C ;END OF MESSAGE TEST RZ CPI CR JZ E1 ;NEVER PRINT A CR IN THIS ROUTINE CALL CHOUT INX H JMP PRN1 ; ; 16 BIT UNSIGNED COMPARE ; COMPARE DE AGAINST VALUE ADDRESSED BY HL ; CLOBBERS A ONLY ; DCMP: MOV A,E SUB M INX H MOV A,D SBB M DCX H RNZ MOV A,E SUB M ORA A ;CLEAR CARRY RET ; ; INDIRECT LOAD HL THRU HL ; LHLI: PUSH PSW MOV A,M INX H MOV H,M MOV L,A POP PSW RET ; ; GET FP CONSTANT FROM TEXT ; PUSHES VALUE ON ARG STACK AND SETS ARGF FLAG ; SETS CARRY IF NOT FOUND ; CONST: LHLD TXA ;PREPARE CALL FPIN XCHG LXI H,FPSINK CALL FPIN RC DCX D XCHG SHLD TXA ;NOW POINTS TO TERMINATOR LXI D,FPSINK CALL PSHA1 XRA A INR A ;SET A TO 1 AND CLEAR CARRY STA ARGF RET ; ; DIRECT STATEMENT CHECKING ROUTINE ; DIRT: LDA DIRF ORA A RZ LXI H,DIRIN JMP ERROR ; ; FIND TEXT LINE WITH LINE NUMBER GIVEN IN DE ; RETURNS TEXT ADDR COUNT BYTE IN HL ; FINDLN: LHLD BOFA MVI B,0 FIND1: MOV C,M MOV A,C CPI EOF JZ LERR INX H CALL DCMP DCX H RZ DAD B JMP FIND1 ; LERR: LXI H,LNUMB JMP ERROR ; ; FIX FLOATING TO POSITIVE INTEGER ; RETURN INTEGER VALUE IN DE ; FP VALUE FROM TOP OF ARG STACK, POP ARG STACK ; PFIX: LHLD ASTKA MOV B,H MOV C,L PUSH H CALL AINT LXI H,FPSINK CALL POPAS POP H MOV C,M ;EXPONENT DCX H MOV A,M ;SIGN ORA A JNZ E5 ;NEGATIVE NO GOOD LXI D,-FPSIZ+1 DAD D LXI D,0 MOV A,C ORA A RZ DCR C ;SET UP FOR LOOP CLOSE TEST PFIX1: INX H MOV A,M RRC RRC RRC RRC CALL MUL10 JC E5 DCR C RP MOV A,M CALL MUL10 JC E5 DCR C JM PFIX1 RET ; ; TAKE NEXT DIGIT IN A (MASK TO 17Q), ACCUMULATE TO DE ; PRESERVES ALL BUT A, DE ; MUL10: PUSH H INX SP INX SP MOV H,D ;GET ORIGINAL VALUE TO HL MOV L,E DAD H ;DOUBLE IT RC DAD H ;AGAIN RC DAD D ;PLUS ORIGINAL MAKES 5 TIMES ORIG RC DAD H ;TIMES TWO MAKES TEN RC XCHG DCX SP DCX SP POP H ANI 17Q ADD E MOV E,A MOV A,D ACI 0 ;PROPOGATE THE CARRY MOV D,A RET ; ; GET INTEGER FROM TEXT ; SET CARRY IF NOT FOUND ; RETURN INTEGER VALUE IN HL ; RETURN TERMINATOR IN ACC ; INTGER: CALL DIG RC LXI D,0 JMP INTG2 ; INTG1: CALL DIG MOV H,D MOV L,E CMC RNC INTG2: SUI '0' CALL MUL10 JNC INTG1 RET ; ; CONVERT INTEGER TO STRING ; DE CONTAINS ADDR OF STRING, RETURN UPDATED VALUE IN DE ; HL CONTAINS VALUE TO CONVERT ; CNS: XRA A ;SET FOR NO LEADING ZEROES LXI B,-10000 CALL RSUB LXI B,-1000 CALL RSUB LXI B,-100 CALL RSUB LXI B,-10 CALL RSUB LXI B,-1 CALL RSUB RNZ MVI A,'0' STAX D INX D RET ; ; TAKE VALUE IN HL ; SUB MINUS NUMBER IN BE THE MOST POSSIBLE TIMES ; PUT VALUE ON STRING AT DE ; IF A=0 THEN DONT PUT ZERO ON STRING ; RETURN NON-ZERO IN A IF PUT ON STRING ; RSUB: PUSH D MVI D,0FFH RSUB1: PUSH H INX SP INX SP INR D DAD B JC RSUB1 DCX SP DCX SP POP H MOV B,D POP D ORA B ;A GETS 0 IF A WAS 0 AND B IS 0 RZ MVI A,'0' ADD B STAX D INX D RET ; ; INPUT CHARACTER FROM TERMINAL ; INCHAR: PUSH B PUSH H MVI C,1 CALL SYSTEM POP H POP B CPI ESC JZ CMND1 CPI LF ;IGNORE LINE FEEDS JZ INCHAR CPI NULL ;IGNORE NULLS JZ INCHAR MOV B,A RET ; INL0: CALL CRLF INLINE: LXI H,IBUF MVI C,LINLEN INL1: CALL INCHAR CPI RUBOUT JZ INL2 ;RUBOUT LAST CHAR MOV M,A MOV A,B CPI CNTRU ;LINE DELETION JZ INL0 MVI B,LF ;IN CASE WE ARE DONE CPI CR JZ CHOUT ;DO LF THEN RETURN INX H DCR C JNZ INL1 LXI H,LENGT JMP ERROR ; INL2: MOV A,C MVI B,BELL CPI LINLEN JZ INL3 ;IF DELETION BEFORE BEGINNING OF LINE DCX H INR C MOV B,M INL3: PUSH B PUSH H CALL CHOUT POP H POP B JMP INL1 ; ; OUPUT ROUTINES ; CHOUT: PUSH B PUSH D PUSH H MVI C,2 MOV E,B LDA PFLAG ;SELECT LINE PRINTER OR CONSOLE ORA A JZ CHO1 ;IF CONSOLE MVI C,5 CHO1: CALL SYSTEM ;OUTPUT CHARACTER THRU CP/M POP H POP D POP B MOV A,B CHCHK: CPI CR JNZ CHLF ;NOT CR IS IT LF? XRA A JMP PSTOR ;RETURN PHEAD TO ZERO ; CHLF: CPI LF JZ NULCH ;IF LINE FEED PROCESS THE NULLS CPI 40Q ;NO PHEAD INC IF CONTROL CHAR RC LDA PHEAD INR A PSTOR: STA PHEAD RET ; NULCH: LDA NULLCT ;OUTPUT NULL CHARS ORA A RZ PUSH B MOV C,A MVI B,NULL CH2: CALL CHOUT ;OUTPUT COUNT 'C' NULLS DCR C JNZ CH2 POP B RET ; CRLF2: CALL CRLF CRLF: MVI B,CR CALL CHOUT MVI B,LF JMP CHOUT ; ; CHECK IF PANIC CHARACTER HAS BEEN HIT ; PCHECK: MVI C,11 CALL SYSTEM ;CHECK FOR A CHARACTER TYPED ORA A RZ ;IF NO CHARACTER TYPED MVI C,1 ;GET THE CHARACTER CALL SYSTEM CPI ESC JZ BREAK ;IF OPERATOR INTERRUPT REQUEST CPI CR RNZ ;IF NOT PROGRAM STATUS REQUEST LDA PFLAG ;SAVE I/O FLAG AND SELECT CONSOLE PUSH PSW XRA A STA PFLAG LXI H,RNING ;OUTPUT 'RUNNING' MESSAGE CALL PRNT CALL CRLF2 POP PSW ;RESTORE I/O FLAG STA PFLAG RET ; BREAK: XRA A ;TURN OFF PFLAG INCASE LLIST OR LPRINT IN PROGRESS STA PFLAG JMP STOP1 ; ; OUTPUT FP NUMBER ADDRESSED BY HL ; FPOUT: LXI B,-DIGIT-1 DAD B MOV B,H MOV C,L LXI H,ABUF ;OUTPUT BUFFER LDA INFES ;OUTPUT FORMAT STA FES ;STORE IT MVI E,DIGIT MVI M,0 ;CLEAR ROUND OFF OVERFLOW BUFFER INX H ;ABUF+1 ; NXT: LDAX B ;GET DIGIT AND UNPACK MOV D,A RAR RAR RAR RAR ANI 17Q ;REMOVE BOTTOM DIGIT MOV M,A ;STORE TOP DIGIT IN OUTPUT BUFFER (ABUF) INX H MOV A,D ;NOW GET BOTTOM DIGIT ANI 17Q MOV M,A ;STORE IT INX H INX B DCR E JNZ NXT LDAX B STA FSIGN ;STORE SIGN OF NUMBER XRA A MOV M,A ;CLEAR ROUND-OFF BUFFER (ABUF+13) 12 DIG NO RND LXI H,XSIGN ;EXPONENT SIGN STORE MOV M,A ;CLEAR XSIGN ; FIX: INX B ;GET EXPONENT LDAX B ORA A ;EXPONENT ZERO? JZ ZRO SUI 128 ;REMOVE NORMALIZING BIAS JNZ FIX2 INR M ;INCREMENT XSIGN TO NEGATIVE FLAG (1) LATER ZERO FIX2: JP CHK13 CMA ;ITS A NEGATIVE EXPONENT INR M ; INCREMENT XSIGN TO NEGATIVE (1) ZRO: INR A CHK13: LXI H,EXPO ;EXPONENT TEMP STORE MOV M,A MOV E,A CPI DIGIT*2 LXI H,FES ;FORMAT TEMP BYTE JC CHKXO CHK40: MVI A,1 ;FORCE EXPONENTIAL PRINTOUT ORA M ;SET FORMAT FOR XOUT MOV M,A ; CHKXO: MOV A,M ;CHECK IF EXPONENTIAL PRINTOUT RAR JNC CHKX3 ANI 17Q CPI DIGIT*2 JC CHKX2 MVI A,DIGIT*2-1 ;MAX DIGITS CHKX2: MOV D,A INR A JMP ROUND ; CHKX3: ANI 17Q ;ADD EXPONENT AND DECIMAL PLACES MOV D,A ADD E CPI DIGIT*2+1 MOV B,A JC CHKXN MOV A,M ANI 100Q JNZ CHK40 ; CHKXN: LDA XSIGN ;CHECK EXPONENT SIGN ORA A JNZ XNEG ;ITS NEGATIVE MOV A,B JMP ROUND ; XNEG: MOV A,D ;SUBTRACT EXPONENT AND DECIMAL PLACE COUNT SUB E JNC XN2 XN1: LDA INFES ORA A JP ZERO ANI 16Q JZ ZERO RRC MOV E,A DCR E MVI C,1 LXI H,ABUF-1 JMP NRND ; XN2: JZ XN1 JMP ROUND ; ; CLEAN: MVI B,37Q ;CLEAR FLAGS ANA B CPI DIGIT*2+1 RC MVI A,DIGIT*2+1 ;MAX DIGITS OUT RET ; ; THIS ROUTINE IS USED TO ROUND DATA TO THE ; SPECIFIED DECIMAL PLACE ; ROUND: CALL CLEAN MOV C,A MVI B,0 LXI H,ABUF+1 DAD B ;GET ROUND-OFF ADDRESS SHLD ADDT MOV A,M CPI 5 ;ROUND IF >=5 JC TRL2-1 ; LESS1: DCX H INR M ;ROUND UP MOV A,M ORA A JZ TRL2 CPI 10 ;CHECK IF ROUNDED NUMBER >9 JNZ TRAIL MVI M,0 JMP LESS1 ; ; THIS ROUTINE IS USED TO ELIMINATE TRAILING ZERO'S ; TRAIL: LHLD ADDT DCX H TRL2: LDA FES ;CHECK IF TRAILING ZERO'S ARE WANTED RAL JC FPRNT ;YES- GO PRINT DATA TRL3: MOV A,M ORA A ;IS IT ZERO? JNZ FPRNT ;NO- GO PRINT DCX H DCR C ;YES- FIX OUTPUT DIGIT COUNT JM ZERO JMP TRL3 ; ; HERE STARTS THE PRINT FORMAT ROUTINES ; FPRNT: LXI H,ABUF MOV A,M ;CHECK IF ROUNDED UP TO 1 ORA A JZ NRND ;JUMP IF NOT MVI B,1 LDA XSIGN ;IS EXPONENT NEGATIVE? ORA A JZ POSR MVI B,0FFH ; POSR: LDA EXPO ;GET EXONENT ORA A JNZ PO2 ;IS IT ZERO? (E+0) STA XSIGN MVI B,1 PO2: ADD B ;FIX EXPONENT COUNT STA EXPO INR E INR C DCX H ; NRND: INX H MOV A,C CPI DIGIT*2+1 ;CHECK FOR MAX DIGITS OUT JNZ NRND1 DCR C NRND1: LDA FSIGN ;CHECK IF NEGATIVE NUMBER RAR JNC PRIN2 ;GO OUTPUT RADIX AND NUMBER CALL NEG ;OUTPUT (-) JMP PRI21 ; ; PRIN2: CALL SPACE ;OUTPUT A SPACE PRI21: LDA FES ;GET OUTPUT FORMAT RAR ;CHECK IF EXPONENTIAL OUTPUT FORMAT JC XPRIN LDA XSIGN ;GET EXPONENT SIGN ORA A ;CHECK IF NEGATIVE EXPONENT JZ POSIT MOV A,C ORA A JNZ PRIN4 ;OUTPUT RADIX AND NUMBER CALL ZERO ;NO DIGITS AFTER RADIX, OUTPUT ZERO AND DONE RET ; PRIN4: CALL RADIX ;PRINT DECIMAL POINT XRA A ORA E JZ PRIN5 ;JUMP IF NO ZEROS TO PRINT CALL ZERO ;FORCE PRINT A ZERO DCR E JNZ PRIN4+3 ; PRIN5: CALL NOUT ;PRINT ASCII DIGIT JNZ PRIN5 RET ; POSIT: CALL NOUT DCR E ;BUMP EXPONENT COUNT JNZ POSIT MOV A,C ;CHECK IF MORE DIGITS TO OUTPUT ORA A RZ ;NO, DONE RM JMP PRIN4 ;NOW PRINT DECIMAL POINT ; ; GET HERE FOR EXPONENTIAL OUTPUT FORMAT ; XPRIN: CALL NOUT JZ NDEC ;INTEGER? CALL RADIX ;NO.....PRINT DECIMAL POINT XPRI2: CALL NOUT JNZ XPRI2 ; NDEC: MVI B,'E' ;OUTPUT 'E' CALL CHOUT LDA XSIGN ORA A JZ XPRI3 CALL NEG ;PRINT EXPONENT SIGN (-) LDA EXPO INR A JMP XOUT2 ; XPRI3: MVI B,'+' ;EXPONENT (+) CALL CHOUT ; ; THIS ROUTINE IS USED TO CONVERT THE EXPONENT ; FROM BINARY TO ASCII AND PRINT THE RESULT ; XOUT: LDA EXPO DCR A XOUT2: MVI C,100 MVI D,0 CALL CONV CPI '0' ;SKIP LEADING ZEROES JZ XO21 INR D CALL CHOUT XO21: MOV A,E MVI C,10 CALL CONV CPI '0' JNZ XO3 DCR D JNZ XO4 XO3: CALL CHOUT XO4: MOV A,E ADI '0' ;ADD ASCII BIAS MOV B,A CALL CHOUT RET ; CONV: MVI B,'0'-1 INR B SUB C JNC CONV+2 ADD C MOV E,A MOV A,B RET ; ; THIS ROUTINE ADDS ASCII BIAS TO A BCD DIGIT ; AND CALLS THE OUTPUT ROUTINE ; NOUT: MOV A,M ADI '0' MOV B,A CALL CHOUT INX H DCR C ;DECREMENT TOTAL DIGITS OUT COUNT RET ; ; COMMON SYMBOL LOADING ROUTINES ; NEG: MVI B,'-' JMP CHOUT ZERO: MVI B,'0' JMP CHOUT SPACE: MVI B,' ' JMP CHOUT RADIX: MVI B,'.' JMP CHOUT ; ; CONVERTS FP STRING AT DE, UPDATE DE PAST TERMINATOR ; PUTS TERMINATOR IN B, PUTS FP NUMBER AT ADDR IN HL ; SETS CARRY IF NOT FOUND ; FPIN: PUSH H PUSH D XCHG DCX H SHLD ADDS LXI H,OPST ;CLEAR TEMP STORAGE AREAS AND BC BUFFER MVI C,DIGIT+6 CALL CLEAR ; SCANC: LXI D,0 LXI H,BC ;BC=PACK BUFFER SCAN0: SHLD BCADD ;PACK BUFFER POINTER SCANP: LXI H,SCANP PUSH H ;USED FOR RETURN FROM OTHER ROUTINES XRA A STA XSIGN ;CLEAR EXPONENT SIGN BYTE ; SCANG: CALL IBSCN JC SCANX ;FOUND A NUMBER, GO PACK IT CPI '.' ;RADIX? JZ SCAN5 ;PROCESS RADIX POINTERS CPI 'E' ;EXPONENT? JZ EXCON ;FOUND 'E', GO PROCESS EXPONENT NUMBER ; ; NOT A CHARACTER LEGAL IN NUMBER ; MOV B,A ;MOVE TERMINATOR TO B LDA OPST ;CHECK IF ANY DIGITS YET ANI 20Q JNZ ENTR2 ; ; GET HERE IF LEGAL FP NUMBER NOT FOUND ; FPIN1: POP H ;SCANP LINK POP D ;TEXT POINTER POP H ;FP # ADDR STC RET ; ; FOUND DECIMAL POINT ; SCAN5: XRA A ;FOUND RADIX PROCESS RADIX POINTERS FOR EXP ORA D ;ANY DIGITS YET? JNZ SCAN6 ADI 300Q ;SET ECNT - STOP COUNTING DIGITS ORA E ;NO INT DIGITS, BIT 7 IS COUNT/DONT COUNT FLAG MOV E,A ;BIT 6 IS NEGATIVE EXPONENT FLAG RET ; SCAN6: MVI A,200Q ;SET ECNT TO COUNT DIGITS ORA E MOV E,A RET ; SCANX: ANI 17Q ;FOUND NUMBER-REMOVE ASCII BIAS MOV B,A LXI H,OPST ;SET FIRST CHARACTER FLAG MVI A,60Q ORA M MOV M,A XRA A ORA B ;IS CHAR ZERO? JNZ PACK ORA D ;LEADING ZERO I. E. ANY INT DIGITS? JNZ PACK ORA E MOV E,A RZ ;IF COUNTING YET, INR E ;ECNT+1-COUNT ZEROS FOR EXPONENT COUNT RET ; ; THIS SUBROUTINE BCD PACKS DIGITS INTO REG BC ; PACK: MOV A,E RAL JC PACK1 INR E PACK1: MOV A,E STA ECNT ;DIGIT COUNT FOR EXPONENT COUNT INR D ;TOTAL DIGIT COUNT (D ALSO HAS TOP/BOTM FLAG BIT 7 MOV A,D ANI 177Q ;REMOVE TOP/BOTTOM FLAG CPI DIGIT*2+1 ;LIMIT INPUT DIGITS RNC XRA A ORA D JM BOTM ; TOP: ORI 200Q ;SET MSB FOR TOP FLAG MOV D,A MOV A,B LHLD BCADD ;GET BC ADDRESS RLC RLC RLC RLC MOV M,A ;SAVE CHR IN BC RET ; BOTM: ANI 177Q ;STRIP MSB (BOTTOM FLAG) MOV D,A MOV A,B LHLD BCADD ORA M ;OR IN TOP NUMBER MOV M,A ;PUT NUMBER BACK IN BC INX H POP B JMP SCAN0 ; IBSCN: LHLD ADDS ;INPUT BUFFER POINTER INX H ;GET NEXT BYTE MOV A,M CPI ' ' JZ IBSCN+3 SHLD ADDS ;NOTE: THIS ROUTINE FALLS THROUGH TO BELOW ; ; THIS ROUTINE CHECKS FOR ASCII NUMBERS (0-9) ; NMCHK: CPI '9'+1 RNC CPI '0' CMC RET ; ; THIS ROUTINE IS USED TO ADJUST A NUMBER IN BC BUFFER ; AND RETURNS VALUE ; ENTR2: LXI D,0 ENT1: PUSH B ;TERMINATOR CALL FIXE ;NORMALIZE FLOATING POINT NUMBER POP B ;TERMINATOR POP D ;SCANP LINK POP D ;OLD TEXT ADDR POP D ;RETURN ADDR MVI C,DIGIT+2 LXI H,BC+DIGIT+1 CALL VCOPY LHLD ADDS XCHG INX D ORA A RET ; ; THIS ROUTINE IS USED TO CLEAR STORAGE AREAS ; THE STARTING ADDRESS IS IN HL AND THE COUNT ; IS IN REG C ; CLEAR: XRA A MOV M,A INX H DCR C JNZ CLEAR+1 RET ; ; THIS ROUTINE CONVERTS THE ASCII EXPONENT OF ; NUMBER IN THE INPUT BUFFER TO BINARY, AND ; NORMALIZES EXPONENT ACCORDING TO THE INPUT ; FORMAT OF THE NUMBER ; EXCON: CALL IBSCN ;GET CHARACTER JC EXC3 CPI PLSRW ;CHECK FOR UNARY SIGNS JZ EXC4 CPI '+' JZ EXC4 CPI '-' JZ EXC2 CPI MINRW JNZ FPERR ;NO SIGN OR NUMBER? EXC2: MVI A,1 STA XSIGN ;SAVE SIGN EXC4: CALL IBSCN JNC FPERR ;NO NUMBER? EXC3: CALL ASCDC ;CONVERT ASCII TO BINARY JMP ENT1 ;NORMALIZE NUMBER AND RETURN ; ; THIS ROUTINE CONVERTS ASCII TO BINARY ; THREE CONSECUTIVE NUMBERS <128 MAY BE CONVERTED ; ASCDC: XCHG LXI H,0 ASC1: LDAX D ;GET CHR FROM INPUT BUFFER, NO SPACES ALLOWED CALL NMCHK ;CHECK IF NUMBER JNC ASC2 SUI '0' ;REMOVE ASCII BIAS MOV B,H MOV C,L DAD H DAD H DAD B DAD H MOV C,A MVI B,0 DAD B INX D JMP ASC1 ; ASC2: XCHG MOV B,A ;SAVE TERMINATOR SHLD ADDS ;SAVE IBUF ADDR MOV A,D ORA A JNZ FPERR ;TOO BIG >255 MOV A,E RAL JC FPERR ;TOO BIG >127 RAR RET ; FPERR: POP B ;ASCDC RET LINK JMP FPIN1 ; ; THIS ROUTINE NORMALIZES THE INPUT NUMBER ; FIXE: XCHG LDA BC ORA A ;IS IT ZERO JZ ZZ2 CALL CHKPN ;SET EXPONENT POSITIVE/NEGATIVE ADI 200Q ;ADD EXPONENT BIAS ZZ2: STA BC+DIGIT+1 ;STORE NORMALIZED EXPONENT IN BC RET ; CHKPN: LDA ECNT ;GET EXPONENT COUNT-SET IN 'SCAN' ROUTINE MOV E,A ANI 77Q ;STRIP BITS 7 AND 8 MOV B,A LDA XSIGN ORA A JZ LPOS ;EXPONENT IS POSITIVE INR H ;SET SIGN IN H **THIS SHOULD BE INR H NOT INX H MVI A,100Q ;L IS NEGATIVE ANA E ;CHECK IF E IS NEGATIVE JZ EPOS MOV A,L ;BOTH E AND L NEGTIVE MOV L,B CALL BPOS+1 CMA INR A RET ;BACK TO FIXE ; EPOS: MOV A,L ;E AND L NEGATIVE CMA INR A ADD B RET ;TO FIXE ; LPOS: MVI A,100Q ;EXPONENT POSITIVE ANA E JZ BPOS ;IF E POSITIVE MOV A,B MOV B,L JMP EPOS+1 ; BPOS: MOV A,B ;E AND L POSITIVE ADD L RP ; POP H JMP FPERR DB 1*16 DW 0 DB 1 FPNONE: DB 129 ; ; THIS PROGRAM IS A FOUR FUNCTION FLOATING POINT BCD ; MATH PACKAGE ; EACH FUNCTION MAY BE EXPRESSED AS: BC=DE # HL ; <BC> = ADDR OF RESULT ; <DE> = ADDR OF 1ST ARGUMENT ; <HL> = ADDR OF 2ND ARGUMENT ; # IS ONE OF THE FUNCTIONS: +, -, *, / ; ALL ADDRESSES ON ENTRY, POINT TO THE EXPONENT PART OF ; THE FLOATING POINT NUMBER ; EACH FLOATING POINT NUMBER CONSISTS OF (2*DIGIT) PACKED ; DECIMAL DIGITS, A SIGN AND A BIASED BINARY EXPONENT. THE ; EXPONENT RANGE IS 10**-127 TO 10**127. ; THE NUMBER ZERO IS REPRESENTED BY THE EXPONENT 0. ; THE NUMBERS ARE STORED IN MEMORY AS (DIGIT) BYTES OF ; DECIMAL DIGITS. ; STARTING AT THE LOW ORDER ADDRESS ; ALL NUMBERS ARE ASSUMED TO BE NORMALIZED. THAT IS EACH ; NUMBER CAN BE REPRESENTED AS F**E. ; WHERE .1<=F<=1.0 AND F IS THE EXPONENT. ; ; FLOATING POINT ADDITION ; FADD: PUSH B CALL EXPCK ;FETCH ARGUMENTS MVI C,0 ADSUM: DCX D XCHG LDA SIGN XRA M ;FORM SIGN OF RESULT MOV B,A XCHG LDAX D DCX D XRA C STA SIGN LXI H,RCTRL ;ROUNDING CONTROL FLAG MOV A,M ORA A INX H MOV A,M ;GET ROUNDING DIGIT JZ ADS8 RLC RLC RLC RLC ADS8: ADI 0B0H ;FORCE CARRY IF DIGIT > 5 MOV A,B RAR JC ADS1 ;HAVE SUBTRACTION RAL ;RESTORE CARRY CALL ADDF ;PERFORM ADDITION JNC ADS2 MVI B,4 CALL RIGHT LXI H,EXP INR M ;INCREMENT EXPONENT JZ OVER ADS2: POP B ;GET RESULTS ADDRESS CALL STORE ;SAVE RESULTS RET ; ZEREX: POP H JMP ADS2 ; ADDF: LXI H,BUF+DIGIT-1 MVI B,DIGIT ADD1: LDAX D ADC M DAA MOV M,A DCX H DCX D DCR B JNZ ADD1 RNC INR M RET ; ; FLOATING POINT SUBTRACTION ; FSUB: PUSH B CALL EXPCK ;GET ARGUMENTS LDA SIGN XRI 1 ;COMPLEMENT SIGN STA SIGN JMP ADSUM ; ADS1: RAL ;RESTORE CARRY CMC ;COMPLEMENT FOR ROUNDING CALL SUBF ;SUBTRACT ARGUMENTS LXI H,SIGN JC ADS4 MOV A,M ;GET SIGN XRI 1 ;COMPLEMENT MOV M,A ADS7: DCX H MVI B,DIGIT ADS3: MVI A,9AH SBB M ;COMPLEMENT RESULT ADI 0 DAA MOV M,A DCX H DCR B CMC JNZ ADS3 ADS4: LXI H,BUF LXI B,DIGIT ADS5: MOV A,M ORA A JNZ ADS6 INX H INR B INR B DCR C JNZ ADS5 XRA A STA EXP JMP ADS2 ; ADS6: CPI 10H JNC ADS9 INR B ADS9: LXI H,EXP MOV A,M SUB B JZ UNDER JC UNDER MOV M,A MOV A,B RLC RLC MOV B,A CALL LEFT JMP ADS2 ; SUBF: LXI H,BUF+DIGIT-1 MVI B,DIGIT SUB1: MVI A,99H ACI 0 SUB M XCHG ADD M DAA XCHG MOV M,A DCX H DCX D DCR B JNZ SUB1 RET ; ; FLOATING POINT MULTIPLY ; FMUL: PUSH B MOV A,M ORA A ;ARGUMENT=0? JZ FMUL1+2 LDAX D ORA A ;ARGUMENT=0? JZ FMUL1+2 ADD M ;FORM RESULT EXPONENT JC FMOVR JP UNDER JMP FMUL1 ; FMOVR: JM OVER FMUL1: SUI 128 ;REMOVE EXCESS BIAS STA EXP ;SAVE EXPONENT DCX D DCX H LDAX D XRA M ;FORM RESULT SIGN DCX H DCX D PUSH H LXI H,SIGN ;GET SIGN ADDRESS MOV M,A DCX H XRA A MVI B,DIGIT+2 FMUL2: MOV M,A ;ZERO WORKING BUFFER DCX H DCR B JNZ FMUL2 LDA EXP ORA A JZ ZEREX MVI C,DIGIT LXI H,HOLD1+DIGIT ; ; GET MULTIPLIER INTO HOLDING REGISTER ; FMUL3: LDAX D MOV M,A ;PUT IN REGISTER DCX H DCX D DCR C JNZ FMUL3 MOV M,C DCX H MVI B,250 ;SET LOOP COUNT FMUL4: LXI D,DIGIT+1 MOV C,E DAD D XCHG DAD D ;HL=NEXT HOLDING REGISTER INR B JP FMUL8 ;FINISHED FMUL5: LDAX D ;GET DIGITS ADC A ;TIMES 2 DAA MOV M,A ;PUT IN HOLDING REGISTER DCX D DCX H DCR C JNZ FMUL5 INR B ;INCREMENT LOOP COUNT JNZ FMUL4 ; ; FORM 10X BY ADDING 8X AND 2X ; FIRST GET 8X ; INX H LXI D,HOLD5 ;NEXT HOLDING REGISTER MVI C,DIGIT+1 MOV B,C FMUL6: MOV A,M STAX D INX H INX D DCR C JNZ FMUL6 LXI H,HOLD2+DIGIT ;GET 2X DCX D FMUL7: LDAX D ADC M ;FORM 10X DAA STAX D DCX D DCX H DCR B JNZ FMUL7 MVI B,249 XCHG JMP FMUL4 ; FMUL8: XCHG INX H MVI M,DIGIT+1 ;SET NEXT LOOP COUNT ; ; PERFORM ACCUMULATION OF PRODUCT ; FMUL9: POP B ;GET MULTIPLIER LXI H,HOLD8+DIGIT+1 DCR M ;DECREMENT LOOP COUNT JZ FMU14 ;FINISHED LDAX B DCX B PUSH B DCX H XCHG FMU10: ADD A ;CHECK FOR BIT IN CARRY JC FMU11 ;FOUND A BIT JZ FMU12 ;ZERO- FINISHED THIS DIGIT LXI H,-DIGIT-1 DAD D ;POINT TO NEXT HOLDING REGISTER XCHG JMP FMU10 ; FMU11: MOV C,A ORA A ;CLEAR CARRY CALL ADDF ;ACCUMULATE PRODUCT LDAX D ADD M DAA MOV M,A MOV A,C DCX D JMP FMU10 ; ; ROTATE RIGHT 1 BYTE ; FMU12: MVI B,8 CALL RIGHT JMP FMUL9 ; FMU14: LDA BUF ANI 0F0H ;CHECK IF NORMALIZED JZ FMU17 MOV A,D ANI 0F0H LXI H,SIGN-1 JMP FMU18 ; FMU17: MVI B,4 LXI H,EXP DCR M JZ UNDER CALL LEFT ;NORMALIZE MOV A,D ;GET DIGIT SHIFTED OFF ; ; PERFORM ROUNDING ; RRC RRC RRC RRC FMU18: CPI 50H JC FMU16 INR A ANI 0FH MVI C,DIGIT FMU15: ADC M DAA MOV M,A MVI A,0 DCX H DCR C JNZ FMU15 ; ; CHECK FOR ROUNDING OVERFLOW ; JNC ADS2 ;NO OVERFLOW INX H MVI M,10H LXI H,EXP INR M JNZ ADS2 JMP OVER ; ; ROUNDING NOT NEEDED ; FMU16: ANI 0FH ADD M MOV M,A JMP ADS2 ; ; FLOATING POINT DIVISION ; FDIV: PUSH B MOV A,M ;FETCH DIVISOR EXP ORA A ;DIVIDE BY 0? JZ DIVZ LDAX D ORA A ;DIVIDEND=0? JZ INSP SUB M JC DIVUN JM OVER JMP FDI1 ; DIVUN: JP UNDER FDI1: ADI 129 ;FORM QUOTIENT EXP STA EXPD XCHG PUSH D CALL LOAD ;FETCH DIVIDEND POP D XCHG LDA SIGN DCX H XRA M ;FORM QUOTIENT SIGN STA SIGND XCHG DCX D LXI B,HOLD1 DIV0: MVI L,DIGIT+DIGIT DIV1: PUSH B PUSH H MVI C,0 ;QUOTIENT DIGIT=0 DIV3: STC ;SET CARRY LXI H,BUF+DIGIT-1 MVI B,DIGIT DIV4: MVI A,99H ACI 0 XCHG SUB M XCHG ADD M DAA MOV M,A DCX H DCX D DCR B JNZ DIV4 MOV A,M CMC SBI 0 MOV M,A RAR LXI H,DIGIT DAD D XCHG INR C ;INCREMENT QUOTIENT RAL JNC DIV3 ORA A ;CLEAR CARRY CALL ADDF ;RESTORE DIVIDEND LXI H,DIGIT DAD D XCHG PUSH B MVI B,4 CALL LEFT ;SHIFT DIVIDEND POP B DCR C POP H MOV H,C POP B MOV A,L JNZ DIV5 CPI DIGIT+DIGIT JNZ DIV5 LXI H,EXPD DCR M CZ UNDER JMP DIV0 ; DIV5: RAR MOV A,H JNC DIV6 LDAX B RLC RLC RLC RLC ADD H STAX B ;STORE QUOTIENT INX B JMP DIV7 ; DIV6: STAX B ;STORE QUOTIENT DIV7: DCR L ;DECREMENT DIGIT COUNT JNZ DIV1 LXI H,EXPD POP B CALL STORO RET ; ; FETCH AND ALIGN ARGUMENTS FOR ; ADDITION AND SUBTRACTION ; EXPCK: LDAX D SUB M ;DIFFERENCE OF EXPS MVI C,0 JNC EXPC1 INR C XCHG CMA INR A EXPC1: MOV B,A LDAX D STA EXP MOV A,B CPI DIGIT+DIGIT JC EXPC2 MVI A,DIGIT+DIGIT EXPC2: RLC RLC MOV B,A ANI 4 STA RCTRL ;SET ROUNDING CONTROL PUSH B PUSH D CALL LOAD ;LOAD SMALLER VALUE MVI A,8*DIGIT+16 SUB B CPI 8*DIGIT+16 JZ EXPC3 ANI 0F8H RAR RAR RAR ADD E MOV E,A MOV A,D ACI 0 MOV D,A LDAX D ;GET ROUNDING DIGIT STA RDIGI ;SAVE EXPC3: CALL RIGHT ;ALIGN VALUES POP D POP B RET ; ; LOAD ARGUMENT INTO BUFFER ; LOAD: LXI D,SIGN MVI C,DIGIT+1 DCX H LOAD1: MOV A,M STAX D DCX H DCX D DCR C JNZ LOAD1 XRA A STAX D DCX D STAX D STA RDIGI ;ZERO ROUNDING DIGIT RET ; ; STORE RESULTS IN MEMORY ; STORE: LXI H,EXP STORO: MVI E,DIGIT+2 STOR1: MOV A,M STAX B DCX B DCX H DCR E JNZ STOR1 RET ; ; SHIFT RIGHT NUMBER OF DIGITS ; IN B/4 ; RIGHT: MVI C,DIGIT+1 RIGH1: LXI H,BUF-1 MOV A,B SUI 8 ;CHECK IF BYTE CAN BE SHIFTED JNC RIGH3 DCR B RM ORA A RIGH2: MOV A,M RAR MOV M,A INX H DCR C JNZ RIGH2 JMP RIGHT ; ; SHIFT RIGHT ONE BYTE ; RIGH3: MOV B,A XRA A RIGH4: MOV D,M MOV M,A MOV A,D INX H DCR C JNZ RIGH4 JMP RIGHT ; ; SHIFT LEFT NUMBER OF DIGITS ; IN B/4 ; LEFT: MVI C,DIGIT+1 LXI H,SIGN-1 LEF1: MOV A,B SUI 8 JNC LEF3 DCR B RM ORA A LEF2: MOV A,M RAL MOV M,A DCX H DCR C JNZ LEF2 JMP LEFT ; ; SHIFT LEFT ONE BYTE ; LEF3: MOV B,A XRA A LEF4: MOV D,M MOV M,A MOV A,D DCX H DCR C JNZ LEF4 JMP LEFT ; ; SET FLAGS FOR OVERFLOW, UNDERFLOW, ; AND DIVIDE BY ZERO ; OVER: LXI H,FLOAT JMP ERROR UNDER: MVI A,0FFH STA ERRI INSP: INX SP INX SP RET ; DIVZ EQU OVER ; ; HAMPSHIRE ADDED COMMANDS ; CSYS: JMP 0 ; SAVE: CALL GC CPI CR CNZ WSID ;RENAME THE WORK-SPACE CALL SETFCB ;SET UP FCB MVI C,19 ;ERASE PREVIOUS FILE (IF ANY) LXI D,TFCB CALL SYSTEM MVI C,22 ;CREATE A NEW FILE LXI D,TFCB CALL SYSTEM CPI 0FFH JZ SAV6 ;IF NO DIRECTORY SPACE LHLD BOFA ;INITIALIZE DMA ADDR XCHG MOV A,D CMA MOV B,A MOV A,E CMA MOV C,A INX B ;NEGATE BOFA LHLD EOFA ;COUNT=EOFA-BOFA+1 DAD B INX H SAV1: XRA A ;COUNT<256? ORA H JNZ SAV2 ;IF COUNT>255 MOV A,L CPI 128 JM SAV3 ;IF COUNT<128 SAV2: PUSH D ;SAVE COUNT AND DMA ADDRESS PUSH H MVI C,26 ;SET DMA ADDR CALL SYSTEM MVI C,21 ;WRITE SECTOR LXI D,TFCB CALL SYSTEM ORA A JNZ SAV5 ;IF NO DISK SPACE POP H ;RETRIEVE COUNT AND DMA ADDR POP D LXI B,-128 ;COUNT=COUNT-128 DAD B XCHG LXI B,128 ;DMA ADDR=DMA ADDR+128 DAD B XCHG JMP SAV1 ; SAV3: ORA A JNZ SAV4 ;IF COUNT>0 MVI C,26 ;RESET DMA ADDRESS TO 80H LXI D,TBUFF CALL SYSTEM MVI C,16 ;CLOSE FILE LXI D,TFCB CALL SYSTEM JMP CMND1 ;RETURN TO TOP LEVEL OF INTERPRETTER ; SAV4: XCHG ;HL=DMA ADDR, E=COUNT LXI B,TBUFF SAV41: MOV A,M ;MOVE BYTE TO TBUFF STAX B INX H INX B DCR E JNZ SAV41 ;LOOP FOR ALL BYTES LXI H,128 ;SO COUNT WILL BE 0 ON NEXT PASS LXI D,TBUFF ;DMA ADDR=TBUFF JMP SAV2 ; SAV5: LXI H,FSERR JMP ERROR ; SAV6: LXI H,DSERR JMP ERROR ; FETCH: CALL SETFCB ;SET UP FCB MVI C,15 ;OPEN FILE LXI D,TFCB CALL SYSTEM CPI 0FFH JZ FET11 ;IF FILE NOT FOUND LXI H,NR ;INITIALIZE NEXT RECORD INDEX MVI M,0 LHLD BOFA ;INITIALIZE DMA ADDR XCHG MOV A,D ;NEGATE BOFA CMA MOV B,A MOV A,E CMA MOV C,A INX B LHLD SYSTEM+1;FREE SPACE LENGTH=FL-BOFA DAD B FET1: XRA A ;COUNT<=255? ORA H JNZ FET2 ;IF COUNT>255 MOV A,L CPI 128 JM FET4 ;IF COUNT<128 JZ FET4 ;IF COUNT=128 FET2: PUSH D ;SAVE DMA ADDR AND LENGTH PUSH H MVI C,26 ;SET DMA ADDR CALL SYSTEM MVI C,20 ;READ SECTOR LXI D,TFCB CALL SYSTEM POP H ;RETRIEVE DMA ADDR AND COUNT POP D ORA A JZ FET3 ;IF SUCCESSFUL READ RRC JC FET9 ;IF EOF READ LXI H,RNDER ;RANDOM ACCESS FILE ERROR JMP ERROR ; FET3: LXI B,-128 ;LENGTH=LENGTH-128 DAD B XCHG LXI B,128 ;DMA ADDR=DMA ADDR+128 DAD B XCHG JMP FET1 ; FET4: ORA A JZ FET5 ;IF LENGTH=0 PUSH D ;SAVE DMA ADDR AND LENGTH PUSH H LXI H,128 LXI D,TBUFF ;DMA ADDR=TBUFF JMP FET2 ; FET5: LXI H,TBUFF ;FIND FIRST CR IN TBUFF LXI D,TBUFF+127 ;SET UPPER LIMIT OF SEARCH MVI C,128 ;SET MAXIMUM NUMBER OF BYTES TO SEARCH MOV A,M CPI EOF JZ FET6 ;IF FIRST BYTE IS EOF FET51: CPI CR INX H JNZ FET52 ;IF NOT CR DCR C JZ FET12 ;IF CR IS LAST BYTE IN TBUFF CALL FET10 ;FIND EOF JMP FET6 ; FET52: MOV A,M DCR C JNZ FET51 ;IF MORE BYTES TO SEARCH JMP FET12 ;FILE SIZE ERROR ; FET6: LXI B,-TBUFF-1 ;SET COUNT OF BYTES TO MOVE DAD B POP B ;RETRIEVE LENGTH OF FREE SPACE MOV A,B CMP H JM FET12 ;IF FILE TOO LONG JNZ FET7 ;IF FILE NOT TOO LONG MOV A,C CMP L JM FET12 ;IF FILE TOO LONG FET7: POP B ;SET FREE SPACE ADDR LXI D,TBUFF FET8: LDAX D ;MOVE COUNT BYTES TO FREE SPACE STAX B INX D INX B DCR L JNZ FET8 ;IF MORE BYTES TO MOVE ; FET9: LHLD SYSTEM+1 ;FIND EOF DCX H XCHG LHLD BOFA CALL FET10 SHLD EOFA MVI C,26 LXI D,TBUFF CALL SYSTEM RET ; FET10: MOV A,M CPI EOF RZ ;IF EOF FOUND ORA A JZ FET11 ;IF ILLEGAL FILE CALL ADR MOV A,E SUB L MOV A,D SBB H JC FET12 ;IF FILE TOO LONG JMP FET10 ; FET11: LXI H,FNAME JMP ERROR ; FET12: LXI H,FSIZE JMP ERROR ; CNAME: CALL GC CPI CR JZ CNAM1 ;IF CURRENT WSID WANTED CALL WSID ;RENAME THE WORK-SPACE JMP CMND1 ; CNAM1: LXI D,IBUF ;ASSEMBLE OUTPUT INTO IBUF LXI H,WSIDN MVI C,8 CALL COPY ;COPY FILE NAME MVI A,' ' STAX D INX D MVI C,3 CALL COPY ;COPY FILE TYPE MVI A,'"' STAX D LXI H,IBUF ;OUTPUT WSID CALL PRNT CALL CRLF JMP CMND1 ; ERA: CALL SETFCB ;INITIALIZE TFCB CALL GC CPI CR JZ ERA1 ;IF FILE NAME=WSID LXI D,TFCB+1;SET UP FILE NAME AND TYPE IN TFCB MVI A,' ' ;PRESET NAME AND TYPE MVI C,11 ERA0: STAX D INX D DCR C JNZ ERA0 LXI D,TFCB+1;SET NAME AND TYPE LHLD TXA MVI C,9 CALL SETFN ;SET NAME CPI CR JZ ERA1 ;IF DONE CPI '.' JNZ ERA2 ;IF FILE NAME ERROR INX H LXI D,TFCB+9 MVI C,4 CALL SETFN ;SET TYPE CPI CR JNZ ERA2 ;IF FILE NAME ERROR ERA1: MVI C,19 ;DELETE FILE LXI D,TFCB CALL SYSTEM JMP CMND1 ; ERA2: LXI H,FNAME JMP ERROR ; WSID: LXI H,WSIDN ;INITIALIZE NAME ADDR LXI D,WSIDD ;INITIALIZE DEFAULT WSID ADDR MVI C,11 WSID1: LDAX D ;INITIALIZE WSID MOV M,A INX H INX D DCR C JNZ WSID1 LHLD TXA CALL GC CPI CR RZ ;IF NO FILE NAME SPECIFIED MVI A,' ' ;PREPARE NAME FIELD MVI C,8 LXI D,WSIDN WSD10: STAX D INX D DCR C JNZ WSD10 ;IF MORE TO DO LXI D,WSIDN MVI C,9 CALL SETFN ;SET FILE NAME CPI CR RZ ;IF DONE CPI '.' JNZ WSID3 ;IF FILE NAME ERROR MVI A,' ' ;PREPARE TYPE FIELD MVI C,3 LXI D,WSIDT WSID2: STAX D INX D DCR C JNZ WSID2 MVI C,4 LXI D,WSIDT INX H CALL SETFN CPI CR RZ ;IF DONE WSID3: LXI H,FNAME JMP ERROR ; SETFN: MOV A,M CPI CR RZ CPI '.' RZ STAX D INX H INX D DCR C RZ JMP SETFN ; SETFCB: LXI H,TFCB ;SET FCB ADDR MVI M,0 ;CLEAR ET INX H MVI C,11 LXI D,WSIDN ;SET ADDR OF WSID SETF1: LDAX D ;COPY WSID TO TFCB MOV M,A INX H INX D DCR C JNZ SETF1 ;IF MORE CHARS MVI C,21 SETF2: MVI M,0 ;CLEAR REST OF FCB INX H DCR C JNZ SETF2 RET ; ; FLOATING POINT RAM ; HOLD1: DS DIGIT+1 HOLD2: DS DIGIT+1 HOLD3: DS DIGIT+1 HOLD4: DS DIGIT+1 HOLD5: DS DIGIT+1 HOLD6: DS DIGIT+1 HOLD7: DS DIGIT+1 HOLD8: DS DIGIT+1 DS 1 ERRI: DS 1 ;ERROR FLAG DS 1 BUF: DS DIGIT ;WORKING BUFFER SIGN: DS 1 ;SIGN BIT EXP: DS 1 ;EXPONENT RCTRL: DS 1 ;ROUNDING CONTROL FLAG 1=MSD RDIGI: DS 1 ;ROUNDING DIGIT SIGND EQU HOLD1+DIGIT EXPD EQU HOLD1+DIGIT+1 ; ; SYSTEM RAM ; LWID: DB 80 ;LINE WIDTH LIMIT WSIDN: DS 8 ;WORK-SPACE NAME FIELD WSIDT: DS 4 ;WORK-SPACE TYPE FIELD WSIDD: DB 'PROGRAM BSC' ;DEFAULT NAME AND TYPE EROM: DS 0 DS 100 CMNDSP: DB 0 MACSIZ EQU 34 MACSP: DW MACSTK DS MACSIZ-1 MACSTK: DB 0 ;DB TO PREVENT MACSTK=TRPSP TRPSIZ EQU 20 TRPSP: DW TRPSTK DS TRPSIZ-1 TRPSTK: DB 0 ;DB TO PREVENT TRPSTK=PHEAD PHEAD: DS 1 RELTYP: DS 1 NULLCT: DS 1 PFLAG: DB 0 ;I/O SWITCH- 1=PRINTER, 0=CONSOLE ARGF: DS 1 DIRF: DS 1 TXA: DS 2 CSTKSZ EQU 100 ASTKSZ EQU FPSIZ*LINLEN/2 CSTKL: DS CSTKSZ ASTKL: DS ASTKSZ RTXA: DS 2 STB: DS 2 CSTKA: DS 2 SINK: DS FPSIZ-1 FPSINK: DS 1 DS FPSIZ-1 FTEMP: DS 1 DS FPSIZ-1 FTEM1: DS 1 DS FPSIZ-1 FTEM2: DS 1 DS FPSIZ-1 FRAND: DS 1 IBCNT: DS 1 IBLN: DS 2 IBUF: DS LINLEN ASTKA: DS 2 MATA: DS 2 ADDS: DS 2 ADDT: DS 2 BCADD: DS 2 OPST: DS 1 OPSTR: DS 1 ECNT: DS 1 FSIGN: DS 1 BC: DS DIGIT+2 ABUF: DS DIGIT*2+2 XSIGN: DS 1 EXPO: DS 1 FES: DS 1 INFES: DS 1 MAXL: DS 2 INSA: DS 2 ; ; SPECIAL INTERFACE GLOBAL ; CALST: DS 6 CALLA: DS 2 EOFA: DS 2 ;END OF FILE ADDRESS BOFA: DS 2 ;START OF FILE ADDRESS MEMTOP: DS 2 ;STORAGE FOR LAST ASSIGNED MEMORY LOCATION ; ; END