Apple-2-SW
/
Zapple-II
mirror of https://github.com/bobbimanners/Zapple-II.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
Zapple-II/BASIC5.S#000000

3495 lines
60 KiB
Plaintext
Raw Permalink Blame History

;
; PROCESSOR TECHNOLOGY BASIC-5
; USING ZILOG OPCODES, COURTESY OF A SED FILE
;
; SYSTEM GLOBAL EQUATES
;
BDOS EQU 0005H ;ADDRESS OF JUMP TO BDOS
CONIN EQU 1 ;CONSOLE IN
CONOUT EQU 2 ;CONSOLE OUT
CONSTS EQU 11 ;CONSOLE STATUS
FPSIZ EQU 5
LINLEN EQU 73 ;# OF CHARS IN LEGAL INPUT LINE
FP123 EQU FPSIZ-2
FPNIB EQU FP123*2
DIGIT EQU FPNIB/2
CR EQU 15Q ;CARRIAGE RETURN
NULL EQU 0
LF EQU 12Q ;LINE FEED
ESC EQU 3Q ;CONTROL C
EOF EQU 1 ;END OF FILE
BELL EQU 7 ;BELL CHARACTER
STESIZ EQU 2+FPSIZ ;SYMBOL TABLE ELEMENT SIZE
OPBASE EQU '('
FTYPE EQU 1 ;CONTROL STACK FOR ENTRY TYPE
FORSZ EQU FPSIZ*2+2+2+1 ;'FOR' CONTROL STACK ENTRY SIZE
GTYPE EQU 2 ;CONTROL STACK GOSUB ENTRY TYPE
ETYPE EQU 0 ;CONTROL STACK UNDERFLOW TYPE
UMINUS EQU 61Q ;UNARY MINUS
;
; STARTUP BASIC SYSTEM
;
ORG 100H
;
START: LD SP,CMNDSP
XOR A
LD (NULLCT),A ;NULL COUNT.
LD HL,BASEND ;START OF USER MEMORY
LD (BOFA),HL ;IS RIGHT AFTER THE BASIC CODE.
LD HL,(BDOS+1) ;THE ADDRESS OF BDOS IS
DEC HL ; ** Bobbi / Qkumba fix **
LD (MEMTOP),HL ;THE END OF USER MEMORY.
ST0: LD HL,PLS ;"PROGRAM LOADED?" MESSAGE
CALL PRNT
CALL INLINE
LD A,(IBUF)
;
; OPTIONAL ENTRY POINT FOR TAPE OR DISK ROUTINES
;
; ALLOWS DIRECT PROGRAM INPUT FROM HIGH SPEED DEVICES
; SEE OPERATING INSTRUCTIONS FOR PROPER IMPLEMENTATION
;
STAR1: CP 'N'
JP Z,ST1 ;IF NO PROGRAM CLEAR AND INITIALIZE
CP 'Y'
JP NZ,ST0
LD HL,(BOFA)
ST2: LD A,(HL) ;FIND END OF PROGRAM
CP EOF
JP Z,ST3
CALL ADR
JP ST2
ST3: LD (EOFA),HL
CALL CCLEAR
JP ST4
ST1: CALL CSCR
ST4: LD A,2*FPNIB
LD (INFES),A
; INITIALIZE RANDOM NUMBER
LD DE,FRAND
LD HL,RANDS
CALL VCOPY ;FRAND=RANDOM NUMBER SEED
;
; COMMAND PROCESSOR
;
CMND1: CALL CRLF2
LD HL,RDYS ;PRINT READY MESSAGE
CALL PRNT
CMNDR: LD A,1 ;SET DIRECT INPUT FLAG
LD (DIRF),A
LD SP,CMNDSP
CALL CRLF
CMND2: CALL INLINE ;GET INPUT LINE FROM OPERATOR
CALL PP ;PRE-PROCESS IT
JP C,CMND3
CALL LINE ;LINE NUMBER...GO EDIT
JP CMND2
CMND3: CALL CMND4
JP CMNDR
CMND4: LD HL,IBUF ;POINT TO COMMAND OR STATEMENT
LD (TXA),HL
CALL GC
AND 240Q
CP 240Q ;CHECK FOR COMMAND
LD DE,CMNDD
JP Z,ISTA1 ;PROCESS COMMAND
CALL ISTAT ;PROCESS STATEMENT (IF ALLOWED)
CALL GCI
CP CR
RET Z
E1: LD BC,'BS'
JP ERROR
; ERROR MESSAGE PRINTOUT
E3: LD BC,'BA'
JP ERROR
E4: LD BC,'CS'
JP ERROR
E5: LD BC,'OB'
JP ERROR
E6: LD BC,'DM'
;
ERROR: PUSH BC
CALL CRLF
POP BC
CALL CHOUT
LD B,C
CALL CHOUT
LD HL,ERS
ERM1: CALL PRNT
LD A,(DIRF)
OR A
JP NZ,CMND1
LD HL,INS
CALL PRNT
; FIND LINE NUMBER
LD HL,(BOFA)
ERM2: LD B,H
LD C,L
LD E,(HL)
LD D,0
ADD HL,DE
EX DE,HL
LD HL,TXA
CALL DCMP
EX DE,HL
JP C,ERM2
INC BC
LD A,(BC)
LD L,A
INC BC
LD A,(BC)
LD H,A
LD DE,IBUF ;USE IBUF TO ACCUMULATE THE LINE NUMBER STRING
CALL CNS
LD A,CR
LD (DE),A
LD HL,IBUF
CALL PRNTCR
JP CMND1
;
; LINE EDITOR
;
LINE: LD HL,(BOFA) ;CHECK FOR EMPTY FILE
FIN: LD A,(HL) ;CHECK IF APPENDING LINE AT END
DEC A
JP Z,APP
EX DE,HL
INC DE
LD HL,(IBLN) ;GET INPUT LINE NUMBER
EX DE,HL
CALL DCMP ;COMPARE WITH FILE LINE NUMBER
DEC HL
JP C,INSR ;LESS THAN
JP Z,INSR ;EQUAL
LD A,(HL) ;LENGTH OF LINE
CALL ADR ;JUMP FORWARD
JP FIN
; APPEND LINE AT END CASE
APP: LD A,(IBCNT) ;DON'T APPEND NULL LINE
CP 4
RET Z
CALL FULL ;CHECK FOR ROOM IN FILE
LD HL,(EOFA) ;PLACE LINE IN FILE
CALL IMOV
LD (HL),EOF
LD (EOFA),HL
RET
; INSERT LINE IN FILE CASE
INSR: LD B,(HL) ;OLD LINE COUNT
LD (INSA),HL ;INSERT LINE POINTER
LD A,(IBCNT) ;NEW LINE COUNT
JP C,LT ;JMP IF NEW LINE # NOT = OLD LINE NUMBER
SUB 4
JP Z,LT1 ;TEST IF SHOULD DELETE NULL LINE
ADD A,4
LT1: SUB B
JP Z,LIN1 ;LINE LENGTHS EQUAL
JP C,GT
; EXPAND FILE FOR NEW OR LARGER LINE
LT: LD B,A
LD A,(IBCNT)
CP 4 ;DON'T INSERT NULL LINE
RET Z
LD A,B
CALL FULL
LD HL,(INSA)
CALL NMOV
LD HL,(EOFA)
EX DE,HL
LD (EOFA),HL
INC BC
CALL RMOV
JP LIN1
; CONTRACT FILE FOR SMALLER LINE
GT: CPL
INC A
CALL ADR
CALL NMOV
EX DE,HL
LD HL,(INSA)
CALL NZ,LMOV
LD (HL),EOF
LD (EOFA),HL
; INSERT CURRENT LINE INTO FILE
LIN1: LD HL,(INSA)
LD A,(IBCNT)
CP 4
RET Z
; INSERT CURRENT LINE AT ADDR HL
IMOV: LD DE,IBCNT
LD A,(DE)
LD C,A
LD B,0
; COPY BLOCK FROM BEGINNING
; HL IS DEST ADDR, DE IS SOURCE ADDR, BC IS COUNT
LMOV: LD A,(DE)
LD (HL),A
INC DE
INC HL
DEC BC
LD A,B
OR C
JP NZ,LMOV
RET
; COPY BLOCK STARTING AT END
; HL IS DEST, DE IS SOURCE, BC IS COUNT
RMOV: LD A,(DE)
LD (HL),A
DEC HL
DEC DE
DEC BC
LD A,B
OR C
JP NZ,RMOV
RET
; COMPUTE FILE MOVE COUNT
; BC GETS (EOFA) - (HL), RET Z SET MEANS ZERO COUNT
NMOV: LD A,(EOFA)
SUB L
LD C,A
LD A,(EOFA+1)
SBC A,H
LD B,A
OR C
RET
; ADD A TO HL
ADR: ADD A,L
LD L,A
RET NC
INC H
RET
; CHECK FOR FILE OVERFLOW, LEAVES NEW EOFA IN DE
; A HAS INCREASE IN SIZE
FULL: LD HL,(EOFA)
CALL ADR
EX DE,HL
LD HL,MEMTOP
CALL DCMP
JP NC,E8
RET
;
; COMMANDS
;
CSCR: LD HL,(BOFA)
LD (HL),EOF
LD (EOFA),HL
; "CLEAR"
CCLEAR: LD HL,(EOFA) ;CLEAR FROM EOFA TO MEMTOP
INC HL
LD (MATA),HL
EX DE,HL
LD HL,MEMTOP ;END OF ASSIGNED MEMORY
CCLR1: XOR A
LD (DE),A
CALL DCMP
INC DE
JP NZ,CCLR1
LD HL,(MEMTOP)
LD (STAA),HL
LD HL,CSTKL+CSTKSZ-1
LD (HL),ETYPE
LD (CSTKA),HL
LD HL,ASTKL+ASTKSZ+FPSIZ-1
LD (ASTKA),HL
RET
; "NULL"
CNULL: CALL INTGER
JP C,E3 ;NO ARGUMENT SUPPLIED
LD A,L
LD (NULLCT),A
JP CMND1
; "LIST"
CLIST: CALL GC
CP CR
LD DE,0
JP Z,CL0 ;JUMP IF NO ARGUMENT SUPPLIED
CALL INTGER ;ERROR DEFAULT IS LIST
CL0: LD HL,(BOFA)
CL1: LD A,(HL)
DEC A
RET Z
INC HL
CALL DCMP
DEC HL ;POINT TO COUNT CHAR AGAIN
JP C,CL2
JP Z,CL2
; INCREMENT TO NEXT LINE
LD A,(HL)
CALL ADR
JP CL1
CL2: PUSH DE
LD DE,IBUF ;AREA TO UNPREPROCESS TO
CALL UPPL
INC HL
PUSH HL
LD HL,IBUF
CALL PRNTCR
CALL PCHECK
CALL CRLF
POP HL
POP DE
JP CL1
; "RUN"
CRUN: CALL CCLEAR
LD HL,(BOFA)
LD A,(HL)
DEC A ;CHECK FOR NULL PROGRAM
JP Z,ENDX
INC HL
INC HL
INC HL
LD (TXA),HL
LD (RTXA),HL ;POINTER FOR 'READ' STATEMENT
XOR A
LD (DIRF),A ;CLEAR DIRECT FLAG AND FALL THROUGH TO DRIVER
CALL CRLF
;
; INTERPRETER DRIVER
;
ILOOP: CALL PCHECK
CALL ISTAT ;INTERPRET CURRENT STATEMENT
CALL JOE ;TEST FOR JUNK ON END
JP NC,ILOOP ;CONTINUE IF NOT AT END OF PROGRAM
JP ENDX ;EXECUTE END STATEMENT
; INTERPRET STATEMENT LOCATED BY TXA
ISTAT: CALL GC ;GET FIRST NON BLANK
OR A
JP P,LET ;MUST BE LET IF NOT RW
CP IRWLIM ;IS IT AN INITIAL RW
JP NC,E1
LD DE,STATD ;STATEMENT DISPATCH TABLE BASE
ISTA1: CALL GCI ;ADVANCE TEXT POINTER
AND 37Q
RLCA ;MULTIPLY BY TWO PREPARING FOR TABLE LOOKUP
LD L,A
LD H,0
ADD HL,DE
CALL LHLI
JP (HL) ;BRANCK TO STATEMENT OR COMMAND
;
; STATEMENTS
;
; "LET"
LET: CALL VAR ;CHECK FOR VARIABLE
JP C,E1
PUSH HL ;SAVE VALUE ADDRESS
LD B,EQRW
CALL EATC
CALL EXPRB
POP DE ;DESTINATION ADDRESS
CALL POPA1 ;COPY EXPR VALUE TO VARIABLE
RET ;******* CALL, RET???!!!****************
; "FOR"
SFOR: CALL DIRT
CALL VAR ;CONTROL VARIABLE
JP C,E1
PUSH HL ;CONTROLVARIABLE VALUE ADDRESS
LD B,EQRW
CALL EATC
CALL EXPRB ;INITIAL VALUE
POP DE ;VARIABLE VALUE ADDRESS
PUSH DE ;SAVE
CALL POPA1 ;SET INITIAL VALUE
LD B,TORW ;RW FOR 'TO'
CALL EATC
CALL EXPRB ;LIMIT VALUE COMPUTATION
CALL GC ;CHECK NEXT CHARACTER FOR POSSIBLE STEP EXPR
CP STEPRW
JP Z,FOR1
; USE STEP OF 1
LD DE,FPONE
CALL PSHA1
JP FOR2
; COMPUTE STEP VALUE
FOR1: CALL GCI ;EAT THE STEP RW
CALL EXPRB ;THE STEP VALUE
; HERE THE STEP AND LIMIT ARE ON THE ARG STACK
FOR2: LD DE,-2 ;PREPARE TO ALLOCATE 2 BYTES ON CONTROL STACK
CALL PSHCS ;RETURNS ADDRESS OF THOSE 2 BYTES IN HL
EX DE,HL
CALL JOE ;TEST FOR JUNK ON END
JP C,E4 ;NO "FOR" STATEMENT AT END OF PROGRAM
EX DE,HL ;DE HAS LOOP TEST ADDR, HL HAS CONTROL STACK ADR
LD (HL),D ;HIGH ORDER TEXT ADDRESS BYTE
DEC HL
LD (HL),E ;LOW ORDER TEXT ADDRESS BYTE
LD DE,-FPSIZ ;ALLOCATE SPACE FOR LIMIT ON CONTROL STACK
CALL PSHCS
PUSH HL ;ADDR ON CONTROL STACK FOR LIMIT
LD DE,-FPSIZ ;ALLOCATE SPACE FOR STEP ON CONTROL STACK
CALL PSHCS
CALL POPAS ;COPY STEP VALUE TO CONTROL STACK
POP DE ;CONTROL STACK ADDR FOR LIMIT VLAUE
CALL POPA1 ;LIMIT VALUE TO CONTROL STACK
LD DE,-3 ;ALLOCATE SPACE FOR TEST ADDRESS AND CS ENTRY
CALL PSHCS
POP DE ;CONTROL VARIABLE ADDRESS
LD (HL),D ;HIGH ORDER BYTE OF CONTROL VAR ADDR
DEC HL
LD (HL),E ;LOW ORDER BYTE
DEC HL
LD (HL),FTYPE ;SET CONTROL STACK ENTRY TYPE FOR "FOR"
JP NEXT5 ;GO FINISH OFF CAREFULLY
; "NEXT"
NEXT: CALL DIRT
LD HL,(CSTKA) ;CONTROL STACK ADDRESS
LD A,(HL) ;STACK ENTRY TYPE BYTE
DEC A ;MUST BE FOR TYPE ELSE ERROR
JP NZ,E4 ;IMPROPER NEXTING ERROR
INC HL ;CONTROL STACK POINTER TO CONTROL VAR ADDR
PUSH HL
CALL VAR ;CHECK VARIABLE, IN CASE USER WANTS
JP C,NEXT1 ;SKIP CHECK IF VAR NOT THERE
EX DE,HL
POP HL ;CONTROL VARIABLE ADDRESS
PUSH HL ;SAVE IT AGAIN
CALL DCMP
JP NZ,E4 ;IMPROPER NESTING IF NOT THE SAME
NEXT1: POP HL ;CONTROL VARIABLE ADDRESS
PUSH HL
PUSH HL
LD DE,FPSIZ+2-1 ;COMPUTE ADDRESS TO STEP VALUE
ADD HL,DE
EX (SP),HL ;NOW ADDRESS TO VAR IN HL
CALL LHLI ;VARIABLE ADDRESS
LD B,H ;COPY VAR ADDRESS TO BC
LD C,L
POP DE ;STEP VALUE ADDRESS
PUSH DE
CALL FADD ;DO INCREMENT
POP HL ;STEP VALUE
DEC HL ;POINT TO SIGN OF STEP VALUE
LD A,(HL) ;SIGN 0=POS, 1=NEG
LD DE,FPSIZ+1
ADD HL,DE ;PUTS LIMIT ADDRESS IN HL
EX DE,HL
POP HL ;VARIABLE ADDRESS
CALL LHLI ;GET ADDRESS
PUSH DE ;SAVE CONTROL STACK POINTER TO GET TEXT ADDR
OR A ;SET CONDITIONS BASED ON SIGN OF STEP VALUE
JP Z,NEXT2 ;REVERSE TEST ON NEGATIVE STEP VALUE
EX DE,HL
NEXT2: LD B,H ;SET UP ARGS FOR COMPARE
LD C,L
CALL RELOP ;TEST <=
POP DE ;TEXT ADDRESS
JP M,NEXT3 ;STILL SMALLER?
JP Z,NEXT3 ;JUMP IF WANT TO CONTINUE LOOP
; TERMINATE LOOP
LD HL,3 ;REMOVE CSTACK ENTRY
ADD HL,DE
LD (CSTKA),HL
RET
NEXT3: INC DE ;TEXT ADDRESS
EX DE,HL
CALL LHLI ;GET TEXT ADDRESS IN HL
; ITERATE, SKIPPING NORMAL JUNK ON END TEST AT ILOOP
NEXT4: EX DE,HL ;SAVE NEW TEXT ADDRESS IN DE
CALL JOE
EX DE,HL
NEXT6: LD (TXA),HL
NEXT5: LD HL,ILOOP
EX (SP),HL
RET ;TO DISPATCHER SKIPPING JOE CALL THERE
; "IF"
SIF: LD B,1 ;SPECIFY PRINCIPAL OPERATOR IS RELATIONAL
CALL EXPB1
LD HL,(ASTKA) ;ADDRESS ON BOOLEAN VALUE ON ARG STACK
INC (HL) ;SETS ZERO CONDITION IF RELATIONAL TEST TRUE
PUSH AF ;SAVE CONDITIONS TO TEST LATER
CALL POPAS ;REMOVE VALUE FROM ARG STACK COPY TO SELF
POP AF
JP NZ,REM ;IF TEST FALSE TREAT REST OF STATEMENT AS REM
; TEST SUCCEEDED
LD B,THENRW
CALL EATC
CALL INTGER ;CHECK IF LINE NUMBER IS DESIRED ACTION
JP C,ISTAT
JP GOTO1
; "GOTO"
SGOTO: XOR A
LD (DIRF),A ;CLEAR DIRECT STATEMENT FLAG
CALL INTGER ;RETURNS INTEGER IN HL IF LINE NUMBER PRESENT
JP C,E1 ;SYNTAX ERROR NO LINE NUMBER
GOTO1: EX DE,HL ;LN IN DE
CALL FINDLN ;RETURNS TEST ADDRESS POINTS TO COUNT VALUE
GOTO2: INC HL
INC HL
INC HL ;ADVANCE TEXT POINTER PAST LINE NUMBER ANDCOUNT
JP NEXT4
; "GOSUB"
GOSUB: CALL DIRT
LD DE,-3 ;CREATE CONTROL STACK ENTRY
CALL PSHCS
PUSH HL ;SAVE STACK ADDRESS
CALL INTGER
JP C,E1
EX DE,HL ;LINE NUMBER TO DE
CALL JOE
LD B,H
LD C,L
POP HL ;STACK ADDRESS
LD (HL),B ;STACK RETURN ADDRESS RETURNED BY JOE
DEC HL
LD (HL),C
DEC HL
LD (HL),GTYPE ;MAKE CONTROL STACK ENTRY TYPE "GOSUB"
CALL FINDLN
INC HL
INC HL
INC HL
JP NEXT6
; "RETURN"
RETRN: CALL DIRT
LD (DIRF),A ;CLEARS DIRF IN ACC IS CLEAR
LD HL,(CSTKA)
RET1: LD A,(HL)
OR A ;CHECK FOR STACK EMPTY
JP Z,E4
CP GTYPE ;CHECK FOR GOSUB TYPE
JP Z,RET2
; REMOVE FOR TYPE ENTRY FROM STACK
LD DE,FORSZ
ADD HL,DE
JP RET1
; FOUND A GTYPE STACK ENTRY
RET2: INC HL
LD E,(HL) ;LOW ORDER TEXT ADDRESS
INC HL
LD D,(HL) ;HIGH ORDER TEXT ADDRESS
INC HL ;ADDRESS OF PREVIOUS CONTROL STACK ENTRY
LD (CSTKA),HL
EX DE,HL ;PUT TEXT ADDRESS IN HL
LD A,(HL) ;ADDRESS POINTS TO EOF IF GOSUB WAS LAST LINE
DEC A ;END OF FILE?
JP NZ,NEXT4
JP ENDX
; "DATA" AND "REM"
DATA: CALL DIRT ;DATA STATEMENT ILLEGAL AS DIRECT
REM: CALL GCI
CP CR
JP NZ,REM
DEC HL ;BACKUP POINTER SO NORMAL JOE WILL WORK
LD (TXA),HL
RET
; "DIM"
DIM: CALL NAME ;LOOK FOR VARIABLE NAME
JP C,E1
LD A,C ;PREPARE TURN ON 80H BIT TO SIGNIFY MATRIX
OR 80H
LD C,A
CALL STLK
JP NC,E6 ;ERROR IF NAME ALREADY EXISTS
PUSH HL ;SYMBOL TABLE ADDRESS
LD B,LPARRW
CALL EATC
CALL EXPRB
LD B,')'
CALL EATC
CALL PFIX ;RETURN INTEGER IN DE
LD HL,MATUB ;MAXIMUM SIZE FORM MATRIX
CALL DCMP
JP NC,E6
POP HL ;SYMBOL TABLE ADDRESS
CALL DIMS
CALL GC ;SEE IF MORE TO DO
CP ','
RET NZ
CALL GCI ;EAT THE COMMA
JP DIM
; "STOP"
STOP: CALL DIRT
STOP1: CALL CRLF2
LD (BRKCHR),A
LD HL,STOPS
JP ERM1
; "END"
ENDX EQU CMND1
; "READ"
READ: CALL DIRT
LD HL,(TXA)
PUSH HL ;SAVE TXA TEMPORARILY
LD HL,(RTXA) ;THE 'READ' TXA
READ0: LD (TXA),HL
CALL GCI
CP ','
JP Z,READ2 ;PROCESS INPUT VALUE
CP DATARW
JP Z,READ2
DEC A
JP Z,READ4
; SKIP TO NEXT LINE
CALL REM ;LEAVES ADDRESS OF LAST CR IN HL
INC HL
LD A,(HL)
DEC A
JP Z,READ4
INC HL
INC HL
INC HL ;HL NOW POINTS TO FIRST BYTE ON NEXT LINE
JP READ0
; PROCESS VALUE
READ2: CALL EXPRB
CALL GC
CP ',' ;SKIP JOE TEST IF COMMA
JP Z,READ3
; JUNK ON END TEST
CALL JOE
READ3: LD HL,(TXA)
LD (RTXA),HL ;SAVE NEW "READ" TEXT ADDRESS
POP HL ;REAL TXA
LD (TXA),HL
CALL VAR
JP C,E1
CALL POPAS ;PUT READ VALUE INTO VARIABLE
CALL GC
CP ',' ;CHECK FOR ANOTHER VARIABLE
RET NZ
CALL GCI ;EAT THE COMMA
JP READ
READ4: POP HL ;PROGRAM TXA
LD (TXA),HL
LD BC,'RD'
JP ERROR
; "RESTORE"
RESTOR: LD HL,(BOFA) ;BEGINNING OF FILE POINTER
INC HL
INC HL
INC HL
LD (RTXA),HL
RET
; "PRINT"
PRINT: CALL GC
CP CR ;CHECK FOR STAND ALONE PRINT
JP Z,CRLF
PRIN2: CP '"'
JP Z,PSTR ;PRINT THE STRING
CP TABRW
JP Z,PTAB ;TABULATION
CP '%'
JP Z,PFORM ;SET FORMAT
CP CR
RET Z
CP ';'
RET Z
CALL EXPRB ;MUST BE EXPRESSION TO PRINT
LD DE,FPSINK
CALL POPA1 ;POP VALUE TO FPSINK
LD A,(PHEAD)
CP 56
CALL NC,CRLF ;DO CRLF IF PRINT HEAD IS PAST 56
LD HL,FPSINK
CALL FPOUT
LD B,' '
CALL CHOUT
PR1: CALL GC ;GET DELIMITER
CP ','
JP NZ,CRLF
PR0: CALL GCI
CALL GC
JP PRIN2
PSTR: CALL GCI ;GOBBLE THE QUOTE
CALL PRNT ;PRINT UP TO DOUBLE QUOTE
INC HL ;MOVE POINTER PAST DOUBLE QUOTE
LD (TXA),HL
JP PR1
PFORM: LD A,2*FPNIB
LD (INFES),A
CALL GCI ;GOBBLE PREVIOUS CHAR
PFRM1: CALL GCI
LD HL,INFES
CP '%' ;DELIMITER
JP Z,PR1
LD B,80H
CP 'Z' ;TRAILING ZEROS?
JP Z,PF1
LD B,1
CP 'E' ;SCIENTIFIC NOTATION?
JP Z,PF1
CALL NMCHK
JP NC,E1
SUB '0' ;NUMBER OF DECIMAL PLACES
RLCA
LD B,A
LD A,(HL)
AND 301Q
LD (HL),A
PF1: LD A,(HL)
OR B
LD (HL),A
JP PFRM1
PTAB: CALL GCI ;GOBBLE TAB RW
LD B,LPARRW
CALL EATC
CALL EXPRB
LD B,')'
CALL EATC
CALL PFIX
PTAB1: LD A,(PHEAD)
CP E
JP NC,PR1
LD B,' '
CALL CHOUT
JP PTAB1
; "INPUT"
INPUT: CALL GC
CP ','
JP Z,NCRLF
CALL CRLF
INP0: LD B,'?'
CALL CHOUT
LINP: CALL INLINE
LD DE,IBUF
IN1: PUSH DE ;SAVE FOR FPIN
CALL VAR
JP C,E1
POP DE
LD B,0
LD A,(DE)
CP '+' ;LOOK FOR LEADING PLUS OR MINUS ON INPUT
JP Z,IN2
CP '-'
JP NZ,IN3
LD B,1
IN2: INC DE
IN3: PUSH BC
PUSH HL
CALL FPIN ;INPUT FP NUMBER
JP C,INERR
POP HL
DEC HL
POP AF
LD (HL),A
CALL GC
CP ','
RET NZ ;DONE IF NO MORE
CALL GCI ;EAT THE COMMA
LD A,B ;GET THE TERMINATOR TO A
CP ','
JP Z,IN1 ;GET THE NEXT INPUT VALUE FROM STRING
; GET NEW LINE FROM USER
LD B,'?'
CALL CHOUT
JP INP0
NCRLF: CALL GCI
JP LINP ;NOW GET LINE
INERR: LD BC,'IN'
JP ERROR
;
; EVALUATE AN EXPRESSION FROM TEXT
; HL TAKE OP TABLE ADDR OF PREVIOUS OPERATOR (NOT CHANGED)
; RESULT VALUE LEFT ON TOP OF ARG STACK, ARGF LEFT TRUE
;
EXPRB: LD B,0
EXPB1: LD HL,OPBOL
XOR A
LD (RELTYP),A
; ZERO IN B MEANS PRINCIPAL OPERATOR MAY NOT BE RELATIONAL
EXPR: PUSH BC
PUSH HL ;PUSH OPTBA
XOR A
LD (ARGF),A
EXPR1: LD A,(ARGF)
OR A
JP NZ,EXPR2
CALL VAR ;LOOK FOR VARIABLE PERHAPS SUBSCRIPTED
CALL NC,PSHAS
JP NC,EXPR2
CALL CONST
JP NC,EXPR2
CALL GC
CP LPARRW
LD HL,OPLPAR
JP Z,XLPAR
; ISN'T OR SHOULDN'T BE AN ARGUMENT
EXPR2: CALL GC
CP 340Q ;CHECK FOR RESERVED WORD OPERATOR
JP NC,XOP
CP 300Q ;CHECK FOR BUILT IN FUNCTION
JP NC,XBILT
; ILLEGAL EXPRESSION CHARACTER
POP HL ;GET OPTBA
LD A,(ARGF)
OR A
JP Z,E1
XDON1: POP AF
LD HL,RELTYP ;CHECK IF LEGAL PRINCIPAL OPERATOR
CP (HL)
RET Z
JP E1
XOP: AND 37Q ;CLEANS OFF RW BITS
LD HL,(ARGF) ;TEST FOR ARGF TRUE
DEC L
JP Z,XOP1
; ARGF WAS FALSE, UNARY OPS ONLY POSSIBILITY
CP '-'-OPBASE
JP Z,XOPM
CP '+'-OPBASE
JP NZ,E1
CALL GCI ;EAT THE '+'
JP EXPR1
XOPM: LD A,UMINUS-OPBASE
XOP1: CALL OPADR
POP DE ;PREVIOUS OPTBA
LD A,(DE)
CP (HL)
JP NC,XDON1 ;NON-INCREASING PRECEDENCE
; INCREASING PRECEDENCE CASE
PUSH DE ;SAVE PREVIOUS OPTBA
PUSH HL ;SAVE CURRENT OPTBA
CALL GCI ;TO GOBBLE OPERATOR
POP HL
PUSH HL
LD B,0 ;SPECIFY NON-RELATIONAL
CALL EXPR
POP HL
; HL HAS OPTBA ADDRESS
; SET UP ARGS AND PERFORM OPERATION ACTION
XOP2: PUSH HL
LD A,(HL)
LD HL,(ASTKA)
LD B,H
LD C,L
AND 1
JP NZ,XOP21
; DECREMENT STACK POINTER BY ONE VALUE BINARY CASE
LD DE,FPSIZ
ADD HL,DE
LD (ASTKA),HL
LD D,H
LD E,L
XOP21: LD HL,EXPR1
EX (SP),HL ;CHANGE RETURN LINK
INC HL ;SKIP OVER PRECEDENCE
CALL LHLI ;LOAD ACTION ADDRESS
JP (HL)
;
; ACTION ROUTINE CONVENTION
; DE LEFT ARG AND RESULT FOR BINARY
; BC RIGHT ARG FOR BINARY, ARG AND RESULT FOR UNARY
;
; INTRINSIC FUNCTION PROCESSING
;
XBILT: CALL GCI ;EAT TOKEN
AND 77Q ;CLEAN OFF RW BITS
LD HL,(ARGF) ;BUILT IN FUNCTION MUST COME AFTER OPERATOR
DEC L
JP Z,E1
CALL OPADR ;OPTBA TO HL
XLPAR: PUSH HL
LD B,LPARRW
CALL EATC
CALL EXPRB
LD B,')'
CALL EATC
POP HL ;CODE FOR BUILT-IN FUNCTION
JP XOP2
; COMPUTE OPTABLE ADDRESS FOR OPERATOR IN ACC
OPADR: LD C,A
LD B,0
LD HL,OPTAB
ADD HL,BC
ADD HL,BC
ADD HL,BC ;OPTAB ENTRY ADDR IS 3*OP+BASE
RET
;
; PREPROCESSOR, UN-PREPROCESSOR
; PREPROCESS LINE IN IBUF BACK INTO IBUF
; SETS CARRY IF LINE HAS NO LINE NUMBER
; LEAVES CORRECT LENGTH OF LINE AFTER PREPROCESSING IN IBCN
; IF THERE IS A LINE NUMBER, IT IS LOCATED AT IBLN=IBUF-2
; TXA IS CLOBBERED
;
PP: LD HL,IBUF ;FIRST CHARACTER OF INPUT LINE
LD (TXA),HL ;SO GCI WILL WORK
CALL INTGER ;SETS CARRY IF NO LINE NUMBER
LD (IBLN),HL ;STORE LINE NUMBER VALUE(EVEN IF NONE)
PUSH AF ;SAVE STATE OF CARRY BIT FOR RETURNING
LD HL,(TXA) ;ADDRESS OF NEXT CHARACTER IN IBUF
LD C,4 ;SET UP INITIAL VALUE FOR COUNT
LD DE,IBUF ;INITIALIZE WRITE POINTER
; COME HERE TO CONTINUE PREPROCESSING
PPL: PUSH DE
LD DE,RWT ;BASE OF RWT
PPL1: PUSH HL ;SAVE TEXT ADDRESS
LD A,(DE) ;RW VALUE FOR THIS ENTRY IN RWT
LD B,A ;SAVE IN B IN CASE OF MATCH
PPL2: INC DE ;ADVANCE ENTRY POINTER TO NEXT BYTE
LD A,(DE) ;GET NEXT CHARACTER FROM ENTRY
CP (HL) ;COMPARE WITH CHARACTER IN TEXT
JP NZ,PPL3
INC HL ;ADVANCE TEXT POINTER
JP PPL2 ;CONTINUE COMPARISON
; COME HERE WHEN COMPARISON OF BYTE FAILED
PPL3: OR A
JP M,PPL6 ;JUMP IF FOUND MATCH
; SCAN TO BEGINNING ON NEXT ENTRY
PPL4: INC DE ;ADVANCE ENTRY POINTER
LD A,(DE) ;NEXT BYTE IS EITHER CHARACTER OR RW BYTE
OR A
JP P,PPL4 ;KEEP SCANNING IF NOT RW BYTE
; NOW SEE IF AT END OF TABLE, AND FAIL OR RETURN CONDITION
POP HL ;RECOVER ORIGINAL TEXT POINTER
XOR -1 ;CHECK FOR END OF TABLE BYTE
JP NZ,PPL1 ;CONTINUE SCAN OF TABLE
; DIDN'T FIND AN ENTRY AT THE GIVER TEXT ADR
POP DE
LD A,(HL) ;GET THE TEXT CHARACTER
CP CR ;CHECK FOR END OF LINE
JP Z,PPL8 ;GO CLEAN UP AND RETURN
LD (DE),A
INC DE
INC C
INC HL ;ADVANCE TEXT POINTER
CP '"' ;CHECK FOR QUOTED STRING POSSIBILITY
JP NZ,PPL ;RESTART RWT SEARCH AT NEXT CHARACTER POSITION
; HERE WE HAVE A QUOTED STRING, SO EAT TILL ENDQUOTE
PPL5: LD A,(HL) ;NEXT CHARACTER
CP CR
JP Z,PPL8 ;NO STRING ENDQUOTE, LET INTERPRETER WORRY
LD (DE),A
INC DE
INC C
INC HL ;ADVANCE TEXT POINTER
CP '"'
JP Z,PPL ;BEGIN RWT SCAN FROM NEW CHARACTER POSITION
JP PPL5
; FOUND MATCH SO PUT RW VALUE IN TEXT
PPL6: POP AF ;REMOVE UNNEEDED TEST POINTER FROM STACK
POP DE
LD A,B
LD (DE),A
INC DE
INC C
JP PPL
; COME HERE WHEN DONE
PPL8: LD A,CR
LD (DE),A
LD HL,IBCNT ;SET UP COUNT IN CASE LINE OF LINE NUMBER
LD (HL),C
POP AF ;RESTORE CARRY CONDITION (LINE NUMBER FLAG)
RET
;
; UN-PREPROCESS LINE ADDRESSES IN HL TO DE BUFFER
; RETURN SOURCE ADDRESS OF CR IN HL ON RETURN
;
UPPL: INC HL ;SKIP OVER COUNT BYTE
PUSH HL ;SAVE SOURCE TEXT POINTER
CALL LHLI ;LOAD LINE NUMBER VALUE
CALL CNS ;CONVERT LINE NUMBER
LD A,' '
LD (DE),A ;PUT BLANK AFTER LINE NUMBER
INC DE ;INCREMENT DESTINATION POINTER
POP HL
INC HL ;INCREMENT H PAST LINE NUMBER
UPP0: INC HL
LD A,(HL) ;NEXT TOKEN IN SOURCE
OR A
JP M,UPP1 ;JUMP IF TOKEN IS RW
LD (DE),A ;PUT CHARACTER IN BUFFER
CP CR ;CHECK FOR DONE
RET Z
INC DE ;ADVANCE DESTINATION BUFFER ADDRESS
JP UPP0
; COME HERE WHEN RW BYTE DETECTED IN SOURCE
UPP1: PUSH HL ;SAVE SOURCE POINTER
LD HL,RWT ;BASE OF RWT
UPP2: CP (HL) ;SEE IF RW MATCHED RWT ENTRY
INC HL ;ADVANCE RWT POINTER
JP NZ,UPP2 ;CONTINUE LOOKING IF NOT FOUND
; FOUND MATCH, ENTRY POINTER LOCATES FIRST CHARACTER
UPP3: LD A,(HL) ;CHARACTER OF RW
OR A ;CHECK FOR DONE
JP M,UPP4
LD (DE),A
INC DE
INC HL
JP UPP3
; COME HERE IF DONE WITH RW TRANSFER
UPP4: POP HL ;SOURCE POINTER
JP UPP0
;
; CONSTANTS AND TABLES
;
RDYS: DEFM 'READY"'
PLS: DEFM 'PROGRAM LOADED? "'
ERS: DEFM ' ERROR"'
INS: DEFM ' IN LINE "'
STOPS: DEFM 'STOP"'
;
DEFB 0FFH ;FLAGS END OF SINE COEFFICIENT LIST
DEFB 0
DEFB 1*16
DEFW 0
DEFB 0
FPONE: DEFB 129 ;EXPONENT
; SINE COEFFICIENT LIST
; NOTE: THE FLOATING PNT 1 ABOVE IS A PART OF THIS TABLE
DEFB 16H
DEFB 66H
DEFB 67H
DEFB 1
DEFB 128 ;-.166667 E 0 (-1/3!)
DEFB 83H
DEFB 33H
DEFB 33H
DEFB 0
DEFB 128-2 ;.833333 E-2 (1/5!)
DEFB 19H
DEFB 84H
DEFB 13H
DEFB 1
DEFB 128-3 ;-.198413 E-3 (-1/7!)
DEFB 27H
DEFB 55H
DEFB 73H
DEFB 0
DEFB 128-5 ;.275573 E-5 (1/9!)
DEFB 25H
DEFB 5
DEFB 21H
DEFB 1
SINX: DEFB 128-7 ;-.250521 E-7 (-1/11!)
; COSINE COEFFICIENT LIST
DEFB 0FFH ;MARKS END OF LIST
DEFB 0
DEFB 10H
DEFB 0
DEFB 0
DEFB 0
DEFB 128+1 ;/100000 E 1 (1/1!)
DEFB 50H
DEFB 0
DEFB 0
DEFB 1
MATUB: DEFB 128 ;-.500000 E 0 (-1/2!)
DEFB 41H
DEFB 66H
DEFB 67H
DEFB 0
RANDS: DEFB 128-1 ;.416667 E-1 (1/4!)
DEFB 13H
DEFB 88H
DEFB 89H
DEFB 1
DEFB 128-2 ;-.138889 E-2 (-1/6!)
DEFB 24H
DEFB 80H
DEFB 16H
DEFB 0
DEFB 128-4 ;.248016 E-4 (1/8!)
DEFB 27H
DEFB 55H
DEFB 73H
DEFB 1
COSX: DEFB 128-6 ;-.275573 E-6 (-1/10!)
DEFB 20H
DEFW 0
DEFB 0
FPTWO: DEFB 129
DEFB 15H
DEFB 70H
DEFB 80H
DEFB 0
PIC2: DEFB 128+1 ;PI/2
DEFB 63H
DEFB 66H
DEFB 20H
DEFB 0
PIC1: DEFB 128 ;2/PI
LCSTKA: DEFW CSTKL
;
; COMMAND TABLE
;
CMNDD: DEFW CRUN ; 0
DEFW CLIST ; 1
DEFW CNULL ; 2
DEFW CSCR ; 3
DEFW START ; 4 SET UP MEMORY BOUNDS
DEFW TSAV ; 5 TAPE SAVE
DEFW TLOAD ; 6 TAPE LOAD
; STATEMENT TABLE
STATD: DEFW LET ; 0
DEFW NEXT ; 1
DEFW SIF ; 2
DEFW SGOTO ; 3
DEFW GOSUB ; 4
DEFW RETRN ; 5
DEFW READ ; 6
DEFW DATA ; 7
DEFW SFOR ; 10
DEFW PRINT ; 11
DEFW INPUT ; 12
DEFW DIM ; 13
DEFW STOP ; 14
DEFW ENDX ; 15
DEFW RESTOR ; 16
DEFW REM ; 17
DEFW CCLEAR ; 20
;
; R/W WORD TABLE FORMAT IS RESERVED WORD FOLLOWED BY CHR
; OF RESERVED WORD. LAST ENTRY IS FOLLOWED BY A 377Q
; RW'S THAT ARE SUBSTRINGS OF OTHER RW'S (E.G. >) MUST
; FOLLOW THE LARGER WORD.
;
RWT: DEFB 200Q
DEFM 'LET'
DEFB 201Q
DEFM 'NEXT'
DEFB 202Q
DEFM 'IF'
DEFB 203Q
DEFM 'GOTO'
DEFB 204Q
DEFM 'GOSUB'
DEFB 205Q
DEFM 'RETURN'
DEFB 206Q
DEFM 'READ'
DEFB 207Q
DEFM 'DATA'
DATARW EQU 207Q
DEFB 210Q
DEFM 'FOR'
DEFB 211Q
DEFM 'PRINT'
DEFB 211Q
DEFM ':'
DEFB 212Q
DEFM 'INPUT'
DEFB 213Q
DEFM 'DIM'
DEFB 214Q
DEFM 'STOP'
DEFB 215Q
DEFM 'END'
DEFB 216Q
DEFM 'RESTORE'
DEFB 217Q
DEFM 'REM'
DEFB 220Q
DEFM 'CLEAR'
CLRRW EQU 220Q
IRWLIM EQU 221Q ;LAST INITIAL RESERVED WORD VALUE+1
DEFB 237Q
DEFM 'STEP'
STEPRW EQU 237Q
DEFB 236Q
DEFM 'TO'
TORW EQU 236Q
DEFB 235Q
DEFM 'THEN'
THENRW EQU 235Q
DEFB 234Q
DEFM 'TAB'
TABRW EQU 234Q
DEFB 240Q
DEFM 'RUN'
RUNRW EQU 240Q
DEFB 241Q
DEFM 'LIST'
LISTRW EQU 241Q
DEFB 242Q
DEFM 'NULL'
NULLRW EQU 242Q
DEFB 243Q
DEFM 'SCR'
SCRRW EQU 243Q
DEFB 244Q
DEFM 'MEM'
MEMRW EQU 245Q ;******* WRONG CODE?*******
DEFB 245Q
DEFM 'TSAV'
DEFB 246Q
DEFM 'TLOAD'
LPARRW EQU '('-OPBASE+340Q
DEFB LPARRW
DEFB '('
DEFB '*'-OPBASE+340Q
DEFB '*'
PLSRW EQU '+'-OPBASE+340Q
DEFB PLSRW
DEFB '+'
MINRW EQU '-'-OPBASE+340Q
DEFB MINRW
DEFB '-'
DEFB '/'-OPBASE+340Q
DEFB '/'
DEFB 67Q-OPBASE+340Q
DEFM '>='
DEFB 70Q-OPBASE+340Q
DEFM '<='
DEFB 71Q-OPBASE+340Q
DEFM '<>'
DEFB 62Q-OPBASE+340Q
DEFM '=>'
DEFB 63Q-OPBASE+340Q
DEFM '=<'
DEFB '<'-OPBASE+340Q
DEFB '<'
EQRW EQU '='-OPBASE+340Q
DEFB EQRW
DEFB '='
DEFB '>'-OPBASE+340Q
DEFB '>'
DEFB 301Q
DEFM 'ABS'
DEFB 306Q
DEFM 'INT'
DEFB 314Q
DEFM 'ARG'
DEFB 315Q
DEFM 'CALL'
DEFB 316Q
DEFM 'RND'
DEFB 322Q
DEFM 'SGN'
DEFB 323Q
DEFM 'SIN'
DEFB 304Q
DEFM 'SQR'
DEFB 327Q
DEFM 'TAN'
DEFB 330Q
DEFM 'COS'
DEFB 377Q
;
; OPERATION TABLE
;
OPTAB: DEFB 15
OPLPAR EQU OPTAB
DEFW ALPAR
DEFB 15
DEFW AABS
DEFB 10
DEFW AMUL
DEFB 6
DEFW AADD
DEFB 15
DEFW ASQR
DEFB 6
DEFW ASUB
DEFB 15
DEFW AINT
DEFB 10
DEFW ADIV
OPBOL: DEFB 1
DEFW 0
DEFB 13
DEFW ANEG
DEFB 4
DEFW AGE
DEFB 4
DEFW ALE
DEFB 15
DEFW AARG
DEFB 15
DEFW ACALL
DEFB 15
DEFW ARND
DEFB 4
DEFW AGE
DEFB 4
DEFW ALE
DEFB 4
DEFW ANE
DEFB 15
DEFW ASGN
DEFB 15
DEFW ASIN
DEFB 4
DEFW ALT
DEFB 4
DEFW AEQ
DEFB 4
DEFW AGT
DEFB 15
DEFW ATAN
DEFB 15
DEFW ACOS
;
; ACTION ROUTINES FOR RELATIONAL OPERATORS
;
AGT: CALL RELOP
JP Z,RFALSE
JP M,RTRUE
RFALSE: XOR A
LD (DE),A
RET
ALT: CALL RELOP
JP Z,RFALSE
JP M,RFALSE
RTRUE: LD A,-1
LD (DE),A
RET
AEQ: CALL RELOP
JP Z,RTRUE
JP RFALSE
ANE: CALL RELOP
JP Z,RFALSE
JP RTRUE
AGE: CALL RELOP
JP Z,RTRUE
JP M,RTRUE
JP RFALSE
ALE: CALL RELOP
JP Z,RTRUE
JP M,RFALSE
JP RTRUE
;
; COMMON ROUTINE FOR RELATIONAL OPERATOR ACTION
; LEFT ARG ADDR IN DE, SAVED
; RIGHT ARG ADDR IN BC
; ON RETURN SIGN SET=GT, ZERO SET =EQUAL
;
RELOP: PUSH DE
DEC BC
DEC DE
LD H,B
LD L,C
LD A,(DE)
SUB (HL)
INC HL
INC DE
JP NZ,RLOP1 ;TEST SIGNS OF ARGS IF DIFFERENT THEN RET
LD BC,FPSINK
CALL FSUB
LD A,(FPSINK) ;CHECK FOR ZERO RESULT
OR A
JP Z,RLOP1
LD A,(FPSINK-1) ;SIGN OF FPSINK
RLCA
DEC A
RLOP1: LD A,1
LD (RELTYP),A ;SET RELTYP TRUE
POP DE
RET
;
; ACTION ROUTINES FOR ARITHMETIC OPERATORS
; (CODE WASTERS)
;
AADD: LD H,B
LD L,C
LD B,D
LD C,E
AADD1: CALL FADD
JP FPETST
ASUB: LD H,B
LD L,C
LD B,D
LD C,E
ASUB1: CALL FSUB
JP FPETST
AMUL: LD H,B
LD L,C
LD B,D
LD C,E
AMUL1: CALL FMUL
JP FPETST
ADIV: LD H,B
LD L,C
LD B,D
LD C,E
ADIV1: CALL FDIV
FPETST: XOR A
LD (RELTYP),A
LD A,(ERRI)
OR A
RET Z
LD HL,(ASTKA) ;ZERO RESULT ON UNDERFLOW
FPET1: LD (HL),0
ALPAR: RET
;
; UNARY AND BUILT IN FUNCTION ROUTINES
;
ANEG: LD A,(BC)
OR A
JP Z,ANEG1
DEC BC
LD A,(BC)
XOR 1
LD (BC),A
ANEG1: XOR A
LD (RELTYP),A
RET
AABS: DEC BC
XOR A
LD (BC),A
JP ANEG1
ASGN: CALL ANEG1
LD D,B
LD E,C
LD A,(BC) ;GET EXPONENT
OR A
JP NZ,ASGN1
LD (DE),A ;MAKE ARGUMENT ZERO
RET
ASGN1: DEC BC
LD A,(BC)
OR A
LD HL,FPONE
JP Z,VCOPY
LD HL,FPNONE
JP VCOPY
;
; COMPUTE SIN(X) X=TOP OF ARGUMENT STACK
; RETURN RESULT IN PLACE OF X
;
ASIN: CALL QUADC ;COMPUTE QUADRANT
LD HL,(ASTKA)
LD D,H
LD E,L
LD BC,FTEMP
CALL AMUL1 ;FTEMP=X*X
POP AF
PUSH AF ;A=QUADRANT
RRA
JP C,SIN10 ;QUAD. ODD, COMPUTE COSINE
; COMPUTE X*P(X*X) -- SINE
LD DE,FTEM1
LD HL,(ASTKA)
CALL VCOPY ;FTEM1=X*X
LD BC,SINX
CALL POLY ;P(X*X)
CALL PREPOP
LD HL,FTEM1
CALL AMUL1 ;X*P(X*X)
; COMPUTE SIGN OF RESULT
; POSITIVE FOR QUADRANTS 0,1. NEGATIVE FOR 2,3
; NEGATE ABOVE FOR NEGATIVE ARGUMENTS
;
SIN5: POP AF ;QUADRANT
LD B,A
POP AF ;SIGN
RLCA ;SIGN, 2 TO THE 1ST BIT
XOR B ;QUADRANT, MAYBE MODIFIED FOR NEG. ARGUMENT
LD HL,(ASTKA)
DEC HL ;PTR TO SIGN
SUB 2
RET M ;QUADRANT 0 OR 1
INC (HL) ;ELSE SET RESULT NEGATIVE
RET
; COMPUTE P(X*X) -- COSINE
SIN10: LD BC,COSX
CALL POLY ;P(X*X)
JP SIN5
;
; COMPUTE COS(X) X=TOP OF ARGUMENT STACK
; RETURN RESULT IN PLACE OF X
; COS(X) = SIN(X+PI/2)
;
ACOS: CALL PREPOP
LD HL,PIC2 ;PI/2
CALL AADD1 ;TOS=TOS+PI/2
JP ASIN
;
; COMPUTE TAN(X) X=TOP OF ARGUMENT STACK
; RETURN RESULT IN PLACE OF X
; TAN(X)=SIN(X)/COS(X)
;
ATAN: LD HL,(ASTKA)
CALL PSHAS ;PUSH COPY OF X ONTO ARG STACK
CALL ACOS ;COS(X)
LD DE,FTEM2
CALL POPA1 ;FTEM2=COS(X)
CALL ASIN
CALL PREPOP
LD HL,FTEM2
JP ADIV1 ;SIN(X)/COS(X)
;
; COMPUTE SQR(X) X=TOP OF ARGUMENT STACK
; RETURN RESULT IN PLACE OF X
;
ASQR: LD HL,(ASTKA)
LD DE,FTEMP
CALL VCOPY ;SAVE X IN FTEMP
; COMPUTE EXPONENT OF FIRST GUESS AS EXPONENT OF X/2
LD HL,(ASTKA)
LD A,(HL)
OR A
RET Z ;X=0
SUB 128
JP M,SQR5 ;NEGATIVE EXPONENT
RRCA
AND 127
JP SQR6
SQR5: CPL
INC A
RRCA
AND 127
CPL
INC A
SQR6: ADD A,128
LD (HL),A
; TEST FOR NEGATIVE ARGUMENT
DEC HL
LD A,(HL)
LD BC,'NA'
OR A
JP NZ,ERROR ;NEGATIVE ARGUMENT
;
; DO NEWTON'S METHOD
; NEWGUESS=(X/OLDGUESS + OLDGUESS)/2
LD A,6 ;DO 6 ITERATIONS
SQR20: PUSH AF ;SET NEW ITERATION COUNT
LD BC,FTEM1
LD DE,FTEMP ;FTEMP IS 'X'
LD HL,(ASTKA) ;GUESS
CALL ADIV1 ;FTEM1=X/GUESS
LD DE,FTEM1
LD HL,(ASTKA)
LD B,H
LD C,L
CALL AADD1 ;TOS=(X/GUESS)+GUESS
CALL PREPOP
LD HL,FPTWO
CALL ADIV1 ;TOS=(X/GUESS+GUESS)/2
POP AF
DEC A ;DECREMENT COUNT
JP NZ,SQR20 ;DO ANOTHER ITERATION
RET
;
; COMPUTE RND(X) X=TOP OF ARGUMENT STACK
; FRAND IS UPDATED TO NEW RANDOM VALUE
; A RANDOM NUMBER IN THE RANGE 0<RND<1 IS RETURNED IN PLACE
;
ARND: CALL PREPOP
LD DE,FRAND
LD HL,FRAND
CALL AMUL1 ;TOS=FRAND*FRAND
; SET EXPONENT = 0
LD HL,(ASTKA)
LD (HL),128 ;EXPONENT = 128 (0 IN EXTERNAL FORM)
; PERMUTE DIGITS OF X AS
; 123456 INTO 345612
LD BC,-4
ADD HL,BC
LD B,(HL) ;SAVE 12
INC HL
INC HL
CALL PERMU ;56=12
CALL PERMU ;34=56
CALL PERMU ;12=34
; NORMALIZE NUMBER
RND5: LD HL,(ASTKA) ;TOS
LD BC,-FPSIZ+1
ADD HL,BC
LD A,(HL) ;FIRST DIGIT PAIR
AND 15*16
JP NZ,RND10 ;NUMBER IS NORMALIZED
; SHIFT LEFT ONE DIGIT
LD HL,(ASTKA)
LD A,(HL) ;EXPONENT
DEC A
LD (EXP),A
CALL LOAD ;TOS INTO TEMP
LD B,4
CALL LEFT ;SHIFT LEFT
CALL PREPOP
CALL STORE
JP RND5 ;TEST IF NORMALIZED
; SAVE NEW RANDOM NUMBER IN FRAND CELL
RND10: LD DE,FRAND
LD HL,(ASTKA)
CALL VCOPY ;FRAND = TOS
RET ;*****************CALL, RET????!!!!******
; PERMUTE DIGIT PAIRS
PERMU: LD A,(HL)
LD (HL),B
LD B,A
DEC HL
RET
;
; EVALUATE P(X) USING HORNER'S METHOD (X IS IN FTEMP)
; COEFFICIENT LIST POINTER IS IN BC
; RESULT REPLACES NUMBER ON TOP OF ARGUMENT STACK (Y)
;
POLY: LD HL,(ASTKA)
EX DE,HL ;DE=PTR TO Y
LD H,B
LD L,C ;HL PTR TO COEFFICIENT LIST
CALL VCOPY ;Y=FIRST COEFFICIENT
; MULTIPLY BY X
POLY1: PUSH HL ;SAVE COEFF LIST POINTER
CALL PREPOP
LD HL,FTEMP
CALL AMUL1 ;Y=Y*X
; ADD NEXT COEFF
CALL PREPOP
POP HL
PUSH HL ;HL = COEFF LIST POINTER
CALL AADD1 ;Y=Y+COEFF
; BUMP POINTER TO NEXT COEFFICIENT
POP HL ;COEFF POINTER
LD BC,-FPSIZ-1
ADD HL,BC ;NEXT COEFF SIGN
LD A,(HL)
INC HL ;PTR TO EXPONENT
OR A
JP P,POLY1 ;PROCESS NEXT COEFFICIENT
RET ;NEGATIVE SIGN (-1) ENDS LIST
;
; PREPARE FOR OPERATION
;
PREPOP: LD HL,(ASTKA)
EX DE,HL ;DE=ASTKA
LD B,D
LD C,E
RET
;
; QUADRANT COMPUTATION
; POPS TOP OF ARGUMENT STACK
; COMPUTE/GETS SIGN OF ARGUMENT, QUADRANT OF ARGUMENT
; AND INDEX INTO QUADRANT
;
; EXITS WITH:
; SP POINTING TO QUADRANT, MOD 4
; SP+2 POINTING TO SIGN OF ARGUMENT
; TOP OF ARGUMENT STACK HAS INDEX INTO QUADRANT
;
QUADC: LD HL,(ASTKA)
DEC HL ;POINT TO SIGN
LD B,(HL)
XOR A
LD (HL),A ;ARG. SIGN=0
LD H,B
EX (SP),HL ;PUT SIGN ON STACK, POP RETURN
PUSH HL ;PUSH RETURN
; COMPUTE QUADRANT OF ABS(X)
LD HL,(ASTKA)
CALL PSHAS ;PUT COPY OF ARG ONOT STACK
CALL PREPOP
LD HL,PIC1 ;2/PI
CALL AMUL1 ;TOS=X*2/PI
CALL PREPOP
CALL AINT ;TOS=INT(X*2/PI)
LD HL,(ASTKA)
CALL PSHAS ;ANOTHER COPY
CALL PFIX ;POP TOS TO DE
LD A,E
PUSH AF ;QUADRANT
CALL PREPOP
LD HL,PIC2
CALL AMUL1 ;TOS=INT(X*2/PI)
LD DE,FTEMP
CALL POPA1 ;FTEMP=TOS
CALL PREPOP
LD HL,FTEMP
CALL ASUB1 ;TOS=TOS-FTEMP
POP AF ;A=QUADRANT, LOW ORDER BYTE
AND 3 ;MOD 4
POP HL ;POP RETURN OFF STACK
PUSH AF ;SAVE QUADRANT ON STACK
JP (HL) ;DO RETURN
; SET UP ARG FOR USER CALL
AARG: CALL PFIX
EX DE,HL
LD (CALLA),HL
LD DE,FPSINK
JP PSHA1 ;PUTS BACK THE ARG VALUE ON ARG STACK
; USED TO CALL USER ROUTINE
ACALL: CALL PFIX ;GET THE ADDRESS
LD HL,(CALLA) ;GET THE USER ARGUMENT
EX DE,HL
LD BC,ACAL1 ;RETURN LINK FOR USER ROUTINE
PUSH BC
JP (HL)
ACAL1: LD DE,CALST
CALL CNS
LD A,CR
LD (DE),A
LD DE,CALST
LD HL,FPSINK
CALL FPIN
LD DE,FPSINK
JP PSHA1 ;PUT THE RETURNED USER VALUE ON ARG STACK
;
; INT FUNCTION ACTION ROUTINE
;
AINT: LD A,(BC)
SUB 129
JP P,AINT1
; ZERO IF VALUE LESS THAN 1
XOR A
LD D,5
AINT3:
LD (BC),A
DEC BC
DEC D
JP NZ,AINT3
RET
; EXP > 0
AINT1: SUB FPNIB-1
RET NC
LD D,A ;COUNT
DEC BC
AINT2: DEC BC
LD A,(BC)
AND 360Q
LD (BC),A
INC D
RET Z
XOR A
LD (BC),A
INC D
JP NZ,AINT2
RET
;
; DIMENSION MATRIX
; SYMTAB ADDRESS IN HL, HL NOT CLOBBERED
; DE CONTAINS SIZE IN NUMBER OF ELEMENTS
;
DIMS: PUSH HL
INC DE
PUSH DE
LD HL,0
LD C,FPSIZ
CALL RADD ;MULTIPLY NELTS BY BYTES PER VALUE
EX DE,HL
LD HL,(MATA)
PUSH HL
ADD HL,DE
CALL STOV ;CHECK THAT STORAGE NOT EXHAUSTED
LD (MATA),HL ;UPDATE MATRIX FREE POINTER
POP BC ;BASE ADDR
POP DE ;NELTS (NUMBER OF ELEMENTS)
POP HL ;SYMTAB ADDR
PUSH HL
LD (HL),D
DEC HL
LD (HL),E
DEC HL
LD (HL),B
DEC HL
LD (HL),C ;SYMTAB ENTRY NOW SET UP
POP HL
RET
;
; FIND VARIABLE OPTIONALLY SUBSCRIPTED IN TEXT
; SETS CARRY IF NOT FOUND
; RETURNS ADDRESS OF VARIABLE IN HL
; UPDATES TXA IF FOUND
;
VAR: CALL ALPHA
RET C
CALL NAME2
CALL GC
CP LPARRW
JP Z,VAR1 ;TEST IF SUBSCRIPTED
; MUST BE SCALAR VARIABLE
CALL STLK ;RETURNS ENTRY ADDRESS IN HL
OR A ;CLEAR CARRY
RET
; MUST BE SUBSCRIPTED
VAR1: CALL GCI ;GOBBLE LEFT PAREN
LD A,80H
OR C
LD C,A ;SET TYPE TO MATRIX
CALL STLK
PUSH HL ;SYMBOL TABLE
LD DE,10 ;DEFAULT MATRIX SIZE
CALL C,DIMS ;DEFAULT DIMENSION MATRIX
CALL EXPRB ;EVALUATE SUBSCRIPT EXPRESSION
CALL PFIX ;DE NOW HAS INTEGER
LD B,')'
CALL EATC ;GOBBLE RIGHT PAREN
POP HL
DEC HL
CALL DCMP ;BOUNDS CHECK INDEX
JP NC,E5
DEC HL
DEC HL
CALL LHLI ;GET BASE ADDR
LD C,FPSIZ
INC DE ;BECAUSE BASE ADDR IS TO ELEMENT - 1
CALL RADD ;ADD INDEX, CLEAR CARRY
RET ;******** CALL, RET????!!!!!**********
;
; JUNK ON END OF STATEMENT, TEST IF AT END OF FILE
; DOES NOT CLOBBER DE
; EATS CHARACTER AND LINE COUNT AFTER CR
; LEAVES NEW TXA IN HL
; SETS CARRY IF END OF FILE
;
JOE: CALL GCI
CP ';'
RET Z
CP CR
JP NZ,E1
LD A,(HL)
DEC A
JP Z,JOE2
INC HL
INC HL
INC HL ;SKIP OVER COUNT AND LINE NUMBER
JOE1: LD (TXA),HL
RET
JOE2: SCF
JP JOE1
;
; GET NAME FROM TEXT
; SETS CARRY IF NAME NOT FOUND
; IF SUCCEEDS RETURNS NAME IN BC, C=0 IF NO DIGIT IN NAME
;
NAME: CALL ALPHA
RET C
NAME2: LD B,A
LD C,0
CALL DIG
CCF
RET NC
LD C,A
OR A ;CLEAR CARRY
RET
;
; SYMBOL TABLE LOOKUP
; BC CONTAIN NAME AND CLASS
; IF NOT FOUND THEN CREATE ZERO'ED ENTRY AND SET CARRY
; HL HAS ADDRESS ON RET
;
STLK: LD HL,(MEMTOP)
LD DE,-STESIZ ;SET UP BASE AND INCREMENT FOR SEARCH LOOP
STLK0: LD A,(HL)
OR A
JP Z,STLK2 ;TEST IF END OF TABLE
CP B
JP NZ,STLK1 ;TEST IF ALPHA COMPARES
DEC HL
LD A,(HL) ;LOOK FOR DIGIT
CP C
DEC HL
RET Z ;CARRY CLEAR TOO, RETURN
INC HL
INC HL
STLK1: ADD HL,DE ;DIDN'T COMPARE, DECREMENT POINTER
JP STLK0
; ADD ENTRY TO SYMTAB
STLK2: LD (HL),B
DEC HL
LD (HL),C
INC HL
EX DE,HL
ADD HL,DE
LD (STAA),HL ;STORE NEW END OF STMTAB POINTER
DEC DE
DEC DE
EX DE,HL
SCF
RET
;
; GOBBLES NEXT TEXT CHARACTER IF ALPHABETIC
; SETS CARRY IF NOT
; NEXT CHAR IN ACC ON FAILURE
;
ALPHA: CALL GC
CP 'A'
RET C
CP 'Z'+1
CCF
RET C
JP DIGT1
;
; GOBBLES NEXT TEXT CHAR IF DIGIT
; SETS CARRY IF NOT
; NEXT CHAR IN ACC ON FAILURE
;
DIG: CALL GC
CP '0'
RET C
CP '9'+1
CCF
RET C
DIGT1: INC HL
LD (TXA),HL
RET
;
; COPYS FPSIZ BYTES AT ADDR HL TO ADDR DE
; ON EXIT HL POINTS TO ADR-1 OF LAST BYTE COPIED
;
VCOPY: LD C,FPSIZ
VCOP1: LD A,(HL)
LD (DE),A
DEC HL
DEC DE
DEC C
JP NZ,VCOP1
RET
;
; PUSH VALUE ADDRESSED BY HL ONTO ARG STACK
; SETS ARGF, CLEARS CARRY
;
PSHAS: EX DE,HL
PSHA1: LD HL,(ASTKA)
LD BC,-FPSIZ
ADD HL,BC
LD (ASTKA),HL ;DECREMENT ARG STACK POINTER
EX DE,HL
CALL VCOPY
LD A,1
LD (ARGF),A ;CLEAR ARGF
OR A
RET
;
; POP ARG STACK
; HL CONTAINS ADDRESS TO PUT POPPED VALUE INTO
;
POPAS: EX DE,HL
POPA1: LD HL,(ASTKA)
PUSH HL
LD BC,FPSIZ
ADD HL,BC
LD (ASTKA),HL ;INCREMENT STACK POINTER
POP HL
JP VCOPY
;
; PUSH FRAM ONTO CONTROL STACK
; TAKES MINUS AMOUNT TO SUB FROM CSTKA IN DE
; DOES OVERFLOW TEST AND RETURNS OLD CSTKA-1
;
PSHCS: LD HL,(CSTKA)
PUSH HL
ADD HL,DE
LD (CSTKA),HL
EX DE,HL
LD HL,LCSTKA ;ADDR CONTAINS CSTKL
CALL DCMP
JP C,E4
POP HL
DEC HL
RET
;
; STORAGE OVERFLOW TEST
; TEST THAT VALUE IN HL IS BETWEEN MATA AND STA
; DOES NOT CLOBBER HL
;
STOV: EX DE,HL
LD HL,MATA
CALL DCMP
JP C,E8
LD HL,STAA
CALL DCMP
EX DE,HL
RET C
E8: LD BC,'SO'
JP ERROR
;
; INCREMENT TXA IF NEXT NON-BLANK CHAR IS EQUAL TO B
; ELSE SYNTAX ERROR
;
EATC: CALL GCI
CP B
RET Z
JP E1
;
; GET NEXT NON-BLANK CHAR INTO ACC
; INCREMENT PAST BLANKS ONLY
;
GC: CALL GCI
DEC HL
LD (TXA),HL
RET
;
; GET NEXT NON-BLANK TEXT CHAR AND INCREMENT TXA
; DOES NOT CLOBBER DE,BC
; RETURN CHAR IN ACC
;
GCI: LD HL,(TXA)
GCI0: LD A,(HL)
INC HL
CP ' '
JP Z,GCI0
LD (TXA),HL
RET
;
; REPEAT ADD
; ADDS DE TO HL C TIMES
;
RADD: ADD HL,DE
DEC C
JP NZ,RADD
RET
;
; PRINT MESSAGE ADDRESSED BY HL
; ENDS WITH CHARACTER PROVIDED IN C
; RETURN IN HL ADDRESS OF TERMINATOR
;
PRNTCR: LD C,CR
JP PRN1
PRNT: LD C,'"'
PRN1: LD A,(HL) ;GET NEXT CHAR
LD B,A ;FOR CHOUT
CP C ;END OF MESSAGE TEST
RET Z
CP CR
JP Z,E1 ;NEVER PRINT A CR IN THIS ROUTINE
CALL CHOUT
INC HL
JP PRN1
;
; 16 BIT UNSIGNED COMPARE
; COMPARE DE AGAINST VALUE ADDRESSED BY HL
; CLOBBERS A ONLY
;
DCMP: LD A,E
SUB (HL)
INC HL
LD A,D
SBC A,(HL)
DEC HL
RET NZ
LD A,E
SUB (HL)
OR A ;CLEAR CARRY
RET
;
; INDIRECT LOAD HL THRU HL
;
LHLI: PUSH AF
LD A,(HL)
INC HL
LD H,(HL)
LD L,A
POP AF
RET
;
; GET FP CONSTANT FROM TEXT
; PUSHES VALUE ON ARG STACK AND SETS ARGF FLAG
; SETS CARRY IF NOT FOUND
;
CONST: LD HL,(TXA) ;PREPARE CALL FPIN
EX DE,HL
LD HL,FPSINK
CALL FPIN
RET C
DEC DE
EX DE,HL
LD (TXA),HL ;NOW POINTS TO TERMINATOR
LD DE,FPSINK
CALL PSHA1
XOR A
INC A ;SET A TO 1 AND CLEAR CARRY
LD (ARGF),A
RET
;
; DIRECT STATEMENT CHECKING ROUTINE
;
DIRT: LD A,(DIRF)
OR A
RET Z
LD BC,'DI'
JP ERROR
;
; FIND TEXT LINE WITH LINE NUMBER GIVEN IN DE
; RETURNS TEXT ADDRESS COUNT BYTE IN HL
;
FINDLN: LD HL,(BOFA)
LD B,0
FIND1: LD C,(HL)
LD A,C
CP EOF
JP Z,LERR
INC HL
CALL DCMP
DEC HL
RET Z
ADD HL,BC
JP FIND1
LERR: LD BC,'LN'
JP ERROR
;
; FIX FLOATING TO POSITIVE INTEGER
; RETURN INTEGER VALUE IN DE
; FP VALUE FROM TOP OF ARG STACK, POP ARG STACK
;
PFIX: LD HL,(ASTKA)
LD B,H
LD C,L
PUSH HL
CALL AINT
LD HL,FPSINK
CALL POPAS
POP HL
LD C,(HL) ;EXPONENT
DEC HL
LD A,(HL) ;SIGN
OR A
JP NZ,E5 ;NEGATIVE NO GOOD
LD DE,-FPSIZ+1
ADD HL,DE
LD DE,0
LD A,C
OR A
RET Z
DEC C ;SET UP FOR LOOP CLOSE TEST
PFIX1: INC HL
LD A,(HL)
RRCA
RRCA
RRCA
RRCA
CALL MUL10
JP C,E5
DEC C
RET P
LD A,(HL)
CALL MUL10
JP C,E5
DEC C
JP M,PFIX1
RET
;
; TAKE NEXT DIGIT IN A (MASK TO 17Q), ACCUMULATE TO DE
; PRESERVES ALL BUT A, DE
;
MUL10: PUSH HL
INC SP
INC SP
LD H,D ;GET ORIGINAL VALUE TO HL
LD L,E
ADD HL,HL ;DOUBLE IT
RET C
ADD HL,HL ;AGAIN
RET C
ADD HL,DE ;PLUS ORIGINAL MAKES 5 TIMES ORIG
RET C
ADD HL,HL ;TIMES TWO MAKES TEN
RET C
EX DE,HL
DEC SP
DEC SP
POP HL
AND 17Q
ADD A,E
LD E,A
LD A,D
ADC A,0 ;PROPAGATE THE CARRY
LD D,A
RET
;
; GET INTEGER FROM TEXT
; SET CARRY IF NOT FOUND
; RETURN INTEGER VALUE IN HL
; RETURN TERMINATOR IN ACC
;
INTGER: CALL DIG
RET C
LD DE,0
JP INTG2
INTG1: CALL DIG
LD H,D
LD L,E
CCF
RET NC
INTG2: SUB '0'
CALL MUL10
JP NC,INTG1
RET
;
; CONVERT INTEGER TO STRING
; DE CONTAINS ADDRESS OF STRING, RETURN UPDATED VALUE IN DE
; HL CONTAINS VALUE TO CONVERT
;
CNS: XOR A ;SET FOR NO LEADING ZEROES
LD BC,-10000
CALL RSUB
LD BC,-1000
CALL RSUB
LD BC,-100
CALL RSUB
LD BC,-10
CALL RSUB
LD BC,-1
CALL RSUB
RET NZ
LD A,'0'
LD (DE),A
INC DE
RET
;
; TAKE VALUE IN HL
; SUB MINUS NUMBER IN BC THE MOST POSSIBLE TIMES
; PUT VALUE ON STRING AT DE
; IF A=0 THEN DON'T PUT ZERO ON STRING
; RETURN NON-ZERO IN A IF PUT ON STRING
;
RSUB: PUSH DE
LD D,-1
RSUB1: PUSH HL
INC SP
INC SP
INC D
ADD HL,BC
JP C,RSUB1
DEC SP
DEC SP
POP HL
LD B,D
POP DE
OR B ;A GETS 0 IF A WAS 0 AND B IS 0
RET Z
LD A,'0'
ADD A,B
LD (DE),A
INC DE
RET
;
; INPUT CHARACTER FROM TERMINAL
; FORCE TO UPPER CASE.
;
INCHAR: PUSH BC ;SAVE ALL THE REGISTERS
PUSH DE ;THAT MIGHT GET WALKED OVER
PUSH HL ;BY CP/M
LD C,CONIN ;LOAD UP FUNCTION CODE AND
CALL BDOS ;CALL THE SYSTEM.
AND 07FH ;MASK OFF PARITY BIT.
CP 'a' ;CHECK IF LOWER CASE
JP C,INCH1 ;TOO LOW
CP 'z'+1 ;CHECK IF LOWER CASE
JP NC,INCH1 ;TOO HIGH
SUB 20H ;FORCE TO UPPER CASE
INCH1: POP HL ;RESTORE THE REGISTERS
POP DE ;THAT GOT PUSHED
POP BC ;GOING IN.
LD B,A ;COPY CHARACTER TO B AND
RET ;RETURN.
;
INL0: CALL CRLF
INLINE: LD HL,IBUF
LD C,LINLEN
INL1: CALL INCHAR
CP 7FH ;DELETE ?
JP Z,INL2
CP 15H ;CONTROL U ?
JP Z,INL0
LD (HL),A
LD B,LF ;IN CASE ALL DONE.
CP CR
JP Z,CHOUT ;ECHO LF AND RETURN.
INC HL
DEC C
JP NZ,INL1
LD BC,'LL'
JP ERROR
INL2: LD A,C
LD B,BELL
CP LINLEN
JP Z,INL3
DEC HL
LD B,(HL) ;ECHO DELETED CHARACTER.
INC C
INL3: CALL CHOUT
JP INL1
;
; TEST CONSOLE STATUS
;
STATUS: PUSH BC ;SAVE ALL THE
PUSH DE ;REGISTERS USED BY
PUSH HL ;CP/M.
LD C,CONSTS ;FIRE OFF THE
CALL BDOS ;CONSOLE STATUS CALL.
POP HL ;RESTORE
POP DE ;ALL
POP BC ;REGISTERS.
AND 01H ;SET FLAGS ON THE STATUS.
RET ;RETURN
;
; OUTPUT ROUTINES
;
CHOUT: PUSH BC ;PUSH THE REGISTERS
PUSH DE ;THAT GET WALKED OVER BY
PUSH HL ;OUR PAL CP/M.
LD C,CONOUT ;LOAD UP THE SYSTEM FUNCTION
LD E,B ;CODE, THEN CALL
CALL BDOS ;THE SYSTEM TO WRITE IT.
POP HL ;RESTORE
POP DE ;ALL THE REGISTERS
POP BC ;WE SAVED.
LD A,B ;GET A COPY OF THE CHARACTER.
;
CHCHK: CP CR
JP NZ,CHLF ;NOT CR, IS IT LF?
XOR A
JP PSTOR ;RETURN PHEAD TO ZERO
;
CHLF: CP LF
JP Z,NULCH ;IF LINE FEED PROCESS THE NULLS
CP 40Q ;NO PHEAD INCREMENT IF CONTROL CHAR
RET C
LD A,(PHEAD)
INC A
PSTOR: LD (PHEAD),A
RET
;
NULCH: LD A,(NULLCT) ;OUTPUT NULL CHARS
OR A
RET Z
PUSH BC
LD C,A
LD B,NULL
CH2: CALL CHOUT ;OUTPUT COUNT "C" NULLS
DEC C
JP NZ,CH2
POP BC
RET
;
CRLF2: CALL CRLF
CRLF: LD B,CR
CALL CHOUT
LD B,LF
JP CHOUT
;
; CHECK IF PANIC CHARACTER HAS BEEN HIT
;
;PCHECK:LD A,(BRKCHR)
; OR A
; CALL Z,STATUS
; RET Z
PCHECK: CALL STATUS ;ANYTHING TYPED
RET Z ;RET IF NO.
CALL INCHAR ;READ THE CHARACTER IN.
CP ESC
JP Z,STOP1
; LD (BRKCHR),A
RET
;
; GET INTEGER FROM TERMINAL
; DE CONTAINS STRING TO PRINT FIRST
; HL HAS 1 LESS THAN ACCEPTABLE LOWER BOUND
; THIS ROUTINE GOES TO START IF BAD NUMBER
; INTEGER VALUE RETURNED IN HL
;
GINT: PUSH HL
EX DE,HL
LD A,(PHEAD)
OR A
CALL NZ,CRLF
CALL PRNT
CALL INLINE
LD HL,IBUF
LD (TXA),HL
CALL INTGER
JP C,START
CP CR
JP NZ,START
POP DE
LD (IBUF),HL ;USE IBUF AS A TEMP
LD HL,IBUF
CALL DCMP
JP NC,START
LD HL,(IBUF) ;GET THE VALUE BACK TO HL
LD A,(HL)
CPL
LD (HL),A ;TRY TO STORE THERE
CP (HL)
JP NZ,START ;BAD OR MISSING MEMORY
CPL
LD (HL),A ;PUT IT BACK LIKE IT WAS
RET
;
; OUTPUT FP NUMBER ADDRESSED BY HL
;
FPOUT: LD BC,-DIGIT-1
ADD HL,BC
LD B,H
LD C,L
LD HL,ABUF ;OUTPUT BUFFER
LD A,(INFES) ;OUTPUT FORMAT
LD (FES),A ;STORE IT
LD E,DIGIT
LD (HL),0 ;CLEAR ROUND-OFF OVERFLOW BUFFER
INC HL ;ABUF+1
;
NXT: LD A,(BC) ;GET DIGIT AND UNPACK
LD D,A
RRA
RRA
RRA
RRA
AND 17Q ;REMOVE BOTTOM DIGIT
LD (HL),A ;STORE TOP DIGIT IN OUTPUT BUFFER (ABUF)
INC HL
LD A,D ;NOW GET BOTTOM DIGIT
AND 17Q
LD (HL),A ;STORE IT
INC HL
INC BC
DEC E
JP NZ,NXT
LD A,(BC)
LD (FSIGN),A ;STORE SIGN OF NUMBER
XOR A
LD (HL),A ;CLEAR ROUND-OFF BUFFER (ABUF+13) 12 DIGIT NO ROUND
LD HL,XSIGN ;EXPONENT SIGN STORE
LD (HL),A ;CLEAR XSIGN
;
FIX: INC BC ;GET EXPONENT
LD A,(BC)
OR A ;EXPONENT ZERO?
JP Z,ZERO
SUB 128 ;REMOVE EXPONENT BIAS
JP NZ,FIX2
INC (HL) ;INCREMENT XSIGN TO NEGATIVE FLAG(1) LATER ZERO
FIX2: JP P,CHK13
CPL ;IT'S A NEGATIVE EXPONENT
INC (HL) ;INCREMENT XSIGN TO NEGATIVE (1)
ZRO: INC A
CHK13: LD HL,EXPO ;EXPONENT TEMP STORE
LD (HL),A
LD E,A
CP DIGIT*2
LD HL,FES ;FORMAT TEMP BYTE
JP C,CHKXO
CHK40: LD A,1 ;FORCE EXPONENTIAL PRINTOUT
OR (HL) ;SET FORMAT FOR XOUT
LD (HL),A
;
CHKXO: LD A,(HL) ;CHECK IF EXPONENTIAL FORMAT
RRA
JP NC,CHKX3
AND 17Q
CP DIGIT*2
JP C,CHKX2
LD A,DIGIT*2-1 ;MAX DIGITS
CHKX2: LD D,A
INC A
JP ROUND
;
CHKX3: AND 17Q ;ADD EXPONENT AND DECIMAL PLACES
LD D,A
ADD A,E
CP DIGIT*2+1
LD B,A
JP C,CHKXN
LD A,(HL)
AND 100Q
JP NZ,CHK40
;
CHKXN: LD A,(XSIGN) ;CHECK EXPONENT SIGN
OR A
JP NZ,XNEG ;IT'S NEGATIVE
LD A,B
JP ROUND
;
XNEG: LD A,D ;SUBTRACT EXPONENT AND DECIMAL PLACE COUNT
SUB E
JP NC,XN2
XN1: LD A,(INFES)
OR A
JP P,ZERO
AND 16Q
JP Z,ZERO
RRCA
LD E,A
DEC E
LD C,1
LD HL,ABUF-1
JP NRND
XN2: JP Z,XN1
JP ROUND
;
CLEAN: LD B,37Q ;CLEAR FLAGS
AND B
CP DIGIT*2+1
RET C
LD A,DIGIT*2+1 ;MAX DIGITS OUT
RET
;
; THIS ROUTINE IS USED TO ROUND DATA TO THE
; SPECIFIED DECIMAL PLACE
;
ROUND: CALL CLEAN
LD C,A
LD B,0
LD HL,ABUF+1
ADD HL,BC ;GET ROUND-OFF ADDRESS
LD (ADDT),HL
LD A,(HL)
CP 5 ;ROUND IF >=5
JP C,TRL2-1
;
LESS1: DEC HL
INC (HL) ;ROUND UP
LD A,(HL)
OR A
JP Z,TRL2
CP 10 ;CHECK IF ROUNDED NUMBER >9
JP NZ,TRAIL
LD (HL),0
JP LESS1
;
; THIS ROUTINE IS USED TO ELIMINATE TRAILING ZEROES
;
TRAIL: LD HL,(ADDT)
DEC HL
TRL2: LD A,(FES) ;CHECK IF TRAILING ZEROES ARE WANTED
RLA
JP C,FPRNT ;YES- GO PRINT DATA
TRL3: LD A,(HL)
OR A ;IS IT A ZERO?
JP NZ,FPRNT ;NO - GO PRINT
DEC HL
DEC C ;YES - FIX OUTPUT DIGIT COUNT
JP M,ZERO
JP TRL3
;
; HERE START THE PRINT FORMAT ROUTINES
;
FPRNT: LD HL,ABUF
LD A,(HL) ;CHECK IF ROUNDED UP TO 1
OR A
JP Z,NRND ;JUMP IF NOT
LD B,1
LD A,(XSIGN) ;IS EXPONENT NEGATIVE?
OR A
JP Z,POSR
LD B,-1
;
POSR: LD A,(EXPO) ;GET EXPONENT
OR A
JP NZ,PO2 ;IS IT ZERO (E + 0)
LD (XSIGN),A
LD B,1
PO2: ADD A,B ;FIX EXPONENT COUNT
LD (EXPO),A
INC E
INC C
DEC HL
;
NRND: INC HL
LD A,C
CP DIGIT*2+1 ;CHECK FOR MAXIMUL DIGITS OUT
JP NZ,NRND1
DEC C
NRND1: LD A,(FSIGN) ;CHECK IN NEGATIVE NUMBER
RRA
JP NC,PRI22 ;GO OUTPUT RADIX AND NUMBER
CALL NEG ;OUTPUT (-)
JP PRI21
;
PRI22: CALL SPACE ;OUTPUT A SPACE
PRI21: LD A,(FES) ;GET OUTPUT FORMAT
RRA ;CHECK IF EXPONENTIAL FORMAT
JP C,XPRIN
LD A,(XSIGN) ;GET EXPONENT SIGN
OR A ;CHECK IF NEGATIVE EXPONENT
JP Z,POSIT
LD A,C
OR A
JP NZ,PRIN4 ;OUTPUT RADIX AND NUMBER
CALL ZERO ;NO DIGITS AFTER RADIX, OUTPUT ZERO AND DONE
RET ;****** CALL, RET????!!!********
;
PRIN4: CALL RADIX ;PRINT DECIMAL POINT
XOR A
OR E
JP Z,PRIN5 ;JUMP IF NO ZEROES TO PRINT
CALL ZERO ;FORCE PRINT A ZERO
DEC E
JP NZ,PRIN4+3
;
PRIN5: CALL NOUT ;PRINT ASCII DIGIT
JP NZ,PRIN5
RET
;
POSIT: CALL NOUT
DEC E ;BUMP EXPONENT COUNT
JP NZ,POSIT
LD A,C ;CHECK IF MORE DIGITS TO OUTPUT
OR A
RET Z ;NO, DONE
RET M
JP PRIN4 ;NOW PRINT DECIMAL POINT
;
; GET HERE FOR EXPONENTIAL OUTPUT FORMAT
;
XPRIN: CALL NOUT
JP Z,NDEC ;INTEGER?
CALL RADIX ;NO....PRINT DECIMAL POINT
XPRI2: CALL NOUT
JP NZ,XPRI2
;
NDEC: LD B,'E' ;OUTPUT 'E'
CALL CHOUT
LD A,(XSIGN)
OR A
JP Z,XPRI3
CALL NEG ;PRINT EXPONENT SIGN (-)
LD A,(EXPO)
INC A
JP XOUT2
XPRI3: LD B,'+' ;EXPONENT (+)
CALL CHOUT
;
; THIS ROUTINE IS USED TO CONVERT THE EXPONENT
; FROM BINARY TO ASCII AND PRINT THE RESULT
;
XOUT: LD A,(EXPO)
DEC A
XOUT2: LD C,100
LD D,0
CALL CONV
CP '0' ;SKIP LEADING ZEROES
JP Z,XO21
INC D
CALL CHOUT
XO21: LD A,E
LD C,10
CALL CONV
CP '0'
JP NZ,XO3
DEC D
JP NZ,XO4
XO3: CALL CHOUT
XO4: LD A,E
ADD A,'0' ;ADD ASCII BIAS
LD B,A
CALL CHOUT
RET ;****** CALL, RET?????!!!!!*****
CONV: LD B,'0'-1
INC B
SUB C
JP NC,CONV+2
ADD A,C
LD E,A
LD A,B
RET
;
; THIS ROUTINE ADD ASCII BIAS TO A BCD DIGIT
; AND CALLS THE OUTPUT ROUTINE
;
NOUT: LD A,(HL)
ADD A,'0'
LD B,A
CALL CHOUT
INC HL
DEC C ;DECREMENT TOTAL DIGITS OUT COUNT
RET
;
; COMMON SYMBOL LOADING ROUTINES
;
NEG: LD B,'-'
JP CHOUT
ZERO: LD B,'0'
JP CHOUT
SPACE: LD B,' '
JP CHOUT
RADIX: LD B,'.'
JP CHOUT
;
; CONVERTS FP STRING AT DE, UPDATE DE PAST TERMINATOR
; PUTS TERMINATOR IN B, PUTS FP NUMBER AT ADDRESS IN HL
; SETS CARRY IF NOT FOUND
;
FPIN: PUSH HL
PUSH DE
EX DE,HL
DEC HL
LD (ADDS),HL
LD HL,OPST ;CLEAR TEMPORARY STORAGE AREAS AND BC BUFFER
LD C,DIGIT+6
CALL CLEAR
;
SCANC: LD DE,0
LD HL,BCX ;BC=PACK BUFFER
SCAN0: LD (BCADD),HL ;PACK BUFFER POINTER
SCANP: LD HL,SCANP
PUSH HL ;USED FOR RETURN FROM OTHER ROUTINES
XOR A
LD (XSIGN),A ;CLEAR EXPONENT SIGN BYTE
;
SCANG: CALL IBSCN
JP C,SCANX ;FOUND A NUMBER, GO PACK IT
CP '.' ;RADIX?
JP Z,SCAN5 ;PROCESS RADIX POINTERS
CP 'E' ;EXPONENT?
JP Z,EXCON ;FOUND 'E', GO PROCESS EXPONENT
; NOT A CHARACTER LEGAL IN NUMBER
LD B,A ;MOVE TERMINATOR TO B
LD A,(OPST) ;CHECK IF ANY DIGITS YET
AND 20Q
JP NZ,ENTR2
; GET HERE IF LEGAL FP NUMBER NOT FOUND
FPIN1: POP HL ;SCANP LINK
POP DE ;TEXT POINTER
POP HL ;FP # ADDR
SCF
RET
; FOUND DECIMAL POINT
SCAN5: XOR A ;FOUND RADIX PROCESS RADIX POINTERS FOR EXP
OR D ;ANY DIGITS YET?
JP NZ,SCAN6
ADD A,300Q ;SET ECNT - STOP COUNTING DIGITS
OR E ;NO INT DIGITS, BIT 7 IS COUNT/DON'T COUNT FLAG
LD E,A ;BIT 6 IS NEGATIVE EXPONENT FLAG
RET
SCAN6: LD A,200Q ;SET ECNT TO COUNT DIGITS
OR E
LD E,A
RET
;
SCANX: AND 17Q ;FOUND NUMBER-REMOVE ASCII BIAS
LD B,A
LD HL,OPST ;SET FIRST CHARACTER FLAG
LD A,60Q
OR (HL)
LD (HL),A
XOR A
OR B ;IS CHARACTER ZERO?
JP NZ,PACK
OR D ;LEADING ZERO? IE. ANY INT DIGITS?
JP NZ,PACK
OR E
LD E,A
RET Z ;IF COUNTING YET
INC E ;ECNT+1-COUNT ZEROS FOR EXPONENT COUNT
RET
;
; THIS SUBROUTINE BCD PACKS DIGITS INTO REG BC
;
PACK: LD A,E
RLA
JP C,PACK1
INC E
PACK1: LD A,E
LD (ECNT),A ;DIGIT COUNT FOR EXPONENT COUNT
INC D ;TOTAL DIGIT COUNT (D ALSO HAS TOP/BOTM FLAG BIT 7)
LD A,D
AND 177Q ;REMOVE TOP/BOTM FLAG
CP DIGIT*2+1 ;LIMIT INPUT DIGITS
RET NC
XOR A
OR D
JP M,BOTM
;
TOP: OR 200Q ;SET MSB FOR TOP FLAG
LD D,A
LD A,B
LD HL,(BCADD) ;GET BC ADDRESS
RLCA
RLCA
RLCA
RLCA
LD (HL),A ;SAVE CHAR IN BC
RET
;
BOTM: AND 177Q ;STRIP MSB (BOTTOM FLAG)
LD D,A
LD A,B
LD HL,(BCADD)
OR (HL) ;OR IN TOP NUMBER
LD (HL),A ;PUT NUMBER BACK IN BC
INC HL
POP BC
JP SCAN0
IBSCN: LD HL,(ADDS) ;INPUT BUFFER POINTER
INC HL ;GET NEXT BYTE
LD A,(HL)
CP ' '
JP Z,IBSCN+3
LD (ADDS),HL ;NOTE: THIS ROUTINE FALLS THROUGH
; THIS ROUTINE CHECKS FOR ASCII NUMBERS
NMCHK: CP '9'+1
RET NC
CP '0'
CCF
RET
;
; THIS ROUTINE IS USED TO ADJUST A NUMBER IN BC BUFFER
; AND RETURNS VALUE
;
ENTR2: LD DE,0
ENT1: PUSH BC ;TERMINATOR
CALL FIXE ;NORMALIZE FLOATING POINT NUMBER
POP BC ;TERMINATOR
POP DE ;SCANP LINK
POP DE ;OLD TEXT ADDR
POP DE ;RETURN ADDR
LD C,DIGIT+2
LD HL,BCX+DIGIT+1
CALL VCOPY
LD HL,(ADDS)
EX DE,HL
INC DE
OR A
RET
;
; THIS ROUTINE IS USED TO CLEAR STORAGE AREAS
; THE STARTING ADDRESS IS IN HL AND THE COUNT
; IS IN C
;
CLEAR: XOR A
LD (HL),A
INC HL
DEC C
JP NZ,CLEAR+1
RET
;
; THIS ROUTINE CONVERTS THE ASCII EXPONENT OF
; THE NUMBER IN THE INPUT BUFFER TO BINARY, AND
; NORMALIZES THE EXPONENT ACCORDING TO THE INPUT
; FORMAT OF THE NUMBER
;
EXCON: CALL IBSCN ;GET CHARACTER
JP C,EXC3
CP PLSRW ;CHECK FOR UNARY SIGNS
JP Z,EXC4
CP '+'
JP Z,EXC4
CP '-'
JP Z,EXC2
CP MINRW
JP NZ,FPERR ;NO SIGN OR NUMBER?
EXC2: LD A,1
LD (XSIGN),A ;SAVE SIGN
EXC4: CALL IBSCN
JP NC,FPERR ;NO NUMBER?
EXC3: CALL ASCDC ;CONVERT ASCII TO BINARY
JP ENT1 ;NORMALIZE NUMBER AND RETURN
;
; THIS ROUTINE CONVERTS ASCII TO BINARY
; THREE CONSECUTIVE NUMBERS < 128 MAY BE CONVERTED
;
ASCDC: EX DE,HL
LD HL,0
ASC1: LD A,(DE) ;GET CHR FROM INPUT BUFFER-NO SPACES ALLOWED
CALL NMCHK ;CHECK IF NUMBER
JP NC,ASC2
SUB '0' ;REMOVE ASCII BIAS
LD B,H
LD C,L
ADD HL,HL
ADD HL,HL
ADD HL,BC
ADD HL,HL
LD C,A
LD B,0
ADD HL,BC
INC DE
JP ASC1
ASC2: EX DE,HL
LD B,A ;SAVE TERMINATOR
LD (ADDS),HL ;SAVE IBUF ADDRESS
LD A,D
OR A
JP NZ,FPERR ;TOO BIG >255
LD A,E
RLA
JP C,FPERR ;TOO BIG >127
RRA
RET
FPERR: POP BC ;ASCDC RET LINK
JP FPIN1
;
; THIS ROUTINE NORMALIZES THE INPUT NUMBER
;
FIXE: EX DE,HL
LD A,(BCX)
OR A ;IS IT ZERO?
JP Z,ZZ2
CALL CHKPN ;SET EXPONENT POSITIVE/NEGATIVE
ADD A,200Q ;ADD EXPONENT BIAS
ZZ2: LD (BCX+DIGIT+1),A ;STORE NORMALIZED EXPONENT IN BC
RET
;
CHKPN: LD A,(ECNT) ;GET EXPONENT COUNT-SET IN 'SCAN' ROUTINE
LD E,A
AND 77Q ;STRIP BITS 7&8
LD B,A
LD A,(XSIGN)
OR A
JP Z,LPOS ;EXPONENT IS POSITIVE
INC H ;SET SIGN IN H ** THIS SHOULD BE INR H NOT INX H
LD A,100Q ;L IS NEGATIVE
AND E ;CHECK IF E IS NEGATIVE
JP Z,EPOS
LD A,L ;BOTH E & L NEGATIVE
LD L,B
CALL BPOS+1
CPL
INC A
RET ;BACK TO FIXE
;
EPOS: LD A,L ;E&L NEGATIVE
CPL
INC A ;TWO'S COMP A
ADD A,B
RET ;TO FIXE
;
LPOS: LD A,100Q ;EXPONENT POSITIVE
AND E ;IS E NEGATIVE?
JP Z,BPOS
LD A,B
LD B,L
JP EPOS+1
;
BPOS: LD A,B ;E&L POSITIVE
ADD A,L
RET P
;
POP HL
JP FPERR
DEFB 10H
DEFW 0
DEFB 1
FPNONE: DEFB 129
;
; FLOATING POINT MATH PACKAGE
;
; EACH FUNCTION OPERATES AS FOLLOWS: (BC) = (DE) # (HL)
; WHERE BC IS ADDRESS OF RESULT
; DE IS ADDRESS OF 1ST ARGUMENT
; HL IS ADDRESS OF 2ND ARGUMENT
; AND # IS ONE OF THE OPERATORS +,-,*,/
;
; ON ENTRY ALL ADDRESS POINT TO THE EXPONENT PART OF THE
; FLOATING POINT ARGUMENT
;
; THE NUMBER ZERO IS REPRESENTED BY A ZERO EXPONENT
;
; ALL NUMBERS ARE ASSUMED TO BE NORMALIZED
;
FADD: PUSH BC
CALL EXPCK ;FETCH ARGUMENTS
LD C,0
ADSUM: DEC DE
EX DE,HL
LD A,(SIGN)
XOR (HL) ;FORM SIGN OF RESULT
LD B,A
EX DE,HL
LD A,(DE)
DEC DE
XOR C
LD (SIGN),A
LD HL,RCTRL ;ROUNDING CONTOL FLAG
LD A,(HL)
OR A
INC HL
LD A,(HL) ;GET ROUNDING DIGIT
JP Z,ADS8
RLCA
RLCA
RLCA
RLCA
ADS8: ADD A,0B0H ;FORCE CARRY IF DIGIT > 5
LD A,B
RRA
JP C,ADS1 ;HAVE SUBTRACTION
RLA ;RESTORE CARRY
CALL ADDX ;PERFORM ADDITION
JP NC,ADS2
LD B,4
CALL RIGHT
LD HL,EXP
INC (HL) ;INCREMENT EXPONENT
JP Z,OVER
ADS2: POP BC ;GET RESULTS ADDRESS
CALL STORE ;SAVE RESULTS
RET ;******* CALL, RET????!!!!********
ZEREX: POP HL
JP ADS2
ADDX: LD HL,BUF+DIGIT-1
LD B,DIGIT
ADD1: LD A,(DE)
ADC A,(HL)
DAA
LD (HL),A
DEC HL
DEC DE
DEC B
JP NZ,ADD1
RET NC
INC (HL)
RET
;
; FLOATING POINT SUBTRACTION
;
FSUB: PUSH BC
CALL EXPCK ;GET ARGUMENTS
LD A,(SIGN)
XOR 1 ;COMPLEMENT SIGN
LD (SIGN),A
JP ADSUM
ADS1: RLA ;RESTORE CARRY
CCF ;COMPLEMENT FOR ROUNDING
CALL SUBX ;SUBTRACT ARGUMENTS
LD HL,SIGN
JP C,ADS4
LD A,(HL) ;GET SIGN
XOR 1 ;COMPLEMENT
LD (HL),A
ADS7: DEC HL
LD B,DIGIT
ADS3: LD A,9AH
SBC A,(HL) ;COMPLEMENT RESULT
ADD A,0
DAA
LD (HL),A
DEC HL
DEC B
CCF
JP NZ,ADS3
ADS4: LD HL,BUF
LD BC,DIGIT
ADS5: LD A,(HL)
OR A
JP NZ,ADS6
INC HL
INC B
INC B
DEC C
JP NZ,ADS5
XOR A ;********* NOT NEEDED
LD (EXP),A
JP ADS2
ADS6: CP 10H
JP NC,ADS9
INC B
ADS9: LD HL,EXP
LD A,(HL)
SUB B
JP Z,UNDER
JP C,UNDER
LD (HL),A
LD A,B
RLCA
RLCA
LD B,A
CALL LEFT
JP ADS2
SUBX: LD HL,BUF+DIGIT-1
LD B,DIGIT
SUB1: LD A,99H
ADC A,0
SUB (HL)
EX DE,HL
ADD A,(HL)
DAA
EX DE,HL
LD (HL),A
DEC HL
DEC DE
DEC B
JP NZ,SUB1
RET
;
; FLOATING POINT MULTIPLY
;
FMUL: PUSH BC
LD A,(HL)
OR A ;ARGUMENT = 0?
JP Z,FMUL1+2
LD A,(DE)
OR A ;ARGUMENT =0?
JP Z,FMUL1+2
ADD A,(HL) ;FORM RESULT EXPONENT
JP C,FMOVR
JP P,UNDER
JP FMUL1
FMOVR: JP M,OVER
FMUL1: SUB 128 ;REMOVE EXCESS BIAS
LD (EXP),A ;SAVE EXPONENT
DEC DE
DEC HL
LD A,(DE)
XOR (HL) ;FORM RESULT SIGN
DEC HL
DEC DE
PUSH HL
LD HL,SIGN ;GET SIGN ADDRESS
LD (HL),A ;SAVE SIGN
DEC HL
XOR A
LD B,DIGIT+2
FMUL2: LD (HL),A ;ZERO WORKING BUFFER
DEC HL
DEC B
JP NZ,FMUL2
LD A,(EXP)
OR A
JP Z,ZEREX
LD C,DIGIT
LD HL,HOLD1+DIGIT
; GET MULTIPLIER INTO HOLDING REGISTER
FMUL3: LD A,(DE)
LD (HL),A ;PUT IN REGISTER
DEC HL
DEC DE
DEC C
JP NZ,FMUL3
LD (HL),C
DEC HL
LD B,250 ;SET LOOP COUNT
FMUL4: LD DE,DIGIT+1
LD C,E
ADD HL,DE
EX DE,HL
ADD HL,DE ;H,L=NEXT HOLDING REGISTER
INC B
JP P,FMUL8 ;FINISHED
FMUL5: LD A,(DE) ;GET DIGITS
ADC A,A ;TIMES 2
DAA
LD (HL),A ;PUT IN HOLDING REGISTER
DEC DE
DEC HL
DEC C
JP NZ,FMUL5
INC B ;INCREMENT LOOP COUNT
JP NZ,FMUL4
;
; FORM 10X BY ADDING 8X AND 2X
; FIRST GET 8X
INC HL
LD DE,HOLD5 ;NEXT HOLDING REGISTER
LD C,DIGIT+1
LD B,C
FMUL6: LD A,(HL)
LD (DE),A
INC HL
INC DE
DEC C
JP NZ,FMUL6
LD HL,HOLD2+DIGIT ;GET 2X
DEC DE
FMUL7: LD A,(DE)
ADC A,(HL) ;FORM 10X
DAA
LD (DE),A
DEC DE
DEC HL
DEC B
JP NZ,FMUL7
LD B,249
EX DE,HL
JP FMUL4
FMUL8: EX DE,HL
INC HL
LD (HL),DIGIT+1 ;SET NEXT LOOP COUNT
; PERFORM ACCUMULATION OF PRODUCT
FMUL9: POP BC ;GET MULTIPLIER
LD HL,HOLD8+DIGIT+1
DEC (HL) ;DECREMENT LOOP COUNT
JP Z,FMU14 ;FINISHED
LD A,(BC)
DEC BC
PUSH BC
DEC HL
EX DE,HL
FMU10: ADD A,A ;CHECK FOR BIT IN CARRY
JP C,FMU11 ;FOUND A BIT
JP Z,FMU12 ;ZERO - FINISHED THIS DIGIT
LD HL,-DIGIT-1
ADD HL,DE ;POINT TO NEXT HOLDING REGISTER
EX DE,HL
JP FMU10
FMU11: LD C,A
OR A ;CLEAR CARRY
CALL ADDX ;ACCUMULATE PRODUCT
LD A,(DE)
ADD A,(HL)
DAA
LD (HL),A
LD A,C
DEC DE
JP FMU10
; ROTATE RIGHT 1 BYTE
FMU12: LD B,8
CALL RIGHT
JP FMUL9
FMU14: LD A,(BUF)
AND 0F0H ;CHECK IF NORMALIZING
JP Z,FMU17
LD A,D
AND 0F0H
LD HL,SIGN-1
JP FMU18
FMU17: LD B,4
LD HL,EXP
DEC (HL)
JP Z,UNDER
CALL LEFT ;NORMALIZE
LD A,D ;GET DIGIT SHIFTED OFF
; PERFORM ROUNDING
RRCA
RRCA
RRCA
RRCA
FMU18: CP 50H
JP C,FMU16
INC A
AND 0FH
LD C,DIGIT
FMU15: ADC A,(HL)
DAA
LD (HL),A
LD A,0
DEC HL
DEC C
JP NZ,FMU15
; CHECK FOR ROUNDING OVERFLOW
JP NC,ADS2 ;NO OVERFLOW
INC HL
LD (HL),10H
LD HL,EXP
INC (HL)
JP NZ,ADS2
JP OVER
; ROUNDING NOT NEEDED
FMU16: AND 0FH
ADD A,(HL)
LD (HL),A
JP ADS2
;
; FLOATING POINT DIVISION
;
FDIV: PUSH BC
LD A,(HL) ;FETCH DIVISOR EXP
OR A ;DIVIDE BY ZERO?
JP Z,DIVZ
LD A,(DE)
OR A ;DIVIDEND 0?
JP Z,INSP
SUB (HL)
JP C,DIVUN
JP M,OVER
JP FDI1
DIVUN: JP P,UNDER
FDI1: ADD A,129 ;FORM QUOTIENT EXP
LD (EXPD),A
EX DE,HL
PUSH DE
CALL LOAD ;FETCH DIVIDEND
POP DE
EX DE,HL
LD A,(SIGN)
DEC HL
XOR (HL) ;FORM QUOTIENT SIGN
LD (SIGND),A
EX DE,HL
DEC DE
LD BC,HOLD1
DIV0: LD L,DIGIT+DIGIT
DIV1: PUSH BC
PUSH HL
LD C,0 ;QUOTIENT DIGIT = 0
DIV3: SCF ;SET CARRY
LD HL,BUF+DIGIT-1
LD B,DIGIT
DIV4: LD A,99H
ADC A,0
EX DE,HL
SUB (HL)
EX DE,HL
ADD A,(HL)
DAA
LD (HL),A
DEC HL
DEC DE
DEC B
JP NZ,DIV4
LD A,(HL)
CCF
SBC A,0
LD (HL),A
RRA
LD HL,DIGIT
ADD HL,DE
EX DE,HL
INC C ;INCREMENT QUOTIENT
RLA
JP NC,DIV3
OR A ;CLEAR CARRY
CALL ADDX ;RESTORE DIVIDEND
LD HL,DIGIT
ADD HL,DE
EX DE,HL
PUSH BC
LD B,4
CALL LEFT ;SHIFT DIVIDEND
POP BC
DEC C
POP HL
LD H,C
POP BC
LD A,L
JP NZ,DIV5
CP DIGIT+DIGIT
JP NZ,DIV5
LD HL,EXPD
DEC (HL)
CALL Z,UNDER
JP DIV0
DIV5: RRA
LD A,H
JP NC,DIV6
LD A,(BC)
RLCA
RLCA
RLCA
RLCA
ADD A,H
LD (BC),A ;STORE QUOTIENT
INC BC
JP DIV7
DIV6: LD (BC),A ;STORE QUOTIENT
DIV7: DEC L ;DECREMENT DIGIT COUNT
JP NZ,DIV1
LD HL,EXPD
POP BC
CALL STORO
RET ;***** CALL, RET????!!!!!*******
;
; FETCH AND ALIGN ARGUMENTS FOR
; ADDITION AND SUBTRACTION
;
EXPCK: LD A,(DE)
SUB (HL) ;DIFFERENCE OF EXPONENTS
LD C,0
JP NC,EXPC1
INC C
EX DE,HL
CPL
INC A
EXPC1: LD B,A
LD A,(DE)
LD (EXP),A
LD A,B
CP DIGIT+DIGIT
JP C,EXPC2
LD A,DIGIT+DIGIT
EXPC2: RLCA
RLCA
LD B,A
AND 4
LD (RCTRL),A ;SET ROUNDING CONTROL
PUSH BC
PUSH DE
CALL LOAD ;LOAD SMALLER VALUE
LD A,8*DIGIT+16
SUB B
CP 8*DIGIT+16
JP Z,EXPC3
AND 0F8H
RRA
RRA
RRA
ADD A,E
LD E,A
LD A,D
ADC A,0
LD D,A
LD A,(DE) ;GET ROUNDING DIGIT
LD (RDIGI),A ;SAVE
EXPC3: CALL RIGHT ;ALIGN VALUES
POP DE
POP BC
RET
; LOAD ARGUMENT INTO BUFFER
LOAD: LD DE,SIGN
LD C,DIGIT+1
DEC HL
LOAD1: LD A,(HL)
LD (DE),A
DEC HL
DEC DE
DEC C
JP NZ,LOAD1
XOR A
LD (DE),A
DEC DE
LD (DE),A
LD (RDIGI),A ;ZERO ROUNDING DIGIT
RET
; STORE RESULTS IN MEMORY
STORE: LD HL,EXP
STORO: LD E,DIGIT+2
STOR1: LD A,(HL)
LD (BC),A
DEC BC
DEC HL
DEC E
JP NZ,STOR1
RET
; SHIFT RIGHT NUMBER OF DIGITS
; IN B/4
RIGHT: LD C,DIGIT+1
RIGH1: LD HL,BUF-1
LD A,B
SUB 8 ;CHECK IF BYTE CAN BE SHIFTED
JP NC,RIGH3
DEC B
RET M
OR A
RIGH2: LD A,(HL)
RRA
LD (HL),A
INC HL
DEC C
JP NZ,RIGH2
JP RIGHT
; SHIFT RIGHT ONE BYTE
RIGH3: LD B,A
XOR A
RIGH4: LD D,(HL)
LD (HL),A
LD A,D
INC HL
DEC C
JP NZ,RIGH4
JP RIGHT
; SHIFT LEFT NUMBER OF DIGITS
; IN B/4
LEFT: LD C,DIGIT+1
LD HL,SIGN-1
LEF1: LD A,B
SUB 8
JP NC,LEF3
DEC B
RET M
OR A
LEF2: LD A,(HL)
RLA
LD (HL),A
DEC HL
DEC C
JP NZ,LEF2
JP LEFT
; SHIFT LEFT ONE BYTE
LEF3: LD B,A
XOR A
LEF4: LD D,(HL)
LD (HL),A
LD A,D
DEC HL
DEC C
JP NZ,LEF4
JP LEFT
; SET FLAGS FOR OVERFLOW, UNDERFLOW,
; AND DIVIDE BY ZERO
DIVZ:
OVER: LD BC,'FP'
JP ERROR
UNDER: LD A,-1
LD (ERRI),A
INSP: INC SP
INC SP
RET
;
; FLOATING POINT RAM
;
HOLD1: DEFS DIGIT+1
HOLD2: DEFS DIGIT+1
HOLD3: DEFS DIGIT+1
HOLD4: DEFS DIGIT+1
HOLD5: DEFS DIGIT+1
HOLD6: DEFS DIGIT+1
HOLD7: DEFS DIGIT+1
HOLD8: DEFS DIGIT+1
DEFS 1
ERRI: DEFS 1 ;ERROR FLAG
DEFS 1
BUF: DEFS DIGIT ;WORKING BUFFER
SIGN: DEFS 1 ;SIGN BIT
EXP: DEFS 1 ;EXPONENT
RC
Reference in New Issue View Git Blame Copy Permalink