; ; ; BAS80 - BASIC INTERPRETER FOR INTEL 8080 MICRO-PROCESSOR ; ; VERSION 1.2 3/07/78 CHANGES FROM IDAHO ; VERSION 1.3 4/20/78 CHANGES FROM IDAHO ; VERSION 1.4 5/09/78 CORRECT BUG IN 'CALLP' ; VERSION 1.5 5/25/78 CORRECT BUGS IN 'FORMT' ; 1. NEGATIVE NUMBERS NOT ROUNDED PROPERLY ; 2. SMALL NEGATIVE NUMBERS PRINTED AS POSITIVE ; ; WRITTEN AT THE UNIVERSITY OF IDAHO BY: ; JOHN W. DICKINSON, JOHN A. TEETER, AND KAREN VAN HOUTEN ; DEPT. OF ELECTRICAL ENGINEERING ; UNIVERSITY OF IDAHO ; MOSCOW, IDAHO ; ; GERALD R. BARBER ; DEPT. OF ELECTRICAL ENGINEERING AND COMPUTER SCIENCE ; MASSACHUSETTES INSTITUTE OF TECHNOLOGY ; CAMBRIDGE, MASSACHUTTES ; ; ; DEFINE ADDRESSES OF I/O,USER-SUBS, AND STACK POINTER TABLE STAACK EQU 800H USUB EQU 802H CMDIN EQU 804H MSGO EQU 807H PROGI EQU 80AH PROGO EQU 80DH PROM EQU 810H ; ; ; DEFINE ADDRESSES OF ACTIVE VARIABLES MEMST EQU 1000H ;MUST BE ON PAGE BOUNDARY LENST EQU 10 ;LENGTH OF STRINGS OBUFF EQU MEMST ;INPUT AND OUTPUT BUFFERS OCCUPY STLINE EQU MEMST+111Q ;FIRST LINE OF USER PROGRAM NLINE EQU MEMST+113Q ;POINTER TO NEW LINE OF USER TEXT NL2 EQU MEMST+115Q ;BINARY VALUE OF NEW LINE NUMBER NL4 EQU MEMST+117Q ;FORWARD POINTER OF NEW LINE NL6 EQU MEMST+121Q ;LENGTH OF NEW LINE KLINE EQU MEMST+122Q ;POINTER TO CURRENT LINE--LINE INSERTI KL2 EQU MEMST+124Q ;BINARY EQU. OF CURRENT LINE NUMBER KL4 EQU MEMST+126Q ;FORWARD POINTER OF CURRENT LINE KL6 EQU MEMST+130Q ;LENGTH OF NEW LINE PLINE EQU MEMST+131Q ;PREVIOUS LINE POINTER--LINE INSERTION PL2 EQU MEMST+133Q ;BINARY LINE NUMBER OF PREVIOUS LINE PL4 EQU MEMST+135Q ;FORWARD POINTER OF PREVIOUS LINE SBSAV EQU PL4 ;RETURN ADD. SAVE FOR CALL STMT. PL6 EQU MEMST+137Q ;LENGTH OF PREVIOUS LINE KASE EQU MEMST+140Q ;SPARE STORAGE USED AS NEEDED LEN EQU MEMST+141Q ;ALSO SPARE-OFTEN LENGTH VARIABLE MULT1 EQU MEMST+142Q ;FIRST OF TWO WORDS USED FOR MULT. MULT2 EQU MEMST+144Q ;SECOND WORD LPNT EQU KLINE ;SOURCE LINE PTR DURING EXEC. KLEN EQU KL6 ;SPARE-USED AS NEEDED CPNT EQU PL2 ;CHAR. PTR DURING EXEC. KFPNT EQU KL4 ;FWD LINE PTR DURING EXEC. FREG2 EQU MEMST+200Q ;FLOATING POINT REG. #2 CREG EQU MEMST+204Q ;TEMP. SPACE FOR ROUTINE 'INP' HLINP EQU MEMST+206Q ;TEMP. SPACE FOR ROUTINE 'INP' GREG EQU MEMST+167Q ;GENERAL PURPOSE REGISTER FREG1 EQU MEMST+174Q ;FLOATING PNT. REGISTER #1 SCR EQU MEMST+146Q ;SCRATCH AREA FOR I/O ROUTINES MODE EQU MEMST+205Q ;MODE FLAG FOR ROUTINE 'INP' 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 VTYPE EQU VARAD ;TEMP SPACE FOR EVAL TYPE SREG1 EQU BOTNS ;TEMP STORE FOR STRINGS SREG2 EQU SREG1+LENST+1 ;TEMP STORE FOR STRINGS IPVAR EQU SREG2+LENST+1 ;INPUT-PROCEED VAR ADDR IPVPT EQU IPVAR+2 ;INPUT-PROCEED VAR LIST ADDR IPVLN EQU IPVPT+2 ;INPUT-PROCEED VAR LIST LEN IOFLAG EQU IPVLN+1 ;THE I/O IN PROGRESS FLAG PPVAR EQU IOFLAG+1 ;PRINT-PROCEED VAR ADRR IBUF EQU PPVAR+2 ;INPUT BUFFER CPOS EQU IBUF+73 ;CURRENT POITION OF PRINT BUFF AM9511 EQU CPOS+1 ;AMD STACK FREG EQU AM9511+16 ;TEMP FOR POWER ROUTINE STSPAC EQU FREG+4 ;START OF SYM. TABLE NXTSP EQU NLINE ;POINTER TO NEXT AVAILABLE MEM. SPACE GRBFLG EQU STSPAC+2 ;GARB. COLL. FLAG 0=YES 1=NO EXPSGN EQU STSPAC+3 PWRTEN EQU STSPAC+4 SGNMANT EQU STSPAC+5 EXPVAL EQU STSPAC+6 DIGKNT EQU STSPAC+7 DECFLAG EQU STSPAC+8 VEND EQU STSPAC+9 ;DEF. END OF VAR. STORAGE AREA ORG 8000H JMP M1 JMP M1A JMP PROMR ; ; ; ; MAIN ROUTINE--HANDLES ALL USER INPUT ; ; M1: LXI H,OBUFF ;INITIALIXE THE OUTPUT BUFFER MVI M,1 ;TO HAVE LENGTH ONE. LXI H,0FFFFH ;ST STLINE TO -1, NO SOURCE SHLD STLINE SHLD STSPAC LXI H,VEND ;GET ADDRES OF FWA MEM. SHLD NLINE ;STORE IN FREE SPACE PNTR. M1A: LHLD STAACK ;SET STACK TO HEIGHT OF MEMORY SPHL LXI H,GRBFLG ;TURN GARB. COLL. FLAG ON MVI M,0 M2: LXI H,LPNT CALL NEG1 XRA A STA IOFLAG ;IOFLAG=NOTHING HAPPENING LXI H,ODAT1 CALL FORM ;PAD "READY" CALL WRIT M3: LHLD NLINE ;GET NEXT LINE FOR ACCEPTING NEW DATA MVI A,4 ;MOVE PAST POINTERS CALL DADHL CALL TTYIN ;GET INPUT LINE. CPI 0 ;WAS ANYTHING INPUT? JZ M3 ;NO--TRY AGAIN CALL PACK ;REMOVE THE BLANKS JC M4 ;LINE INPUT- GO INSERT IT INX H ;COMMAND OR KEYWRD. GET TOKEN MOV A,M RAL JC COMND ;A COMMAND--GO PROCESS RAR ;A KEY WORD--GO PROCESS JMP IMEDAT COMND: RAR CMA ;RE-ESTABLISH COMMAND TOKEN LXI H,M1A ;SET UP RETURN ADDR. PUSH H LXI H,CTABL ADD A CALL DADHL ;GET PROPER JUMP ADDR. MOV E,M INX H MOV D,M XCHG XRA A ;SET A=0 FOR LIST CMMD PCHL ; ; M4: CALL INSERT ;GO INSERT THE LINE JMP M3 ;GO GET NEXT LINE ; IMEDAT: DCX H ;POINT TO FIRST LENGTH PUSH H MOV A,M INX H CALL DADHL SHLD NLINE SHLD NXTSP ;UPDATE SYM. TAB POINTER POP H MVI D,0FFH ;SET -1 IN DE MOV E,D CALL IMMED ;GO EXECUTE IMMEDIATE JMP M2 ; CTABL: DW RUN DW TAPE DW LIST DW M1 DW PTAPE DW UGARB ; ; ; ROUTINE TO INPUT FROM HSR ; THIS CONDITION IS DEFAULT NOW ; PTAPE: LHLD NLINE MVI A,4 CALL DADHL PT1: CALL CHAR5 ;GET CHAR. FROM READER CPI 0 ;IS IT LEADER? JZ PT1 ;YEP -- WAIT FOR GOOD INFO PT2: CALL HSRIN ;GOT CHAR. MOV C,A CPI 0 ;IS CHAR COUNT = 0? JZ PT1 ;YEP-- KEEP WAITING MOV M,B ; STORE LENGTH OF STATEMENT CALL PACK ;GO PACK LINE AND DECIPHER RNC ;NOT SOURCE LINE. GO TO READY CALL INSERT ;NOPE--SO GO INSERT IT PT3: CALL CHAR5 ;GET NEXT CHAR. CPI 0AH ;LINE-FEED? JZ PT3 ;IGNORE CPI 0 ;IS IT LEADER? RZ PUSH PSW ;SAVE CHAR LHLD NLINE MVI A,4 ;MOVE PAST POINTERS OF NEXT LINE CALL DADHL POP PSW JMP PT2 ;LOOP ON PROCESS ; ; ROUTINE TO HANDLE ALL SOURCE LINE INPUT. ; THIS INCLUDES INSERTION, DELEATION, AND ; ADDITION OF NEW SOURCE LINES. ; INSERT: LXI H,NLINE CALL PTVAL ;FIND THE POINTER VALUES LHLD STLINE ;GET START OF SOURCE CALL CHK1 ;CHECK FOR NO TEXT JNC ISRT3 ;THERE IS SOMETHING-START SERCH LHLD NLINE ;THIS IS FIRST LINE SHLD STLINE ;MOVE NLINE TO STLINE ISRT1: MVI D,377Q ;SET UP -1 FOR END OF LIST MOV E,D CALL STPNT ;STORE IT AWAY IN POINTERS INX H ISRT2: MOV A,M ;GETLINE LENGTH ADI 5 ;ADJUST TO LEN+5 LHLD NLINE ADD L MOV L,A MVI A,0 ADC H MOV H,A SHLD NLINE ;STEP PAST NEW LINE SHLD NXTSP ;UPDATE SYB. TAB PNTR. RET ISRT3: SHLD KLINE ;SET UP CURRENT LINE ISRT4: LXI H,KLINE ;GET CURRENT LINE AND CALL PTVAL ;SET UP POINTERS LXI H,NL2 ;GET BINARY VALUE MOV D,M ;OF NEW LINE INX H MOV E,M LXI H,KL2 ;GET CURRENT LINE BINARY MOV B,M INX H MOV C,M CALL DCOMP ;HOW DO THEY COMPARE? JZ ISRT6 ;REPLACE/DELETE JC ISR12 ;KLINE>NLINE LHLD KL4 ;MOVE ON TO NEXT LINE CALL CHK1 ;ARE WE DONE? JC ISRT5 PUSH H LHLD KLINE SHLD PLINE ;SET UP PREVIOUS LINE LXI H,PLINE CALL PTVAL ;SET POINTERS POP H SHLD KLINE ;SET UP CURRENT LINE JMP ISRT4 ;LOOP ON PROCESS ISRT5: LHLD NLINE ;GET NLINE ADDRESS CALL NOLINE ;IS IT 0 LEN. LINE? RZ ;YES-DO NOTHING XCHG LHLD KLINE ;GET CURRENT LINE CALL STPNT ;STORE AWAY POINTERS XCHG JMP ISRT1 ;GO SET END OF LIST ISRT6: LHLD KLINE ;GET MATCHED ADDR. CALL SBIT8 ;SET DELETION BIT LHLD NLINE ;DO DELETE OR REPLACE CALL NOLINE ;NOLINE MEANS DELETE JNZ ISRT8 ;GO REPLACE IF NOT 0 LHLD STLINE ;GET STLINE XCHG LHLD KLINE ;IF STLINE=KLINE THEN LIST PUSH H ;NOW ZERO POP B CALL DCOMP LHLD KL4 JZ ISRT7 ;IF NOT STLINE THEN GO DELETE XCHG LHLD PLINE CALL STPNT RET ISRT7: SHLD STLINE RET ISRT8: LHLD KL4 ;REPLACE LINE XCHG LHLD NLINE CALL STPNT ISRT9: LHLD KLINE XCHG LHLD STLINE PUSH H POP B CALL DCOMP JZ ISR11 ;IF KLINE =STLINE GOTO ISR11 LHLD NLINE XCHG LHLD PLINE CALL STPNT ;PREVIOUS LINE PNTS. TO NLINE ISR10: LXI H,NL6 ;SET UP NEW LINE TO JMP ISRT2 ;POINT TO M(KL4) ISR11: LHLD NLINE ;NLINE=STLINE SHLD STLINE JMP ISR10 ISR12: LHLD KLINE ;NLINE IN FRONT OF KLINE XCHG LHLD NLINE CALL NOLINE RZ CALL STPNT JMP ISRT9 ; ; ; ROUTINE SBIT8 SETS THE EIGTH BIT OF BYTE 2 TO INDICATE THE ; LINE HAS BEEN DELETED. SBIT8: PUSH H INX H MVI A,0FFH MOV M,A POP H RET ; ; ; ROUTINE NEG1 IS USED TO SET HL _ -1, HL+1 _ -1 . ; THAT IS TO TERMINATE THE SOURCE LISTS. NEG1: MVI A,0FFH MOV M,A INX H MOV M,A RET ; ; ; ROUTINE TO STORE POINTERS INTO MEM ARRAY ; HL CONTAIN ADDR. OF FIRST WORD OF ENTRY. ; THE CORESPONDING ELEMENTS (HL2,HL4,HL6) CONTAIN ; THE NEW ENTRIES. STPNT: INX H INX H MOV M,E ;MOVE HL2/NL2/PL2 INTO MEM'HL) INX H MOV M,D RET ; ; ROUTINE TO CHECK NEW LINE FOR SOURCE STMT. NOLINE: PUSH H MVI A,4 ;MOVE PAST POINTERS CALL DADHL MOV A,M ;GET LENGTH OF LINE IN A CPI 0 ;IS ANYTHING THERE? POP H RET ; ; ; ROUTINE TO RESPOND WITH 'WHAT?' FOR UNIDENTIFIED COMMAND. WHAT: LXI H,ODAT5 ;GET OUTPUT BUFFER ADDR. CALL FORM ;PAD IT CALL WRIT ;DUMP IT JMP M1A ;JUMP TO RESTART. ; ; ROUTINE TO PUNCH PAPER TAPE OF SOURCE. ; CALLED IN RESPONSE TO TAPE COMMAND TAPE: PUSH PSW PUSH B LXI H,ODAT2 ;GET OUTPUT BUFFER ADDR. CALL FORM ;PAD IN TURN ON PUNCH CALL WRIT ;DUMP IT MVI A,0 ;SET UP TO CUMP LEADER POP B MVI B,100Q PUSH PSW PUSH B CALL PAD ;PAD 100 0'S CALL PWRIT POP B PUSH B MVI A,1 ;TO INDICATE PUNCH OUTPUT CALL LIST ;GO DO STANDARD LIST POP B POP PSW CALL PAD ;GO PAD AND DUMP TRAILER. CALL PWRIT POP PSW RET ; ; ROUTINE TO LIST TO TTY THE SOURCE STMTS. ; ALSO USED TO DUMP TAPE. ; ALLOWS THE USER TO INPUT FIRST LINE OR ; OR FIRST AND LAST LINES. ; A=0 MEANS LIST TO TTY, A=1 MEANS PUNCH OUTPUT LIST: PUSH PSW ;SAVE DESTINATION FLAG LHLD STLINE CALL CHK1 ;CHECK FOR NO SOURCE JC M1A ;GO RESTART SHLD PLINE ;SET UP TO START LOOKING FOR FIRST LIN LXI H,0FFFFH SHLD KLINE LHLD NLINE ;CHECK FOR LINE LENGTH MVI A,4 CALL DADHL MOV C,M INR C CALL BUMP ;MOVE TO START OF NUMBER CNZ BOUND ;GO FIND FIRST LINE LHLD PLINE ;STORE IT AWAY LIS1: CALL DNUMB ;CALL FLOATING POINTS ROUTINES INX H MOV C,M INX H ;GET FORWARD PTR IN REG BC MOV B,M PUSH B ;SAVE FPTR INX H MOV C,M INX H MOV A,M ;GET FIRST CHARACTER RAL ;CHECK FOR IMBEDDED BLANKS JNC LIS2 RAR CMA ;SET FOR POSSITIVE # OF BLANKS MOV B,A ;GET READY TO PAD MVI A,' ' CALL PAD ;PAD THE BLANKS DCR C INX H ;MOVE TO NEXT CHARACTER-KEY TOKEN LIS2: MOV A,M ;GET KEYWORD TOKEN PUSH H PUSH B LXI H,KPAD ;GET ADDR. OF KW STRINGS ADD A ;MULT. BY 2 CALL DADHL ;POINT TO RIGHT ONE MOV E,M ;GET LOW ADDR INX H MOV D,M ;GET HIGH ADDR XCHG MOV C,M ;GET STRING LENGTH INX H CALL FORM6 ;PADD IT POP B POP H INX H DCR C ;CHECK FOR END OF LINE JZ LIS4 CALL FORM6 ;PADD REST OF LINE LIS4: POP B ;GET FPTR POP PSW ;GET DESTINATION FLAG PUSH PSW ORA A ;TEST IF LIST OR PUNCH JNZ LISP ;GO PUNCH CALL WRIT ;GO DUMP LINE LIS5: LHLD KLINE ;CHECK FOR LAST LINE XCHG POP H CALL DCOMP RZ PUSH H PUSH B POP H CALL QUITT ;CHECK FOR INTERRUPTION JMP LIS1 ;NONE - CONTINUE LISP: CALL PWRIT ;PUNCH IT JMP LIS5 ; BOUND: PUSH H CALL NUMB ;SEE IF THERE IS A NUMBER THERE JNC WHAT ;IT IS NOT CALL CVB ;CONVERT NUMBER TO BINARY PUSH PSW PUSH B CALL BND2 ;GO FIND FIRST LINE POP B DCX H SHLD PLINE ;STORE IT WAY AS FIRST LINE POP PSW POP H CALL DADHL MVI A,0 CMP C ;IS THAT END OF LINE? RZ CALL BUMP CALL NUMB ;IS NEXT CHAR NUMB? JNC WHAT ;NOT NUMBER --WHATS UP PUSH D CALL CVB ;CONVERT TO BINARY PUSH D PUSH B CALL BND2 ;GO FIND SECOND BOUND POP B INX H MOV E,M INX H MOV D,M ;SETUP TO STORE IT IN KLINE XCHG SHLD KLINE POP D POP H MOV A,C CPI 0 ;ARE WE AT END OF LINE JNZ WHAT MOV B,H MOV C,L CALL DCOMP RNC JMP WHAT BND2: LHLD STLINE ;SET UP TO SEARCH FROM FROUNT BND3: MOV B,M INX H MOV C,M CALL DCOMP ;COMPARE BINARY OF REQUESTED LINE RC ;TO CURRENT LINE RZ PUSH H INX H MOV A,M INX H MOV H,M MOV L,A ;MOVE TO NEXT LINE CALL CHK1 ;IS THAT ALL? POP B JNC BND3 ;NOPE--LOOP ON PROCESS PUSH B POP H RET ; ; WRITES TO PUNCH OUTPUT DEVICE PWRIT: PUSH B LXI H,OBUFF PUSH H ;SAVE TO INITIALIZE LEN AT END MOV C,M ;GET LENGTH DCR C ;IS BUFF EMTPY JZ PW2 INX H PW1: MOV A,M ;GET CHAR CALL PUNCH INX H ;MOVE TO NEXT CHAR DCR C ;DONE? JNZ PW1 ;NOT YET MVI A,15Q ;;CR CALL PUNCH MVI A,12Q ;LF CALL PUNCH PW2: POP H MVI M,1 ;LENGTH OF OBUFF POP B RET ; ; ; THE FOLLOWING TABLE IS USED TO PAD THE STRINGS FOR THE KEYWORDS ; DURING THE LISTING PROCESS. THE KEYWORD STRINGS ARE LOCATED IN ; THE ROUTINE SYMSRT. KPAD: DW KDAT2 DW T3 DW T4 DW T5 DW T6 DW T7 DW T8 DW T9 DW T10 DW T11 DW T12 DW T13 DW T14 DW T15 ; ; ROUTINES NUMB AND ALPHA CHECK IF CONTENTS OF MEMORY ; LOCATION IN HL CONTAIN ASCII NUMERIC OR ALPHBETIC ; CHARACTER. RETURN CY=1 IF YES, CY=0 IF NO. NUMB: PUSH B MVI B,'0' ;SET UP ASCII 0 MVI C,':' ;CHAR AFTER 9 C1: MOV A,M CMP B CMC JNC BAC CMP C BAC: POP B RET ALPHA: PUSH B MVI B,'A' ;SET UP ASCII A MVI C,5BH ;CHAR AFTER Z JMP C1 ; ; ROUTINE TO CONVERT ASCII NUMERIC CHAR. STRING TO ; EQUIVALENT BINARY NUMBER. RETURNS EQUIVALENT IN ; DE REG. LENGTH OF LINE PASSED IN REG C AND ; RETURNED POINTING TO LAST NUMERIC CHAR. LENGTH ; OF CHAR STRING RETURNED IN REG A. CVB: PUSH H PUSH B CALL LENGTH ;GET LENGTH OF STRING PUSH PSW PUSH H CPI 0 ;IS LENGTH=0? JZ CVB2 ;YEP--GO TO CVB2 LXI H,KASE ;SET UP TEMP VAR KASE MOV M,A ;SAVE LENGTH IN KASE INX H ;SET UP TO MULT. BY MOV M,C ;DEC 10 LXI H,10 SHLD MULT1 LXI H,0 SHLD MULT2 LXI H,MULT2+1 CVB1: CALL MULT XTHL MOV A,M ;GET NEXT CHAR. SBI '0' ;STRIP ASCII ADD D ;THE CONVERSION ALGORITHM GOES: MOV D,A MVI A,0 ;DE_0 ADC E ;DO WHILE A>0 MOV E,A ;DE_(HL(M)-260B)+DE*10: CALL BUMP ;END: XTHL MOV M,D INX H MOV M,E PUSH H LXI H,LEN DCR M DCX H DCR M POP H JNZ CVB1 CVB2: POP H ;THE PROCESS IS COMPLETE, POP PSW ;RESULT IN DE POP B LXI H,LEN MOV C,M POP H RET ; ; ROUTINE TO EVALUATE LENGTH OF ASCII NUMERIC ; CHAR STRING: PASSED ADD OF FIRST CHAR IN HL REG. ; RETURNS LENGTH IN REG A. LENGTH: PUSH B ;SAVE REGISTERS PUSH H MVI B,0 ;INITIALIZE REG B NLE1: CALL NUMB ;IS HL(M) AN ASCII NUMBER? JNC NLE2 ;NO DONE- REG B CONTAINS LEN INR B CALL BUMP ;CHECK FOR END OF LINE JZ NLE2 JMP NLE1 ;LOOP ON PROCESS NLE2: MOV A,B ;MOVE LENGTH INTO A POP H POP B RET ; ; ROUTINE TO LOCATE SOURCE LINE IN MEM. PASSED BIN VALUE ; OF LINE NUMBER IN DE(LOW,HIGH) REG. RETURNS ADDRESS OF ; SOURCE LINE IN HL REGS.(HIGH,LOW). CY SET=> NOT FOUND. NSRCH: LHLD STLINE ;GET FIRST LINE CALL CHK1 ;ANY SOURCE? RC ;NO--RETURN SRCH1: PUSH H ;SAVE LINE ADDR. MOV B,M INX H MOV C,M ;GET LINE BIN. IN BC POP H CALL DCOMP ;COMPARE THEM RC RZ PUSH H MVI A,2 ;FOLLOW THE POINTER CALL DADHL MOV C,M INX H MOV B,M PUSH B POP H POP B CALL CHK1 ;CHECK FOR END OF LIST JNC SRCH1 RET ;YES--DONE ; ; ROUTINE TO COMPARE CONTENTS OF HL TO 0FFFFH . ; RETURNS CY=1 IF YES: CY=0 IF NO. CHK1: PUSH B ;SAVE REGISTERS PUSH H MVI B,0 ;MOVE 1 INTO BC MVI C,1 DAD B ;DOUBLE ADD TO SET STATUS POP H POP B RET ; ; ; ROUTINE TO PAD OUTPUT BUFFER WITH CONTENTS OF REG A. ; REG B CONTAINS NUMBER OF CHAR TO PAD. PAD: PUSH B ;SAVE REGISTERS PUSH D PUSH H LXI H,OBUFF ;GET OBUFF ADDRESS MOV C,L ;POINT TO PROPER ENTRY MOV L,M MOV D,A MOV A,B ;TEST FOR 0 OR NEG PADS ORA A JZ P3 JM P3 P1: MVI A,73 ;CHECK FOR LINE LENGTH CMP L JNZ P2 ;ROOM LEFT--GO FILL MOV L,C ;OBUFF IS FULL- AUTO PRINT MOV M,A LDA IOFLAG ;TURN OFF I/O PROCEEDS PUSH PSW ;SAVING IOFLAG XRA A STA IOFLAG PUSH D ;SAVE CHAR CALL WRIT POP D POP PSW ;RESTORE IOFLAG STA IOFLAG LXI H,OBUFF INR L ;RE-INITIALIZE L P2: MOV A,D ; PUT CHAR IN A CPI 13H JNZ P2A ; TEST IF COLON SUBST CHAR MVI A,':' P2A: MOV M,A ; STORE CHAR IN BUFFER INR L DCR B ;DECREMENT NUMB. CHAR. TO PAD JNZ P1 ;GO TO P1 IF ANY LEFT MOV B,L MOV L,C MOV M,B P3: MOV A,D POP H POP D POP B RET ; ; ROUTINE TO LOCATE COMMANDS, KEY WORDS, OPERATORS, ; AND FUNCTIONS. HL CONTAINS ADD OF FIRST CHAR.: ; REG C CONTAINS LENGTH OF LINE: RETURNS SYMBOL NUMBER ; IF FOUND IN REG A, 0FFH IN A IF NOT FOUND. ; ON ENTRY REG. A CONTAINS TYPE OF ENTRY SOUGHT: ; 0 FOR COMMAND ; 1 FOR KEYWORD ; 2 FOR OPERATOR AND DELIMITER ; 3 FOR FUNCTION SYMSRT: PUSH D PUSH B PUSH H PUSH H LXI H,KDATA ADD A ;DOUBLE FOR FIRST CHAR. CALL DADHL ;ADD TO ADDR. LIST MOV E,M INX H MOV D,M XCHG MVI E,0 MOV D,M S3: INX H ;LEN IN D AND BUMP L MOV B,M ;FIRST CHAR. IN B XTHL ;FIRST CHAR OF USER STRING IN A S3A: MOV A,M ;AND COMPARE CPI ' ' ;IGNORE BLANKS JNZ S3B ;NOT BLANK--CONTINUE CALL BUMP ;DCR. LINE LENGTH JZ S4 ;TERMINATE THIS SERCH JMP S3A S3B: CMP B JNZ S4 ;NO MATCH-TRY AGAIN DCR D ;SET UP FOR NEXT CHAR JZ S5 ;IF DONE EXIT CALL BUMP ;DECREMENT LINE LENGTH JZ S4A ;IF 0 THEN MOVE ON XTHL JMP S3 S4A: INR D S4: POP H ;GET ADDR. OF TABLE MOV A,D CALL DADHL ;A+HL, NEW L IS ALSO IN A MOV D,H POP H POP B ;RESTORE C, HL PUSH B PUSH H PUSH H MOV L,A ;RESTORE HL PTR TO SYM TAB MOV H,D MOV A,M INR E MOV D,A INR A JNZ S3 POP H CALL UNBUMP PUSH H MVI E,0FFH ;E=-1 IF NO MATCH S5: MOV A,E ;MOVE SYMBOL NUMBER INTO REG A CALL BUMP MOV E,C ;SAVE C COUNT IN E POP B POP B POP B MOV C,E ;MOVE NUMBER OF CHAR. LEFT IN LINE INTO C POP D RET ; ; KDATA: DW KDAT1 DW KDAT2 DW KDAT3 DW KDAT4 KDAT1: DB 3,'RUN' DB 5,'PLIST' DB 4,'LIST' DB 3,'SCR' DB 5,'PTAPE' DB 4,'FREE' DB 0FFH KDAT2: DB 3,'LET',1,'L' T3: DB 5,'PRINT',1,'P' T4: DB 6,'RETURN',2,'RT' T5: DB 4,'STOP',1,'S' T6: DB 3,'END',1,'E' T7: DB 2,'IF',2,'IF' T8: DB 5,'INPUT',1,'I' T9: DB 3,'DIM',1,'D' T10: DB 4,'CALL',1,'C' T11: DB 5,'GOSUB',2,'GS' T12: DB 4,'GOTO',1,'G' T13: DB 3,'REM',1,'R' T14: DB 3,'FOR',1,'F' T15: DB 4,'NEXT',1,'N' DB 0FFH ; ;DELIMITERS HAVE FOLLOWING VALUES: ; ; < 0 ; > 1 ; , 2 ; = 3 ; ) 4 ; ; 5 ; THEN 6 ; TO 7 ; STEP 8 ; * 9 ; / 10 ; + 11 ; - 12 ; AS 13 ; ? 14 (UP ARROW) ; [ 15 (RIGHT OR CLOSING SQUARE BRACKET) ; KDAT3: DB 1,'<',1,'>' DB 1,',',1,'=' DB 1,')' DB 1,';' DB 4,'THEN' DB 2,'TO' DB 4,'STEP' DB 1,'*' DB 1,'/',1,'+' DB 1,'-' DB 2,'AS',1,5EH ;5E IS UP ARROW DB 1,5DH ;5D IS RIGHT BRACKET DB 0FFH ; ; KDAT4: DB 3,'GET' DB 3,'PUT' DB 3,'ABS' DB 3,'SQR' DB 3,'SIN' DB 3,'COS' DB 3,'TAN' DB 3,'ASN' DB 3,'ACN' DB 3,'ATN' DB 3,'EXP' DB 2,'LN' DB 3,'INT' DB 3,'LOG' DB 3,'RND' DB 0FFH ; ; ; THE ROUTINE PACK ENCODES ALL BLANKS IN THE LINE EXCEPT THOSE ; IN QUOTES. IF THE LINE CONTAINS A COMMAND OR AN IMMEDIATE ; KEYWORD, THEN THERE WILL BE NO RETURN. I.E. RETURNS ONLY FOR ; SOURCE LINE INSERTION. THE ROUTINE IS ACCESSED FROM TTYIN AND ; PTAPE(HRSIN). FOR COMMAND-KEYWORD RETURN, SEE PK100. ; ; ROUTINE TO REMOVE BLANKS FROM SOURCE UNLESS ENCLOSED IN "'S PACK: INX H PUSH H LHLD NLINE ;SET BIN. WORD 2 TO -1 INX H MVI M,0FFH POP H PUSH H PK1: MOV A,M ;CHECK FIRST CHARACTER CPI ' ' ;IS IT BLANK? JNZ PK2 ;NOPE--CONTINUE DCR B ;TEST FOR END OF LINE JZ M3 INX H ;YEP--DELETE IT JMP PK1 ;CONTINUE PK2: MOV C,B ;SET LINE LENGTH IN C MVI B,0 ;INIT. CHARS STORED. CALL NUMB ;TEST FOR LINE NUMBER SHLD PLINE ;SAVE CURRENT HL POP H ;GET ENTRY HL PUSH H PUSH PSW ;SAVE CARRY BIT. PUSH H PUSH H LHLD PLINE ;RESTORE CURRENT HL. JNC PK4 ;NOT NUMBER--COMMAND/KEYWORD CALL CVB ;COVERT LINE # TO BINARY PUSH PSW CPI 5 ;TEST FOR VALID LINE # JC PK3 ;GOOD--CONTINUE CNZ WHAT ;ASK FOR NEW # MOV A,E RAL ;TES FOR OVERSIZED # CC WHAT ;ASK FOR NEW # PK3: POP PSW ;RETRIEVE STRING LENGTH PUSH H ;SAVE CURRENT HL. LHLD NLINE ;GET ADDDR OF NLINE POINTER MOV M,D ;SAVE LOW BINARY INX H ;BUMP IT MOV M,E ;SAVE HIGH BINARY POP H ;RETREIVE ADDR. JZ PK6 ;NO MORE SOURCE--END IT. CALL DADHL CALL CBLNK ;REVOVE ANY BLANKS JZ PK4A XTHL ;SET TO STORE ENCODED BLANKS MOV M,A INX H INR B ;INCREMENT STORED COUNT XTHL JMP PK4A PK4: MVI A,0 ;SET UP TO LOCATE COMMAND TOKEN CALL SYMSRT CMA CPI 0 ;WAS IT FOUND? JNZ PK4B ;YES--GO SAVE IT PK4A: MVI A,1 ;SEARCH FOR KEY WORD CALL SYMSRT CPI 0FFH JZ WHAT ;NOT FOUND--REPORT IT ORA A ;CLEAR CARRY RAR ;DIVIDE BY TWO PK4B: XTHL ;STORE TOKEN WAY MOV M,A INX H INR B MOV A,C ;TEST FO NO MORE SOURCE CPI 0 JZ PK6 XTHL MVI E,'"' ;INIT E FOR COMPARES MVI D,0 ;D=1=>WITHIN QUOTES, LEAVE BLANKS PK5: XRA A ;CLEAR A CMP D ;CHECK INPUT MODE MOV A,M ;GET CHAR JNZ QSTR0 ;WITHIN QUOTE STRING CMP E ;IS TI FIRST " JNZ QSTR2 ;NOPE -- CONTINUE PROCESSING INR D ;YEP-- SET FLAG JMP QSTR3 ;STORE IT AWAY QSTR0: CPI ':' ; LOOK FOR COLONS JNZ QSTR1 MVI A,13H ; USE CONTROL-S FOR SUBST CHAR JMP QSTR3 QSTR1: CMP E ;TEST FOR SECOND " JNZ QSTR2 ;STORE VERBATUM DCR D ;CLEAR FLAG JMP QSTR3 ;STORE IT AWAY QSTR2: CPI ' ' ;IS IT A BLANK JNZ QSTR3 CALL CBLNK ;GO COMPRESS IT DCX H ;MOVE POINTER BACK INR C ;INCR. # CHAR. LEFT QSTR3: XTHL MOV M,A ;SAVE CHAR. INX H ;BUMP SAVE ADDR. XTHL INR B ;BUMP LINE LENGTH INX H ;POINT TO NEXT CHAR. DCR C ;DECREMENT # CHAR. LEFT JNZ PK5 ;LOOP ON PROCESS PK6: POP H POP H POP PSW POP H ;GET ADDR OF FIRST SOURCE CHAR. DCX H MOV M,B ;STORE LENGTH RET ;GO INSERT THE LINE. ; ; ; CBLNK-- ROUTINE TO TEST SOURCE LINE FOR BLANK STRINGS. PASSED ; ADDRESS OF FIRST CHAR. TO TEST IN HL. # CHAR. LEFT IN PENDING LINE IN ; REG. C. RETURNS WHITH HL POINTING TO FIRST CHAR. BEYOND THE ; STRING AND REG C CONTAINING THE # OF CHARACTERS LEFT IN THE ; LINE SANS BLANKS IN STRING. ; REG A WILL CONTAIN 0 IF NO BLANKS, OR COMPLEMENT OF THE NUMBER ; OF BLANKS FOUND. CBLNK: PUSH D MVI D,0 ;INITIATE THE COUNT CBLK1: MOV A,M ;GET CHAR. CPI ' ' ;BLANK? JNZ CBLK2 ;NOPE-- GO END INR D ;BUMP COUNT INX H DCR C ;DCR. # CHAR LEFT JZ LEND ;SPECIAL RETURN. SOURCE LINE GONE. JMP CBLK1 ;LOOP ON PROCESS CBLK2: MOV A,D CPI 0 ;ANY BLANKS? JZ CBLRT CMA ;COMPLEMENT # OF BLANKS CBLRT: POP D RET LEND: POP D ;ABNORMAL RETURN. LINE ENDED POP H ;BUMP RETURN ADDR. JMP PK6 ;GO TERMINATE SOURCE INPUT. ; ; ; DADHL-- ROUTINE TO ACCOMPLISH DOUBLE ADD OF HL WITH REG ; A USING CARRY. DADHL: ADD L MOV L,A RNC INR H RET ; ; FORM: MOV C,M ;MOVE LENGTH INTO C MOV A,C ;AND STORE IN A CPI 0 ;IS IT 0? RZ F1: INX H ;INCREMENT TO GET FIRST CHAR. FORM6: MOV A,M ;THE PAD LOOP RAL ;CHECK FOR IMBEDDED BLANKS JNC F2 RAR CMA ;CONVERT TO + # OF BLANKS MOV B,A MVI A,' ' CALL PAD DCR C RZ INX H ;POINT TO NEXT WORD F2: MOV A,M MVI B,1 CALL PAD DCR C JNZ F1 RET ; ;***************************************************** ODAT1: DB 7,15Q,12Q,'READY' ODAT2: DB 13,'TURN ON PUNCH' ODAT3: DB 8,15Q,12Q,'ERROR ' ODAT5: DB 5,'WHAT?' ODAT6: DB 10,'MEM FULL',15Q,12Q ODA18: DB 6,'GARB',15Q,12Q ODA20: DB 11,' WORDS FREE' ; ;************************************************************** ; ; ROUTINE TO INSURE SOURCE DOES NOT OVERFLOW MEM SPACE ; COMPARES CURENT MEM ADDRESS TO SP. MEMFUL: PUSH B ;SAVE REG B,D,H PUSH D PUSH H MVI A,50 ;SET FOR 50 BYTE BUFFER CALL DADHL PUSH H ;MOVE HL+50 TO B REG POP B LXI H,0 ;GET CURRENT STACK DAD SP XCHG ;SET UP FOR COMPARE CALL XCOMP POP H POP D POP B RNC ;ALL OK CONTINUE LXI H,ODAT6 CALL FORM CALL WRIT UGARB: CALL GARB ;PACK IT WAY LXI H,ODA18 CALL FORM CALL WRIT LHLD NLINE XCHG ;FIND NUMBER OF FREE WORDS LHLD STAACK MOV A,L SUB E MOV L,A MOV A,H SBB D XCHG MOV M,E ;PUT IT IN MEM. INX H MOV M,A DCX H CALL DNUMB ;PAD IT LXI H,ODA20 CALL FORM CALL WRIT JMP M1A ;START OALL OVER AGAIN ; ; ; THE GARBAGE COLLECTION ROUTINE -- USED ONLY WHEN NECESARY ; AND THEN ONLY BY THE BRAVE. GARB: LHLD STLINE ;CHECK FOR ANY THING IN MEM. CALL CHK1 JC GARBR ;NO SOURCE--RETURN LXI H,0FFFFH ;SET UP TO COUNT # OF LINES SHLD KASE ;SAVED LXI H,VEND ;GET FWAM SHLD KLINE ;INITIALIZE SAVE ADDR. GARB1: SHLD PLINE ;GET ADDR. INX H ;POINT TO SECOND BYTE OF MOV A,M ;BINARY LINE # RAL ;CY=1 IF LINE DELETED PUSH PSW ;SAVE CARRY MVI A,3 ;MOVE TOLINE LENGTH CALL DADHL POP PSW MOV A,M ;GET LINE LENGTH CNC SAVE ;SAVE IF NOT DELETED CALL DADHL ;MOVE PAST LINE INX H CALL FSTAB ;CHECK FOR SYM. TAB. OR END JC GARB1 ;CY=0 THEN CONTINUE CALL IPNTS ;GO SET ALL THE POINTERS GARB2: LXI H,0FFFFH ;INITIALIZE STSPAC SHLD STSPAC RET ;DONE!!?!!?!!? GARBR: LXI H,VEND SHLD NLINE JMP GARB2 ; ; ; ROUTINE SAVE TO MOVE LINES INTO PACKED STORAGE. SAVE: PUSH PSW PUSH H LHLD KASE INX H SHLD KASE ;INCREMENT # LINES SAVED LHLD KLINE ;GET SAVE ADDR. PUSH H LHLD PLINE ;GET 'GET' ADDR. POP B ;CHECK IF MOVEMENT NEXX. PUSH PSW ;SAVE REG A XCHG CALL XCOMP XCHG JZ NCHG POP PSW PUSH B ADI 5 ;ADD 5 TO LENGTH TO INCLUDE POINTERS MOV B,A SAVE1: MOV A,M ;GET FIRST BYTE XTHL ;SAVE IT AWAY MOV M,A INX H ;BUMP SAVE ADDR. DCR B ;DCR LINE LENGTH JZ SAVER ;DONE--ADJUST KLINE--RET XTHL INX H ;BUMP 'GET' ADDR. JMP SAVE1 SAVER: SHLD KLINE ;SET NEW SAVE ADDR. POP H POP H POP PSW RET ;DONE. ; NCHG: MVI A,4 CALL DADHL MOV A,M INX H CALL DADHL ;POINT PAST CURR. LINE JMP SAVER ; ; ; ROUTINE IPNTS PREFORMS ALL OF THE POINTER ADJUSTMENT ; OF THE PACKED SOURCE BY SIMPLY INSERTING THE LINES ; ONE AT A TIME AS IF THEY WERE ENTERED EXTERNALLY. IPNTS: LHLD KASE ;GET NUMBER OF LINES LEFT MOV B,H MOV C,L LXI H,VEND ;INITIALIZE NLINE SHLD NLINE LXI H,0FFFFH ;SET STLINE TO NO SOURCE SHLD STLINE PUSH B POP H IPNT1: PUSH H CALL INSERT ;GO INSERT LINE POP H DCX H CALL CHK1 JNC IPNT1 RET ;DONE. ; ; ; ROUTINE FSTAB CHECKS FOR: ; A) BEGINNING OF SYMBOL TABLE. IF THIS OCCURES THEN THE ; VALUE OF PLINE ( 'GET' ADDR.) IS RETURNED POINTING TO THE ; NEXT SOURCE LINE. THAT IS IT BYPASSES THE BLOCK OF ; SYMBOL TABLE. IF THE LAST BLOCK OF SYM TAB IS ENCOUNTERED, ; THEN CY IS SET TO 1 TO INDICATE COMPLETION. ; B) CHECKS FOR PLINE = NLINE.INDICATES THAT THERE IS NO ; SYMBOL TABLE AND WE ARE DONE.CY SET TO 1 ; C) IF NONE OF THE ABOVE.THE RETURN IS WITH CY=0 AND ; ALL ELSE UNCHANGED FSTAB: SHLD PLINE ;SAVE CURRENT PLINE PUSH H POP B LHLD NLINE XCHG ;PLINE=NLINE CALL XCOMP RZ ;IF EQUAL THEN DONE LHLD STSPAC XCHG ;STSPAC=PLINE CALL XCOMP CZ PTABL LHLD NLINE XCHG CALL XCOMP RZ ;PROCESS COMPLETE LHLD PLINE STC ;SET CARRY TO CONTINUE RET ; ; ; ROUTINE PTABLE PACKS THE SYMBOL TABLE REMOVING IT FROM ; THE SOURCE AND MEMORY.THE ROUINE IS ENTERED WITH ; HL POINTING TO THE FIRST ENTRY OF A SYM TAB BLOCK AND RETURNS ; WITH STSPAC UPDATED TO POINT TO THE NEXT BLOCK ( OR -1) AND ; PLINE POINTING TO THE NEXT SOURCE BLOCK. PTABL: PUSH B POP H PUSH H MVI A,2 ;MOVE TO FRD. PNTER. CALL DADHL MOV C,M ;SAVE IN BC. INX H MOV B,M POP H ;MMOVE HL BACK TO FIRST MOV A,M ORA A JZ ARRP ;GO PACK ARRAY INX H ; SO COUNTS COME OUT RIGHT CPI '$' ; LOOK FOR TEM VAR FOR CALL JZ STRGP CPI '%' JZ VARRP DCX H ; SO ALPHA WORKS RIGHT CALL ALPHA ;IF NOT A LETTER JNC STPRP ;THEN IT'S A FOR-STEP VAR INX H MOV A,M CPI '$' JZ STRGP ;GO PACK STRING VARRP: MVI A,7 ;ADJUST TO POINT PAST VARIABLE JMP TSTIT ;GO SEE IF ITS STILL SYB TAB. STPRP: MVI A,16 ;MOVE PASSED FOR STEP VAR JMP TSTIT ARRP: MVI A,4 ;SET TO POINT TO LENGTH CALL DADHL MOV E,M ;GET HIGH LEN INTO D INX H MOV D,M ;GET LOW LENGTH INTO E DAD D ;ADD TO HL INX H ;POINT TO FIRST WORD OF NEXT ENT. JMP TSTI2 ; STRGP: MVI A,4+(LENST AND 0FFH) ;SET TO ADD LEN OF POINTERS TSTIT: CALL DADHL ;POINT PAST ENTRY TSTI2: XCHG CALL XCOMP ;ARE THEY EQUAL? JZ PTABL ;YES--TRY AGAIN PUSH B ;NO--SET FWD. PNTR. TO STSPAC POP H SHLD STSPAC XCHG ;END OF CURRENT ENTRY IN HL SHLD PLINE ;CONTINUE PACKING FROM THERE PUSH H POP B RET ; ; XCOMP: MOV A,D CMP B RNZ MOV A,E CMP C RET ; ; ; ROUTINE TO OUTPUT ERROR MSG. TO USER. ; REG A CONTAINS BCD ERROR NUMBER, HL ; LOADED WITH VALUE OF KLINE. ERROR: LHLD STAACK SPHL LXI H,ODAT3 ;OUTPUT BUFFER DATA TABLES MOV D,A ;SAVE ERROR NUMB. IN D XRA A STA IOFLAG ;TURN OFF I/O PROCEEDS CALL FORM ;PAD 'ERROR ' MVI B,1 ;INIT FOR PADS MOV C,B ;INIT AS CNTR. MOV A,D ;GET ERROR NUMB. RLC ;ROTATE HIGH 4 BITS TO LOW 4 RLC RLC RLC ERRR1: ANI 17Q ;MASK ADI 60Q ;CONVERT TO ASCII CALL PAD ;PAD IT MOV A,D ;GET ERROR NUMB. DCR C ;ANOTHER PASS? JP ERRR1 ;YES ERRR2: LHLD KLINE CALL CHK1 ;SEE IF IMMEDIATE STMT JC ERR12 XCHG ;SAVE PTR TO LINE NUMBER IN DE LXI H,ODAT4 CALL FORM ;PAD 'IN LINE' XCHG CALL DNUMB ;DUMP LINE # ERR12: CALL WRIT ;WRITE MESSAGE JMP M1A ; ; THIS ROUTINE COPIES A STRING FROM DE PTR ; TO HL PTR. ALL REGS ARE SAVED STD2H: LDAX D ;SAVE REGS PUSH B PUSH D PUSH H MOV C,A ;START CNTR INR C STLOP: LDAX D ;GET CHAR MOV M,A ;MOVE CHAR INX D ;INCR PTRS INX H DCR C ;DECR CNTR JNZ STLOP ;TEST IF DONE POP H ;RESTORE REGS AND RET POP D POP B MOV A,M RET ; ; THIS ROUTINE FILLS A STRING VAR WITH BLANKS ; AND SETS THE LENGTH TO ZERO. BSTRG: PUSH H ;SAVE REGS PUSH B MVI B,0 MOV M,B ;SET LENGTH TO ZERO INX H ;INCR PTR IN STRING MVI C,(LENST AND 0FFH) ;COUNT OF STRING MVI B,' ' ;BLANK BSTR2: MOV M,B ;STORE BLANK INX H DCR C ; BUMP CNTRS JNZ BSTR2 ;TEST IF DONE POP B POP H RET ; ; THIS ROUTINE INCREMENTS H AND L AND ; DECR. C(CHARS IN LINE) SHOULD C RESULT ; IN 0 THEN THE ERROR CORRES. TO ENTRY PNT. ; IS GIVEN ICP7: MVI A,7 JMP INCPT ICP6: MVI A,6 JMP INCPT ICP8: MVI A,8 JMP INCPT ICP4: MVI A,4 JMP INCPT ICP2: MVI A,2 INCPT: CALL BUMP RNZ JMP ERROR ; ; FSYM FINDS SYMBOLS IN TABLE ; B,C CONTAIN SYMBOL ; RET WITH B,C,D,E SAME ; H AND L PNT TO VALUE (1ST BYTE) ; CY=1 => FOUND ; CY=0 AND A SCALAR VAR. => INSERTED ; AND SET TO 0 ; CY=0 AND A STRING VAR. => INSERTED ; AND SET TO LENGTH 0 AND FILLED BLANK. ; CY=0 AND AN ARRAY => NO ACTION, ; H AND L PNT TO LAST ENTRY IN SYMBOL TABLE FSYM: PUSH D XRA A ORA B ;SET CARRY IF NOT JZ AR ;AN ARRAY AND SAVE CMC AR: PUSH PSW LHLD NXTSP ;GET NEXT AVAILABLE PUSH B ;SPACE PNTR. MOV B,H MOV C,L ;CHECK TO SEE LHLD STSPAC ;IF SYMBOL TABLE CALL CHK1 ;IS STSPAC= -1 JNC AR1 ;NO--TEST FOR NXTSP PUSH B POP H ;SET STSPAC=NXTSP=NLINE SHLD STSPAC POP B XCHG JMP NOENT AR1: MOV D,H ;EMPTY MOV E,L CALL DCOMP ;DOUBLE BYTE COMPARE POP B ;GET VAR. BACK JZ NOENT LUKON: CALL CHK1 ;CHECK FOR END JC NOENT MOV D,H ;SAVE OLD PNTR MOV E,L MOV A,B CMP M ;DO VARIABLES MATCH JNZ NOMAT INX H MOV A,C CMP M JZ ENTRY DCX H NOMAT: INX H ;NO MATCH GET NEW PNT. INX H MOV A,M INX H MOV H,M MOV L,A JMP LUKON ; ; ; ARRIVE HERE WHEN NO ENTRY FOUND NOENT: LHLD NXTSP ;ADD. OF FREE MEMORY XCHG ;TO DE, HL HAVE LAST SYM. TAB. ENTRY POP PSW ;ARRAY? JNC FBAC ;YES, RETURN CALL STPNT ;UPDATE PNTR XCHG ;NXTSP TO HL MOV M,B ;STORE VAR. INX H MOV M,C INX H PUSH H MVI A,6 ;ADJUST ADDR CALL DADHL MOV A,B CPI '$' ; CHECK FOR TEMP STRING VAR JZ STFUL MOV A,C ;CHEK FOR STRING VAR CPI '$' ;COMPARE WITH $ JNZ CKFUL ;(STRINGS ARE 1 BYTE FOR STFUL: MVI A,(LENST AND 0FFH)-3 ;LENGTH AND 10 BYTES FOR CALL DADHL ;CHARS) CKFUL: SHLD NXTSP XTHL MVI M,0FFH ;SET FWD. PNTR. TO -1 INX H MVI M,0FFH INX H ;INIT TO FLT. PNT. 0 XTHL ;GET READY TO CHECK MEMORY CALL MEMFUL ;MEMORY FULL? POP H ;RESTORE NORMAL H-L MOV A,C ;TEST IF STRING CPI '$' JZ MTSTR ;INSERT STRING MOV A,B CPI '$' JZ MTSTR CALL WZER ORA A ;CLEAR CY JMP FBAC ;RESET CARRY AND RETURN MTSTR: CALL BSTRG ;CREATE BLANK STRING ORA A ;CLEAR CY (VAR INSERT) JMP FBAC ENTRY: POP PSW ;VAR FOUND INX H ;MOVE PNT. TO FIRST BYTE INX H ;OF FLT. PNT. NO. INX H STC ;SET CY AND RET. FBAC: POP D ;RESTORE D RET ; ; ; CONTAIN LOW BYTE OF TWO BYTE VALUE. RETURNS CY=1 IF ; BC>DE, CY=0 IF BC NO MORE SOURCE JC M1A ;END OF PROGRAM, GO TO M1A SHLD LPNT INX H ;STEP PASSED BINAY VALUE INX H MOV E,M ;GET FORWARD PTR INX H MOV D,M INX H ; ; ; ENTER HERE FOR IMMEDIATE EXECUTION. DE= -1 AND HL PT TO SOURCE-1 IMMED: MOV A,M ;GET LENGTH OF SOURCE XCHG ;SAVE HL SHLD KFPNT ;SAVE FORWARD PTR STA KLEN ;SAVE LENGTH XCHG ;RESTORE HL MOV C,A INR C CALL BUMP MOV A,M ;GET CODED KEYWORD SHLD CPNT LXI H,JTBL ;LOAD JUMP TABLE PNTR. ADD A ;DOUBLE A CALL DADHL ;PT TO PROPER STMT PROCESSOR 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 RETRN DW M1A ;STOP STMT.-RETURN TO EDIT MODE DW ENDD DW IFRT DW INPUT DW DIM DW CALLP DW GOSUB DW GOTO DW IEND ;REM STMT. - NO ACTION DW FOR DW NEXT ; ; ; RUN LINE# PROCESS RUNNO: CALL BOUND ;GET NEAREST LINE NUMBER LHLD PLINE ;PUT INTO H-L JMP ILOOP ;EXECUTE ; ; ; END PROCESSOR ENDD: LHLD KFPNT ;CHECK TO SEE IF MORE CALL CHK1 ;SOURCE AFTER END JC M1A MVI A,3 ;MORE SOURCE ERROR 3 JMP ERROR ; ; ; GO TO PROCESSOR GOTO: LHLD CPNT ;GOTO STMT. PROC. GSENT: CALL ICP4 ;INCREMENT PAST KEYWORD 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 ; ; ; DIMENSION PROCESSOR DIM: LHLD CPNT ;DIM STMT. PROC. CALL ICP6 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,'(' ;CHECK FOR ( CMP M JNZ ER6 CALL ICP7 ;INCR. CPNT CALL CVB ;CONV. TO BIN NO. CALL DADHL ;UPDATE HL MVI A,')' ;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 H ;ADD. OF LAST SYM. TAB. ENTRY TO DE LHLD NXTSP ;GET ADD. OF AVAILABLE MEM. MVI M,0 INX H ;INSERT VAR IN SYMB. TAB. MOV M,C INX H INX H MOV A,D ;GET VALUE INTO PROPER ORDER MOV D,E MOV E,A INX D ;NOW DE HAVE NUMBER OF ELEMENTS MOV A,D ;GET ONE'S COMPLEMENT OF CMA ;NUMBER OF ELEMENTS MOV B,A ;IN ARRAY TO B,C MOV A,E CMA MOV C,A XCHG ;CALCULATE NUMBER OF BYTES DAD H DAD H ;MULT BY 4 XCHG INX H ;STORE LEN OF ARRAY MOV M,E INX H MOV M,D INX H ;PNTS TO FIRST DATA CONT: CALL WZER ;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 POP D ;RETRIEVE ADDR OF LAST SYMBOL PUSH H ;SAVE NEW NXTSP LHLD NXTSP ;GET OLD NXTSP (START OF ARRAY) XCHG CALL STPNT ;STORE FPNT IN PREVIOUS SYMBOL XCHG ;SET CURRENT FPTR TO -1 INX H INX H MVI M,0FFH INX H MVI M,0FFH POP H ;UPDATE NXTSP-NLINE SHLD NXTSP SHLD NXTSP ;NEW VALUE OF NXTSP.NLINE POP B ;RESTORE REG'S POP H CALL BUMP ;MORE ELEMTS IN LINE? JZ IEND MVI A,',' ;NEXT ELEMENT A , CMP M JNZ ER6 ;ERROR IF NOT COMMA CALL ICP6 ;INCR HL AND C JMP DLOOP ; ; ; 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 ; ; ; VALUE RETURNS IN AM9511 STACK IF NUMBER ; IF STRING DE PT TO LOCATION OF STRING ; C,H,L ARE UPDATED ; A,B ARE DESTROYED VALUE: CALL VAR ;IS IT A VARIABLE? JNC NOVAR ;NOT A VARIABLE CPI 2 ;TEST IF STRING VARIABLE RZ ;YES IT IS, NOT PUT ON AM9511 XCHG ;LET HL PT TO VALUE CALL HL2AM ;PUT VALUE ON AM9511 XCHG ;RESTORE REGS RET NOVAR: MVI A,3 ;NO CHEK IF A FUNC. CALL SYMSRT CPI 377Q JZ KONT ;NOT A FUNCTION - PUSH PSW ;SAVE FUNCTION MOV A,C ;CHECK FOR PREMATURE EOL ORA A JZ ER8 MVI A,'(' ;CHEK FOR ( CMP M JNZ ER8 CALL ICP8 ;BUMP PNTR'S MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;GET PORT # CPI 1 ;NO STRING ARGS ALLOWED JZ ER10 POP PSW ;PUT BC, HL ON STACK PUSH B PUSH H LXI H,ENDFUN ;PUSH A RETURN ADDR SO THAT PUSH H ; THE FUNCTION ROUTINE CAN BE ; LIKE SUBROUTINES ADD A ;DOUBLE FUNCTON NUMBER LXI H,FTABLE CALL DADHL ;FORMJUMP ADDR MOV A,M INX H MOV H,M MOV L,A PCHL ;GO DO IT ; ; FTABLE: DW GET DW ER10 ;PUT IS AN ERROR DW ABS DW SQR DW SIN DW COS DW TAN DW ASN DW ACN DW ATN DW EXP DW LOG DW INT DW LGT ;LOG BASE 10 DW RANDOM ; ENDFUN: POP H POP B MOV A,C ;EOL? ORA A JZ ER8 MVI A,')' ;CHECK FOR ) CMP M JNZ ER8 CALL BUMP ;BUMP PNTR'S MVI A,0 ;INDICATE NUMBER VALUE RET ; ; ; THE FUNCTIONS GO HERE GET: CALL FIXD ;FIX PORT NUMBER LXI H,FREG1 CALL AM2HL ;PUT PORT NUMBER IN FREG XCHG ;LET DE PT TO PORT NUMBER INX D INX D ;GET LOWEST BYTE TO INX D ;REG D LDAX D MOV D,A ;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+3 ;SET UP FOR FLOAT MOV M,A ;STORE AWAY INPUT DCX H XRA A ;ZERO OUT HIGHER BYTES MOV M,A ;ALL 3 NEED TO BE ZERO DCX H ;TO PRODUCE A 4 BYTE INTEGER MOV M,A DCX H MOV M,A CALL HL2AM ;PUT VALUE ON AM9511 CALL FLTD ;FLOAT IT RET ;DONE RINST: IN 0 ;RAM INSTRUCTIONS JMP HOME ABS: CALL XCHF CALL XCHF CALL STATUS RP CALL CHSF RET KONT: CALL NUMB ;NUMBER JC OKK MOV A,M CPI '.' ;DEC PT? JZ OKK CPI '"' ;IS IT "? JZ SKOUT CPI '(' ;IS IT (? JNZ ER8 CALL ICP8 ;WE HAVE A (EXPR) MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVAL EXPRESSION MOV A,M ;IN FUTURE CHECK EXPRS TYPE CPI ')' ;CHECK FOR ) JNZ ER8 CALL BUMP ;BUMP POINTERS MVI A,0 ;INDICATE NUMREIC RESULT RET SKOUT: PUSH H ;YES WE HAVE A STRING LXI H,SREG2 ;PT TO SREG2 CALL BSTRG ;PUT BLANKS IN SREG2 XCHG ;PUT STRING ADDR IN DE INX D POP H ;RESTORE HL MVI B,0 ;SET CNTR=0 LTQLP: INX H ; BUMP PNTRS DCR C JZ ER8 MOV A,M ; GET NEXT CHAR CPI '"' ; IS IT QUOTE? JZ LTQOT ORA A ; SET PSW TO SEE IF IMBEDDED BLANKS JP LTCHR ; REGULAR CHAR CMA ; IMBEDDED SPACES.SINCE LTBED: INX D ; SPACES ALREADY IN BUFFER INR B ; JUST MOVE POINTERS B & DE DCR A JNZ LTBED JMP LTLTS ; GO TEST IF STRING TOO LONG LTCHR: STAX D ; PUT CHAR IN SREG2 INX D INR B ; INCREMENT PTR AND CNT LTLTS: MOV A,B CPI LENST+1 ; TEST IF 10 CHAR IN SREG2 JM LTQLP ; IF NOT 10, LOOP UNTIL " MVI A,'"' LTPP: CALL ICP8 ;BUMP PTRS CMP M ;TEST NEXT CHAR JNZ LTPP MVI A,LENST LTSDN: LXI D,SREG2 ; STORE LENGTH STAX D CALL BUMP MVI A,2 ; INDICATES STRING RET LTQOT: INX H ; BUMP POINTERS DCR C JZ LTQTE ; END OF STRING AT END OF LINE MOV A,M ; CHECK FOR A DOUBLE QUOTE CPI '"' JZ LTCHR ; DOUBLE QUOTE BECOMES THE CHAR " LTQTE: CALL UNBUMP ; SETS POINTERS UP CORRECTLY MOV A,B ; PREPARE TO PUT LENGTH IN BUFFER JMP LTSDN ; DONE. OKK: MVI A,1 ;MODE=1, IE. INPUT FROM SOURCE CALL RDKON ;READ CONSTANT TO GREG JC ER9 ;IF ERROR THEN CY=1 XCHG ;SAVE HL IN DE LXI H,GREG ;POINT TO CONSTANT CALL HL2AM ;PUT ON AM9511 XCHG ;RESTORE HL XRA A ;SET A=0 TO INDICATE NUMBER RESULT 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 ;WHERE 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 ; ; ; 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 ; B DESTROYED,A=0(VARIABLE),1(ARRAY),2(STRING VAR) ; IF NOT A VARIBLE CY=0 ; H,L,C ARE LEFT UNTOUCHED VAR: CALL ALPHA ;1ST CHAR A LETTER? RNC ;NO-NOT VAR. CALL BUMP ;BUMP PNTR'S JNZ MORE ;MORE TO LINE SC1: PUSH B ;SAVE B,EOL CALL UNBUMP ;GET SINGLE LETTER MOV B,M ;VAR TO B CALL BUMP MVI C,0 ;SET FOR CALL TO FSYM MOV A,C JMP SCALR MORE: CALL ALPHA ;2ND A LETTER? JNC SFSG ;SO FAR SO GOOD PUSH B ;SAVE C PUSH H MVI A,2 ;CHECK FOR DELIMITER CALL SYMSRT POP H POP B ;RESTORE C INR A ;FOUND? JNZ SC1 ;YES CALL UNBUMP ;NOT A VAR. ORA A ;CY=0 AND RET RET SFSG: CALL NUMB ;TEST FOR NUMBER JNC ARCK ;MAYBE AN ARRAY MVI A,0 ;INDICATE NUMBER VAR FOUND SFSG2: CALL BUMP ;ITS A SCALAR JZ SLOAD ;EOL PUSH H PUSH B ;SAVE C PUSH PSW ;SAVE VAR TYPE MVI A,2 ;SET UP FOR SYMSRT CALL SYMSRT ;TEST FOR LEGAL POP B ;GET VAR TYPE BACK INR A ;DELIMITER FOUND? MOV A,B ;MOVE VAR TYPE TO A POP B ;GET BACK C-REG POP H JZ ER8 ;NO, ERROR SLOAD: PUSH B ;SAVE C, CALL UNBUMP MOV B,M ;GET VAR. INTO CALL UNBUMP ;B,C FOR FSYM MOV C,B MOV B,M PUSH B ;SAVE BC CALL BUMP CALL BUMP POP B SCALR: XCHG ;SAVE H,L IN D,E PUSH PSW CALL FSYM ;GET PNTR TO VALUE POP PSW XCHG ;RESTORE H,L PNTR TO DE POP B ;GET C REG BACK STC ;SET CY,RET RET ARCK: MOV A,M ;ARRAY & STRING CHEK, GET CHARACTER CPI '(' ;IS IT (? JZ ARYES ;YES,ITS AN ARRAY CPI '$' ;IS IT $? JZ VSTR ;YES IT IS A STRING VAR MVI A,2 ;NO-CHEK FOR LEGAL DELIM. PUSH H PUSH B ;SAVE C CALL SYMSRT POP B ;RESTORE C POP H INR A ;DELIMITER FOUND? JZ ER1 XRA A ;SET A=0 TO INDICATE VAR JMP SC1 ;1 CHAR. SCALAR VAR. VSTR: MVI A,2 ;INDICATE STRING VAR JMP SFSG2 ;FIND ADDR OF VAR ARYES: CALL UNBUMP ;YES-WE HAVE ARRAY MOV A,M ;GET VAR. CALL BUMP PUSH PSW ;SAVE VAR. CALL ICP1 ;BUMP PNTR'S MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE SUBSCRIPT PUSH H ;SAVE HL PTRS LXI H,HALF ;ROUND SUBSCRIPT CALL HL2AM CALL FADD ;BY ADDING 1/2 CALL STATUS ;CHECK IF SUBSCRIPT NEG. JM ER22 ;NOT ALLOWED IN IDAHO CALL FIXD ;FIX SUBSCRIPT LXI H,FREG1 CALL AM2HL ;PUT SUBSCRIPT IN FREG XCHG ;LET DE PT TO SUBSCRIPT POP H ;RESTORE HL MVI A,')' ;CHECK FOR ) CMP M JNZ ER1 CALL BUMP ;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 MOV D,B ;PUT SUBSCRIPT IN DE MOV E,A XCHG DAD H ;MULT BY 4 DAD H XCHG 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. ER1: MVI A,1 JMP ERROR ICP1: MVI A,1 CALL BUMP RNZ JMP ERROR AFOND: MOV A,M ;1'S COMPLEMENT CMA MOV C,A INX H MOV A,M CMA MOV B,A ;BC= - LENGTH OF ARRAY INX B ;MAKE IT 2'S COMPL INX H ;PT TO START OF DATA PUSH D ;SAVE SUBSCRIPT XCHG DAD B ;SUBSCRIPT-LENGTH JC ER22 ;SUBSCRIPT OUT OF RANGE XCHG POP D DAD D ;H,L NOW PNT TO START OF XCHG ;ARRAY, ADD OFFSET, EXCHG POP H ;RESTORE PNTR'S AND RET. POP B MVI A,1 ;INDICATE NUM. ARRAY FOUND STC ;SET CY RET ER22: MVI A,22H ;SUBSCRIPT TOO LARGE JMP ERROR ; ; ; BUMP AND UNBUMP INCR AND DECR HL, C PTRS TO NEXT ; NORMAL CHARACTER, SKIPPING SPACES IN EITHER DIRECTION ; HL, C ALWAYS RETURN POINTING AT A CHARACTER. ; IMBEDDED BLANKS ARE RECOGNIZED BY A ONE IN THE SIGN BIT. ; FOR BUMP, THE PSW RETURNS WITH THE ZERO FLAG SET AFTER ; THE DCR C INSTRUCTION, SO IT INDICATES EOL OR NOT. BUMP: PUSH D ;SAVE TO ENABLE A TO BE RESTORED PUSH PSW ;SAVE A LBUMP: INX H ;BUMP PTRS DCR C JZ BEND ;AT EOL PUSH PSW ;SAVE ZERO FLAG (SAVE PSW) MOV A,M CPI ':' ;COLON WILL END SOURCE LINE JZ COLON ORA A ;TEST FOR BLANKS JP BOK ;REGULAR CHAR POP PSW JMP LBUMP ;SKIP OVER SPACES COLON: POP PSW ;GET RID OF OLD PSW XRA A ;SET ZERO FLAG=1 MOV C,A ;SET LENGTH TO ZERO PUSH PSW ;PUT PSW IN ITS PLACE BOK: POP PSW ;RESTORE PSW TO STATE AFTER DCR C BEND: POP D ;POP A INTO D MOV A,D ;RESTORE A POP D ;RESTORE DE RET UNBUMP: PUSH PSW ;SAVE A LUNBUMP: DCX H ;UNBUMP PTRS INR C MOV A,M ;GET CHAR ORA A ;TEST FOR SPACES JM LUNBUMP ;FOUND IMBEDDED SPACES POP PSW ;RESTORE A AND PSW RET ; ; ;CALCULATES PRECEDENCE OR BINDING POWER OF OPERATIONS ; + - 2 ; * / 4 ; ? 6 ;OPERATOR POINTED AT BY HL,PRECEDENCE RETURNED IN A BIND: MOV A,M ;GET OPERATOR CPI '+' ;COMPARE WITH +-*/? JZ BIND2 CPI '-' JZ BIND2 CPI '*' JZ BIND4 CPI '/' JZ BIND4 CPI 5EH ;UP ARROW DOES NOT COMPUTE JZ BIND6 MVI A,0 ;PREC = 0 IF NOT OPERATOR RET BIND2: MVI A,2 ;IF OPERATOR ASSIGN PREC RET BIND4: MVI A,4 RET BIND6: MVI A,6 RET ; ; ;EVAL EVALUATES EXPRESSIONS. VALUE IS USED TO GET ;A VALUE (WHICH MAY BE A CONST, VAR, ARRAY, FUNCTION, ;OR EXPRESSION IN PARENTHESES). EVAL THEN OPERATES ;ON THESE VALUES USING THE PROPER PRECEDENCE OF THE ;OPERATORS. ;ON ENTRY B=BINDING POWER (BP) OF PREVIOUS OP (INITIALLY 0) ;ON EXIT A=1 FOR STRING, A<=0 FOR NUMBER ; C,HL ARE UPDATED ; DE POINT TO RESULT IF STRING, IF NUMBER ; RESULT IN AM9511. EVAL: MVI A,'-' ;IS IT UNARY - CMP M ;Z=1 => YES PUSH PSW ;Z=0 => NO JNZ ECAV CALL ICP8 ;BUMP POINTER ECAV: MOV A,B PUSH PSW ;SAVE BP CALL VALUE ;GET NEXT VALUE CPI 2 ;TEST IF STRING RESULT JZ EVSTR ;MOVE STRING TO SREG2 POP PSW MOV B,A ;RESTORE BP POP PSW ;RESTORE ZERO FLAG (NEGATE INDICATOR) JNZ DOL ;DO NOT NEGATE CALL CHSF ;CHANGE SIGN OF TOS ON AM9511 DOL: MOV A,C ;TEST FOR END-OF-LINE ORA A RZ ;RETURN WITH A=0 (INDICATES NUMBER) MOV A,M ;GET OPERATOR CALL BIND ;DETERMINE PRECEDENCE CMP B ;COMPARE BIND(OP) WITH BP JZ ERET ;BIND(OP) = BP JC ERET ;BIND(OP) < BP XCHG ;SAVE HL IN DE (AM2HL DESTROYS HL) CALL AM2SP ;PUT VALUE ON 8080 STACK XCHG ;RESTORE HL PUSH B ;SAVE BP MOV B,A ;SET NEW BP,PREPARE FOR CALL TO EVAL MOV A,M ;GET OPERATOR PUSH PSW ;SAVE OPERATOR CALL ICP8 ;BUMP PTRS CALL EVAL ;EVAL REST OF EXPRESSION XCHG ;SAVE HL IN DE POP PSW ;OPERATOR IN A POP H ;BP IN H MOV B,H ;RESTORE BP TO B CALL SP2AM ;PUT 1ST OPERAND ON AM9511 CALL XCHF ;PUT OPERANDS IN PROPER ORDER XCHG ;RESTORE HL CALL BINOP ;DO OPERATION JMP DOL ;LOOP WHILE BIND(OP) > BP ERET: XRA A ;INDICATE NUMERIC RESULT BY A=0 RET ER8: MVI A,8 JMP ERROR EVSTR: POP PSW ;GET RID OF PRECEDENCE ON STACK PUSH H LXI H,SREG2 CALL STD2H ;MOVE STRING TO SREG2 XCHG POP H ;DE PNTS TO SREG2,HL TOSOURCE POP PSW MOV A,C ;END OF LINE? ORA A JZ ESRET PUSH H PUSH B MVI A,2 ;TEST FOR DELIMITER CALL SYMSRT POP B POP H INR A JZ ER8 CPI 8 ;ONLY VALID ENDS FOR STRINGS: JNC ER8 ; < > , = ) ; THEN ESRET: MVI A,1 ;INDICATE RESULT IS STRING RET ; ; ; THIS ROUTINE PERFORMS BINARY OPERATIONS ON OPERANDS IN FREG1 AND FREG2 ; A,B,C,H,L ARE LEFT UNDISTURBED. ; D,E PNT TO RESULT ; OPERATIONS ARE SPECIFIED BY A REGISTER AS FOLLOWS: ; ; A='*' => OPND1 * OPND2 ; A='/' => OPND1 / OPND2 ; A='+' => OPND1 + OPND2 ; A='-' => OPND1 - OPND2 ; A='?' => OPND1 ? OPND2 (OPND2 ASSUMED INTEGER) ; ; 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 RUN (THE INTERPRETER) IS ABORTED. ; BINOP: CPI '+' JZ ADDD CPI '-' JZ SUBB CPI '*' JZ FMULT CPI '/' JZ DIV CPI 5EH ;UP ARROW DOES NOT COMPUTE JZ PWR JMP ER8 ;ILLEGAL OP PWR: CALL PWRF RET ADDD: CALL FADD RET SUBB: CALL FSUB RET FMULT: CALL FMUL RET DIV: CALL FDIV RET ; ;ADJUSTS THE IOFLAG VALUE ; ADJIO: LXI H,IOFLAG MOV A,M ;GET IOFLAG INTO A ORA A ;TEST FOR ZERO JZ ADJ7 DCR A ;TEST FOR 1 JZ ADJ12 DCR A ;TEST FOR 2 JZ ADJ12 DCR A ;FOR 3 JZ ADJ5 DCR A ;4 JZ ADJ13 DCR A ;5 JZ ADJ13 DCR A ;6 JZ ADJ13 RET ADJ5: MOV A,M ;GET IOFLAG AND THEN ADI 5 ;ADD A VALUE TO IT AND MOV M,A ;STORE IT AWAY JMP ADCPOS ADJ7: MOV A,M ADI 7 MOV M,A JMP ADCPOS ADJ12: MOV A,M ADI 12 MOV M,A ADCPOS: MVI A,1 STA CPOS ;INITIALISE CPOS RET ADJ13: MOV A,M ADI 13 MOV M,A RET ; ; PRINT PROCESSOR ; PRI: CALL QUITT LDA IOFLAG CPI 7 ;LOOP UNTIL IOFLAG<7 JNC PRI LHLD CPNT PRIS2: CALL BUMP MVI B,0 ;SET CHAR CNT JNZ PPTST ;CONTINUE IF MORE PRIS3: INR B ;NOTHING MORE, PAD A NULL PUSH PSW ;SET PSW NON-ZERO(NORMAL PRINT) JMP PEND ;WRITE IT AND CONTINUE PPTST: MOV A,M CPI 5BH ;FIRST BRACKET? PUSH PSW ;SAVE IN CASE A PRINT-PROCEED JNZ PLOOP ;NORMAL PRINT CALL IOPVR ;GET PRINT-PROCEED VAR JNZ PPRO ;WE DO A PRINT-PROCEED (VAR=0) POP D ;GET RID OF LOLD PSW JMP PRIS2 ;NORMAL PRINT PPRO: XCHG SHLD PPVAR ;SAVE PRINT-PROCEED VAR ADDR XCHG CALL BUMP JZ PRIS3 PLOOP: MOV A,M ;GET CHARACTER CPI '"' ;IS IT "? JNZ EXPRE ;NO QUOTE: INX H ;GET CHARACTER TO A DCR C JZ ER7 MOV A,M CPI '"' ;IS IT "? JZ QCHEK ORA A ; CHECK FOR IMBEDDED BLANKS JP QOTOK ; NOPE.. CMA MOV D,A ; SAVE NUMBER OF SPACES ADD B ; UPDATE CHAR COUNTER MOV B,D ; READY FOR PAD MOV D,A ; SAVE CHAR COUNTER MVI A,' ' ; PAD SPACES CALL PAD MOV B,D ; CHAR COUNTER INTO B JMP QUOTE 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: CALL BUMP ;BUMP PNTRS JZ PEND ;EOL MOV A,M CPI '"' ;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 '(' ;IS IT THE START OF XPRES JZ PRTIT ;YES CPI '.' ;IS IT A DECIMAL PNT? JZ PRTIT ;YES EVALUATE, PRINT CPI '-' ;IS IT A -? JZ PRTIT ;YES EVALUATE AND PRINT CPI '+' ;IS IT A +? JNZ SCOLN ;NO, CHECK FOR ; PRTIT: PUSH B ;SAVE CNT MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE EXPRESION DCR A JZ PRSTR ;PRINT STRING PUSH H PUSH B ;SAVE BC COUNTERS MVI A,2 ;LOOK FOR KEYWORD AS CALL SYMSRT CPI 13 ;TEST FOR AS JNZ PSAME ;NO FORMAT, USE 11E4 POP PSW ;GET RID OF OLD C, HL POP PSW MOV A,C ;TEST FOR EOL ORA A JZ ER7 CALL CVB ;GET FIELD WIDTH INTO D ORA A JZ ER8 ;ERROR IF NO WIDTH CALL DADHL ;UPDATE HL PTRS MOV A,C ;TEST FOR EOL ORA A JZ ER8 MOV B,D ;RE-ORDER STACK SO POP D ;WIDTH IS UNDER BC PUSH B ;PUT D ON STACK PUSH D ;NOW PUT B MOV D,B ;RESTORE D PUSH D ;PUT WIDTH ON AGAIN MOV A,M ;TEST FOR TYPE OF FORMAT CALL BUMP CPI 'I' JZ IFMT CPI 'E' JZ EFMT CPI 'F' JZ FFMT JMP ER8 IFMT: POP D ;GET WIDTH PUSH B ;SAVE HL,C PUSH H MOV B,D MVI C,0 FDO: CALL FORMT JMP POVER EFMT: POP D MOV B,D MVI A,80H PUSH PSW JMP OFMT FFMT: POP D MOV B,D MVI A,40H PUSH PSW OFMT: CALL CVB ORA A JZ ER8 CALL DADHL ;UPDATE PNTS POP PSW ORA D PUSH B PUSH H MOV C,A JMP FDO PSAME: POP B ;RESTORE BC POP H XCHG MVI H,11 ;STORE WIDTH FOR 11E4 XTHL PUSH H ;SAVE ON STACK XCHG PUSH B ;SAVE HL,C PUSH H LXI B,0B84H ;SET UP FOR 11E4 JMP FDO ;PRINT VALUE POVER: POP H ;RESTORE REG'S POP B MOV A,C POP B MOV C,A ORA A ;CHECK EOL JZ PEND1 POP PSW ;UPDATE CNTR ADD B MOV B,A MOV A,M ;GET CHAR. SCOLN: CPI ';' ;IS IT ;? JZ SONWD ;YES CPI ',' ;IS IT ,? JNZ ER6 ;NO-UNEXPECTED CHAR. XRA A ;ZERO A ADFLD: ADI 13 ;ADD FIELD LENGTH CMP B ;COMPARE TO CNT JZ LSTFLD JNC FLDFD LSTFLD: CPI 52 ;LAST FLD? JNZ ADFLD MVI B,1 MVI A,0DH ;PAD A CR AND LF CALL PAD MVI A,0AH CALL PAD PUSH H ;SAVE HL BECAUSE ADJIO USES HL CALL ADJIO POP H CALL WRIT ;YES-WRITE LINE MVI B,0 ;RESET CNT CALL BUMP ;BUMP PNTRS JZ PEND JMP PLOOP PRSTR: POP PSW ;GET RID OF OLD BC FROM STK MOV B,A ;RESTORE B LDAX D ;GET LENGTH OF STRING INX D ORA A JZ PRSND ;TEST FOR ZERO LEN PUSH H MOV L,A ;SAVE LEN ADD B ;UPDATE COUNT IN B MOV B,A PUSH B ;SAVE BC MVI B,1 ;SET B FOR SUBR PAD PRSLP: LDAX D ;GET CHAR CALL PAD ;PUT CHAR IN OBUFF INX D DCR L ;TEST LEN JNZ PRSLP ;REPEAT POP B POP H PRSND: MOV A,C ;CHEK EOL ORA A JZ PEND MOV A,M ;GET NEXT CHAR FROM SOURCE JMP SCOLN ;DETERMINE CARRIAGE CNTRL 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,' ' CALL PAD ;PAD SPACES MOV A,D ADD E ;NEW CNT MOV B,A ;SAVE IN B SONWD: CALL BUMP ;CHECK EOL JNZ PLOOP PREND: CALL ADJIO POP PSW ;TEST IF NORMAL OR P-PROCEED JZ IEND ;WE HAVE A PRINT-PROCEED LXI H,OBUFF+1 ;SET PPVAR TO FREE SPACE SHLD PPVAR ;BECAUSE PRINTING DONE IN QUITT MVI D,1 ;SUPPRESS CR/LF CALL WRIT1 JMP IEND PEND1: POP PSW ;GET RID OF FIELD WIDTH PEND: MVI B,1 MVI A,0DH ;PUT CR AND LF AT END OF BUFF CALL PAD MVI A,0AH CALL PAD JMP PREND ;GO PRINT BUFFER ; ; 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 CALL ICP7 MOV A,M ;LOOK FOR FIRST BRACKET CPI 5BH ;INPUT AND PROCEED???? JZ IPROC ;YES PRMPT: PUSH B ;SAVE PNTR'S PUSH H INLOP: CALL QUITT ;LOOP UNTIL IOFLAG=0 LDA IOFLAG ORA A JNZ INLOP MVI B,1 ;SEND PROMPT MVI A,'?' MOV D,B ;TO SUPPRESS CR/LF CALL PAD ;PAD IT MVI A,' ' CALL PAD ;PROMT IS A '? ' (TWO CHAR) CALL WRIT1 ;WRITE IT LXI H,IBUF ;ADD. OF INPUT BUFFER CALL TTYIN ;READ A LINE INX H ;PT TO DATA 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 IEND ;NO ERROR LXI H,ODAT7 ;SEND ERROR MESSAGE CALL FORM CALL WRIT LDA PL6 ;GET V-STRING CNT MOV C,A JMP INPER ;START AGAIN IPROC: CALL IOPVR ;GET IO-PROCEED VAR PUSH PSW CALL ICP7 ;BUMP PASSED 2ND BRACKET POP PSW ;RETAIN PSW FROM IOPVR JZ PRMPT ;VAR = 0. NORMAL INPUT SHLD IPVPT ;SAVE PT TO VAR LIST XCHG SHLD IPVAR ;SAVE INPUT-PROCEED VAR ADDR MOV A,C STA IPVLN ;SAVE LENGTH OF VAR LIST IPTST: CALL QUITT LDA IOFLAG ORA A JZ IFO1 CPI 7 JNZ IPTST MVI A,11 ;PROMPT AFTER PRINTING STA IOFLAG JMP IEND IFO1: INR A ;DO PROMPT STA IOFLAG IEND: LHLD KFPNT ;ALL OK - GET NEW PNTR. JMP ILOOP ;CONTINUE IOPVR: CALL ICP2 CALL VAR JNC ER2 ;NOT A VARIABLE IN ^[ ORA A JNZ ER2 ;MUST BE A SIMPLE VAR MOV A,M CPI 5DH ;CHECK FOR FINAL BRACKET JNZ ER2 XCHG ;POINT TO VAR WITH HL CALL HL2AM ;PUT VAR ON AM9511 CALL XCHF CALL XCHF CALL STATUS XCHG ;RESTORE HL RET ER2: MVI A,2 JMP ERROR ; ; 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=1 ALL OK ; Z=0 ERROR IN CONVERSION OR ; NUMBER OF CONSTANTS ; ; ALL POINTERS AND LINE CNT'S ARE RETURNED UPDATED ; STRIN: MOV A,C ;GET V-STRING CNT ORA A ;TEST FOR EOL JZ STDNE ;DONE? TEST IF CONSTANTS DONE MOV A,M ;GET CHAR. CPI ',' ;IS IT A ,? JNZ STOKV ;IT'S NOT A , CALL BUMP ;COMMA, BUMP PNTR'S JZ ERRET ;POSSIBLE ERROR (IF EOL) STOKV: MOV A,B ;GET K-STRING LENGTH ORA A ;TEST FOR EOL JNZ STOK1 INR A ;NOT ENOUGH CONSTANT DATA RET STOK1: LDAX D ;GET CHAR CPI ',' ;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 CPI 2 ;IS IT STRING VAR? JZ STINP ;INPUT STRING VALUE 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 STDNE: MOV A,B ;GET K-LEN ORA A RET ;OK IF ZERO, ELSE ERROR 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 STINP: MOV A,C ;SAVE V-LEN POP B ;RESTORE K-LEN TO B PUSH PSW ;SAVE V-LEN PUSH D ;SAVE V-PTR XCHG ;LOAD DE WITH K-PTR LHLD VARAD ;GET V-ADDR CALL BSTRG ;SET VAR TO BLANKS XCHG ;DE=V-ADDR, HL=K-PTR MVI C,0 ;INITIAL CHAR COUNT PUSH D ;SAVE V-ADDR INX D ;STEP PASSED LENGTH SINP2: MOV A,M ;GET CHAR CPI ',' ;LOOK FOR , JZ SINP3 ;DONE CPI ' ' ;IS IT A SPACE JNZ SILLY ;SKIP SPACES INX H ;MOVE PTR TO SKIP SPACES DCR B JMP SINP2 SILLY: CPI '"' JNZ SINQU ;STRING WITHOUT QUOTE MARKS SINP4: INX H DCR B JZ SERRET ;ERROR IF CONST LIST ENDS HERE MOV A,M ;GET CHAR CPI '"' JNZ SSSVE ;SAVE CHAR INX H DCR B JZ SINP3 ;DONE IS CONST LIST ENDS HERE MOV A,M ;GET CHAR, CHECK IF " " (DOUBLE ") CPI '"' JNZ SINP3 ;END OF STRING, MOVE PTS BACK SSSVE: INR C MOV A,C CPI (LENST AND 0FFH)+1 JZ SERRET ;STRING TOO LONG MOV A,M ;RESTORE CHAR CPI ':' ; TEST FOR COLON JNZ SSSV2 MVI A,13H ; CONTROL-S IS SUBST CHAR FOR : SSSV2: STAX D ; SAVING CHAR IN DE POINTER INX D JMP SINP4 SINP3: POP D ;GET V-ADDR MOV A,C STAX D ;STORE LEN OF STRING XCHG ;PUT K-PTR IN DE POP H ;PUT V-PTR IN HL POP PSW ;GET V-LEN IN A MOV C,A ;PUT V-LEN IN C JMP STRIN ;ARE THERE MORE VARIABLES? SINQU: INR C MOV A,C ;TEST LENGTH CPI (LENST AND 0FFH)+1 JZ SERRET ;NO ROOM MOV A,M ;RESTORE CHAR LOST IN TEST CPI ':' JNZ SINQZ ; CONTROL-S IS SUBST CHAR FOR : MVI A,13H SINQZ: STAX D ; SAVING CHAR INX D JMP SINQ2 ;STILL ROOM SINQ3: INX H ;LOOP UNTIL COMMA OR EOL DCR B ;IF NON-SPACES THEN ERROR JZ SINQD ;DONE MOV A,M ;GET CHAR CPI ',' ;IS IT A COMMA JZ SINQD ;DONE CPI ' ' ;IS IT A SPACE JZ SINQ3 ;REPEAT JMP SERRET ;NON-SPACE SO IT IS AN ERROR SINQ2: INX H DCR B JZ SINQD ;DONE MOV A,M ;TEST FOR COMMA CPI ',' JNZ SINQU ;REPEAT SINQD: MVI A,LENST AND 0FFH MOV C,A ;NEED TO DELETE TRAILING SPACES POP D ;GET PTR TO START OF STRING PUSH D ;SAVE IT AGAIN XCHG ;SAVE K-PTR IN DE CALL DADHL ;HL PT TO END OF STRING SINQ4: MOV A,M ;LOOP UNTIL NON-SPACE CPI ' ' JNZ SINQ5 ;GOT A NON-SPACE DCX H DCR C ;NO NEED TO TEST IF C=0 JMP SINQ4 ;REPEAT SINQ5: XCHG ;RESTORE HL JMP SINP3 ;STORE LEN INFO SERRET: POP PSW ;EMPTY STACK POP PSW POP PSW JMP ERRET ;ERROR RETURN ; ; LET STMT. PROCESSOR ; LET: LHLD CPNT ;GET PNTR. CALL BUMP ;FIX PNTR. JNZ LOK ER7: MVI A,7 JMP ERROR LOK: CALL VAR ;GET ADDRESS TO VAR. MOV B,A ;SAVE TYPE OF VARIABLE JC SAVV ;IT'S A VARIABLE MVI A,3 ;NO-CHEK FOR FUNC. CALL SYMSRT CPI 377Q JZ ER1 ;DON'T KNOW WHAT IT IS DCR A JNZ ER10 ;ILLEGAL USE OF FUNC. MOV A,C ;EOL CHK ORA A JZ ER7 MOV A,M ;CHEK FOR ( CPI '(' JNZ ER7 CALL ICP7 ;BUMP PNTRS MVI B,0 ;SET INTIAL PRECEDENCE CALL EVAL ;EVALUATE AND FIX CALL FIXD ;FIX PORT NUMBER XCHG ;SAVE HL IN DE LXI H,FREG1 CALL AM2HL ;PUT PORT NUMBER INTO FREG XCHG ;RESTORE HL INX D INX D INX D LDAX D ;GET LOWEST BYTE PUSH PSW ;PORT # IS SAVED MOV A,M CPI ')' ;CHECK FOR ) JNZ ER7 CALL ICP7 ;BUMP PNTR'S MVI D,377Q MOV E,D MVI B,0 ;SET TYPE TO NUMBER SAVV: PUSH D ;KEEP ADDRESS MOV A,M ;CHEK FOR = CPI '=' JNZ ER7 CALL ICP8 ;BUMP PNTRS PUSH B ;SAVE TYPE IN B MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE EXPRESSION POP B ;RESTORE TYPE OF LEFT SIDE IN B POP H ;GET ADDRESS CPI 1 ;TEST IF RT SIDE IS STRING JZ LTSR MOV A,B CPI 2 JZ ER8 ;BOTH SIDES MUST BE SAME TYPE CALL CHK1 JC PTFIN ;IT WAS A PUT CALL AM2HL ;COPY TO ADDRESS JMP IEND ;CONTINUE PTFIN: CALL FIXD ;FIX VALUE TO BE PUT LXI H,FREG1 ;COPY VALUE TO FREG1 CALL AM2HL XCHG 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 LTSR: MOV A,B CPI 2 JNZ ER8 ;BOTH SIDES MUST BE STRINGS CALL STD2H ;COPY STRING JMP IEND ER10: MVI A,10H JMP ERROR ; ; IF STMT. PROCESSOR ; IFRT: LHLD CPNT ;GET PNTR., ADJUST CALL ICP7 MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE EXPRESSION STA VTYPE ;SAVE TYPE CPI 1 ;IS VALUE A STRING JNZ IFRT2 ;NO,VALUE IS NUMBER PUSH D ;SAVE DE,HL PUSH H LXI D,SREG2 LXI H,SREG1 CALL STD2H ;MOVE STRING TO SREG1 POP H POP D JMP IFRT3 ;GET DELIMITER IFRT2: MOV A,C ORA A ;CHECK EOL JZ ER7 XCHG ;SAVE HL CALL AM2SP ;PUT VALUE ON 8080 STACK XCHG ;RESTORE HL IFRT3: 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 MOV A,C ;CHECK FOR EOL ORA A JZ ER7 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 MOV A,C ;CHECK FOR EOL ORA A JZ ER7 POP PSW ;GET SECOND RELATION ADD B ;ADD THEM PUSH PSW ;AND SAVE CPI 10Q ;TEST FOR == JZ ER14 ; ; AT THIS POINT: ; RELATION IS STORED ON TOP OF STACK (PUSH PSW) ACCORDING TO ; THE FOLLOWING ; ; 1 => < ; 2 => > ; 3 => <> ; 4 => = ; 5 => <= ; 6 => >= ; RELAT: MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE CPI 1 ;2ND VALUE A STRING? JZ IFST1 ;YES LDA VTYPE ;GET TYPE OF 1ST VALUE CPI 1 JZ ER8 ;BOTH MUST BE SAME JMP RELA2 ;BOTH ARE NUMBERS IFST1: LDA VTYPE CPI 1 ;TEST TYPE OF 1ST VALUE JNZ ER8 ;BOTH MUST BE SAME XTHL PUSH H ;PUT HL PTR UNDER OLD TOP OF ST. LXI D,SREG1 LXI H,SREG2 CALL STCMP ;COMPARE SREG1 AND SREG2 MOV D,A ;SAVE RESULT POP PSW ;GET RELATION JMP RELA3 ;TEST IF REL IS TRUE OR FALSE RELA2: POP PSW ;GET RELATION XCHG ;SAVE HL CALL SP2AM ;PUT ON 1ST OPERAND PUSH D ;SAVE HL PUSH PSW ;SAVE RELATION CALL FCOMP ;COMPARE NUMBERS MOV D,A ;SAVE RESULT IN D POP PSW ;GET RELATION,B,C RELA3: 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 ; ; COMPARES STRING POINTED TO BY DE, HL ; RETURNS RESULT IN A REG. ; A=1 -> DE DE>HL ; A=4 -> DE=HL ; STCMP: PUSH B ;SAVE BC LDAX D CMP M ;COMPARE LENGTHS OF STRINGS PUSH PSW ;SAVE LENGTH COMPARISON INX D ;SKIP OVER LEN INFO MOV B,M INX H STCLP: LDAX D ;GET CJAR FROM DE CMP M ;COMPARE TO HL CHAR JNZ STCND ;UNEQUAL STRINGS INX D ;BUMP PTRS INX H DCR B ;DECR CNT JNZ STCLP ;NOT DONE YET POP PSW ;CHECK LENGTHS JNZ STCN2 ;UNEQUAL LENGTHS MVI A,4 ;STRING EQUAL POP B ;RESTORE BC RET STCND: POP B ;GET RID OF LENGTH COMPARISON STCN2: POP B ;RESTORE BC MVI A,1 ;SET A=1 RC ;RET IF DEHL ; ; ROUTINE FCOMP COMPARES 2 FLOATING POINT #'S.THEY ARE ASSUMED ; TO BE ON THE AM9511 STACK (THE SECOND OPND PUSHED 1ST) ; THE VALUE RETURNED IN REG A IS RESULT OF COMPARISON. ; RESULTS ARE AS FOLLOWS: ; ; A=1 => OPND1 < OPND2 ; A=2 => OPND1 > OPND2 ; A=4 => OPND1 = OPND2 ; FCOMP: CALL FSUB ;SUBRTRACT OPNDS (OPND2-OPND1) CALL STATUS ;GET STATUS OF RESULT JZ COMP4 JP COMP1 ;SET A TO CORRECT VALUE MVI A,2 RET COMP1: MVI A,1 RET COMP4: MVI A,4 RET ; ; CALL PROCESSOR ; CALLP: LXI H,IEND ;INIT RETURN ADDRESS PUSH H LHLD CPNT ;INIT POINTERS CALL ICP7 MOV A,M ;GET CHAR CPI '(' ;IS IT A (? JNZ ER7 ;BAD CALL ICP7 ;BUMP PNTRS CALL CVB ;GET SUB CALL DADHL ;UPDATA H,L PUSH H ;SAVE HL LHLD USUB ;GET START OF SUB TABLE NUSUB: MOV A,M ;GET ENTRY CMP D ;COMPARE JZ FNDSB ;FOUND IT INX H ;PNT TO NEXT ENTRY INX H INX H INR A ;CHECK TO SEE IF LAST WAS 377Q JNZ NUSUB MVI A,15H ;ER 15 - NO SUB BY THIS # JMP ERROR FNDSB: INX H ;FOUND IT,GET STARTING ADD. MOV E,M INX H MOV H,M MOV L,E ;AND SAVE IT SHLD SBSAV LXI H,0 ; INITIALIZE TEMP VAR NAMES SHLD MESCR POP H ;GET SOURCE PNTR BACK PARLP: MOV A,M ;GET CHAR CPI ')' ;IS IT )? JZ CLSUB ;YES - GO CALL SUB CPI ',' ;DO WE HAVE A ,? JNZ ER6 ;UEXPECTED CHARACTER CALL ICP7 ;BUMP PNTRS PUSH H PUSH B CALL VAR ;DO WE HAVE A VARIABLE JNC PREXR ;NO MOV A,M ; TEST IF ACTUALLY AN EXPR. CPI ')' JZ PREXV CPI ',' JNZ PREXX PREXV: POP PSW POP PSW PUSH D ;YES - SAVE ADDRESS JMP PARLP ;CONTINUE PREXX: POP B POP H JMP PREXP PREXR: POP PSW POP PSW PREXP: MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE EXPRESSION PUSH B ; SAVE C-REG PUSH H ;SAVE H,L CPI 1 ;TEST FOR STRING CONSTANT JZ PARMST ;YES IT IS MVI B,'%' ; GENERATE NUMERIC NAME LDA MESCR INR A STA MESCR MOV C,A CALL FSYM CALL AM2HL ;AND COPY TO IT PCONT: POP D ;HL TO DE POP B ; RESTORE C-REG PUSH H ;SAVE ADDRESS XCHG ;GET H,L BACK JMP PARLP ;CONTINUE PARMST: MVI B,'$' ; GENERATE TEMP STRING VAR LDA MESCR+1 INR A STA MESCR+1 MOV C,A CALL FSYM CALL STD2H ;COPY STRING JMP PCONT ;STD2H RETURNS LEN IN A CLSUB: LHLD SBSAV ;START OF ROUTINE PCHL ;TRANSFER ; ; GOSUB PROCESSOR ; GOSUB: LXI H,ILOOP ;FOR RETURN STMT. PUSH H ;TO STACK LHLD KFPNT ;PNTR. TO NEXT STMT. PUSH H ;SAVE ON STACK LHLD NXTSP ;CHECK MEMORY CALL MEMFUL LHLD CPNT ;GET CHAR. PNTR JMP GSENT ;PART OF GOTO TO FINISH ; ; RETURN STMT. PROCESSOR ; RETRN: POP H ;GET RETURN ADD. FROM STACK RET ;CONTINUE ; ; FOR STATEMENT PROCESSOR ; FOR: LHLD CPNT ;FIX PNTRS CALL ICP7 CALL ALPHA ;LETTER? JNC ER21 ;NO MOV B,M ;GET IT TO B CALL ICP7 ;BUMP PNTR'S MOV D,C ;SAVE C MVI C,0 ;INIT C TO 0 CALL NUMB ;NUMBER? JNC NOTNUM ;NO MOV C,M ;YES, GET IT INX H ;BUMP PNTR'S DCR D JZ ER7 ;PREMATURE EOL NOTNUM: PUSH H ;SAVE H,L CALL FSYM ;GET VAR. LOCATION XTHL ;PUT ON STACK, GET H,L MOV E,C ;VARIABLE TO D,E MOV C,D ;RESTORE C MOV D,B XCHG ;SAVE VAR NAME SHLD VNAME XCHG ;RESTORE H,L MOV A,M ;LOOK FOR = CPI '=' JNZ ER16 CALL ICP7 ;BUMP PNTR'S MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE EXPRESSION XTHL ;VARIABLE LOCATION CALL AM2HL ;WRITE VALUE SHLD VLOC ;SAVE PNTR TO VARIABLE LOCATION POP H ;GET H,L BACK MOV A,C ;CHECK EOL ORA A JZ ER7 MVI A,2 ;CHECK FOR 'TO' CALL SYMSRT CPI 7 JNZ ER17 MOV A,C ;CHECK EOL ORA A JZ ER7 MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;EVALUATE LIMIT PUSH H ;SAVE H,L LXI H,FLIMT ;SAVE LIMIT VALUE CALL AM2HL MOV A,C ;CHECK EOL ORA A JNZ STP LXI H,FONE ;DEFAULT STEP = 1 CALL HL2AM ;PUT ON AM9511 POP H ;RESTORE H,L JMP FBILD STP: POP H ;GET H,L MVI A,2 ;LOOK FOR 'STEP' CALL SYMSRT CPI 8 JNZ ER17 MOV A,C ;TEST FOR EOL ORA A JZ ER7 MVI B,0 ;SET INITIAL PRECEDENCE CALL EVAL ;GET STEP SIZE ; ; AT THIS POINT: ; VARIABLE NAME IS IN LOCATION VNAME ; VARIABLE ADDRESS IS IN LOCATION VLOC ; VARIBLE HAS BEEN INITIALIZED ; LIMIT IS IN 4 BYTE LOCATION FLIMT ; STEP IS ON THE TOP OF THE AM9511 STACK ; H,L,C ARE POINTER, COUNTER AS USUAL ; FBILD: LHLD VNAME ;GET VARIABLE NAME MVI A,77Q ;MASK ANA H ;MASK OFF TOP 2 BITS MOV B,A ;SET UP TO CALL FSYM MOV C,L CALL FSYM ;FIND ENTRY JC FEXST ;IT WAS THERE PUSH H ;IT WASN'T, SAVE H,L LHLD NXTSP ;UPDATE NXTSP MVI A,8 ;ADD 8 TO H,L CALL DADHL SHLD NXTSP ;NEW VALUE OF NXTSP CALL MEMFUL ;CHECK MEMORY POP H ;GET ADD. IN DATA BLOCK FEXST: CALL AM2HL ;STORE STEP SIZE INX H ;PNT TO WHERE VAR. PNTR GOES INX H INX H INX H LDA VLOC ;FIRST BYTE MOV M,A ;STORE IT INX H LDA VLOC+1 ;SECOND BYTE MOV M,A INX H ;PNT TO WHERE LIMIT GOES LXI D,FLIMT ;WHERE IT IS NOW CALL COPDH ;COPY IT INX H ;PNT TO WHERE KFPNT GOES INX H INX H INX H LDA KFPNT ;1ST BYTE MOV M,A INX H LDA KFPNT+1 ;2ND BYTE MOV M,A ; PUT CURRENT VNAME ON NESTING STACK LXI H,0 ;GET STACK-POINTER DAD SP SHLD VLOC ;SAVE IT LHLD NEST ;GET NEST SP MOV A,L ;COMPARE WITH STACK LIMIT CPI TOPNS AND 377Q ;NEED ONLY COMPARE PAGE LOCATION JZ ER18 ;FOR'S NEXTED TOO DEEPLY SPHL ;LOAD NEW SP XCHG ;SAVE NEST SP LHLD VNAME ;GET INDEX NAME PUSH H ;SAVE IT DCX D ;UPDATE NEST SP DCX D XCHG ;SAVE IT SHLD NEST LHLD VLOC ;RESTORE OLD SP SPHL JMP IEND ;ALL DONE ; ; NEXT STATEMENT PROCESSOR ; NEXT: LHLD CPNT ;FIX PNTR'S CALL ICP7 CALL ALPHA ;LETTER? JNC ER21 ;NO, ERROR MOV B,M ;YES, GET IT CALL BUMP ;INCR PTRS (IF C=0, ALL SET FOR FSYM) JZ NEXT1 CALL NUMB ;NUMBER? JNC ER21 ;NO, ERROR MOV D,M ;YES, GET IT CALL BUMP ;SHOULD BE EOL JNZ ER21 MOV C,D ;RESTORE C NEXT1: LXI H,0 ;GET SP DAD SP SHLD VLOC ;SAVE IT LHLD NEST ;GET NEST SP MOV A,L ;COMPARE WITH BOTTOM CPI BOTNS AND 377Q JZ ER19 ;NEXT BEFORE FOR SPHL ;LOAD SP POP H ;GET LAST INDEX MOV A,B ;COMPARE TO CURRENT CMP H JNZ ER20 ;NESTING ERROR MOV A,C CMP L JNZ ER20 LHLD VLOC ;ALL OK, RESTORE OLD SP SPHL MVI A,77Q ;MASK ANA B ;MASK OUT TOP 2 BITS MOV B,A CALL FSYM ;FIND SYMBOL CALL HL2AM ;PUT STEP ON AM9511 MVI A,2 CALL XCHF CALL XCHF CALL STATUS JM NEXT2 MVI A,1 ;SET A=2 IF STEP NEG, ELSE A=1 NEXT2: STA VLOC MVI A,4 ;PT TO VARIABLE PTR CALL DADHL MOV E,M INX H MOV D,M INX H PUSH H ;SAVE DATA BLOCK PNTR. XCHG CALL HL2AM ;PUT VARIABLE ON AM9511 CALL FADD ;ADD STEP TO VARIABLE CALL PTOF ;MAKE TWO COPIES OF RESULT CALL AM2HL ;COPY TO VARIABLE POP H ;PNT TO LIMIT CALL HL2AM PUSH H ;SAVE DATA BLOCK PNTR CALL FCOMP ;COMPARE LXI H,VLOC ;COMPARE WITH STEP TYPE CMP M POP H ;GET DATA BLOCK PNTR. JZ NXTDN ;YES => 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 ER9: MVI A,9 JMP ERROR 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: LHLD VLOC ; REESTABLISH STACK-POINTER SPHL MVI A,20H ;NESTING ERROR, 'FOR'-'NEXT' JMP ERROR ER21: MVI A,21H ;BAD INDEX IN FOR-NEXT JMP ERROR ; ; ; ROUTINE TO DUMP OUTPUT BUFFER TO TTY. WRIT: MVI D,0 WRIT1: PUSH PSW PUSH H PUSH B LXI H,OBUFF ;GET OBUFF ADDR. PUSH H LDA IOFLAG ORA A ;TEST FOR ZERO JNZ WRTIO ;GO USE QUITT TO WRITE MOV C,M ;GET NUMB. OF CHAR. DCR C ;IS OBUFF EMPTY JZ W2 INX H W1: MOV A,M ;MOVE CHAR. CALL SEND ;PRINT INX H ;MOVE TO NEXT CHAR. DCR C JNZ W1 DCR D JZ W2 MVI A,15Q ;PUT OUT CR. LF. CALL SEND ;PRINT MVI A,12Q CALL SEND ;PRINT W2: POP H MVI M,1 POP B POP H POP PSW RET WRTIO: LXI H,IOFLAG ;PUT ADDR OF IOFLAG IN HL WRLOP: CALL QUITT ;USE QUITT TO DO PRINT MOV A,M ;GET IOFLAG CPI 7 JNC WRLOP ;LOOP WHILE IOFLAG < 7 JMP W2 ; ; FILL BUFFER ; HL=PTR TO LEN OF INPUT BUFFER ; RETURNS WITH BUFFER LENGTH IN B, CY=0 MEANS DONE, ; CY=1 MEANS MORE TO COME ; BFILL: PUSH H CALL CHAR2 POP H RC ;RETURN IF CANNOT GET CHAR BFILX: PUSH H ;ENTRY WHEN CHAR ALREADY HAD PUSH PSW ;SAVE START OF STMT AND CHAR MOV A,M ;GET LEN MOV B,A ;SAVE LEN INX H CALL DADHL ;PT TO NEXT LOC IN BUFFER CALL MEMFUL POP PSW ;GET CHAR AGAIN CPI 0DH ;CR? JZ BFDONE CPI 0AH ;LF? JZ BFMORE CPI 0CH ;FF? JZ BFMORE CPI 0 ;NULL? JZ BFMORE CPI 7FH ;RUBOUT? (CHAR DELETE) JZ BFCHAR CPI 19H ;CONTROL Y? (LINE DELETE) JZ BFLINE CPI 13H ;CONTROL S JZ STOPS BFSTORE: MOV M,A ;PUT CHAR IN BUFF CALL ECHO INR B ;INCR LEN MOV A,B CPI 70 ;IS LEN OF LINE>=70 JZ BFDONE BFMORE: POP H MOV M,B ;STORE LEN STC ;INDICATE MORE TO COME RET BFCHAR: MVI A,5FH ;BACK ARROW '_' JMP BFSTORE BFLINE: MVI A,5CH ;BACK SLASH ' ' JMP BFSTORE BFDONE: MVI A,0DH MOV M,A ;PUT CR IN BUFFER CALL ECHO INX H MVI A,0AH MOV M,A ;PUT LF IN BUFFER CALL ECHO INR B INR B POP H ;PUT LENGTH IN IBUF MOV M,B ORA A ;CLEAR CY TO MEAN DONE RET TTYBF: PUSH D ;SAVE REGS PUSH B PUSH H MVI C,0 INX H ;INITAILIZE CTNR AND PTR MOV D,H MOV E,L ;SET DE=HL BOTH PT TO START TTLOOP: MOV A,M ;GET CHAR INX H CPI 0DH ;CR? JZ TBFDN ;YES, ALL DONE CPI 0AH ;LF? JZ TTLOOP ;IGNOR CPI 5CH ;BACK SLASH ' ' (LINE DELETE) JZ TTLINE CPI 5FH ;BACK ARROW (CHAR DELETE) JZ TTCHAR STAX D ;SAVE CHAR IN BUFFER INX D ;BUMP NEW BUFF PTRS INR C JMP TTLOOP ;REPEAT TTLINE: POP D ;RESET NEW BUFFER PTR TO BEGINNING PUSH D INX D MVI C,0 ;SET LEN TO ZERO JMP TTLOOP ;REPEAT TTCHAR: MOV A,C ORA A ;TEST IF A START OF LINE JZ TTLOOP ;NO CHAR TO DELETE DCX D ;DELETE CHAR BY DECR PTR AND CTR DCR C JMP TTLOOP ;REPEAT TBFDN: POP H ;SAVE LENGTH MOV M,C POP B POP D RET ECHO: PUSH H ;SAVE HL MOV H,A ;SAVE CHAR LDA IOFLAG ORA A ;ONLY ECHO IS NOTHING HAPPENING (0) MOV A,H ;RESTORE CHAR POP H ; AND HL RNZ CALL SEND RET ; CPOS1: MVI A,1 ;SET CPOS TO 1 STA CPOS RET ; ; ;QUITT WILL LOOK FOR CONTROL S AND ALSO HANDLE ;THE SIMULATED INTERRUPT BY MEANS OF A SPECIAL ;FLAG CALLED IOFLAG. THE VALUES THAT THE FLAG TAKES ;ON AND THE MEANING IS GIVEN BELOW. ; ;IOFLAG MEANING ; 0 NOTHING HAPPENING ; 1 OUTPUT A ? (START OF PROMPT) ; 2 OUTPUT SPACE ; 3 WAIT FOR INPUT TO START ; 4 INPUTTING ; 5 DUMP INPUT BUFFER WHILE INPUTTING ; 6 DUMP INPUT BUFFER (INPUT COMPLETE) ; 7 PRINT ; 8 PRINTING WHILE WAITING FOR INPUT ; 9 PRINTING WHILE INPUTTING ; 10 PRINTING WHILE INPUTTING BUT INPUT COMPLETE ; 11 PRINTING THEN DO PROMPT ; 12 PRINTING THEN DO ERROR ON INPUT MESSAGE ; 13 PRINT AFTER ? ; 14 PRINT AFTER SPACE ; 15 PRINT AFTER RETURN ; 16 PRINT AFTER LINE FEED ; 17 PRINT AFTER INPUT COMPLETE ; 18 PRINT AFTER INPUT COMPLETE, CURRENTLY ; DUMPING INPUT BUFFER ; 19 PRINT AFTER INPUT COMPLETE, CURRENTLY ; DUMPING INPUT BUFFER BUT INPUT IS ; COMPLETE ; QUITT: PUSH PSW ;SAVE A LDA IOFLAG ;GET I/O FLAG ORA A JNZ IOTST ;SOMETHING HAPPENING, GO TEST CNTRS: CALL CHAR2 ;TRY TO GET INPUT CHAR JC TOUT ;NO CHAR INPUT CPI 13H ;IS IT A CNTRL S JZ STOPS ;YES, STOP EXECUTION TOUT: POP PSW ;RESTORE A RET IOTST: PUSH B ;SAVE ALL REGS PUSH D PUSH H LXI H,IODNE ;SET RETURN ADDR TO IODNE PUSH H ADD A ;DOUBLE IOFLAG LXI H,IOTAB ;GET START OF IOFLAG TABLE CALL DADHL ;CALC JUMP TABLE ADDR MOV A,M INX H MOV H,M MOV L,A PCHL ;TRANSFER TO IO OPER. IOTAB: DW CNTRS ;IOFLAG=0 DW IOF1 ;IOFLAG=1 DW IOF2 ;ETC. FOR DESCIPTIONS DW IOF3 ;OF IOFLAG VALUES SEE DW IOF4 ;QUITT COMMENTS DW IOF5 DW IOF6 DW IOF7 DW IOF8 DW IOF9 DW IOF10 DW IOF11 DW IOF12 DW IOF13 DW IOF14 DW IOF15 DW IOF16 DW IOF17 DW IOF18 DW IOF19 IOF1: MVI A,'?' CALL MSGO ;OUTPUT A ? RC ;NOT ABLE TO MVI A,2 STA IOFLAG ;IOFLAG 1=>2 RET IOF2: MVI A,' ' CALL MSGO ;OUTPUT A SPACE RC MVI A,3 STA IOFLAG ;IOFLAG 2=>3 RET IOF3: CALL CHAR2 RC ;NO CHAR MOV B,A ;SAVE CHAR MVI A,5 STA IOFLAG ;IOFLAG 3=>5 CALL CPOS1 MOV A,B ;RESTORE CHAR TO A LXI H,IBUF MVI M,0 ;SET LEN IBUF TO ZERO CALL BFILX ;ENTER BFILL AFTER CHAR2 JNC IOF4E ;NO CHAR ON INPUT LINE IS AN ERROR RET IOF4: CALL CHAR2 RC MOV B,A MVI A,5 STA IOFLAG ;IOFLAG 4=>5 MOV A,B LXI H,IBUF CALL BFILX RC ;NOT END OF LINE MVI A,6 STA IOFLAG ;IOFLAG 4=>6 RET IOF4X: CALL IOF4S RZ IOF4E: XRA A STA IOFLAG ;ENABLE WRIT TO OUTPUT MESSAGE LXI H,ODAT7 CALL FORM CALL WRIT ;WRITE ERROR MESSAGE MVI A,1 STA IOFLAG ;IOFLAG =>1 FOR PROMPT RET IOF4S: LXI H,IBUF MOV B,M ;K-STRING LEN TO B INX H XCHG ;K-STRING ADDR TO DE LHLD IPVPT ;V-STRING ADDR TO HL LDA IPVLN MOV C,A ;V-STRING LEN TO C CALL STRIN RNZ ;ERROR ON INPUT LHLD IPVAR ;ADDR OF INPUT-PROCEED VAR LXI D,FZERO CALL COPDH ;SET VAR=0 XRA A STA IOFLAG ;IOFLAG 4=>0 RET FZERO: DB 0,0,0,0 ;A FLOATING POINT ZERO ODAT7: DB 24,'INPUT ERROR, TRY AGAIN',0DH,0AH IOF5: CALL IOF5S ;DUMP CHAR FROM INPUT BUFFER JC IOF5I ;DONE IF NO CARRY MVI A,4 STA IOFLAG ;IOFLAG 5=>4 JMP IOF4 ;GO DO INPUT IOF5I: LXI H,IBUF CALL BFILL RC ;NOT END OF LINE YET MVI A,6 STA IOFLAG ;IOFLAG 5=>6 RET IOF5S: LDA CPOS LXI H,IBUF CALL DADHL MOV A,M ;GET CHAR CALL MSGO RC ;NOT ABLE TO OUTPUT LDA CPOS INR A ;UPDATE PTRS STA CPOS LXI H,IBUF ;TEST FOR END DCR A ;PREPARE FOR COMPARISON CMP M RET ;CHECK FOR RESULT AFTER RETURNING IOF6: CALL IOF5S ;OUTPUT INPUT BUFFER RC LXI H,IBUF CALL TTYBF ;DO LINE AND CHAR EDITS JMP IOF4X ;ASSIGN INPUT VALUES IOF7: CALL IOF7S RC CALL IOF7D ;SET PROCEED VAR=0 AND INITIAL OBUFF XRA A STA IOFLAG ;IOFLAG 7=>0 RET IOF7S: LDA CPOS LXI H,OBUFF CALL DADHL MOV A,M ;GET NEXT CHAR CALL MSGO RC ;NOT PRINTED LDA CPOS INR A STA CPOS LXI H,OBUFF CMP M ;TEST IF END OF PRINT LINE RET IOF7D: LHLD PPVAR ;SET PRINT-PROCEED VAR TO ZERO LXI D,FZERO CALL COPDH LXI H,OBUFF ;SET START OF OBUFF TO ONE MVI M,1 RET IOF8: CALL IOF7S ;PRINT CHAR JC IOF8I ;SEE IF INPUT BEING DONE CALL IOF7D ;SET PPVAR AND OBUFF MVI A,3 STA IOFLAG ;IOFLAG 8=>3 JMP IOF3 ;LOOK FOR INPUT IOF8I: CALL CHAR2 RC ;NO INPUT MOV B,A MVI A,9 STA IOFLAG ;IOFLAG 8=>9 MOV A,B ;RESTORE CHAR LXI H,IBUF MVI M,0 ;SET LEN IBUF TO ZERO CALL BFILX ;PROCESS CHAR RC MVI A,12 ;ERROR IN INPUT STA IOFLAG ;IOFLAG =>12 RET IOF9: CALL IOF7S ;PRINT CHAR JC IOF9I ;GO CHECK INPUT CALL IOF7D ;SET PPVAR AND OBUFF MVI A,5 STA IOFLAG ;IOFLAG 9=>5 CALL CPOS1 JMP IOF5 ;BEGIN TO DUMP INPUT BUFFER IOF9I: LXI H,IBUF CALL BFILL ;GET CHAR RC MVI A,10 STA IOFLAG ;IOFLAG 9=>10 RET IOF10: CALL IOF7S ;PRINT RC ;DONE? CALL IOF7D ;SET PPVAR AND OBUFF MVI A,6 STA IOFLAG ;IOFLAG 10=>6 CALL CPOS1 RET IOF11: CALL IOF7S RC CALL IOF7D ;SET PPVAR AND OBUFF MVI A,1 STA IOFLAG ;IOFLAG 11=>1 RET IOF12: CALL IOF7S RC JMP IOF4E ;PRINT ERROR MESSAGE IOF13: MVI A,'?' CALL MSGO RC ;NOT SENT MVI A,14 STA IOFLAG ;IOFLAG 13=>14 IOF14: MVI A,' ' CALL MSGO RC ;NOT SENT MVI A,15 STA IOFLAG ;IOFLAG 14=>15 RET IOF15: MVI A,0DH ;PRINT RETURN CALL MSGO RC ;NOT SENT MVI A,16 STA IOFLAG ;IOFLAG 15=>16 RET IOF16: MVI A,0AH ;PRINT LINE FEED CALL MSGO RC MVI A,8 ;PROMPT DONE NOW PRINT STA IOFLAG ;IOFLAG 16=>8 CALL CPOS1 RET IOF17: CALL CHAR2 ;LOOK FOR CHAR RC ;NONE YET MOV B,A ;SAVE CHAR MVI A,18 STA IOFLAG ;IOFLAG 17=>18 MOV A,B ;RESTORE CHAR LXI H,IBUF ;PREPARE FOR STRING CHAR N BUFF CALL BFILX ;PUT CHAR IN BUFF RC MVI A,19 ;INPUT IS DONE STA IOFLAG ;IOFLAG 17=>19 RET IF17X: CALL IOF4S ;ASSIGN INPUT VALUES JNZ IF17E ;ERROR ON INPUT MVI A,7 STA IOFLAG ;IOFLAG 17=>7 CALL CPOS1 RET IF17E: CALL IOF4E MVI A,13 STA IOFLAG ;IOFLAG 17=>13 RET IOF18: CALL IOF5S JC IF18I MVI A,17 STA IOFLAG ;IOFLAG 18=>17 JMP IOF17 IF18I: LXI H,IBUF CALL BFILL RC MVI A,19 STA IOFLAG ;IOFLAG 18=>19 RET IOF19: CALL IOF5S RC LXI H,IBUF CALL TTYBF ;DO LINE AND CHAR EDITS JMP IF17X ;INPUT COMPLETE IODNE: POP H ;RESTORE ALL REGS POP D POP B POP PSW RET ; ;TTYIN IS THE NORMAL WAY TO FILL A BUFFER TTYIN: MVI M,0 ;INITIALIZE BUFF LEN TTY1: CALL BFILL ;FILL BUFFER JC TTY1 CALL TTYBF ;DO CHAR AND LINE DELETE MOV A,M ;PUT LENGTH IN A AND B MOV B,A RET ; ;TTY INPUT ROUTINE. CARRY INDICATES IF CHAR ;AVAILABLE (CY=1 MEANS NO CHAR). PARITY BIT ;IS REMOVED. ; CHAR2: CALL CMDIN ;TRY AND GET CHAR RC ;RETURN IF NO CHAR ANI 7FH ;MASK OUT PARITY BIT RET ; ;OUTPUT TO TTY, WAITS UNTIL CHAR PRINTED ; SEND: CALL MSGO ;OUTPUT CHAR IN A JC SEND ;WAIT UNTIL CHAR PRINTS RET ; ROUTINE TO INPUT SOURCE LINE FROM HSR. PASSED ADD ; OF FIRST CHAR IN HL. RETURNS LENGTH OF LINE IN REG A ; HSRIN: PUSH H ;SAVE ADDR. MVI B,0 ;INIT. NUMB. OF CHAR. READ JMP PIN1A PIN1: CALL CHAR5 ;GET A CHAR. PIN1A: CPI 31Q ;CNTRL Y? JZ PIN2 CPI 0 ;NULL? JZ PIN1 CPI 177Q ;DEL? JZ PIN3 CPI 12Q ;LF? JZ PIN1 CPI 15Q ;CR? JZ PIN4 INX H ;MOVE TO NEXT SLOT MOV M,A ;GOOD CHAR--STORE IT AWAY INR B CALL MEMFUL ;IS MEM. FULL? JMP PIN1 ;LOOP ON PROCESS PIN3: DCX H ;DELETE THE LAST CHAR. DCR B ;MUST INSURE THE LINE IS NOT EMPTY JP PIN1 PIN2: POP H XRA A ;ZERO A RET PIN4: POP H ;DONE MOV A,B RET ; ; ROUTINE TO OUTPUT TO PUNCH DEVICE ; PUNCH: CALL PROGO ;OUTPUT CHAR TO PUNCH JC PUNCH ;WAIT UNTIL IT GETS OUTPUT RET ; ; ROUTINE TO INPUT CHAR FROM HSR ; CHAR5: CALL PROGI JC CHAR5 ANI 7FH ;BANISH THE PARITY BIT FOREVER RET ; ; ; ENTER INTERPRETER HERE IF USER SOURCE RESIDES IN PROM PROMR: LHLD STAACK ; INITIALIZE STACK-POINTER SPHL LHLD PROM ; PICK UP PROM USER SOURCE LOCATION SHLD STLINE LXI H,VEND ; PICK UP RAM ADDRESS FOR VARIABLE STORAGE SHLD NLINE LXI H,OBUFF ; INITIALIZE OUTPUT BUFFER MVI M,1 LXI H,M1A ; SET UP RETURN ADDRESS IF PUSH H ; PROGRAM HITS A 'STOP' OR 'END' LXI H,GRBFLG ; SET FLAG TO TURN GARBAGE COLLECTION OFF MVI M,1 LXI H,0FFFFH SHLD STSPAC ; SIGNIFY SYMBOL TABLE EMPTY JMP RUN ; R U N T H E I N T E R P R E T E R ; ; ;PWRF RAISES NOS TO THE POWER OF TOS. ;TOS IS ASSUMED TO BE A FLOATING PT INTEGER. PWRF: PUSH H ;SAVE REGS PUSH PSW PUSH D CALL FIXD ;MAKE TOS AN INTEGER LXI H,FREG1 CALL AM2HL ;POP POWER TO FREG INX H INX H MOV D,M ;MOVE 3RD BYTE TO D INX H MOV E,M ;MOVE 4TH BYTE TO E MOV A,D ;TEST IF NUMBER TOO LARGE ORA A JNZ ER13 ;TOO LARGE MOV A,E ;TEST IF POWER IS 0 ORA A JZ ZPOW ;PUT A ONE ON AM9511 LXI H,FREG CALL AM2HL CALL HL2AM ;GET VALUE IN FREG PWRL: DCR E ;LOOP UNTIL POWER = 0 JZ RETPWR ;POWER = POWER-1 CALL HL2AM CALL FMUL ;MULTIPLY JMP PWRL ;REPEAT RETPWR: POP D ;RESTORE REGS POP PSW POP H RET ZPOW: LXI H,0 PUSH H INX H ;SET H=1 PUSH H ;PUT INTEGER 1 ON STACK CALL POPF ;POP OFF VALUE CALL SP2AM ;PUT INTEGER 1 ON AM9511 CALL FLTD ;FLOAT IT JMP RETPWR ;RETURN ER13: MVI A,13H JMP ERROR FPERR: ORA A ;SET FLAGS RZ ;NO ERROR PUSH PSW ;SAVE A XRA A STA IOFLAG ;TURN OFF I/O PROCEEDS CALL WRIT ;DUMP BUFFER POP PSW ;GET A BACK LXI H,WFPER ;RETURN ADDRESS PUSH H ;SAVE ON STACK LXI H,ODA10 ;MESSAGE TABLE RAL ;UNDERFLOW? JC FORM ;YES LXI H,ODAT9 RAL ;OVERFLOW? JC FORM ;YES LXI H,ODAT8 JMP FORM ;NO - ITS ZERODIVIDE WFPER: LXI H,ODAT4 ;MESSAGE TABLE JMP ERRR2 ;PRINT 'IN LINE --' (USE PART OF ERROR) ODAT4: DB 9,' IN LINE ' ODAT8: DB 10,'INDEFINITE' ODAT9: DB 8,'OVERFLOW' ODA10: DB 9,'UNDERFLOW' ; CHECKS IF VALUE IS ZERO ZSTAT: PUSH H PUSH PSW LXI H,AM9511 XRA A ;SET A=0 CMP M ; TEST FOR FOUR ZEROS JNZ ZSTR INX H ZSTFL: CMP M ;ENTRY FOR FLOAT TEST FOR ZERO JNZ ZSTR INX H CMP M JNZ ZSTR INX H CMP M ZSTR: POP H ;GET A INTO H MOV A,H ;RESTORE A POP H ;ZERO FLAG SET TO RESULT RET ZSTAF: PUSH H ;SAVE REGS PUSH PSW LXI H,AM9511 ;SET UP FOR CALL TO ZSTFL XRA A ;SET A=0 JMP ZSTFL ; CHECKS IF VALUE IS POS OR NEG SSTAT: PUSH H PUSH PSW LXI H,AM9511+3 MOV A,M ANI 80H ORA A POP H ;MOVE A INTO H MOV A,H ;RESTORE A WITHOUT DISTURBING PSW POP H RET SISTAT: PUSH H LXI H,AM9511 MOV A,M ANI 80H ORA A POP H RET ;STAUS FOR INTEGERS ISTAT: PUSH B MOV B,A CALL SISTAT ;GET INTEGER SIGN STATUS JP STATP JMP STATM ; MAIN CALL FOR STATUS STATUS: PUSH B MOV B,A ;SET UP PSW IN C REG CALL SSTAT JP STAFP CALL ZSTAF JZ MZ JMP MNZ STAFP: CALL ZSTAF JZ PZ JMP PNZ STATM: CALL ZSTAT JZ MZ MNZ: MVI C,82H ;NEG,NOT ZERO JMP FSTAT MZ: MVI C,0C2H ;NEG,ZERO JMP FSTAT STATP: CALL ZSTAT JZ PZ PNZ: MVI C,2 ;POS,NOT ZERO JMP FSTAT PZ: MVI C,42H FSTAT: PUSH B POP PSW ;USE THE STACK TO SET UP FLAGS IN PSW POP B RET ; SP2AM DESTROYS HL AND VALUE ON STACK. VALUE IS ASSUMED ; TO BE PUSHED ON STACK AS 1ST BYTES 1&2 THEN BYTES 3&4. SP2AM: PUSH PSW PUSH B PUSH D LXI H,8 DAD SP ;HL POINT TO STACK MOV D,M ;GET VALUE INTO REGS BCDE. INX H MOV E,M INX H MOV B,M INX H MOV C,M XCHG ;3&4 BYTES TO HL SHLD FREG1+2 MOV H,B MOV L,C SHLD FREG1 LXI H,FREG1 CALL HL2AM ;PUT ON AM9511 STACK POP D POP B POP PSW ;RESTORE REGS POP H ;DELETE VALUE ON STACK XTHL POP H XTHL RET AM2SP: LXI H,FREG1 CALL AM2HL ;GET VALUE LHLD FREG1 ;GET BYTES 1 &2 PUSH PSW ;EXHHANGE H AND L VALUES MOV A,H MOV H,L MOV L,A POP PSW XTHL ;PUT ON STACK PUSH H ;SAVE RET ADDR LHLD FREG1+2 PUSH PSW ;EXCHANGE H AND L VALUES MOV A,H MOV H,L MOV L,A POP PSW XTHL ;PUT 1ST BYTES ON STACK PUSH H RET ; ; 4 BYTE FIXED ARITHMETIC ; ALL DONE IN FLOATINT PT ; DSUB: CALL FLTD CALL XCHF CALL FLTD CALL XCHF CALL FSUB CALL FIXD RET DMUL: CALL FLTD CALL XCHF CALL FLTD CALL XCHF CALL FMUL CALL FIXD RET DDIV: CALL FLTD CALL XCHF CALL FLTD CALL XCHF CALL FDIV CALL FIXD RET ; THESE ARE SUBROUTINES THAT PROVIDE A MINIMAL ; SET OF STACK OPERATIONS SO THAT SOFTWARE THAT ; WILL USE THE AM9511 CHIP MAY BE TESTED. ; ; ; PUSH TOS TO NOS PTOF: PUSH H PUSH D ;SAVE ALL REGS PUSH B PUSH PSW LXI H,AM9511+11 ;POINTERS LXI D,AM9511+15 MVI B,12 PTOFL: MOV A,M STAX D DCX D DCX H DCR B JNZ PTOFL POP PSW POP B POP D POP H RET ; POP TOS, NOS TO TOS POPF: PUSH H PUSH D PUSH B PUSH PSW LXI H,AM9511+4 LXI D,AM9511 MVI B,12 POPFL: MOV A,M STAX D INX D INX H DCR B JNZ POPFL POP PSW POP B POP D POP H RET ; PUTS DATA ON STACK OF AM9511, PNT IS HL HL2AM: PUSH H PUSH D CALL PTOF LXI D,AM9511 XCHG CALL COPDH POP D POP H RET ; GET DATA FROM AM9511 STACK. PNT IS HL AM2HL: PUSH H PUSH D LXI D,AM9511 CALL COPDH CALL POPF POP D POP H RET ; DOES A FADD FADD: PUSH H PUSH D PUSH B PUSH PSW CALL SETUP CALL LADD CALL SAVEV POP PSW POP B POP D POP H RET ; PREPARES FOR A FLOAT OPERATION SETUP: CALL QUITT ;TEST FOR I/O LXI H,FREG2 CALL AM2HL LXI D,AM9511 LXI H,FREG1 CALL COPDH LXI H,FREG1 MVI B,FREG2 AND 0FFH MVI C,SCR AND 0FFH RET ; SAVES VALUE AFTER A FADD OR FSUB SAVEV: CALL FPERR ;CHECK FOR ERROR LXI D,AM9511 XCHG CALL COPDH RET ; F SUBTRACT FSUB: PUSH H PUSH D PUSH B PUSH PSW CALL SETUP CALL LSUB CALL SAVEV POP PSW POP B POP D POP H RET ; F MULT FMUL: PUSH H PUSH D PUSH B PUSH PSW CALL SETUP CALL LMUL MOV L,C CALL SAVEV POP PSW POP B POP D POP H RET FDIV: PUSH H PUSH D PUSH B PUSH PSW CALL SETUP CALL LDIV MOV L,C CALL SAVEV POP PSW POP B POP D POP H RET ; EXCHANGE TOS AND NOS XCHF: PUSH H PUSH D LXI H,FREG1 LXI D,AM9511 CALL COPDH LXI H,AM9511 LXI D,AM9511+4 CALL COPDH LXI H,AM9511+4 LXI D,FREG1 CALL COPDH POP D POP H RET ; FIX A FLOATING PT NUMBER FIXD: PUSH D PUSH PSW LXI D,AM9511 CALL FIX POP PSW POP D RET ; FLOAT A FIXED NUMBER FLTD: PUSH B PUSH D PUSH H PUSH PSW LXI H,AM9511 LXI D,AM9511+1 MVI C,3 MOV B,M ;THERE IS A NEED TO REARRANGE FLTDL: LDAX D ;THE INTEGER BEFORE FLOATING IT. MOV M,A INX D INX H DCR C JNZ FLTDL MOV M,B LXI H,AM9511 CALL FLOAT POP PSW POP H POP D POP B RET ; CHANGES SIGN FOR SIGNED INTEGER CHSD: PUSH H PUSH PSW LXI H,AM9511 MOV A,M RAL CMC RAR MOV M,A POP PSW POP H RET ; CHANGES SIGN OF FLOATING NUMBER CHSF: PUSH H PUSH PSW LXI H,AM9511+3 MOV A,M RAL CMC RAR MOV M,A POP PSW POP H RET ; ; ; SUBROUTINE LMCP ; ; THIS SUBROUTINE COMPUTES THE CHARACTERISTIC ; FOR THE FLOATING MULTIPLY ROUTINE. ; ; REGISTERS ON EXIT: ; ; A = CONDITION FLAG (SEE ERROR RETURNS) ; D,E = GARBAGE ; B,C,H,L = SAME AS ON ENTRY ; ; REGISTERS ON ENTRY: ; ; (H,B) = ADDRESS OFF MULTIPLICAND ; (H,C) = ADDRESS OF PRODUCT ; (H,L) = ADDRESS OF MULTIPLIER ; LMCP: CALL CFCHE ;SET E=CHAR(H,B), A=CHAR(H,L) ADD E ;ADD TO GET NEW CHARACTERISTIC ;NOW FALL INTO THE ROUTINE ;WHICH CHECKS FOR OVER/UNDERFLOW ;AND STORE CHARACTERTISTIC ; ; ; SBUROUTINE CCHK ; ; THIS SUBROUTINE CHECKS A CHARACTERISTIC IN ; THE ACCUMULATOR FOR OVERFLOW OR UNDERFLOW. ; IT THEN STORES THE CHARACTERISTIC, PRESERVING ; THE PREVIOUSLY COMPUTED MANTISSA SIGN. ; ; REGISTERS ON ENTRY: ; ; (H,L) = ADDRESS OF ONE OPERAND ; (H,B) = ADDRESS OF OTHER OPERAND ; (H,C) = ADDRESS OF RESULT ; A = NEW CHARACTERISTIC OF RESULT ; ; REGISTERS ON EXIT: ; ; A = CONDITION FLAG (SEE ERROR RETURNS) ; D,E = GARBAGE ; B,C,H,L = SAME AS ON ENTRY ; CCHK: ;ENTER HERE TO CHECK CHARACTERISTIC CPI 100Q ;CHECK FOR 0 TO +63 JC STORC ;JUMP IF OKAY CPI 200Q ;CHECK FOR +64 TO +127 JC OFLWC ;JUMP IF OVERFLOW CPI 300Q ;CHECK FOR -128 TO -65 JC UFLWC ;JUMP IF UNDERFLOW STORC: MOV E,L ;SAVE L IN E MOV L,C ;LET L POINT TO RESULT MOV D,A ;SAVE CHARACTERISTIC IN D CALL INCR3 ;STORE CHARACTERISTIC MOV L,E ;RESTORE L RET ;RETURN ; ; SUBROUTINE OFLWC ; ; THIS ROUTINE WRITES A FLOATING POINT OVERFLOW AT (H,C) ; SETS THE CONDITION FLAG, AND RETURNS. ; OFLWC: MOV E,L ;SAVE L IN E MOV L,C ;SET L=CPTR, SO (H,L)=ADDR OF RESULT CALL WOVR ;WRITE OUT OVERFLOW MOV L,E ;RESTORE L RET ;RETURN ; ; SUBROUTINE UFLWC ; ; THIS ROUTINE WRITES A FLOATING POINT UNDERFLOW AT (H,C) ; SETS THE CONDITION FLAG, AND RETURNS. ; UFLWC: MOV E,L ;SAVE L IN E MOV L,C ;SET L=CPTR, SO (H,L)=ADDR OF RESULT CALL WUND ;WRITE OUT UNDEFLOW MOV L,E ;RESTORE L RET ;RETURN ; ; ; SUBROUTINE CSIGN ; ; THIS SUBROUTINE COMPUTES AND STORE THE MANTISSA ; SIGN FOR THE FLOATING MULTIPLY AND DIVIDE ROUTINES ; ; REGISTERS ON ENTRY: ; ; (H,L) = ADDRESS OF ONE OPERAND ; (H,B) = ADDRESS OF OTHER OPERAND ; (H,C) = ADDRESS OF RESULT ; ; REGISTERS ON EXIT: ; ; A,D,E = GARBAGE ; B,C,H,L = SAME AS ON ENTRY ; ; CSIGN: CALL MSFH ;SET A=SIGN(H,L), E=SIGN(H,B) XRA E ;EXCLUSIVE OR SIGNS TO GET NEW SIGN CALL CSTR ;STORE SIGN INTO RESULT RET ;RETURN ; ; ; SUBROUTINE CSTR ; STORES VALUE IN A IN ; CPTR?2 ; PUTS LPTR IN E CSTR: MOV E,L ;SAVE LPTR IN E MOV L,C ;CPTR TO L INR L ;CPTR?2 INR L ;TO L INR L ;/***TP MOV M,A ;STORE ANSWER MOV L,E ;LPTR BACK TO L RET ; ; SUBROUTINE MSFH ; ; THIS SUBROUTINE FETCHES THE SIGNS OF THE MANTISSAS ; OF THE FLOATING POINT NUMBERS POINTED TO BY (H,L) ; AND (H,B) INTO THE A AND E REGISTERS RESPECTIVELY. ; ; REGISTERS ON EXIT: ; ; A = SIGN OF MANTISSA OF (H,L) ; E = SIGN OF MANTISSA OF (H,B) ; B,C,D,H,L = SAME AS ON ENTRY ; MSFH: MOV E,L ;SAVE LPTR MOV L,B ;BPTR TO L INR L ;BPTR?2 INR L ;/***TP INR L ;TO L MOV A,M ;_BPTR?2>TO A ANI 128 ;SAVE MANT SIGN MOV L,E ;LPTR BACK TO L MOV E,A ;STORE BPTR MANT SIGN INR L ;LPTR?2 INR L ;/***TP INR L ;TO L MOV A,M ;_LPTR?2>TO A ANI 128 ;SAVE LPTR MANT SIGN DCR L ;LPTR BACK DCR L ;TO L DCR L ;/***TP RET ; SUBROUTINE BCTL ; MOVES BPTR CHAR TO LPTR CHAR ; DESTROYSE BCTL: MOV E,L ;LPTR TO E MOV L,B ;BPTR TO L INR L ;BPTR ?2 INR L ;/***TP INR L ;TO L MOV A,M ;BPTR CHAR TO A MOV L,E ;LPTR TO L INR L ;LPTR ?2 INR L ;TO L INR L ;/***TP MOV M,A ;STORE BPTR CHAR IN LPTR CHAR MOV L,E ;LPTR TO L RET ; ; ERROR RETURNS ; ; THE FOLLOWING CODE IS USED TO RETURN VARIOUS ; ERROR CONDITIONS.IN EACH CASE A FLOATING POINT ; NUMBER IS STORED IN THE 4 WORDS POINTED TO BY (H,L) ; AND A FLAG IS STORED IN THE ACCUMULATOR. ; ; CONDITION FLAG RESULT (+) RESULT (-) ; ; UNDERFLOW 377 000 000 000 100 000 000 000 300 ; OVERFLOW 177 377 377 377 077 377 377 377 277 ; INDEFINITE 077 377 377 377 077 377 377 377 277 ; NORMAL 000 XXX XXX XXX XXX XXX XXX XXX XXX ; NORMAL ZERO 000 000 000 000 100 (ALWAYS RETURNS +0) ; ; ENTRY POINTS: ; ; WUND - WRITE UNDERFLOW ; WOVR - WRITE OVERFLOW ; WIND - WRITE INDEFINITE ; WZER - WRITE NORMAL ZERO ; ; WRITE UNDERFLOW WUND: MVI D,100Q ;LOAD CHARACTERISTIC INTO D REGISTER CALL WCHAR ;WRITE CHARACTERISTIC MVI A,0 ;LOAD MANTISSA VALUE ;WE ASSUME HERE THAT ALL BYTES ;OF MANTISSA ARE THE SAME CALL WMANT ;WRITE THE MANTISSA MVI A,377Q ;SET ACCUMULATOR TO FLAG ORA A ;SET FLAGS PROPERLY RET ;RETURN (WMANT RESTORED (H,L)) ; ; WRITE OVERFLOW WOVR: MVI D,77Q ;LOAD CHARACTERISTIC INTO D REGISTER CALL WCHAR ;WRITE CHARACTERISTIC OFLW1: MVI A,377Q ;LOAD MANTISSA VALUE ;WE ASSUME HERE THAT ALL BYTES ;OF MANTISSA ARE THE SAME CALL WMANT ;WRITE THE MANTISSA MVI A,177Q ;SET ACCUMULATOR TO FLAG ORA A ;SET FLAGS PROPERLY RET ;RETURN (WMANT RESTORED (H,L)) ; ; WRITE INDEFINITE WIND: MVI D,77Q ;LOAD CHARACTERISTIC INTO D REGISTER CALL WCHAR ;WRITE CHARACTERISTIC MVI A,377Q ;LOAD MANTISSA VALUE ;WE ASSUME HERE THAT ALL BYTES ;OF MANTISSA ARE THE SAME CALL WMANT ;WRITE THE MANTISSA MVI A,77Q ;SET ACCUMULATOR TO FLAG ORA A ;SET FLAGS PROPERLY RET ;RETURN (WMANT RESTORED (H,L)) ; ; WZER: INX H ;WRITE NORMAL ZERO INX H INX H MVI M,100Q ;STORE CHARACTERISTIC FOR ZERO XRA A ;ZERO ACCUMULATOR CALL WMANT ;STORE ZERO MANTISSA ORA A ;SET FLAGS PROPERLY RET ;RETURN ; ; ROUTINE TO WRITE MANTISSA FOR ERROR RETURNS ; WMANT: DCX H ;POINT TO LEAST SIGNIFICANT BYTE ;OF MANTISSA MOV M,A ;STORE LSBYTE OF MANTISSA DCX H ;PNT TO NEXT LEAST SIGNIFICANT BYTE ;OF MANTISSA MOV M,A ;STORE NLSBYTE OF MANTISSA DCX H ;POINT TO MOST SIGNIFICANT BYTE ;OF MANTISSA MOV M,A ;STORE MSBYTE OF MANTISSA RET ;RETURN (H,L) POINTS TO BEGINNING OF ;FLOATING POINT RESULT ; ; ROUTINE TO WRITE CHARACTERTIC FOR ERROR RETURNS ; NOTE: WE PRESERVE ORIGINAL MANTISSA SIGN ; ON ENTRY D CONTAINS NEW CHARACTERTISTIC TO BE STORED. ; WCHAR: INR L ;SET (H,L) TO POINT TO CHARACTERISTIC INR L ;PART OF ABOVE INR L ;PART OF ABOVE MOV A,M ;LOAD CHARACTERISTIC A ;AND MANTISSA SIGN ANI 200Q ;JUST KEEP MANTISSA SIGN ORA D ;OR IN NEW CHARACTERISTIC MOV M,A ;STORE IT BACK RET ;RETURN WITH (H,L) POINT TO CHARACTERISTIC ;OF RESULT ;SOMEONE ELSE WILL FIX UP (H,L) ; ; SUBROUTINE INDFC ; ; THIS ROUTINE WRITES A FLOATING INDEFINITE, SETS ; THIS WRITES WRITES A FLOATING POINT INDEFINITE ; AT (H,C), SETS THE CONDITION FLAG AND RETURNS ; ; INDFC: MOV E,L ;SAVE LPTR IN E MOV L,C ;SET L=CPTR SO (H,L)-ADDR OF RESULT CALL WIND ;WRITE INDEFINITE MOV L,E ;RESTORE L=LPTR RET ;RETURN ; ; ; SUBROUTINE WZERC ; ; THIS ROUTINE WRITES A NORMAL FLAOTING POINT ZERO ; AT (H,C), SETS THE CONDITION FLAG AND RETURNS ; WZERC: MOV E,L ;SAVE LPTR IN E MOV L,C ;SETL=CPTR SO (H,L)=ADDR OF RESULT CALL WZER ;WRITE NORMAL ZERO MOV L,E ;RESTORE L=LPTR RET ;RETURN ; ; SUBROUTINE INCR ; ; THIS SUBROUTINE INCREMENTS THE CHARACTERISTIC ; OF THE FLOATING POINT NUMBER POINTED TO BY (H,L). ; WE TEST FOR OVERFLOW AND SET APPROPRIATE FLAG. ; (SEE ERRROR RETURNS). ; ; REGISTERS ON EXIT: ; ; A = CONDITION FLAG (SEE ERROR RETURNS) ; D = CLOBBERED ; B,C,H,L = SAME AS ON ENTRY ; INCR: CALL GCHAR ;GET CHAR WITH SIGN EXTENDED CPI MAXCH ;COMPARE WITH MAX CHAR PERMITTED JZ OFLW1 ;INCREMENT WOULD CAUSE OVERFLOW MOV D,A ;/SAVE IT IN D INR D ;/INCREMENT IT JMP INCR2 ;JUMP AROUND ALTERNATE ENTRY POINT INCR3: INR L ;COME HERE TO STORE CHARACTERISTIC INR L ;POINT (H,L) TO CHAR INR L ;POINT (H,L) TO CHAR INCR2: MVI A,177Q ANA D ;/KILL SIGN BIT MOV D,A ;/BACK TO D MOV A,M ;/NOW SIGN IT ANI 200Q ;/GET MANTISSA SIGN ORA D ;/PUT TOGETHER MOV M,A ;/STORE IT BACK DCR L ;/NOW BACK TO BASE DCR L ;/***TP DCR L SCCFG: XRA A ;SET SUCCESS FLAG RET ; ; SUBROUTINE AORS ; RETURN S[1 IF BASE ?6 ; HAS A 1 IN MSB AORS: MOV E,L ;SAVE BASE MOV L,C ;BASE ?6 TO L MOV A,M ;LOAD IT ORA A ;SET FLAGS MOV L,E ;RESTORE BASE RET ; SUBROUTINE TSTR ; CHECKS C PTR TO SEE IF ; NLSB[1 ; RETURNS Z[1 IF NOT ; DESTROYS E,D TSTR: MOV E,L ;SAVE BASE MOV L,C ;C PTR TO L MVI D,2 ;MASK TO D MOV A,M ;LOAD VALUE MOV L,E ;RESTORE BASE ANA D ;AND VALUE WITH MASK RET ; SUBROUTINE ACPR ; STORES A IN LOCATION OF CPTR ; LPTR IN E ACPR: MOV E,L ;SAVE LPTR MOV L,C ;CPTR TO L MOV M,A ;STORE A MOV L,E ;RESTORE BASE RET ; SUBROUTINE DCMP ; COMPARES TWO DOUBLE LENGTH ; WORDS DCMP: MOV A,M ;NUM MANTA TO A MOV E,L ;SAVE BASE IN E MOV L,B ;BASE?3 TO L CMP M ;COMPARE WITH DEN MANTA MOV L,E ;RETURN BASE TO L RNZ ;RETURN IF NOT THE SAME INR L ;L TO NUM MANTB MOV A,M ;LOAD IT MOV L,B ;DEN MANTB ADD TO L INR L ;BASE? 4 TO L CMP M MOV L,E RNZ ;/***TP EXTENSION INR L ;/NOW CHECK BYTE 3 INR L MOV A,M ;/GET FOR COMPARE MOV L,B INR L INR L ;/BYTE 3 NOW CMP M ;/COMPARE MOV L,E ;/***TP - ALL DONE RET ; SUBROUTINE DIVC ; PERFORMS ONE CYCLE OF DOUBLE ; PRECISION FLOATING PT DIVIDE ; ENTER AT ENT1 ON FIRST CYCLE ; ENTER AT ENT2 ALL THEREAFTER ENT2: CALL DLST ;SHIFT MOVING DIVIDEND JC OVER ;IF CARRY[1,NUM.GT.D ENT1: CALL DCMP ;COMPARE NUM WITH DEN JNC OVER ;IF CARRY NOT SET,NUM.GE.DEN RET OVER: CALL DSUB2 ;CALL DOUBLE SUBTRACT MOV E,L ;SAVE BASE IN E MOV L,C ;BASE ?6 TO L INR L ;BASE ?7 TO L INR L ;/***TP MOV A,M ADI 1 ;ADD 1 MOV M,A ;PUT IT BACK MOV L,E ;RESTORE BASE TO L RET ; SUBROUTINE LXFR ; MOVES CPTR TO EPTR ; MOVES 3 WORDS IF ENTER AT LXFR LXFR: MVI D,4 ;/MOVE 4 WORDS REP5: MOV L,C ;CPTR TO L MOV A,M ;_CPTR> TO A MOV L,E ;EPTR TO L MOV M,A INR C ;/INCREMENT C INR E ;/INCREMENT E TO NEXT DCR D ;/TEST FOR DONE JNZ REP5 ;/GO FOR FOR TILL D=0 MOV A,E ;/NOW RESET C AND E SUI 4 ;/RESET BACK BY 4 MOV E,A ;/PUT BACK IN E MOV A,C ;/NOW RESET C SUI 4 ;/BY 4 MOV C,A ;/BACK TO C RET ;/DONE ; ; SUBROUTINE LDCP ; ; THIS SUBROUTINE COMPUTES THE CHARACTERISTIC ; FOR THE FLOATING DIVIDE ROUTINE ; ; REGISTERS ON EXIT: ; ; A = CONDITION FLAG (SEE ERROR RETURNS) ; D,E = GARBAGE ; B,C,H,L = SAME AS ON ENTRY ; ; REGISTERS ON ENTRY: ; ; (H,B) = ADDRESS OFF DIVISOR ; (H,C) = ADDRESS OF QUOTIENT ; (H,L) = ADDRESS OF DIVIDEND ; LDCP: CALL CFCHE ;SET E=CHAR(H,B), A=CHAR(H,L) SUB E ;SUBTRACT TO GET NEW CHARACTERISTIC JMP CCHK ;GO CHECK FOR OVER/UNDERFLOW ;AND STORE CHARACTERTISTIC ; SUBROUTINE DCLR ; CLEARS TWO SUCCESSIVE ; LOCATIONS OF MEMORY DCLR: XRA A MOV M,A INR L MOV M,A INR L ;/***TP EXTENSION MOV M,A ;/***TP ZERO 3 DCR L ;/***TP - ALL DONE DCR L RET ; /*****ALL NEW DSUB2 - SHORTER*** ; SUBROUTINE DSUB2 ; DOUBLE PRECISION SUBTRACT DSUB2: MOV E,L ;SAVE BASE IN E INR L ;/***TP EXTENSION INR L ;/START WITH LOWS MOV A,M ;/GET ARG MOV L,B ;/NOW SET UP TO SUB INR L INR L SUB M ;/NOW DO IT MOV L,E ;/NOW MUST PUT IT BACK INR L INR L MOV M,A ;/PUT BACK DCR L ;/***TP - ALL DONE MOV A,M ;/GET LOW OF LOP MOV L,B ;/SET TO BOP INR L ;/SET TO BOP LOW SBB M ;/GET DIFF. OF LOWS MOV L,E ;/SAVE IN LOP LOW INR L ;/TO LOP LOW MOV M,A ;/INTO RAM DCR L ;/BACK UP TO LOP HIGH MOV A,M ;/GET LOP HIGH MOV L,B ;/SET TO BOP HIGH SBB M ;/SUB. WITH CARRY MOV L,E ;/SAVE IN LOP HIGH MOV M,A ;/INTO RAM RET ;/ALL DONE - MUCH SHORTER ; ; SUBROUTINE GCHAR ; ; THIS SUBROUTINE RETURNS THE CHARACTERISTIC OF ; THE FLOATING POINT NUMBER POINTED TO BY (H,L) ; IN THE A REGISTER WITH ITS SIGN EXTENDED INTO THE ; LEFTMOST BIT. ; ; REGISTERS ON EXIT: ; ; A = CHARACTERISTIC OF (H,L) WITH SIGN EXTENDED ; L = (ORIGINAL L) + 3 ; B,C,D,E,H = SAME AS ON ENTRY ; GCHAR: INR L ;MAKE (H,L) POINT TO CHAR INR L ;MAKE (H,L) POINT TO CHAR INR L ;MAKE (H,L) POINT TO CHAR MOV A,M ;SET A=CHAR + MANTISSA SIGN ANI 177Q ;GET RID OF MANTISSA SIGN BIT ADI 100Q ;PROPAGATE CHAR SIGN INTO LEFTMOST BIT XRI 100Q ;RESTORE ORIGINAL CHAR SIGN BIT RET ;RETURN WITH (H,L) POINTING TO THE ;CHAR = ORIGINAL (H,L)+3 ;SOMEONE ELSE WILL CLEAN UP ; ; ; SUBROUTINE CFCHE ; ; THIS SUBROUTINE RETURNS THE CHARACTERISTICS OF THE ; FLOATING POINT NUMBERS POINTED TO BY (H,L) AND ; (H,B) IN THE A AND E REGISTERS RESPECTIVELY, ; WITH THEIR SIGNS EXTENDED INTO THE LEFTMOST BIT. ; ; REGISTERS ON EXIT: ; ; A = CHARACTERISTIC OF (H,L) WITH SIGN EXTENDED ; E = CHARACTERISTIC OF (H,B) WITH SIGN EXTENDED ; B,C,H,L = SAME AS ON ENTRY ; D = A ; CFCHE: MOV E,L ;SAVE LPTR IN E MOV L,B ;SET L = BPTR CALL GCHAR ;GET CHAR(H,B) WITH SIGN EXTENDED IN A MOV L,E ;RESTORE L = LPTR MOV E,A ;SET E=CHAR(H,B) WITH SIGN EXTENDED CALL GCHAR ;SET A=CHAR(H,L) WITH SIGN EXTENDED DCR L ;RESTORE L = LPTR DCR L ;RESTORE L = LPTR DCR L ;RESTORE L = LPTR MOV D,A ;SET D=A=CHAR(H,L) WITH SIGN EXTENDED RET ; ; ; SUBROUTINE CCMP ; ; THIS SUBROUTINE COMPARES THE CHARACTERISTICS OF ; FLOATING POINT NUMBERS POINTED TO BY (H,L) AND (H,B). ; THE ZERO FLIP-FLOP IS SET IF CHAR(H,L) EQUALS ; CHAR(H,B).IF CHAR(H,L) IS LESS THAN CHAR(H,B) THEN ; THE CARRY BIT WILL BE SET. ; ; REGISTERS ON EXIT: ; ; A = CHARACTERISTIC OF (H,L) WITH SIGN EXTENDED ; E = CHARACTERISTIC OF (H,B) WITH SIGN EXTENDED ; D = A ; B,C,H,L = SAME AS ON ENTRY ; CCMP: CALL CFCHE ;FETCH CHARACTERTISTICS WITH SIGN EXTENDED ;INTO A (CHAR(H,L)) AND E (CHAR(H,B)) REGISTERS MOV D,A ;SAVE CHAR (H,L) SUB E ;SUBTRACT E (CHAR(H,B)) RAL ;ROTATE SIGN BIT INTO CARRY BIT MOV A,D ;RESTORE A=CHAR(H,L) RET ;RETURN ; ; ;*************************************************** ; //// MULTIPLY SUBROUTINE ;*************************************************** ; ; SUBROUTINE LMUL ; FLOATING POINT MULTIPLY ; L PTR X B PTR TO C PTR ; LMUL: CALL CSIGN ;COMPUTE SIGN OF RESULT AND STORE IT CALL ZCHK ;CHECK FIRST OPERAND FOR ZERO JZ WZERC ;ZERO * ANYTHING = ZERO CALL BCHK ;CHECK SECOND OPERAND FOR ZERO JZ WZERC ;ANYTHING * ZERO = ZERO MOV E,L ;SAVE L PTR MOV L,C ;C PTR TO L CALL DCLR ;CLR PRODUCT MANT LOCS MOV L,E ;L PTR TO L MVI D,24 ;LOAD NUMBER ITERATIONS KPGO: CALL DRST ;SHIFT L PTR RIGHT JC MADD ;WILL ADD B PTR IF C[1 MOV A,L ;INTERCHANGE MOV L,C ;L AND MOV C,A ;C PTRS INTR: CALL DRST ;SHIFT PRODUCT OVER MOV A,L ;INTERCHANGE MOV L,C ;L AND C PTRS_BACK TO MOV C,A ;ORIGINAL> DCR D JNZ KPGO ;MORE CYCLES IF Z[0 CALL AORS ;TEST IF RESULT IS NORMALIZED JM LMCP ;IF NORMALIZED GO COMPUTE CHAR MOV E,L ;SAVE LPTR IN E MOV L,C ;SET L=CPTR CALL DLST ;LEFT SHIFT RESULT TO NORMALIZE MOV L,E ;RESTORE LPTR CALL CFCHE ;OTHERWISE SET A=CHAR(H,L), E=CHAR(H,B) ADD E ;CHAR(RESULT) = CHAR(H,L) + CHAR(H,B) CPI 200Q ;CHECK FOR SMALLEST NEGATIVE NUMBER JZ UFLWC ;IF SO THEN UNDERFLOW SUI 1 ;SUBTRACT 1 TO COMPENSATE FOR NORMALIZE CALL CCHK ;CHECK CHARACTERISTIC AND STORE IT RET ;RETURN ; MADD: MOV A,L ;INTERCHANGE MOV L,C ;L AND MOV C,A ;C PTRS CALL DADD2 ;ACCUMULATE PRODUCT JMP INTR ; ; SUBROUTINE NORM ; ; THIS SUBROUTINE WILL NORMALIZE A FLOATING POINT ; NUMBER, PRESERVING ITS ORIGINAL SIGN. ; WE CHECK FOR UNDERFLOW AND SET THE CONDITION ; FLAG APPROPRIATELY. (SEE ERROR RETURNS). ; THER IS AN ENTRY POINT TO FLOAT A SIGNED INTEGER ; (FLOAT) AND AN ENTRY POINT TO FLOAT AN UNSIGNED ; INTEGER. ; ; ENTRY POINTS: ; ; NORM - NORMALIZE FLOATING PT NUMBER AT (H,L) ; FLOAT - FLOAT TRIPLE PRECISION INTEGER AT (H,L) ; PRESERVING SIGN BIT IN (H,L)+3 ; DFXL - FLOAT UNSIGNED (POSITIVE) TRIPLE PRECISION ; AT (H,L) ; ;REGISTERS ON EXIT: ; ; A = CONDITION FLAG (SEE ERROR RETURNS) ; D,E = GARBAGE ; B,C,H,L = SAME AS ON ENTRY ; NORM: MOV E,L ;SAVE L IN E CALL GCHAR ;GET CHAR(H,L) IN A WITH SIGN EXTENDED MOV D,A ;SAVE CHAR IN D MOV L,E ;RESTORE L FXL2: CALL ZMCHK ;CHECK FOR ZERO MANTISSA JZ WZER ;IF ZERO MANTISSA THEN ZERO RESULT REP6: MOV A,M ;GET MOST SIGNIFICANT BYTE OF ;MANTISSA ORA A ;SET FLAGS JM SCHAR ;IF MOST SIGNFICANT BIT = 1 THEN ;NUMBER IS NORMALIZED AND WE GO TO ;STORE THE CHARACTERISTIC MOV A,D ;OTHERWISE CHECK FOR UNDERFLOW CPI MINCH ;COMPARE WITH MINIMUM CHAR JZ WUND ;IF EQUAL THEN UNDERFLOW CALL DLST ;SHIFT MANTISSA LEFT DCR D ;DECREMENT CHARACTERSTIC JMP REP6 ;LOOP AN TEST NEXT BIT SCHAR: JMP INCR3 ;STORE THE CHARACTERISTIC USING ;THE SAME CODE AS THE INCREMENT ; DFXL: MOV E,L ;ENTER HERE TO FLOAT UNSIGNED ;INTEGER ;FIRT SAVE L IN E INR L ;MAKE (H,L) POINT TO CHAR INR L ;MAKE (H,L) POINT TO CHAR INR L ;MAKE (H,L) POINT TO CHAR XRA A ;ZERO ACCUMULATOR MOV M,A ;STORE A PLUS (+) SIGN MOV L,E ;RESTORE L FLOAT: MVI D,24 ;ENTER HERE TO FLOAT INTEGER ;PRESERVING ORIGINAL SIGN IN (H,L)+3 ;SET UP CHARACTERISTIC JMP FXL2 ;GO FLOAT THE NUMBER ; ; ; SUBROUTINE ZCHK ; ; THIS ROUTINE SETS THE ZERO FLAG IF IT DETECTS ; A FLOATING ZERO AT (H,L). ; ; SUBROUTINE ZMCHK ; ; THIS ROUTINE SETS THE ZERO FLAG IF IT DETECTS A ; ZERO MANTISSA AT (H,L) ; ZCHK: ZMCHK: INR L ;SET L TO POINT LAST BYTE OF MANTISSA INR L ;SET L TO POINT TO LAST BYTE OF MANTISSA MOV A,M ;LOAD LEAST SIGNIFICANT BYTE DCR L ;L POINTS TO MIDDLE BYTE ORA M ;OR WITH LEAST SIGNFICANT BYTE DCR L ;L POINTS TO MOST SIGNFICANT BYTE ;OF MANTISSA (ORIGINAL VALUE) ORA M ;OR IN MOST SIGNFICANT BYTE RET ;RETURNS WITH ZERO FLAG SET APPROPRIATELY ; ; SUBROUTINE BCHK ; ; THIS ROUTINE CHECKS (H,B) FOR FLOATING PT ZERO ; BCHK: MOV E,L ;SAVE LPTR IN E MOV L,B ;SET L=BPTR CALL ZCHK ;CHECK FOR ZERO MOV L,E ;RESTORE L=LPTR RET ;RETURN ; ; ; SUBROUTINE DLST ; SHIFTS DBL WORD ONE PLACE LF DLST: INR L INR L ;/***TP MOV A,M ;LOAD IT ORA A ;KILL CARRY RAL ;SHIFT IT LEFT MOV M,A ;STORE IT DCR L MOV A,M ;LOAD IT RAL ;SHIFT IT LEFT ; IF CARRY SET BY FIRST SHIFT ; IT WILL BE IN LSB OF SECOND MOV M,A DCR L ;/***TP EXTENSION MOV A,M RAL MOV M,A ;/***ALL DONE TP RET ; SUBROUTINE DRST ; SHIFTS DOUBLE WORD ONE PLACE ; TO THE RIGHT ; DOES NOT AFFECT D DRST: MOV E,L ;/***TP MODIFIED RIGHT SHIFT TP MOV A,M ;LOAD FIRST WORD RAR ;ROTATE IT RIGHT MOV M,A ;STORE IT INR L ;/*** TP MOV A,M ;LOAD SECOND WORD RAR ;SHIFT IT RIGHT MOV M,A ;STORE IT INR L ;/*** TP EXTENSION MOV A,M RAR MOV M,A MOV L,E ;/***TP - ALL DONE TP RET ; ; COMPANION FILE FOR BAS80 ; CONTAINS FLOATING POINT ROUTINES AND SOME ; UTILITY ROUTINES. ; ; ////FLOATING POINT PACKAGE FOR THE MCS8 ; ////BY DAVID MEAD ; ////MODIFIED BY HAL BRAND 9/6/74 ; ////MODIFIED FOR 24 BIT MANTISSAS*********** ; ////PLUS ADDED I/O CONVERSION ROUTINES ; ////NEW ROUTINE COMMENTS ; ////ARE PRECEEDED BY / ; ////OTHER CHANGES ARE NOTED BY ** ; ////MODIFIED BY FRANK OLKEN 6/28/75 ; ; ORG 2200H ; MINCH EQU 300Q ;MINIMUM CHARACTERISTIC WITH SIGN EXTENDED MAXCH EQU 077Q ;MAXIMUM CHARACTERISTIC WITH SIGN EXTENDED ; ;****************************************************** ; //// DIVIDE SUBROUTINE ;****************************************************** ; LDIV: CALL CSIGN ;COMPUTE SIGN OF RESULT CALL ZCHK ;CHECK IF DIVIDEND = ZERO JNZ DTST2 ;IF DIVIDEND .NE. 0 CHECK DIVISOR CALL BCHK ;CHECK FOR ZERO/ZERO JZ INDFC ;ZERO/ZERO = INDEFINITE JMP WZERC ;ZERO/NONZERO = ZERO DTST2: CALL BCHK ;COME HERE IF DIVIDEND .NE. 0 JZ OFLWC ;NONZERO/ZERO = OVERFLOW ;IF WE GET HERE, THINGS LOOK OKAY MOV E,L ;SAVE BASE IN E MOV L,C ;BASE?6 TO L CALL DCLR ;CLEAR QUOTIENT MANTISSA SLOT MOV L,E ;RESTORE BASE IN L CALL ENT1 ;DO FIRST CYCLE MOV L,C ;BASE ?6 TO L CALL DLST ;MOVE QUOTIENT OVER ONE PLACE MVI D,23 ;NUMBER OF ITERATIONS TO D REP3: MOV L,E CALL ENT2 DCR D ;DEC D JZ GOON MOV A,L MOV L,C ;BASE?6 TO L MOV C,A CALL DLST ;MOVE QUOTIENT MANT OVER MOV A,L ;CPTR TO A MOV E,C ;LPTR TO E MOV C,A ;CPTR TO C JMP REP3 ; GOON: CALL AORS ;CHECK IF RESULT IS NORMALIZED JM CRIN MOV A,L ;LPTR TO A MOV L,C ;CPTR TO L MOV C,A ;LPTR TO C CALL DLST ;SHIFT QUOTIENT LEFT MOV C,L MOV L,E CALL LDCP ;COMPUTE THE CHARACTERISTIC OF RESULT RET ; CRIN: CALL CFCHE ;GET A=CHAR(H,L), E=CHAR(H,B) SUB E ;NEW CHAR = CHAR(DIVIDEND) - CHAR(DVISIOR) CPI 177Q ;CHECK MAX POSITIVE NUMBER JZ OFLWC ;JUMP ON OVERFLOW ADI 1 ;ADD 1 SINCE WE DID NOT LEFTSHIFT CALL CCHK ;CHECK AND STORE CHARACTERISTIC RET ;RETURN ; ; ; ;****************************************************** ; //// ADDITION SUBROUTINE ;****************************************************** ; ; LADD: XRA A ;/***SET UP TO ADD JMP LADS ;/NOW DO IT ; ; ;****************************************************** ; //// SUBTRACTION SUBROUTINE ;****************************************************** ; ; LSUB: MVI A,200Q ;/****SET UP TO SUBTRACT ; SUBROUTINE LADS ; FLOATING POINT ADD OR SUB ; A[128 ON ENTRY[SUB ; A[0 ON ENTRY[ADD ; F-S[F,FIRST OPER DESTROYED ; BASE ?11 USED FOR SCRATCH LADS: CALL ACPR ;SAVE ENTRY PNT AT BASE ?6 CALL BCHK ;CHECK ADDEND/SUBTRAHEND = ZERO RZ ;IF SO, RESULT=ARG SO RETURN ;THIS WILL PREVENT UNDERFLOW INDICATION ON ;ZERO + OR - ZERO CALL CCMP JZ EQ02 ;IF EQUAL, GO ON MOV D,A ;SAVE LPTR CHAR IN D JC LLTB SUB E ;L.GT.B IF HERE ANI 127 MOV D,A ;DIFFERENCE TO D MOV E,L ;SAVE BASE IN E MOV L,C ;C PTR TO L INR L ;C PTR?1 TO L MOV M,E ;SAVE BASE IN C PTR?1 MOV L,B ;B PTR TO L JMP NCHK LLTB: MOV A,E ;L.LT.B IF HERE,BPTR TO A SUB D ;SUBTRACT LPTR CHAR FROM BPTR CHAR ANI 127 MOV D,A ;DIFFERENCE TO D NCHK: MVI A,24 CMP D JNC SH10 MVI D,24 SH10: ORA A CALL DRST DCR D JNZ SH10 MOV A,L CMP B JNZ EQ02 ;F.GT.S IF L.NE.B MOV L,C ;C PTR TO L INR L ;C PTR?1 TO L MOV L,M ;RESTORE L EQ02: CALL LASD ;CHECK WHAT TO CALL ACPR ;SAVE ANSWER CPI 2 ;TEST FOR ZERO ANSWER JNZ NOT0 JMP WZER ;WRITE FLOATING ZERO AND RETURN ; NOT0: MVI D,1 ;WILL TEST FOR SUB ANA D JZ ADDZ ;LSB[1 INPLIES SUB CALL TSTR ;CHECK NORMAL/REVERSE JZ SUBZ ;IF NORMAL,GO SUBZ MOV A,L ;OTHERWISE REVERSE MOV L,B ;ROLES MOV B,A ;OF L AND B ; SUBZ: CALL DSUB2 ;SUBTRACT SMALLER FROM BIGGER CALL MANT ;SET UP SIGN OF RESULT CALL TSTR ;SEE IF WE NEED TO INTERCHANGE ;BPTR AND LPTR JZ NORM ;NO INTERCHANGE NECESSARY, SO NORMALIZE ;AND RETURN MOV A,L ;INTERCHANGE MOV L,B ;L MOV B,A ;AND B MOV A,C ;CPTR TO A MOV C,B ;BPTR TO C MOV E,L ;LPTR TO E MOV B,A ;CPTR TO B CALL LXFR ;MOVE_BPTR> TO _LPTR> MOV A,B MOV B,C MOV C,A MOV L,E JMP NORM ;NORMALIZE RESULT AND RETURN ; ; COPY THE LARGER CHARACTERISTIC TO THE RESULT ; ADDZ: CALL CCMP ;COMPARE THE CHARACTERISTICS JNC ADD2 ;IF CHAR(H,L) .GE. CHAR(H,B) CONTINUE CALL BCTL ;IF CHAR(H,L) .LT. CHAR(H,B) THE COPY ;CHAR(H,B) TO CHAR(H,L) ADD2: CALL MANT ;COMPUTE SIGN OF RESULT CALL DADD2 ;ADD MANTISSAS JNC SCCFG ;IF THERE IS NO OVFLW - DONE CALL DRST ;IF OVERFLOW SHIFT RIGHT CALL INCR ;AND INCREMENT CHARACTERISTIC RET ;ALL DONE, SO RETURN ; ; THIS ROUTINE STORES THE MANTISSA SIGN IN THE RESULT ; THE SIGN HAS PREVIOUSLY BEEN COMPUTED BY LASD. ; MANT: MOV E,L ;SAVE L PTR MOV L,C ;C PTR TO L MOV A,M ;LOAD INDEX WORD ANI 128 ;SCARF SIGN MOV L,E ;RESTORE L PTR INR L ;L PTR?2 INR L INR L ;TO L MOV E,A ;SAVE SIGN IN E MOV A,M ANI 127 ;SCARF CHAR ADD E ;ADD SIGN MOV M,A ;STORE IT DCR L ;RESTORE DCR L DCR L ;L PTR RET ; ; ; SUBROUTINE LASD ; UTILITY ROUTINE FOR LADS ; CALCULATES TRUE OPER AND SGN ; RETURNS ANSWER IN LASD: CALL MSFH ;FETCH MANT SIGNS, F IN A,D CMP E ;COMPARE SIGNS JC ABCH ;F?,S- MEANS GO TO A BRANCH JNZ BBCH ;F- S? MEANS GO TO B BRANCH ADD E ;SAME SIGN IF HERE, ADD SIGNS JC BMIN ;IF BOTH MINUS, WILL OVERFLOW CALL AORS ;BOTH POS IF HERE JP L000 ;IF AN ADD, LOAD 0 COM1: CALL DCMP ;COMPARE F WITH S JC L131 ;S.GT.F,SO LOAD 131 JNZ L001 ;F.GT.S,SO LOAD 1 L002: MVI A,2 ;ERROR CONDITION, ZERO ANSWER RET BMIN: CALL AORS ;CHECK FOR ADD OR SUB JP L128 ;ADD, SO LOAD 128 COM2: CALL DCMP ;COMPARE F WITH S JC L003 ;S.GT.F,SO LOAD 3 JNZ L129 ;FGT.S.SO LOAD 129 JMP L002 ;ERROR ABCH: CALL AORS ;FT,S- SO TEST FOR A/S JM L000 ;SUBTRACT, SO LOAD 0 JMP COM1 ;ADD, SO GO TO DCMP BBCH: CALL AORS ;F-,S?,SO TEST FOR A/S JM L128 ;SUB JMP COM2 ;ADD L000: XRA A RET L001: MVI A,1 RET L003: MVI A,3 RET L128: MVI A,128 RET L129: MVI A,129 RET L131: MVI A,131 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 INT: CALL FIXD CALL ISTAT JM INT2 ;NEGATIVE INTEGER CALL FLTD RET INT2: LXI H,0 ;SUBRTACT ONE PUSH H LXI H,1 PUSH H CALL SP2AM CALL DSUB CALL FLTD RET SQR: RET SIN: RET COS: RET TAN: RET ASN: RET ;NONE OF THESE FUNCTIONS ARE AVAILABLE YET ACN: RET ATN: RET EXP: RET LOG: RET LGT: RET ;LOG BASE 10 RANDOM: RET ; ; ; ROUTINE FORMT USED FOR FORMATTED OUTPUT. ; IT IS ASSUMED THAT THE FOLLOWING REGISTERS ARE SET BEFORE ; CALLING: ; REG. B CONTAINS THE FIELD WIDTH ; REG. C CONTAINS THE FRACTION FIELD WIDTH, ; FOR E OR F FORMAT ; THE TWO HIGH ORDER BITS OF REG C ALSO CONTAIN A ; CODE INDICATING THE TYPE OF FORMAT: ; 00 = I ; 01 = F ; 10 = E ; ; FORMT ALSO USES THE HIGH ORDER BITS OF REG C TO INDICATE ; THAT *'S HAVE BEEN PRINTED BECAUSE OF THE FIELD WIDTH NOT ; BEING LARGE ENOUGH. 11 IS THE ERROR CODE. ; ; THE NUMBER TO BE PRINTED IS STORED AS A FLOATING POINT NUMBER ; ON THE TOP OF THE AM9511 STACK. ; ; THE CONTENTS OF ALL REGISTERS AND THE AM9511 STACK ARE DESTROYED. ; FORMT: MVI E,' ' ;SET PAD CHARACTER TO BLANK ; TYPE I, E, OR F? MOV A,C ANI 0C0H ;SELECT TOP TWO BITS OF REG C ORA A JZ CALLI ;TYPE I IS DETECTED (00) SUI 40H ;CHECK FOR TYPE F JZ CALLF ;TYPE F IS DETECTED (01) CALL EFORM ;TYPE E IS ASSUMED RET CALLI: CALL ROUND CALL IFORM RET CALLF: CALL ROUND CALL FFORM RET ; ROUTINE IFORM OUTPUTS AN INTEGER ; REG B = FIELD WIDTH ; REG E = PAD CHARACTER (0 OR BLANK) ; IFORM IS CALLED BY FFORM AND EFORM TO OUTPUT ; INTEGRAL AND FRACTIONAL PART OF A NUMBER. ; THE HIGH ORDER BITS OF REG C ARE SET TO 11 IF THE FIELD ; WIDTH IS TOO SMALL. ; THE VALUE TO BE PRINTED IS A FLOATING POINT NUMBER ; AT THE TOP OF THE AM9511 STACK. ; IFORM: ; FOLLOWING TWO OPS SET STATUS OF 'TOS' CALL XCHF CALL XCHF CALL STATUS JP IFOR1 CALL CHSF ; MAKE 'TOS' POSITIVE MOV A,E ORI 80H ; SET HIGH ORDER BIT OF E-REG MOV E,A ; TO INDICATE NUMBER WAS NEGATIVE IFOR1: CALL FIXD ;CHANGE VALUE TO DOUBLE PRECISION ;FIXED POINT (NV) MOV A,B ;TEST FOR ZERO FIELD WIDTH ORA A RZ ;ZERO SO RETURN WITH NOTHING DONE IFOR2: MVI D,0 ;SET REG D TO ZERO, REG D COUNTS DIGITS NEXTDIG: CALL PTOF ;TOS=NV, NOS=NV CALL PTOF ;TOS=NOS=NNOS=NV CALL DIVTEN ;TOS=NV/10,NOS=NNOS=NV CALL PUTTEN ;PUT 10 ON TOS CALL DMUL ;TOS=(NV/10)*10,NOS=NNOS=NV CALL DSUB ;TOS=NV-(NV/10)*10,NOS=NV CALL AM2SP ;TOS=NV,MOVE 4 BYTES FROM AM STACK ;TO 8080 STACK ;GET DIGIT TO BE PRINTED POP H MOV A,L ;FIRST VALUE POPPED OFF STACK IS THE DIGIT POP H ;FINISH CLEARING STACK ORI 30H ;CHANGE NUMBER TO CHARACTER PUSH PSW ;SAVE CHARACTER TO PRINT INR D ;COUNT NUMBER OF DIGITS CALL DIVTEN ;NEXT VALUE(NV)=LAST VALUE/10,PUT ON TOS CALL ISTAT ;CHECK TO SEE IF NV=0 JNZ NEXTDIG ;NV NOT 0, MORE DIGITS ;NO MORE DIGITS MOV A,E ORA A ;CHECK FOR NEGATIVE SIGN JP WIDTH MVI A,'-' ;PUT NEGATIVE SIGN ON STACK PUSH PSW ;AND INR D ;COUNT AS DIGIT WIDTH: MOV A,B ;REG A NOW CONTAINS FIELD WIDTH SUB D ;REG A = FIELD WIDTH - NUMBER OF DIGITS JP OUTPUT ;WIDTH>=NUMBER OF DIGITS, OUTPUT NUMBER ;WIDTH=FIELD WIDTH NODIG: MVI A,'*' ;REG B=FIELD WIDTH, OUTPUT *'S CALL PAD MOV A,C ;SET ERROR BITS ORI 0C0H MOV C,A RET ;ERROR RETURN FROM FFORM ; ; ROUTINE TO MAKE TOS=TOS*10**REG C FPOWER: MOV A,C ;TEST IF C<=0 ORA A RM ;RETURN IF C<=0 RZ PUSH B ;SAVE C FPOWLOOP: CALL FPUTTEN ;PUSH A 10 ON AM9511 CALL FMUL ;MULTIPLY DCR C JNZ FPOWLOOP ;WHILE C NOT 0 REPEAT POP B ;RESTORE C RET ; ; ; ROUTINE TO ROUND VALUE ON TOP OF AM9511 STACK ROUND: PUSH B ; SAVE BC. DE NOT CHANGED. A,HL DESTROYED CALL XCHF CALL XCHF CALL STATUS ; GET SIGN OF INPUT SO ROUNDING PUSH PSW ; IS DONE CORRECTLY AND SAVE ON STACK MOV A,C ; GET FRACTIONAL WIDTH FROM C-REG ANI 3FH MOV C,A LXI H,TWO ; PUT A TWO ON THE STACK CALL HL2AM CALL FPOWER ; 2*10**(C-REG). INVERSE OF ROUNDING TERM LXI H,FONE ; INVERT TOS CALL HL2AM CALL XCHF CALL FDIV POP PSW ; RETRIEVE SIGN OF INPUT JP ROUN1 CALL FSUB ; ROUND NEGATIVE INPUT JMP ROUN2 ROUN1: CALL FADD ; ROUND POSITIVE INPUT ROUN2: POP B RET TWO: DB 80H,0,0,2 ; ; ; ROUTINE EFORM OUTPUTS DATA IN E-FORMAT EFORM: MOV A,B SUI 4 ;REG A = WIDTH - 4 MOV B,A ;NEW WIDTH LEAVES ROOM FOR EXXX MVI D,0 ;SET REG D TO 0, D WILL CONTAIN EXPONENT CALL STATUS ;CHECK TO SEE IF NEGATIVE JZ EZERO ;ZERO IS A SPECIAL CASE JP POSNUM CALL CHSF ;CHANGE TO POSITIVE MOV A,E ORI 80H MOV E,A ;SET REG E TO INDICATE NEGATIVE POSNUM: PUSH D ;SAVE REG E CALL CHEKTEN ;MAKE VALUE LESS THAN 10 CALL CHEKONE ;MAKE VALUE>=1 CALL ROUND ; ROUND VALUE CALL CHEKTEN ; VALUE MAY HAVE BEEN ROUNDED OVER 10 ;CHANGE VALUE BACK TO NEGATIVE, IF NECESSARY POP H ;REG L CONTAINS SAVED REG E PUSH D ;SAVE REG D (CONTAINS EXPONENT) XRA A ORA L ;CHECK FOR NEGATIVE IN E REG (NOW REG L) JP OUTMAIN ;POSITIVE NUMBER, OUTPUT IT CALL CHSF ;NEGATIVE NUMBER, CHANGE BACK TO NEGATIVE OUTMAIN: CALL FFORM ;OUTPUT NUMBER POP D ;RESTORE REGISTER D MOV A,C ANI 0C0H ;SEE IF * PRINTED JZ EXPONENT ;NO *, SO OUTPUT EXPONENT MVI A,'*' ;OUTPUT 4 MORE *'S MVI B,4 CALL PAD RET ;ERROR END OF EFORM EZERO: MOV L,E PUSH D ;SAVE EXPONENT JMP OUTMAIN ;GO OUTPUT NUMBER EXPONENT: MVI A,'E' MVI B,1 CALL PAD ;PRINT E XRA A ;ZERO REG A ORA D ;CHECK TO SEE IF REG D (EXPONENT) IS NEG JP EXPOS MVI A,'-' ;EXPONENT IS NEGATIVE MVI B,1 CALL PAD ;OUTPUT NEGATIVE SIGN XRA A SUB D ;REG A = ABS(REG D) MOV D,A ;REG D IS POSITIVE JMP EXOUT EXPOS: MVI A,' ' ;EXPONENT IS A POSITIVE NUMBER MVI B,1 CALL PAD ;OUTPUT A BLANK IN SIGN POSITION EXOUT: LXI H,0 PUSH H MOV L,D PUSH H CALL SP2AM ;DOUBLE PRECISION EXPONENT ON AM STACK MVI E,'0' ;SET PAD CHARACTER TO ZERO MVI B,2 ;WIDTH OF FIELD FOR EXPONENT IS 2 CALL IFOR2 ;OUTPUT INTEGER FORMAT RET ;NORMAL END OF EFORM ; ; ; ROUTINE TO SEE IF VALUE IS <10 ; DIVIDE BY 10 UNTIL IT IS AND COUNT NUMBER OF DIVIDES FOR EXPONENT CHEKTEN: CALL PTOF ;SAVE VALUE (V) CALL FPUTTEN ;TOS=10,NOS=NV,NNOS=V CALL FSUB ;TOS=NV-10,NOS=V CALL STATUS ;SEE IF NEGATIVE PUSH PSW CALL POPF ;DISCARD NV-10, TOS=V POP PSW RM ;DONE IF NEGATIVE CALL FPUTTEN ;DIVIDE V BY FLOATING POINT 10 CALL FDIV ;TOS=TOS/10 INR D ;COUNT EXPONENT JMP CHEKTEN ; ; ; ROUTINE TO INSURE VALUE IS >=1 ; MULT BY 10 UNTIL IT IS AND COUNTS NUMBER OF MULTIPLIES FOR NEGATIVE EXPONENT CHEKONE: CALL PTOF ;SAVE VALUE(V) CALL FIXD ; IF VALUE IS LESS THAN 1 CONVERTING CALL ISTAT ; TO INTEGER IS ZERO. LOOP UNTIL NOT 0 PUSH PSW CALL POPF ;DISCARD NV, TOS=V POP PSW RNZ ;DONE IF NV-1 IS >=0 CALL FPUTTEN CALL FMUL ;MULTIPLY V BY FLOATING POINT 10 DCR D ;COUNT NEGATIVE EXPONENT JMP CHEKONE ; ; ; ROUTINE TO PUT FLOATING POINT 10 ON TOS FPUTTEN: LXI H,0A000H PUSH H LXI H,4 PUSH H CALL SP2AM RET ; ; ; ROUTINE TO DUMP BINARY NUMBER TO USER THROUGH FLOATING PNYT. PACKAGE. DNUMB: LXI B,0 PUSH B MOV E,M INX H MOV D,M XCHG PUSH H CALL SP2AM PUSH D CALL FLTD LXI B,600H CALL FORMT POP H RET ; ; ; SUBROUTINE DADD2 ADDS TWO DOUBLE PRECISION WORDS, C[1 IF THERE IS OVRFLW DADD2: MOV E,L ;SAVE BASE IN E MOV L,B ;BASE ?3 TO L INR L ;BASE ?4 TO L INR L ;/***TP MOV A,M ;LOAD S MANTB MOV L,E ;BASE TO L INR L ;BASE ?1 TO L INR L ;/***TP ADD M ;ADD TWO MANTB?S MOV M,A ;STORE ANSWER MOV L,B ;/***TP EXTENSION INR L MOV A,M MOV L,E INR L ADC M MOV M,A ;/***TP - ALL DONE MOV L,B ;BASE ?3 TO L MOV A,M ;MANTA OF S TO A MOV L,E ;BASE TO L ADC M ;ADD WITH CARRY MOV M,A ;STORE ANSWER RET ; ; ; MISCELLANEOUS NUMBER CONVERSION SUBROUTINES ; MULTT: MVI E,1 ;/MULT. BY 10 (START WITH X2) CALL LSFT ;/LEFT SHIFT 1 = X2 MOV L,C ;/SAVE X2 IN "RESULT" DCR L ;/SET TO TOP OF NUMBER MOV A,C ;/SET C TO RESULT ADI 11Q MOV C,A ;/NOW C SET RIGHT MOV A,H ;/SHOW RAM TO RAM TRANSFER CALL COPY ;/SAVE X2 FINALLY MOV A,C ;/MUST RESET C SUI 11Q ;/BACK TO NORMAL MOV C,A MVI E,2 ;/NOW GET (X2)X4=X8 MOV L,C ;/BUT MUST SAVE OVERFLOW DCR L CALL TLP2 ;/GET X8 MOV L,C ;/SET UP TO CALL DADD2 MOV A,C ;/SET B TO X2 ADI 12Q ;/TO X2 MOV B,A CALL DADD2 ;/ADD TWO LOW WORDS DCR L ;/BACK UP TO OVERFLOW MOV A,M ;/GET IT MOV L,B ;/NOW SET TO X2 OVERFLOW DCR L ;/ITS AT B-1 ADC M ;/ADD WITH CARRY - CARRY WAS PRESERVED RET ;/ALL DONE, RETURN OVERFLOW IN A LSFT:;MOV L,C ;/SET PTR FOR LEFT SHIFT OF NUMBER DCR L ;/BACK UP TO OVERFLOW XRA A ;/OVERFLOW=0 1ST TIME TLOOP: MOV M,A ;/SAVE OVERFLOW TLP2: DCR E ;/TEST FOR DONE RM ;/DONE WHEN E MINUS INR L ;/MOVE TO LOW INR L INR L ;/***TP EXTENSION MOV A,M ;/SHIFT LEFT 4 BYTES RAL MOV M,A ;/PUT BACK DCR L ;/***TP - ALL DONE MOV A,M ;/GET LOW RAL ;/SHIFT LEFT 1 MOV M,A ;/RESTORE IT DCR L ;/BACK UP TO HIGH MOV A,M ;/GET HIGH RAL ;/SHIFT IT LEFT WITH CARRY MOV M,A ;/PUT IT BACK DCR L ;/BACK UP TO OVERFLOW MOV A,M ;/GET OVERFLOW RAL ;/SHIFT IT LEFT JMP TLOOP ;/GO FOR MORE GETA: INR L ;/MOVE TO IT INR L INR L ;/***TP MOV A,M ;/FETCH INTO A RET ;/DONE MORD: CALL GETEX ;/MUL OR DIV DEPENDING ON EXP MOV E,A ;/SAVE DECIMAL EXP MOV B,L ;/SET UP TO MULT OR DIV INR B ;/NOW BOP POINTER SET MOV L,C ;/L POINTS TO NUMBER TO CONVERT MOV A,C ;/POINT C AT "RESULT" AREA ADI 11Q ;/IN SCRATCH MOV C,A ;/NOW C SET RIGHT MOV A,E ;/NOW TEST FOR MUL ANI 200Q ;/TEST NEGATIVE DEC. EXP. JZ DIVIT ;/IF EXP IS + THEN DIVIDE CALL LMUL ;/MULT. FINUP: MOV A,C ;/SAVE LOC. OF RESULT MOV C,L ;/C=LOC OF NUMBER (IT WAS DESTROYED) MOV L,A ;/SET L TO LOC. OF RESUTL MOV A,H ;/SHOW RAM TO RAM TRANSFER CALL COPY ;/MOVE RESULT TO NUMBER GETEX: MOV L,C ;/NOW GET DECIMAL EXP INR L JMP GETA ;/USE PART OF GCHR DIVIT: CALL LDIV ;/DIVIDE JMP FINUP COPT: MOV A,C ;/COPY FROM 10^N TO RAM ADI 5 MOV C,A ;/SET C TO PLACE TO PUT MVI A,(TEN5/256) CALL COPY ;/COPY IT MOV A,C ;/NOW RESET C SUI 5 MOV C,A ;/ITS RESET RET COPY: MOV B,H ;/SAVE RAM H MOV H,A ;/SET TO SOURCE H MOV A,M ;/GET 4 WORDS INTO THE REGS. INR L MOV D,M INR L MOV E,M INR L MOV L,M ;/LAST ONE ERASES L MOV H,B ;/SET TO DESTINATION RAM MOV B,L ;/SAVE 4TH WORD IN B MOV L,C ;/SET TO DESTINATION MOV M,A ;/SAVE FIRST WORD INR L MOV A,M ;/SAVE THIS WORD IN A (INPUT SAVES C HERE MOV M,D ;/NOW PUT 2ND WORD INR L MOV M,E INR L MOV M,B ;/ALL 4 COPIED NOW RET ;/ALL DONE ; ; ; ; SCRATCH MAP FOR I/O CONVERSION ROUTINES ; ; RELATIVE TO (C+2)USE ; C-2 DIGIT COUNT ; C-1 OVERFLOW ; C HIGH NUMBER - MANTISSA ; C+1 LOW NUMBER ; C+2 CHARACTERISTIC ; C+3 DECIMAL EXPONEXT (SIGN & MAG.) ; C+4 TEN**N ; C+5 TEN**N ; C+6 TEN**N ; C+7 RESULT OF MULT & DIV ; C+8 AND TEMP FOR X2 ; C+9 " " ; C+10 L FOR NUMBER TO GO INTO (INPUT ONLY) ; C+11 DIGIT JUST INPUT (INPUT ONLY) ; ; ; /*****BEGIN INPUT************* ; ; ERR: STC ;ERROR FLAG RET ;AND RETURN ; ;******************************************************** ; //// 4 1/2 DIGIT INPUT ROUTINE ;******************************************************* ; ; ; /L POINTS TO WHERE TO PUT INPUT NUMBER ; /C POINTS TO 13(10) WORDS OF SCRATCH ; FINPT: MOV B,L ;/SAVE ADDRESS WHERE DATA IS TO GO MOV A,C ;/IN SCRATCH ADI 17Q ;/COMPUTE LOC. IN SCRATCH MOV L,A MOV M,B ;/PUT IT INR C ;/OFFSET SCRATCH POINTER INR C ;/BY 2 CALL ZROIT ;/ZERO NUMBER INR L ;/AND ZERO MOV M,A ;/DECIMAL EXPONENT CALL GNUM ;/GET INTEGER PART OF NUM CPI 376Q ;/TERM=.? JZ DECPT ;/YES TSTEX: CPI 25Q ;/TEST FOR E JZ INEXP ;/YES - HANDLE EXP CPI 360Q ;/TEST FOR SPACE TERM (240B-260B) JNZ ERR ;/NOT LEGAL TERM CALL FLTSGN ;/FLOAT # AND SIGN IT SCALE: CALL GETEX ;/GET DECIMAL EXP ANI 177Q ;/GET GOOD BITS MOV E,A ;/SAVE COPY ANI 100Q ;/GET SIGN OF EXP RLC ;/INTO SIGN BIT ORA A ;/SET FLOPS MOV B,A ;/SAVE SIGN MOV A,E ;/GET EXP BACK JZ APLS ;/JMP IS + MVI A,200Q ;/MAKE MINUS + SUB E ;/NOW ITS + APLS: ADD B ;/SIGN NUMBER MOV M,A ;/SAVE EXP (SIGN & MAG.) MVI L,(TEN5 AND 377Q) ;/TRY MORD WITH 10**5 FIRST CALL COPT ;/TRANSFER TO RAM CALL GETEX ;/GET DECIMAL EXP INT5: ANI 77Q ;/GET MAG. OF EXP CPI 5 ;/TEST FOR USE OF 10**5 JM TRYTN ;/WONT GO - TRY 10 CALL MORD ;/WILL GO SO DO IT SUI 5 ;/MAG = MAG -5 MOV M,A ;/UPDATE DEC. EXP IN MEM JMP INT5 ;/GO TRY AGAIN TRYTN: MVI L,(TEN AND 377Q) ;/PUT TEN IN RAM CALL COPT CALL GETEX ;/SET UP FOR LOOP INT1: ANI 77Q ;/GET MAGNITUDE ORA A ;/TEST FOR 0 JZ SAVEN ;/DONE, MOVE NUM OUT AND GET OUT CALL MORD ;/NOT DONE - DO 10 SUI 1 ;/EXP = EXP -1 MOV M,A ;/UPDATE MEM JMP INT1 ;/TRY AGAIN DECPT: MOV L,C ;/ZERO DIGIT COUNT DCR L ;/SINCE ITS NECESSARY DCR L ;/TO COMPUTE EXP. MVI M,0 ;/ZEROED CALL EP1 ;/GNUM IN MIDDLE MOV E,A ;/SAVE TERMINATOR MOV L,C ;/MOVE DIGIT COUNT TO EXP DCR L ;/BACK UP TO DIGIT COUNT DCR L MOV B,M ;/GOT DIGIT COUNT CALL GETEX ;/SET L TO DEC. EXP MOV M,B ;/PUT EXP MOV A,E ;/TERM BACK TO A JMP TSTEX ;/TEST FOR E+OR-XX INEXP: CALL FLTSGN ;/FLOAT AND SIGN NUMBER CALL SAVEN ;/SAVE NUMBER IN (L) TEMP CALL ZROIT ;/ZERO OUT NUM. FOR INPUTTING EXP CALL GNUM ;/NOW INPUT EXPONENT CPI 360Q ;/TEST FOR SPACE TERM. JNZ ERR ;/NOT LEGAL - TRY AGAIN MOV L,C ;/GET EXP OUT OF MEM INR L ;/***TP INR L ;/EXP LIMITED TO 5 BITS MOV A,M ;/GET LOWEST 8 BITS ANI 37Q ;/GET GOOD BITS MOV B,A ;/SAVE THEM INR L ;/GET SIGN OF EXP MOV A,M ;/INTO A ORA A ;/SET FLOPS MOV A,B ;/INCASE NOTHING TO DO JM USEIT ;/IF NEG. USE AS + MVI A,0 ;/IF + MAKE - SUB B ;/0-X = -X USEIT: INR L ;/POINT AT EXP ADD M ;/GET REAL DEC. EXP MOV M,A ;/PUT IN MEM MOV A,C ;/NOW GET NUMBER BACK ADI 15Q ;/GET ADD OF L MOV L,A ;/L POINTS TO L OF NUMBER MOV L,M ;/NOW L POINTS TO NUMBER MOV A,H ;/RAM TO RAM COPY CALL COPY ;/COPY IT BACK JMP SCALE ;/NOW ADJUST FOR EXP GNUM: CALL INP ;/GET A CHAR CPI ' ' ;/IGNORE LEADING SPACES JZ GNUM CPI '-' ;/TEST FOR - JNZ TRYP ;/NOT MINUS MOV L,C ;/MINUS SO SET SIGN INR L ;/IN CHAR LOC. INR L ;/***TP INR L MVI M,200Q ;/SET - SIGN JMP GNUM TRYP: CPI '+' ;/IGNORE + JZ GNUM TSTN: SUI 60Q ;/STRIP ASCII RM ;/RETURN IF TERM CPI 12Q ;/TEST FOR NUMBER RP ;/ILLEGAL MOV E,A ;/SAVE DIGIT CALL GETN ;/LOC. OF DIGIT STORAGE TO L MOV M,E ;/SAVE DIGIT CALL MULTT ;/MULT NUMBER BY 10 ORA A ;/TEST FOR TOO MANY DIGITS RNZ ;/TOO MANY DIGITS CALL GETN ;/GET DIGIT MOV L,C ;/SET L TO NUMBER INR L INR L ;/***TP ADD M ;/ADD IN THE DIGIT MOV M,A ;/PUT RESULT BACK DCR L ;/NOW DO HIGH MOV A,M ;/GET HIGH TO ADD IN CARRY ACI 0 ;/ADD IN CARRY MOV M,A ;/UPDATE HIGH DCR L ;/***TP EXTENSION MOV A,M ACI 0 ;/ADD IN CARRY MOV M,A ;/***TP ALL DONE RC ;/OVERFLOW ERROR DCR L ;/BUMP DIGIT COUNT NOW DCR L MOV B,M ;/GET DIGIT COUNT INR B ;/BUMP DIGIT COUNT MOV M,B ;/UPDATE DIGIT COUNT EP1: CALL INP ;/GET NEXT CHAR JMP TSTN ;/MUST BE NUM. OR TERM FLTSGN: MOV L,C ;POINT L AT NUMBER TO FLOAT JMP FLOAT ;GO FLOAT IT SAVEN: MOV A,C ;/PUT NUMBER IN (L) ADI 15Q ;/GET ADD OF L MOV L,A MOV E,M ;/GET L OF RESULT MOV L,E ;/POINT L AT (L) INR L ;/SET TO 2ND WORD TO SAVE C MOV M,C ;/SAVE C IN (L) +1 SINCE IT WILL BE DESTROYED MOV L,C ;/SET UP TO CALL COPY MOV C,E ;/NOW L&C SET MOV A,H ;/RAM TO RAM COPY CALL COPY ;/COPY TO L MOV C,A ;/(L)+1 RETURNED HERE SO SET AS C ORA A ;MAKE SURE CY=0 (NO ERROR) RET ;/NOW EVERYTHING HUNKY-DORRY GETN: MOV A,C ;/GET DIGIT ADI 16Q ;/LAST LOC. IN SCRATCH MOV L,A ;/PUT IN L MOV A,M ;/GET DIGIT RET ZROIT: MOV L,C ;/ZERO NUMBER XRA A MOV M,A ;/***TP INR L ;/***TP MOV M,A INR L MOV M,A INR L ;/NOW SET SIGN TO + MOV M,A RET ;/DONE ; ; ;PRINTS THE LINE NUMBER WHERE EXECUTION STOPPED,UNLESS LINE NUMBER IS -1. ;CALLED WHENEVER PROGRAM EXEC IS HALTED WITH A CONTROL S. STOPS: XRA A STA IOFLAG ;TURN OFF ALL PROCEED I/O CALL WRIT ;DUMP ANY DATA IN OUTPUT BUFF LXI H,OSTP1 CALL FORM ;PAD FIRST PART OF OUTPUT MESSAGE LHLD LPNT CALL CHK1 ;ARE WE EXEC A NUMBERED STMT JC STPWR ;NO, GO WRITE BUFFER MOV E,M INX H MOV D,M ;GET LINE NUMBER TO DE LXI H,OSTP2 CALL FORM CALL LNUM ;PAD LINE NUMBER STPWR: CALL WRIT ;WRITE MESSAGE JMP M1A ;RETURN TO MONITOR OSTP1: DB 5,15Q,12Q,'INT' OSTP2: DB 6,' AT # ' ;LNUM PRINTS LINE NUMBER IN DE LNUM: PUSH D ;PUT NUMBER ON STACK XCHG ;SAVE HL IN DE LXI H,0 XTHL ;PUT ZEROS (HIGH BYTES ON STACK) PUSH H ;PUT LOW BYTES CALL SP2AM ;PUT VALUE ONTO AM9511 CALL FLTD ;FLOAT IT PUSH B ;SAVE B,C PUSH D ;SAVE HL (WAS STORED IN DE) LXI B,600H ;SET UP B,C FOR CALL TO FORMAT CALL FORMT ;PAD FORMATTED LINE NUMBER POP H ;RESTORE REGS POP B RET ; ; TEN5: DB 303Q,120Q,0Q,21Q ;/303240(8) = 100000. TEN: DB 240Q,0Q,0Q,4Q ;/12(8) = 10 FONE: DB 200Q,0,0,001Q ;FLOATING PNT ONE HALF: DB 80H,0,0,0 ;FLOATING 1/2 END