DEFINE NOT_XROM
INCLUDE "2068_DEFS.ASM"
;these are probably spurious labels, but I have defined them to
; make the assembler happy
DEFC M492A = $492A
DEFC MB3C8 = $B3C8
DEFC M6000 = $6000
DEFC M6815 = $6815
DEFC M65D0 = $65D0
DEFC M6499 = $6499
DEFC M6722 = $6722
DEFC MFD90 = $FD90
DEFC M0F09 = $0F09 ;in EXROM
ORG 0
;******************************************************************
; Module: BASIC
; Routine: PLUGIN
;******************************************************************
PLUGIN:
DI ;disable interrupts
XOR A ;
LD DE,$FFFF ;physical ramtop
JP M0D31 ;go to the initialization routine
;******************************************************************
; Module: BASIC
; Routine: ERROR
; Handles errors. top of machine stack has the address of the
; error identifier
;******************************************************************
LD HL,(CHADD) ;load HL with character pointer CH_ADD
LD (XPTR),HL ;store in X_PTR – character after ? mark
JR GETERNR
;******************************************************************
; Module: BASIC
; Routine: WRCH
; Write a character to the current stream
;******************************************************************
WRCH:
JP M11ED ;jump to stream output routine
RST $38
RST $38
RST $38
RST $38
RST $38
;******************************************************************
; Module: BASIC
; Routine: GETCURCH
; get the current character pointed to by CH_ADD
;******************************************************************
GETCURCH:
M0018: LD HL,(CHADD) ;get CH_ADD
LD A,(HL) ;get the current character
M001C: CALL M007D ;determine type of character
RET NC ;return if not a token or
; not a space
;if the character was a space or a token whose value was less
; than $1F, get the next character
;
M0020: CALL NEXTCH ;get the next character
JR M001C
RST $38
RST $38
RST $38
;******************************************************************
; Module: BASIC
; Routine: CALCCALL
; Jumps to the calculator interpreter
;******************************************************************
JP M371A ;jump to CALC
RST $38
RST $38
RST $38
RST $38
RST $38
;******************************************************************
; Module: BASIC
; Routine: expand the workspace BC bytes
;******************************************************************
ALLOCBC: PUSH BC ;save BC
LD HL,(WORKSP) ;get WORKSP
PUSH HL ;save HL
;******************************************************************
; Module: BASIC
; Routine: GLPR
;******************************************************************
GLPR:
JP LCU2 ;insert BC items at (HL)
;
;IM1 interrput target address. this is the keyboard interrogation routine
;
INTRPT:
PUSH AF
PUSH HL
LD HL,(FRAMES) ;/
INC HL ;|increment FRAMES
LD (FRAMES),HL ;\
LD A,H ;/is HL = 0?
OR L ;\
JR NZ,M0048
INC (IY+OFRAMES2) ;increment high byte of FRAMES ;FRAMES2
M0048: PUSH BC ;/save registers
PUSH DE ;\
CALL M02E1 ;go scan the keyboard
POP DE ;/restore registers
POP BC ;|
;******************************************************************
; Module: BASIC
; Routine: PHLAF
; POP HL and AF – WHY???
;******************************************************************
PHLAF: POP HL ;/
POP AF ;\
EI ;enable interrupts
RET ;exit
;******************************************************************
; Module: BASIC
; Routine: GETERNR
; gets the error number by popping the return address from
; the stack then loading it into L
;******************************************************************
GETERNR:
M0053: POP HL ;get the error address
; (stacked by RST 8 instruction)
LD L,(HL) ;stuff error number in L
;******************************************************************
; Module: BASIC
; Routine: LE3
; put the error number in L in ERRNR
;******************************************************************
LE3:
M0055: LD (IY+OERRNR),L ;save error number in ERR_NR ;ERRNR
LD SP,(ERRSP) ;load SP with the error routine stack pointer
JP RESET ;reset the calculator stack and memory pointers
RST $38 ;/
RST $38 ;|
RST $38 ;|
RST $38 ;|fill unused bytes
RST $38 ;|
RST $38 ;|
RST $38 ;\
;******************************************************************
; Module: BASIC
; Routine: NMI
;******************************************************************
PUSH AF ;/save registers
PUSH HL ;\
LD HL,(USRNMI) ;get user-defined NMI routine address
LD A,H ;/
OR L ;|if zero exit
JR NZ,M0070
JP (HL) ;jump to NMI routine
M0070: POP HL ;/restore registers
POP AF ;\
RETN
;******************************************************************
; Module: BASIC
; Routine: NEXTCH
; get the next character after bumping CH_ADD
;******************************************************************
NEXTCH:
M0074: LD HL,(CHADD) ;get CH_ADD
;******************************************************************
; Module: BASIC
; Routine: NC_HL
; bump the current character pointer by 1
;******************************************************************
NC_HL:
M0077: INC HL ;move to next character
;******************************************************************
; Module: BASIC
; Routine: TC_HL
; update the character pointer with HL
;******************************************************************
TC_HL:
M0078: LD (CHADD),HL ;save HL to CH_ADD
LD A,(HL) ;get the character
RET ;
;******************************************************************
; Module: BASIC
; Routine: TEST_CH
; this routine tests the character in A. if it is ‘!’ or later,
; $0D (CR), or $0C (DELETE) it immediately returns with carry
; reset. if the character is less than $10 (but not $0D or $0C)
; or greater than $18 (includes space [$20]) it returns with carry set.
; if the character is $16 (AT) or $17 (TAB) the character pointer in CH_ADD
; is advanced, carry set and return is done. if the character is any
; of the display control tokens (INK, PAPER, FLASH, BRIGHT, INVERSE, or OVER)
; the CH_ADD is advanced twice.
; enter with char in A and char ptr in HL
; EXIT: NC if char greater than ‘!’
; Z if char is $0D or $0C
; C if char is $0E, $0F
;
;******************************************************************
TEST_CH:
M007D: CP ‘!’ ;/return if ‘!’ or later
RET NC ;\in ASCII collating sequence
CP $0D ;/if it is carriage-return
RET Z ;\exit
CP $0C ;/if is DELETE then exit
RET Z ;\
CP $10 ;/if less than $10 exit
RET C ;\
CP $18 ;/if greater than $17
CCF ;|then exit
RET C ;\
;at this point HL is pointing at a character in the range
; $10 to $17, which are various control tokens
INC HL ;point to next character
CP $16 ;/if the token is a display
JR C,M0093
INC HL ;point to next char
M0093: SCF ;set carry
LD (CHADD),HL ;save new char ptr in CH_ADD
RET
;******************************************************************
; Module: BASIC
; Routine: TOKENS
;******************************************************************
TOKENS:
DEFB (‘?’+$80)
DEFM "RN"&(‘D’+$80)
DEFM "INKEY"&(‘$’+$80)
DEFM "P"&(‘I’+$80)
DEFM "F"&(‘N’+$80)
DEFM "POIN"&(‘T’+$80)
DEFM "SCREEN"&(‘$’+$80)
DEFM "ATT"&(‘R’+$80)
DEFM "A"&(‘T’+$80)
DEFM "TA"&(‘B’+$80)
DEFM "VAL"&(‘$’+$80)
DEFM "COD"&(‘E’+$80)
DEFM "VA"&(‘L’+$80)
DEFM "LE"&(‘N’+$80)
DEFM "SI"&(‘N’+$80)
DEFM "CO"&(‘S’+$80)
DEFM "TA"&(‘N’+$80)
DEFM "AS"&(‘N’+$80)
DEFM "AC"&(‘S’+$80)
DEFM "AT"&(‘N’+$80)
DEFM "L"&(‘N’+$80)
DEFM "EX"&(‘P’+$80)
DEFM "IN"&(‘T’+$80)
DEFM "SQ"&(‘R’+$80)
DEFM "SG"&(‘N’+$80)
DEFM "AB"&(‘S’+$80)
DEFM "PEE"&(‘K’+$80)
DEFM "I"&(‘N’+$80)
DEFM "US"&(‘R’+$80)
DEFM "STR"&(‘$’+$80)
DEFM "CHR"&(‘$’+$80)
DEFM "NO"&(‘T’+$80)
DEFM "BI"&(‘N’+$80)
DEFM "O"&(‘R’+$80)
DEFM "AN"&(‘D’+$80)
DEFM "<"&(‘=’+$80)
DEFM ">"&(‘=’+$80)
DEFM "<"&(‘>’+$80)
DEFM "LIN"&(‘E’+$80)
DEFM "THE"&(‘N’+$80)
DEFM "T"&(‘O’+$80)
DEFM "STE"&(‘P’+$80)
DEFM "DEF F"&(‘N’+$80)
DEFM "CA"&(‘T’+$80)
DEFM "FORMA"&(‘T’+$80)
DEFM "MOV"&(‘E’+$80)
DEFM "ERAS"&(‘E’+$80)
DEFM "OPEN "&(‘#’+$80)
DEFM "CLOSE "&(‘#’+$80)
DEFM "MERG"&(‘E’+$80)
DEFM "VERIF"&(‘Y’+$80)
DEFM "BEE"&(‘P’+$80)
DEFM "CIRCL"&(‘E’+$80)
DEFM "IN"&(‘K’+$80)
DEFM "PAPE"&(‘R’+$80)
DEFM "FLAS"&(‘H’+$80)
DEFM "BRIGH"&(‘T’+$80)
DEFM "INVERS"&(‘E’+$80)
DEFM "OVE"&(‘R’+$80)
DEFM "OU"&(‘T’+$80)
DEFM "LPRIN"&(‘T’+$80)
DEFM "LLIS"&(‘T’+$80)
DEFM "STO"&(‘P’+$80)
DEFM "REA"&(‘D’+$80)
DEFM "DAT"&(‘A’+$80)
DEFM "RESTOR"&(‘E’+$80)
DEFM "NE"&(‘W’+$80)
DEFM "BORDE"&(‘R’+$80)
DEFM "CONTINU"&(‘E’+$80)
DEFM "DI"&(‘M’+$80)
DEFM "RE"&(‘M’+$80)
DEFM "FO"&(‘R’+$80)
DEFM "GO T"&(‘O’+$80)
DEFM "GO SU"&(‘B’+$80)
DEFM "INPU"&(‘T’+$80)
DEFM "LOA"&(‘D’+$80)
DEFM "LIS"&(‘T’+$80)
DEFM "LE"&(‘T’+$80)
DEFM "PAUS"&(‘E’+$80)
DEFM "NEX"&(‘T’+$80)
DEFM "POK"&(‘E’+$80)
DEFM "PRIN"&(‘T’+$80)
DEFM "PLO"&(‘T’+$80)
DEFM "RU"&(‘N’+$80)
DEFM "SAV"&(‘E’+$80)
DEFM "RANDOMIZ"&(‘E’+$80)
DEFM "I"&(‘F’+$80)
DEFM "CL"&(‘S’+$80)
DEFM "DRA"&(‘W’+$80)
DEFM "CLEA"&(‘R’+$80)
DEFM "RETUR"&(‘N’+$80)
DEFM "COP"&(‘Y’+$80)
DEFM "DELET"&(‘E’+$80)
DEFM "ON ER"&(‘R’+$80)
DEFM "STIC"&(‘K’+$80)
DEFM "SOUN"&(‘D’+$80)
DEFM "FRE"&(‘E’+$80)
DEFM "RESE"&(‘T’+$80)
;******************************************************************
; Module: KBSCAN
; Routine: LCKEYS
;******************************************************************
LCKEYS:
;Data table: LCKEYS module: KBSCAN
;byte mnemonics: B,H,Y,6,5,T,G,V
DEFB $42,$48,$59,$36,$35,$54,$47,$56
;byte mnemonics: N,J,U,7,4,R,F,C
DEFB $4E,$4A,$55,$37,$34,$52,$46,$43
;byte mnemonics: M,K,I,8,3,E,D,X
DEFB $4D,$4B,$49,$38,$33,$45,$44,$58
;byte mnemonics: SLUG,L,O,9,2,W,S,Z
DEFB $0E,$4C,$4F,$39,$32,$57,$53,$5A
;byte mnemonics: SPACE,ENTER,P,0,1,Q,A
DEFB $20,$0D,$50,$30,$31,$51,$41
;******************************************************************
; Module: KBSCAN
; Routine: EKEYS
;******************************************************************
EKEYS:
;Data table: EKEYS module: KBSCAN
;byte mnemonics: READ,BIN,LPRINT,DATA,TAN,SGN,ABS,SQR
DEFB $E3,$C4,$E0,$E4,$B4,$BC,$BD,$BB
;byte mnemonics: CODE,VAL,LEN,USR,PI,INKEY$,PEEK,TAB
DEFB $AF,$B0,$B1,$C0,$A7,$A6,$BE,$AD
;byte mnemonics: SIN,INT,RESTORE,RND,CHR$,LLIST,COS,EXP
DEFB $B2,$BA,$E5,$A5,$C2,$E1,$B3,$B9
;byte mnemonics: STR$,LN
DEFB $C1,$B8
;******************************************************************
; Module: KBSCAN
; Routine: SEKEYS
;******************************************************************
SEKEYS:
;Data table: SEKEYS module: KBSCAN
;byte mnemonics: FREE,BRIGHT,PAPER,/,ATN,{,},CIRCLE
DEFB $7E,$DC,$DA,$5C,$B7,$7B,$7D,$D8
;byte mnemonics: IN,VAL$,SCREEN$,ATTR,INVERSE,OVER,OUT,COPYRIGHT
DEFB $BF,$AE,$AA,$AB,$DD,$DE,$DF,$7F
;byte mnemonics: ASN,VERIFY,STICK,MERGE,],FLASH,ACS,INK
DEFB $B5,$D6,$7C,$D5,$5D,$DB,$B6,$D9
;byte mnemonics: [,BEEP
DEFB $5B,$D7
;******************************************************************
; Module: KBSCAN
; Routine: NUMFNTBL
;******************************************************************
NUMFNTBL:
;Data table: NUMFNTBL module: KBSCAN
;byte mnemonics: DELETE,EDIT,PRINT,Unused,Unused,CSRLFT,CSRDN,CSRUP
DEFB $0C,$07,$06,$04,$05,$08,$0A,$0B
;byte mnemonics: CSRRT,NOTUSED
DEFB $09,$0F
;******************************************************************
; Module: KBSCAN
; Routine: KKEYS
;******************************************************************
KKEYS:
;Data table: KKEYS module: KBSCAN
;byte mnemonics: STOP,*,?,STEP,>=,TO,THEN,^
DEFB $E2,$2A,$3F,$CD,$C8,$CC,$CB,$5E
;byte mnemonics: AT,-,+,=,.,`,;,"
DEFB $AC,$2D,$2B,$3D,$2E,$2C,$3B,$22
;byte mnemonics: <=,<,NOT,>,OR,/,<>,POUND
DEFB $C7,$3C,$C3,$3E,$C5,$2F,$C9,$60
;byte mnemonics: AND,:,FORMAT,DEFFN,FN,LINE,OPEN#,CLOSE#
DEFB $C6,$3A,$D0,$CE,$A8,$CA,$D3,$D4
;byte mnemonics: MOVE,ERASE,POINT,CAT
DEFB $D1,$D2,$A9,$CF
;******************************************************************
; Module: KBSCAN
; Routine: K_SCAN
;
; RETURNS MEANING
; Z/NZ D E
; Z $FF Key one key pressed
; Z Shift Key Shift an key pressed
; Z $FF $FF no key pressed
; NZ X X too many keys pressed
;******************************************************************
K_SCAN:
M02B0: LD L,$2F ;initialize position code
LD DE,$FFFF ;indicate "no key" found
LD BC,$FEFE ;C=keyboard port, B=scan group to test. the ‘0’
; bit is the key group that is scanned
M02B8: IN A,(C) ;get key information, low=key pressed
CPL ;high is now a pressed key
AND $1F ;allow only keyboard bits
JR Z,M02CD ;jump if no keys pressed
;at least one key has been pressed, so…
LD H,A ;save the key value
LD A,L ;save position code
M02C1: INC D ;/return if too many keys pressed
RET NZ ;\
M02C3: SUB $08 ;update position code
SRL H ;check a key bit
JR NC,M02C3 ;jump if the key is not pressed
LD D,E ;put previous key value into D
LD E,A ;put present key value into E
JR NZ,M02C1 ;check for another key
M02CD: DEC L ;decrement position code
RLC B ;move the keygroup bit
JR C,M02B8 ;jump if more groups need to be scanned
;we have scanned all key groups and so far have not returned, so
; there must have been only one key pressed, Shift and key pressed, or
; no keys pressed
LD A,D ;get previous key
INC A ;/return if only one key or no keys
RET Z ;\ pressed
CP $28 ;/return if caps shift and another
RET Z ;\ key
CP $19 ;/return if symbol shift and another
RET Z ;\ key
LD A,E ;/
LD E,D ;|swap D and E
LD D,A ;\
CP $18 ;check for symbol shift
RET ;ZF = 1 if there is a symbol shift
;ZF = 0 if two charater keys
;******************************************************************
; Module: KBSCAN
; Routine: UPD_K
;******************************************************************
UPD_K:
M02E1: CALL M02B0 ;scan the keyboard
RET NZ ;return if too many keys pressed
LD HL,KS_A1 ;get key state
M02E8: BIT 7,(HL) ;/jump if no key stored
JR NZ,M02F3 ;\
INC HL ;point to debounce count
DEC (HL) ;decrement debounce counter
DEC HL ;point back to KS_A1
JR NZ,M02F3 ;jump if debounce counter is not zero
LD (HL),$FF ;force no key pressed for KS_A1
M02F3: LD A,L ;save lower byte of key buffer
LD HL,KS_A2 ;"next key" buffer address
CP L ;/jump if we are looking at different
JR NZ,M02E8 ;\ buffers
CALL M035C ;look for key code
RET NC ;return if no character key detected
RES 5,(IY+OFLAGS2) ;reset repeat deletion flag in FLAGS2
LD HL,KS_A1 ;/
CP (HL) ;|jump to handle repeat counters if KEY0 = KEY2
JR Z,M0336 ;\
EX DE,HL ;save address KS_A1 in DE
LD HL,KS_A2 ;/
CP (HL) ;|jump to handle repeat counters if KEY0 = KEY2
JR Z,M0336 ;\
BIT 7,(HL) ;/jump if KS_A2 indicates no key pressed
JR NZ,M0317 ;\(saves A into KS_A2
EX DE,HL ;point to KS_A1
BIT 7,(HL) ;/return if KS_A1 has key hit
RET Z ;\
M0317: LD E,A ;save A
LD (HL),A ;store A into KS_A1 or KS_A2
INC HL ;/initialize the debounce counter
LD (HL),$05 ;\
INC HL ;/
LD A,(REPDEL) ;|initialize the repeat counter
LD (HL),A ;\
INC HL ;point to the character
LD C,(IY+OMODE) ;
LD D,(IY+OFLAGS) ;
PUSH HL ;save the character pointer
CALL M0371 ;
POP HL ;
LD (HL),A ;
M032E: LD (LASTK),A ;store the keystroke in LASTK
SET 5,(IY+OFLAGS) ;set KEYHIT flag in FLAGS
RET ;done
M0336: INC HL ;/initialize the debounce counter
LD (HL),$05 ;\
INC HL ;point to repeat counter
LD A,(LASTK) ;/
CP $CE ;|return if last key value is a token
RET NC ;\
DEC (HL) ;decrement repeat counter
RET NZ ;return if not time to repeat yet
LD A,(REPPER) ;/intitialize repeat counter
LD (HL),A ;\
INC HL ;point to character
LD A,(HL) ;get character
CP $0C ;/jump if character code is not DELETE
JR NZ,M032E ;\
SET 5,(IY+OFLAGS2) ;FLAGS2
PUSH AF ;save AF
LD BC,$4E20 ;/
M0354: DEC BC ;|delay loop
LD A,C ;|
OR B ;|
JR NZ,M0354 ;\
POP AF ;restore AF
JR M032E ;
;******************************************************************
; Module: KBSCAN
; Routine: K_BASE
;RETURNS:
; C/NC A MEANS
; NC – NO CHAR KEY
; C CODE CHAR KEY
;******************************************************************
K_BASE:
M035C: LD B,D ;"last key" to B
LD D,$00 ;
LD A,E ;
CP $27 ;/return if key is greater than
RET NC ;\CAPS SHIFT
CP $18 ;/jump if not SYMBOL SHIFT
JR NZ,M036A ;\
BIT 7,B ;/return if this only one key
RET NZ ;\has been pressed
M036A: LD HL,LCKEYS ;/
ADD HL,DE ;|retrieve the key code from
LD A,(HL) ;\LCKEYS table
SCF ;indicate key was found
RET ;done
;******************************************************************
; Module: KBSCAN
; Routine: CHCODE
; enter with MODE in C, FLAGS in D, and shift state in B
; and candidate character in E
;******************************************************************
CHCODE:
M0371: LD A,E ;get key code to A
CP $3A ;/jump if key code < $3A
JR C,M03A5 ;\
DEC C ;/jump if mode is 0
JP M ,M038D ;\
JR Z,M037F ;jump if mode is 1
;mode must be 2 – "G" mode
ADD A,$4F ;make graphics character
RET ;done
;
;here for mode 1 – "E" mode
;
M037F: LD HL,EKEYS-‘A’ ;get base of "E" table
INC B ;/jump if shifted character
JR Z,M0388 ;\
LD HL,LCKEYS ;unshifted "E" mode table
M0388: LD D,$00 ;/get "E" mode character from
ADD HL,DE ;|selected table
LD A,(HL) ;\
RET ;
;******************************************************************
; Module: KBSCAN
; Routine: LED4
;******************************************************************
;mode 0 code
LED4:
M038D: LD HL,$024B ;point to mode 0 keytable
BIT 0,B ;/jump if symbol shift
JR Z,M0388 ;\
BIT 3,D ;/jump if "K" mode
JR Z,M03A2 ;\
BIT CAPS_L,(IY+OFLAGS2) ;/return if CAPS LOCK ;FLAGS2
RET NZ ;\or CAPS SHIFT
INC B ;/return if upper case (B=$FF)
RET NZ ;\
ADD A,$20 ;/convert to lower case
RET ;\
M03A2: ADD A,$A5 ;convert to keyword
RET ;
;
;keycode < $3a
;
M03A5: CP $30 ;/return if key <$30
RET C ;\
DEC C ;
JP M ,M03DB ;jump if mode=0
JR NZ,M03C7 ;jump if mode=2
;
;mode=1 ("E" mode)
;
LD HL,$0276 ;get "E" mode key table
BIT 5,B ;/jump if symbol shift
JR Z,M0388 ;\
CP $38 ;/jump if digit is 8 or 9
JR NC,M03C0 ;\
;
;digit was 0-7
;
SUB $20 ;convert to SET FG color
INC B ;/return if no SHIFT
RET Z ;\
ADD A,$08 ;convert to SET BG color
RET ;done
M03C0: SUB $36 ;convert to BRIGHT/UNBRIGHT
INC B ;/return if no SHIFT
RET Z ;\
ADD A,$FE ;convert to FLASH/UNFLASH
RET ;
;
;mode=2 ("G" mode)
;
M03C7: LD HL,$0252 ;get "G" mode key table
CP $39 ;/
JR Z,M0388 ;|jump if character is "0" or "9"
CP $30 ;|
JR Z,M0388 ;\
AND $07 ;/
ADD A,$80 ;\make graphics mosaic patterns
INC B ;/return if no SHIFT
RET Z ;\
XOR $0F ;invert pattern if SHIFT
RET ;
;
;mode=0 ("K" or "L" mode)
;
M03DB: INC B ;/return if no SHIFT
RET Z ;\
BIT 5,B ;/
LD HL,$0252 ;|jump if not SYMBOL SHIFT
JR NZ,M0388 ;\
SUB $10 ;convert to symbol
CP $22 ;/jump if ampersand "@"
JR Z,M03F0 ;\
CP $20 ;/return for space
RET NZ ;\
LD A,$5F ;/make underline "_"
RET ;\
M03F0: LD A,$40 ;/return ampersand "@"
RET ;\
;******************************************************************
; Module: KBSCAN
; Routine: PARP
; Enter: DE contains number of cycles – 1
; HL contains the waveform period (8*HL+236 to 8*HL+246 t-states)
; (HL = $3CE for 440Hz, 2 cycles)
;******************************************************************
PARP: ; A HL DE BC IX
M03F3: DI ;don’t interrupt me 03CE 0002 —- —-
LD A,L ;save L CE 03CE 0002 —- —-
SRL L ;/divide L by 4 CE 0367 0002 —- —-
SRL L ;\ CE 0333 0002 —- —-
CPL ;/initialize fine tune for the 31 0333 0002 —- —-
AND $03 ;\requested period 01 0333 0002 —- —-
LD C,A ;/ 01 0333 0002 –01 —-
LD B,$00 ;\ 01 0333 0002 0001 —-
LD IX,$040F ;/form the loop address for the 01 0333 0002 0001 040F
ADD IX,BC ;\timing loop 01 0333 0002 0001 0410
LD A,(BORDCR) ;/
AND $38 ;|get the border color and make
RRCA ;| it compatible with the port
RRCA ;| at $FE
RRCA ;\
OR $08 ;set tape bit
;at this point A contains a template value to be output to the speaker
; port. bit 4 (value $10) will be toggled to make the noise
MO40F: NOP ;/
NOP ;|the NOPs allow fine tuning of
NOP ;\the period
INC B ; — 0333 0002 0101 0410
INC C ; — 0333 0002 0002 0410
M0414: DEC C ;/timing loop based on C
JR NZ,M0414 ;\
LD C,$3F ;/ — 0333 0002 003F 0410
DEC B ;|timing loop based on B
JP NZ,M0414 ;\
XOR $10 ;/toggle the speaker output
M041F: OUT ($FE),A ;\
LD B,H ;precharge B with upper byte of — 0333 0002 0301 0410
; period value
LD C,A ;save C 01 0333 0002 00– 0410
BIT 4,A ;/jump if the speaker bit is
JR NZ,M0430 ;\ a one
LD A,D ;/
OR E ;|exit if cycle counter is
JR Z,M0434 ;\ zero
LD A,C ;restore C
LD C,L ;BC now contains the period value
DEC DE ;decrement the cycle counter
JP (IX) ;back around for more cycles
M0430: LD C,L ;/BC now again contains the
INC C ;|period value, so loop back
JP (IX) ;\for more cycles
M0434: EI ;I am now interruptable
RET ;
;******************************************************************
; Module: KBSCAN
; Routine: BEEP
;******************************************************************
BEEP:
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $27 ;INT find the integer portion of the note
DEFB $C0 ;T -> MEM 0 copy to MEM 0
DEFB $03 ;SUB calc now has the fractional portion of the note value
DEFB $34,$EC,$6C,$98,$1F,$F5 ;LITERAL 7C6C981FF5 ( 5.77622650453122E-2),0441
DEFB $04 ;TIMES
DEFB $A1 ;CONST 1 (256)
DEFB $0F ;ADD
DEFB $38 ;QUIT calc now has a factor that represents the ratio of the
; requested frequency to a full step in frequency.
; e.g. if the note value was 3.73, MEM 0 now contains 3
; and calc contains 1+0.73*0.57762265e-2 or 1.0042167.
; when the base period (3 or D#) is multiplied by this number, the
; new number will be the period of the requested frequency
LD HL,MEMBOT ;get the calculator’s memory address (MEM 0)
LD A,(HL) ;/
AND A ;|jump if the number is not an integer (and reset the carry)
JR NZ,M04AA ;\
INC HL ;/get the sign byte
LD C,(HL) ;\
INC HL ;/get the ls byte of the number
LD B,(HL) ;\
LD A,B ;/
RLA ;|check to see if the number is C is less than
SBC A,A ;|128, and zero the accumulator
CP C ;|
JR NZ,M04AA ;\
INC HL ;/
CP (HL) ;|jump if high byte is not zero
JR NZ,M04AA ;\
LD A,B ;A now has the note code
ADD A,$3C ;/jump if the note code is 68 or less
JP P ,M0463 ;\
JP PO ,M04AA ;jump if overflow, A musta been below -60
;the note number (-60 to +69 has now been shifted to 0 to $81)
;we now find which octave the note occupies
M0463: LD B,$FA ;B = -6 initialize the octave counter
M0465: INC B ;/
SUB $0C ;|loop until we have subrtacted enough octaves
JR NC,M0465 ;\
ADD A,$0C ;A now contains the note within the octave stored in B
PUSH BC ;save the octave number
LD HL,$04AC ;base of the note table
CALL M37C5 ;HL = HL + 5 * A
CALL STK_M ;stack the number found above onto the calc stack
RST $28 ;calc entry
DEFB $04 ;TIMES multiply the base frequency by the factor computed above
; this gives the final frequency
DEFB $38 ;QUIT
POP AF ;get the octave number
ADD A,(HL) ;/essentially does 2^N*note_number
LD (HL),A ;\
RST $28 ;calc entry
DEFB $C0 ;T -> MEM 0 MEM 0 now contains the final frequency
; for the desired note
DEFB $02 ;DROP remove the frequency from the fp stack
DEFB $31 ;DUP duplicate the duration value
DEFB $38 ;QUIT
CALL INS_U1 ;convert the fp top of stack to a value in A
CP $0B ;
JR NC,M04AA ;
;translate the duration value to the equivalent number of cycles for PARP
RST $28 ;calc entry
DEFB $E0 ;MEM 0 -> T get the desired frequency
DEFB $04 ;TIMES multiply by required the duration to give the # of cycles
DEFB $E0 ;MEM 0 -> T again, get the frequency
DEFB $34,$80,$43,$55,$9F,$80 ;LITERAL 93559F8000 ( 437500),0492 /clock/8
DEFB $01 ;SWAP |
DEFB $05 ;DIV | convert the frequency into a period value for PARP
DEFB $34,$35,$71 ;LITERAL 8571000000 ( 30.125),0497 |
DEFB $03 ;SUB \
DEFB $38 ;QUIT
CALL FIX_U ;period on FP stack to BC
PUSH BC ;save frequency
CALL FIX_U ;convert duration to BC
POP HL ;restore the frequency
LD D,B ;/move the duration to DE
LD E,C ;\
LD A,D ;/
OR E ;|if the duration is zero, we are done
RET Z ;\
DEC DE ;adjust the duration for PARP
JP PARP ;make the noise
M04AA: RST $08 ;/error: INTEGER OUT OF RANGE
DEFB $0A ;\
;BEEP look-up table ;
TONC: DEFB $89,$02,$D0,$12,$86 ;261.625565290451 Hz
TONCIS: DEFB $89,$0A,$97,$60,$75 ;277.182631134987 Hz
TOND: DEFB $89,$12,$D5,$17,$1F ;293.664768099785 Hz
TONDIS: DEFB $89,$1B,$90,$41,$02 ;311.126983880997 Hz
TONE: DEFB $89,$24,$D0,$53,$CA ;329.627557039261 Hz
TONF: DEFB $89,$2E,$9D,$36,$B1 ;349.228231549263 Hz
TONFIS: DEFB $89,$38,$FF,$49,$3E ;369.994422674179 Hz
TONG: DEFB $89,$43,$FF,$6A,$73 ;391.99543607235 Hz
TONGIS: DEFB $89,$4F,$A7,$00,$54 ;415.30469751358 Hz
TONA: DEFB $89,$5C,$00,$00,$00 ;440 Hz
TONB: DEFB $89,$69,$14,$F6,$24 ;466.163761615753 Hz
TONH: DEFB $89,$76,$F1,$10,$05 ;493.883301377296 Hz
;
;name for SAVE, LOAD, MERGE?
;
CALL EXPRN ;evaluate the current expression
LD A,(FLAGS) ;/jump if the expression is numerical
ADD A,A ;|
JP M ,M1BED ;\error – BAD BASIC
POP HL ;restore HL
RET NC ;return if syntax checking
PUSH HL ;save HL
CALL PGPSTR ;get the string descriptor
LD H,D ;/string location to DE
LD L,E ;\
DEC C ;/return if the string length is zero
RET M ;\
ADD HL,BC ;point to last character of string
SET 7,(HL) ;set bit 7
RET ;
;******************************************************************
; Module: IO_1
; Routine: SENDTV
; enter with the character to print in A
;******************************************************************
SENDTV:
M0500: CALL LDTVCU ;update DFCC and DFLCC
CP $20 ;/jump if character is not a control
JP NC,M05F0 ;\character (output the bit pattern)
CP $0C ;/jump if character is not DELETE
JR NZ,M0513 ;\
BIT 4,(IY+OFLAGS) ;/jump if not a listing?
JP Z ,M05F0 ;\jump if a listing? (output the bit pattern)
M0513: CP $06 ;/jump if char is less than PRINT COMMA
JR C,M0580 ;\(all of these are not used)
CP $18 ;/jump if char is greater than TAB
JR NC,M0580 ;\
;
;we are printing a control character so get the jump address for
; the code to handle it
;
LD HL,CONTRO-6 ;base of jump table – 6
LD E,A ;/
LD D,$00 ;|form the address of the jump table entry
ADD HL,DE ;\
LD E,(HL) ;get the code offset
ADD HL,DE ;make the address of the code handler
PUSH HL ;save it
JP LDTVCU ;jump to the print routine
; this is effectively a call to the stacked
; address after DFCC and DFLCC have been set up
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; print control jump table
;
CONTRO: DEFB QM0A5F-ASMPC ;Print comma
DEFB M0580-ASMPC ;Edit
DEFB P_LFT-ASMPC ;Cursor left
DEFB P_RT-ASMPC ;Cursor right
DEFB M0580-ASMPC ;Cursor down
DEFB M0580-ASMPC ;Cursor up
DEFB M0580-ASMPC ;Delete
DEFB P_NL-ASMPC ;Enter
DEFB M0580-ASMPC ;number slug /not print control
DEFB M0580-ASMPC ;not used \
DEFB M0591-ASMPC ;Ink
DEFB M0591-ASMPC ;Paper
DEFB M0591-ASMPC ;Flash
DEFB M0591-ASMPC ;Bright
DEFB M0591-ASMPC ;Inverse
DEFB M0591-ASMPC ;Over
DEFB M058C-ASMPC ;At
DEFB M058C-ASMPC ;Tab
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;******************************************************************
; Module: IO_1
; Routine: P_LFT
; cursor left routine
;******************************************************************
P_LFT:
INC C ;/
LD A,$22 ;|
CP C ;|
JR NZ,M0551 ;\
BIT PR,(IY+OFLAGS) ;/jump if printing to the printer
JR NZ,M054F ;\
INC B ;
LD C,$02 ;
LD A,$19 ;
CP B ;
JR NZ,M0551 ;
DEC B ;
M054F: LD C,$21 ;33 lines
M0551: JP STTVC ;
;******************************************************************
; Module: IO_1
; Routine: P_RT
; cursor right routine
;******************************************************************
P_RT:
LD A,(PFLAG) ;/get printing flags and
PUSH AF ;\save them
LD (IY+OPFLAG),01 ;make permanent print flag OVER
LD A,$20 ;/print a space to the TV
CALL M05F0 ;\(output the bit pattern)
POP AF ;/restore the print flags
LD (PFLAG),A ;\
RET
;******************************************************************
; Module: IO_1
; Routine: P_NL
; enter with number of lines in B
;******************************************************************
P_NL:
BIT PR,(IY+OFLAGS) ;/jump if printing to printer
JP NZ,M0A23 ;\
LD C,$21 ;
CALL TVFUL ;return here if the screen is not full
DEC B ;
JP STTVC ;
QM0A5F: CALL LDTVCU ;get DF pointer (DE is the important one)
LD A,C ;
DEC A ;
DEC A ;
AND $10 ;
JR M05DA
M0580: LD A,’?’ ;/output a question mark bit pattern
JR M05F0 ;\
M0584: LD DE,M059E ;
LD (TVDATA+1),A ;
JR M0597 ;
M058C: LD DE,M0584 ;
JR M0594 ;
M0591: LD DE,M059E ;
M0594: LD (TVDATA),A ;
M0597: LD HL,(CURCHL) ;get the address of the current
; channel
LD (HL),E ;/make it point to the
INC HL ;|channel handler in DE
LD (HL),D ;\
RET ;
M059E: LD DE,SENDTV ;
CALL M0597 ;
LD HL,(TVDATA) ;
LD D,A ;
LD A,L ;
CP $16 ;
JP C ,M23BB ;
JR NZ,M05D9 ;
LD B,H ;
LD C,D ;
;******************************************************************
; Module: IO_1
; Routine: SET_AT
;******************************************************************
SET_AT:
LD A,$1F
SUB C
JR C,M05C3
ADD A,$02
LD C,A
BIT PR,(IY+OFLAGS) ;/jump if printing to printer
JR NZ,M05D6 ;\
LD A,$16
SUB B
M05C3: JP C ,M1F29
INC A
LD B,A
INC B
BIT 0,(IY+OTVFLAG) ;TVFLAG
JP NZ,TVFUL
CP (IY+ODFSZ) ;DFSZ
JP C ,M07C1
M05D6: JP STTVC
M05D9: LD A,H
M05DA: CALL LDTVCU
ADD A,C
DEC A
AND $1F
RET Z
LD D,A
SET 0,(IY+OFLAGS) ;FLAGS
M05E7: LD A,$20
CALL M0776
DEC D
JR NZ,M05E7
RET
M05F0: CALL M063B
;******************************************************************
; Module: IO_1
; Routine: STTVCU
; set the column position and display file pointers for the TV
; based on various flags
;******************************************************************
STTVCU:
M05F3: BIT PR,(IY+OFLAGS) ;/jump if printing to
JR NZ,M0613 ;\printer
BIT LHS,(IY+OTVFLAG) ;/jump if printing to the
JR NZ,M0607 ;\ lower half of the screen
;handle the upper screen parameters
LD (SPOSNCOL),BC ;update the upper screen col pointer
LD (DFCC),HL ;update upper display file character pointer
RET ;done
;do the lower screen parameters
M0607: LD (SPOSNLCOL),BC ;update lower screen col pointer
LD (ECHOE),BC ;update keyboard buffer pinter
LD (DFCCL),HL ;update lower display file character pointer
RET ;done
M0613: LD (IY+OPPOSN),C ;update print position
LD (PRCC),HL ;update printer buffer character pointer
RET ;done
;******************************************************************
; Module: IO_1
; Routine: LDTVCU
; loads registers with TV display information
; loads HL with the display file position for a character
; loads BC with the LIN (B) and COL (C) of the current screen position
;******************************************************************
LDTVCU:
M061A: BIT PR,(IY+OFLAGS) ;/jump if printing to printer
JR NZ,M0634 ;\
LD BC,(SPOSNCOL) ;/get current print column position
LD HL,(DFCC) ;\load into the display file column
BIT LHS,(IY+OTVFLAG) ;/return if printing to the upper half
RET Z ;\of the screen
LD BC,(SPOSNLCOL) ;/put the lower screen print column position
LD HL,(DFCCL) ;\into the display column pointer
RET ;done
M0634: LD C,(IY+OPPOSN) ;get the print buffer position
LD HL,(PRCC) ;
RET
;
;put a character on the screen
; ENTER: A contains the character
; DE contains the character position in the DF
;
M063B: CP $0C ;/jump if char is not DELETE
JR NZ,M0643 ;\
LD A,$7A ;
JR M0694 ;
M0643: CP $7C ;/jump if char is STICK
JR Z,M0694 ;\
CP $7E ;/jump if char is FREE
JR Z,M0694 ;\
CP $7B ;/jump if char is printable
JR C,M0659 ;\
CP $80 ;/jump if char is block graphics 0
JR NC,M0659 ;\
BIT RETPOS,(IY+OFLAGS) ;/jump if retype is not possible after
JR Z,M0694 ;\syntax error (RUN mode?)
M0659: CP $80 ;/jump if below block graphics 0
JR C,M069A ;\
CP $90 ;/jump if we is a possible UDG
JR NC,M0687 ;\
LD B,A ;transfer character to B
CALL MKBLKGR ;generate a block graphic of the character
; code in B
CALL LDTVCU ;HL now has the DF position
LD DE,MEMBOT ;point to the block graphic bit map buffer
JR M06B4
;
;handle block graphics characters
;this routine dynamically generates the block graphics characters
; each bit of the character code specifies one quadrant of the block
; graphic as follows (the digits refer to bit numbers):
; 11110000 scan line 0
; 11110000 scan line 1
; 11110000 scan line 2
; 11110000 scan line 3
; 33332222 scan line 4
; 33332222 scan line 5
; 33332222 scan line 6
; 33332222 scan line 7
; the character code is in B
MKBLKGR:
M066D: LD HL,MEMBOT ;point to free space, provides a buffer for
; the character bit map
CALL M0673 ;generate the first four scan lines (bits 0 and 1)
;
;falling through to here will generate the bit map pattern for bits
; 2 and 4
;
M0673: RR B ;/rotate the lsb into the CF
SBC A,A ;|if lsb is 1, A=$FF else A=$00
AND $0F ;\keep only those needed for the character
LD C,A ;save the character
RR B ;/check the next bit up,
SBC A,A ;|handle as before
AND $F0 ;\
OR C ;or in the previously found bit pattern
LD C,$04 ;/
M0681: LD (HL),A ;|save the bit map to the buffer
INC HL ;|
DEC C ;|
JR NZ,M0681 ;\
RET ;
;
;handle UDG and above
;
M0687: SUB $A5 ;/jump if a token not a UDG
JR NC,M0694 ;\
ADD A,$15 ;adjust value for UDG bit map table
PUSH BC ;save BC
LD BC,(UDG) ;load BC with the base of the UDG table
JR M069F ;
M0694: CALL PRTTOK ;print the token in A
JP LDTVCU ;HL points to the DF
M069A: PUSH BC
LD BC,(CHARS)
;
;BC contains the base address of the character bit map table
;
M069F: EX DE,HL ;save DE
LD HL,FLAGS ;/force no printing leading spaces
RES 0,(HL) ;\
CP $20 ;/jump if the character is not a space
JR NZ,M06AB ;\
SET 0,(HL) ;force printing leading spaces
M06AB: LD H,$00 ;/ HL <- character
LD L,A ;\
ADD HL,HL ;/
ADD HL,HL ;| HL <- 8 * HL
ADD HL,HL ;\
ADD HL,BC ;HL now points to the bit map for the character
POP BC ;restore BC
EX DE,HL ;DE now points to the bit map
;
;DE points to the character bit map, HL points to the DF or printer buffer
;
M06B4: LD A,C ;get column position to A
DEC A ;put in range [0..31]
LD A,$21 ;
JR NZ,M06C8 ;jump if not
DEC B ;normalize screen line number
LD C,A ;
BIT PR,(IY+OFLAGS) ;/jump if printing to TV
JR Z,M06C8 ;\
PUSH DE ;save the bit map buffer address
CALL M0A23 ;flush the printer buffer to the printer
POP DE ;restore the buffer address
LD A,C ;force check of display
M06C8: CP C ;
PUSH DE ;save bit map buffer address
CALL Z ,TVFUL ;return here if display not full
POP DE ;restore the bit map buffer address
PUSH BC ;/save BC and HL
PUSH HL ;\
LD A,(PFLAG) ;get printing flags
LD B,$FF ;
RRA ;/jump if XORing new and
JR C,M06D9 ;\ old characters
INC B ;
M06D9: RRA ;/check invert
RRA ;\
SBC A,A ;A=$FF if invert, else A=0
LD C,A ;save A
LD A,$08 ;FOR 8 bytes…
AND A ;
BIT PR,(IY+OFLAGS) ;/jump if printing to TV
JR Z,M06EB ;\
SET PRLEFT,(IY+OFLAGS2) ;force print buffer not empty
SCF ;printer flag
;
;I still haven’t determined the magic required to get the display file
; address into the right register
;
M06EB: EX DE,HL ;HL contains the bit map address, DE contains DF pointer
M06EC: EX AF,AF’ ;to alt regs
LD A,(DE) ;get the first byte of DF character
AND B ;clear all bits if not XORing characters
XOR (HL) ;XOR the bit map
XOR C ;invert, if called for
LD (DE),A ;save back to DF
EX AF,AF’ ;back to normal regs
JR C,M0708 ;
INC D ;point to next byte in DF
M06F6: INC HL ;point to next bit map character
DEC A ;decrement byte counter
JR NZ,M06EC ;jump back if more are needed
EX DE,HL ;HL=DF pointer, DE=bit map pointer
DEC H ;point back to last modified byte in DF
BIT PR,(IY+OFLAGS) ;/update the attribute for this character
CALL Z ,ATTBYT ;\
POP HL ;restore HL
POP BC ;restore BC
DEC C ;
INC HL ;
RET ;
M0708: EX AF,AF’ ;alt regs
LD A,$20 ;/
ADD A,E ;|adjust the address for a print
LD E,A ;|buffer rather than the DF
EX AF,AF’ ;|
JR M06F6 ;\
;******************************************************************
; Module: IO_1
; Routine: ATTBYT
;******************************************************************
ATTBYT:
M0710: LD A,H ;get the high byte of the DF address
RRCA ;/
RRCA ;|divide by 8
RRCA ;\
AND $03 ;use only the lower 2 bits
OR $58 ;/generate the MS byte of the
LD H,A ;\attribute address
LD DE,(ATTRT) ;get the temporary attributes
LD A,(HL) ;get the current attribute
XOR E ;/for every bit in D that is a 0,
AND D ;|the corresponding bit in A will
XOR E ;\come from E, else it will come from A
BIT B_CF,(IY+OPFLAG) ;/jump if colors OK
JR Z,M072F ;\
AND $C7 ;keep flash, hilite, and fgnd colors
BIT 2,A ;/jump if green is active
JR NZ,M072F ;\
XOR $38 ;invert fgnd colors
M072F: BIT F_CB,(IY+OPFLAG) ;/jump if colors still OK
JR Z,M073D ;\
AND $F8 ;keep flash, hilite, and bgnd colors
BIT 5,A ;/jump if green is active
JR NZ,M073D ;\
XOR $07 ;invert bgnd colors
M073D: LD (HL),A ;store the attribute
RET
;******************************************************************
; Module: IO_1
; Routine: PUTMES
;
;******************************************************************
PUTMES:
M073F: PUSH HL ;save HL
LD H,$00 ;/push value to prevent trashing
EX (SP),HL ;\return address???
JR M074F ;go find string in buffer
;
;print the token whose value is in A
;
PRTTOK:
M0745: LD DE,$0098 ;base of token table
CP $5B ;/adjust token number, if necessary
JR C,M074E ;|
SUB $1F ;\
M074E: PUSH AF ;save token value
M074F: CALL M077C ;find the message number A in table
; at (DE)
JR C,M075D ;no leading space needed, so jump ahead
LD A,$20 ;/print a leading space, if needed
BIT 0,(IY+OFLAGS) ;| ;FLAGS
CALL Z ,M0776 ;\
M075D: LD A,(DE) ;get the character
AND $7F ;mask off the high bit
CALL M0776 ;output the char to the current stream
LD A,(DE) ;re-get the character
INC DE ;bump the message pointer
ADD A,A ;/back around for more if the
JR NC,M075D ;\high bit of the character is not set
POP DE ;trash return address unless entered via PUTMES
CP $48 ;/jump if the character is "$"
JR Z,M0770 ;\
CP $82 ;/return if char is less than "A"
RET C ;\
M0770: LD A,D ;/return if message is below page 3
CP $03 ;|
RET C ;\
LD A,$20 ;output a space
;******************************************************************
; Module: IO_1
; Routine: PR_TV2
;******************************************************************
PR_TV2:
M0776: PUSH DE ;save current character pointer
EXX ;to alt registers
RST $10 ;WRCHAR – output the character in A to the
; current stream
EXX ;to regular registers
POP DE ;restore character pointer
RET ;done
;
;find the message with index "A" located in table at (DE). if
; return with CF=0 if the current character is greater than "@".
; this will force printing a leading space if BIT 0,(IY+OFLAGS) is "0" ;FLAGS
;
FINDMSG:
M077C: PUSH AF ;save message number index
EX DE,HL ;HL = buffer pointer
INC A ;bump message number passed
M077F: BIT 7,(HL) ;/skip over characters until
INC HL ;|bit 7 of the current byte is
JR Z,M077F ;\set
DEC A ;decrement msg number
JR NZ,M077F ;not the message we want so,
; back around
EX DE,HL ;put the buffer pointer back in DE
POP AF ;restore the message number index
CP $20 ;/return if the message pointer is less than
RET C ;\ $20
LD A,(DE) ;get current character
SUB $41 ;compare to ‘@’
RET ;
;******************************************************************
; Module: IO_1
; Routine: TVFUL?
; determine if the VIDEO display is full. if it is exit via
; error 5 – OUT OF SCREEN
; enter with the line number in B
;******************************************************************
TVFUL:
M0790: BIT PR,(IY+OFLAGS) ;/return if printing to printer;
RET NZ ;\nothing more to be done
LD DE,STTVC ;/jump address
PUSH DE ;\
LD A,B ;put line number in A
BIT LHS,(IY+OTVFLAG) ;/jump if printing to the lower
JP NZ,M083D ;\half of the screen
CP (IY+ODFSZ) ;/if
JR C,M07C1 ;\exit via error 5
RET NZ ;if we are not on the last line, return
BIT TVLIST,(IY+OTVFLAG) ;/jump if not an automatic listing
JR Z,M07C3 ;\
LD E,(IY+OBREG) ;BREG
DEC E ;
JR Z,M080D ;
LD A,$00 ;/force lower screen stream
CALL SELECT ;\
LD SP,(LISTSP) ;get the auto list return address pointer
RES TVLIST,(IY+OTVFLAG) ;force no auto listing
RET ;
;******************************************************************
; Module: IO_1
; Routine: ERR5
;******************************************************************
ERR5:
M07C1: RST $08 ;error: OUT OF SCREEN
DEFB $04 ;
;******************************************************************
; Module:
; Routine:
; ENTRY: B contains the number of lines to scroll
;******************************************************************
M07C3: DEC (IY+OSCRCT) ;decrement scroll count
JR NZ,M080D ;jump if scroll count not zero (proceed)
LD A,$18 ;24 possible lines
SUB B ;subtract screen line number
LD (SCRCT),A ;store the number of lines below B back
; into scroll count
LD HL,(ATTRT) ;/get the temporary printing attributes
PUSH HL ;\ and save them
LD A,(PFLAG) ;/save the printing flags
PUSH AF ;\
LD A,$FD ;/stream -3 (keyboard/lower screen)
CALL SELECT ;\
XOR A ;/
LD DE,SCROLLMSG ;|print the "SCROLL?" message
CALL PUTMES ;\
SET CLHS,(IY+OTVFLAG) ;force clearing the lower half screen
LD HL,FLAGS ;
SET LMODE2,(HL) ;force "L" mode at cursor
RES KEYHIT,(HL) ;force no keyboard input
EXX ;/
CALL RDCH ;|read the keyboard
EXX ;\
CP ‘ ‘ ;/jump if a space
JR Z,M083B ;\
CP $E2 ;/jump if "STOP" token
JR Z,M083B ;\
OR $20 ;force lower case
CP $6E ;/jump to BREAK if "n" is input
JR Z,M083B ;\
LD A,$FE ;/stream -1 (main screen)
CALL SELECT ;\(select the main screen)
POP AF ;/restore the printing flags
LD (PFLAG),A ;\
POP HL ;/restore the temporary attributes
LD (ATTRT),HL ;\
M080D: CALL SCRL1 ;scroll the screen one line
LD B,(IY+ODFSZ) ;get display file line counter
INC B ;bump by one
LD C,$21 ;start of line
PUSH BC ;save BC
CALL M09D6 ;get the display file adress for line "B"
LD A,H ;/
RRCA ;|form attribute address for
RRCA ;|the line number in "B"
RRCA ;|
AND $03 ;|
OR $58 ;|
LD H,A ;\
LD DE,$5AE0 ;line 23 attribute address
LD A,(DE) ;A = line 23 attribute
LD C,(HL) ;C = line "B" attribute
LD B,$20 ;FOR 32 bytes
EX DE,HL ;HL -> line 23, DE -> line "B"
M082B: LD (DE),A ;/
LD (HL),C ;|swap attibutes
INC DE ;|
INC HL ;|
DJNZ M082B ;\
POP BC ;restore BC
RET ;
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SCROLLMSG:
DEFB $80
DEFM "scroll"&(‘?’+$80)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
M083B: RST $08 ;/error: BREAK – CONT REPEATS
DEFB $0C ;\
M083D: CP $02 ;/jump if the requested lower screen line
JR C,M07C1 ;\is 1
ADD A,(IY+ODFSZ) ;add the present lower screen size
SUB $19 ;/return if more than 24 lines requested
RET NC ;\
NEG ;
PUSH BC ;
LD B,A ;
LD HL,(ATTRT) ;/save the temporary attributes
PUSH HL ;\
;
LD HL,(PFLAG) ;
PUSH HL ;
CALL DO_ATTS ;
LD A,B ;
M0857: PUSH AF ;
LD HL,DFSZ ;
LD B,(HL) ;
LD A,B ;
INC A ;
LD (HL),A ;
LD HL,SPOSNLIN ;
CP (HL) ;
JR C,M0868 ;
INC (HL) ;
LD B,$18 ;
M0868: CALL SCRLB ;
POP AF ;
DEC A ;
JR NZ,M0857 ;
POP HL ;
LD (IY+OPFLAG),L ;PFLAG
POP HL ;
LD (ATTRT),HL ;
LD BC,(SPOSNCOL) ;
RES 0,(IY+OTVFLAG) ;TVFLAG
CALL STTVC ;
SET 0,(IY+OTVFLAG) ;TVFLAG
POP BC ;
RET ;
;******************************************************************
; Module: IO_1
; Routine: DO_ATTS
;
; setup attributes. if printing to the upper screen, zero MASKT and
; transfer the border color to ATTRT, else transfer ATTRP to ATTRT.
; also, if printing to the upper screen, transfer the perm attributes
; to the temp attributes via R_ATTS. if printing to the LHS, do
; put the temporary attributed into the permanent attributes.
;******************************************************************
DO_ATTS:
M0888: XOR A ;zero A
LD HL,(ATTRP) ;get the permanent attributes and mask
BIT 0,(IY+OTVFLAG) ;/jump if not printing to LHS
JR Z,M0896 ;\
LD H,A ;load attribute mask (take attrib from ATTRP)
LD L,(IY+OBORDCR) ;get the border color
M0896: LD (ATTRT),HL ;store into the temp attributes
;******************************************************************
; Module: IO_1
; Routine: R_ATTS
; if ZF=1, transfer the permanent attributes to the temporary attributes
; if ZF=0, update the temporary attributes
; ENTER: A with new attribute flags
; ZF = 0: use the flags in PFLAG else use passed flags
;******************************************************************
R_ATTS: LD HL,PFLAG ;get the print flag address
JR NZ,M08A0 ;
LD A,(HL) ;get the print attribute flags
RRCA ;make the perm flags the temp flags
M08A0: XOR (HL) ;
AND $55 ;save the temporary flags,
;zero the permanent flags
XOR (HL) ;this transfers in the permanent flags
;into A and puts the temp flags into A
LD (HL),A ;save the flags
RET
;******************************************************************
; Module: IO_1
; Routine: K_CLS
;******************************************************************
K_CLS:
M08A6: CALL CLS ;clear the screen
;******************************************************************
; Module: IO_1
; Routine: CLLHS
;******************************************************************
CLLHS:
M08A9: LD HL,TVFLAG ;/
RES 5,(HL) ;|force no clear LHS when key pressed
SET 0,(HL) ;\force printing to LHS
CALL DO_ATTS ;set up the attributes. effectively
; transfers the permanent attributes to the
; temporary attributes
LD B,(IY+ODFSZ) ;get the size of the LHS
CALL CLS_B ;clear the LHS
LD HL,$5AC0 ;address of end of LHS attributes+1
LD A,(ATTRP) ;get the permanent attributes
DEC B ;normalize line counter for 1 base
JR M08C9 ;
M08C2: LD C,$20 ;for 32 characters
M08C4: DEC HL ;point to an attribute byte
LD (HL),A ;store the attribute
DEC C ;/jump around until all 32 characters
JR NZ,M08C4 ;\ have been cleared
M08C9: DJNZ M08C2 ;jump back around for the next line
LD (IY+ODFSZ),02 ;force 2 lines for the LHS
M08CF: LD A,$FD ;/stream -3 (keyboard/lower screen)
CALL SELECT ;\
LD HL,(CURCHL) ;point to the current channel address
; store
LD DE,SENDTV ;
AND A ;reset the carry flag
M08DB: LD (HL),E ;/
INC HL ;|update the current channel output
LD (HL),D ;| routine address, then the input
INC HL ;\ routine address
LD DE,IN_K ;
CCF ;/"loop" counter
JR C,M08DB ;\
LD BC,$1721 ;line 2, start of line
JR STTVC ;update the printing parameters
;******************************************************************
; Module: IO_1
; Routine: CLS
;******************************************************************
CLS:
M08EA: LD HL,$0000 ;/zero the X and Y print
LD (XCOORD),HL ;\coordinates
RES ALOS,(IY+OFLAGS2) ;force no autolisting
CALL M08CF ;
LD A,$FE ;/stream -2 (main screen)
CALL SELECT ;\
CALL DO_ATTS ;update the atributes
LD B,$18 ;FOR 24 lines
CALL CLS_B ;clear the screen
LD HL,(CURCHL) ;get the address of the current channel
; output routine
LD DE,SENDTV ;/
LD (HL),E ;|make the current output channel
INC HL ;| the TV
LD (HL),D ;\
LD (IY+OSCRCT),01 ;set scroll count to 1
LD BC,$1821 ;get ready to set the cursor pointers
; to the top left corner of the
; screen
;******************************************************************
; Module: IO_1A
; Routine: STTVC
; set the TV current print position pointers
; ENTER: D contains (24-line number)
; E contains (33-char number)
;******************************************************************
STTVC:
M0914: LD HL,PRBUF ;point to printer buffer
BIT PR,(IY+OFLAGS) ;/jump if printing to
JR NZ,M092F ;\ the printer
LD A,B ;get the line number into A
BIT LHS,(IY+OTVFLAG) ;/jump if not printing to
JR Z,M0929 ;\ the lower half of the screen
ADD A,(IY+ODFSZ) ;add the number of lines in the lower
; screen
SUB $18 ;
M0929: PUSH BC ;briefly save BC
LD B,A ;/
CALL M09D6 ;|find the display file address for the
;\ screen line in "B"
POP BC ;restore BC
M092F: LD A,$21 ;/form the char position number for
SUB C ;\ the char position in C
LD E,A ;/
LD D,$00 ;|form the DF address for the char in
ADD HL,DE ;\ C
JP STTVCU ;update character pointers
;******************************************************************
; Module: IO_1A
; Routine: SCRL
; SCRL1: entry point to scroll one line
; SCRLB: entry point to scroll "B" lines
;******************************************************************
SCRL1:
M0939: LD B,$17 ;second line
SCRLB:
M093B: CALL M09D6 ;get the line’s address in DF1
;
;fill the screen bit map with
;
LD C,$08 ;FOR 8 scan lines
M0940: PUSH BC ;save scan line counter
PUSH HL ;save the display file "FROM" address
LD A,B ;save character lines
AND $07 ;test if this is the last scan line
; in the character line
LD A,B ;save the character line counter
JR NZ,M0954 ;jump if the not the last scan line
; in the character line
M0948: EX DE,HL ;/make DE point to the previous
LD HL,$F8E0 ;|(-720)
ADD HL,DE ;\scan line
EX DE,HL ;HL now points to the line whose number was in B
;DE points to the line before it
LD BC,$0020 ;32 bytes
DEC A ;decrement the character line counter
LDIR ;move the bytes
M0954: EX DE,HL ;/
LD HL,$FFE0 ;|-$20 (32)
ADD HL,DE ;|move HL to point back one character line
EX DE,HL ;\
LD B,A ;
AND $07 ;
RRCA ;
RRCA ;
RRCA ;
LD C,A ;
LD A,B ;
LD B,$00 ;
LDIR ;
LD B,$07 ;
ADD HL,BC ;
AND $F8 ;
JR NZ,M0948 ;
POP HL ;
INC H ;
POP BC ;
DEC C ;
JR NZ,M0940 ;
CALL M09C3 ;form the address for the attributes
LD HL,$FFE0 ;subtract 32 from DE
ADD HL,DE ;
EX DE,HL ;
LDIR ;
LD B,$01 ;clear the bottom line
; of the display
;******************************************************************
; Module: IO_1A
; Routine: CLS_B
; clear lower B lines of the display
;******************************************************************
CLS_B:
M097F: PUSH BC ;save the # of lines to clear
CALL M09D6 ;HL=location in DF1 where the line
; in B resides
LD C,$08 ;FOR 8 scan lines per character line
M0985: PUSH BC ;save the scan line counter
PUSH HL ;save the scan line address
LD A,B ;get the character line number
M0988: AND $07 ;number of character lines to clear in this
; block
RRCA ;/
RRCA ;|*32 bytes/character line
RRCA ;\
LD C,A ;initialize the byte counter
LD A,B ;save the # of character lines
LD B,$00 ;zero the MS byte of the byte counter
DEC C ;decrement the scan line counter
LD D,H ;/copy the first location to clear
LD E,L ;\ to DE
LD (HL),$00 ;zero the first location
INC DE ;bump the "to" address to the next
; byte
LDIR ;clear the scan line
LD DE,$0701 ;/point to the start of the next
ADD HL,DE ;\ scan line in the next block
DEC A ;decrement the character line counter
AND $F8 ;force clearing 8 character lines in the
; next block
LD B,A ;save the character line counter
JR NZ,M0988 ;back around for more scan lines
POP HL ;restore the display file pointer
INC H ;move to the next scan line
POP BC ;restore the scan line counter
DEC C ;/back around for more scan lines
JR NZ,M0985 ;\
;
;now, do the attributes
;
CALL M09C3 ;get the start address of the attributes
LD H,D ;/copy the attribute start address to HL
LD L,E ;\
INC DE ;again, bump the "to" pointer
LD A,(ATTRP) ;get the permanent attributes
BIT LHS,(IY+OTVFLAG) ;/jump if doing the upper half screen
JR Z,M09BB ;\
LD A,(BORDCR) ;the border color is used for the LHS
M09BB: LD (HL),A ;change the first attribute
DEC BC ;adjust counter
LDIR ;change the rest of the attributes
POP BC ;restore the number of lines to clear (B)
LD C,$21 ;???
RET ;done
M09C3: LD A,H ;/
RRCA ;|
RRCA ;|form the address for the attribute
RRCA ;|RAM
DEC A ;|
OR $50 ;|
LD H,A ;\
EX DE,HL ;DE=start of attributes to change
LD H,C ;/
LD L,B ;\get the number of character lines
ADD HL,HL ;*2
ADD HL,HL ;*4
ADD HL,HL ;*8
ADD HL,HL ;*16
ADD HL,HL ;*32
LD B,H ;/number of attribute bytes
LD C,L ;\ to change
RET
;
;form the base address in DF1 of the line number in B
; ENTRY: B contains the line to access
; EXIT: HL points to the location in DF1 where the
; line resides. basically, perform the computation
; $4000+$100*INT(line#/2)+(32*(line# AND 7)), where line# = 24-B
;
M09D6: LD A,$18 ;max 24 lines to the screen
SUB B ;number of lines down from top of
; screen B is
LD D,A ;save A
;32*(line# AND 7)
RRCA ;/
RRCA ;|LS byte of base address of
RRCA ;|line to clear
AND $E0 ;|
LD L,A ;\
;$100*INT(line#/2)
LD A,D ;/
AND $18 ;|form the MS byte of the line
OR $40 ;|base address
LD H,A ;\
RET ;
;
;wait for a key, then clear the lower half screen
; (LHS)
;
PUSH AF ;/
PUSH BC ;|save registers
PUSH DE ;\
LD BC,$9C40 ;
M09ED: DEC BC ;/
LD A,C ;|wait until BC=0
OR B ;|
JR NZ,M09ED ;\
M09F2: XOR A ;/
IN A,($FE) ;|loop until no keys are pressed
AND $1F ;|
CP $1F ;|
JR Z,M09F2 ;\
CALL CLLHS ;clear the lower half screen
POP DE ;/restore registers
POP BC ;|
POP AF ;\
RET ;
;******************************************************************
; Module: IO_2
; Routine: K_DUMP
; dump the screen to the printer
;******************************************************************
K_DUMP:
DI ;don’t interrupt us
LD B,$B0 ;22 character lines * 8 scanlines per character
LD HL,DF1 ;HL points to display file #1
M0A08: PUSH HL ;/save the pointers
PUSH BC ;\
CALL PRSCAN ;output (HL) to the printer
POP BC ;/restore the registers
POP HL ;\
INC H ;point to the next scan line
LD A,H ;/jump if we have not finished
AND $07 ;| 8 scan lines
JR NZ,M0A1F ;\
LD A,L ;/bump to the next character
ADD A,$20 ;|line
LD L,A ;\
;we now update the high byte of the DF address
; if we have not finished a section of the screen
;(lines 0..7, 8..15, or 16..23) we must set H back to
; $40, $48, or $50 depending on the section being printed
;
; at this point H will contain $48, $50, or $58 for the
; first, second, or third segment respecively
;
CCF ;carry will be set when transitioning
; to the next DF segment
SBC A,A ;A=$FF if in the same DF segment or
;A=$00 if going to the next segment
AND $F8 ;-8
ADD A,H ;/subtract 8 to put H back to where
LD H,A ;\ it should be
M0A1F: DJNZ M0A08 ;decrement scan line counter
JR M0A30 ;jump to finish up
;******************************************************************
; Module: IO_2
; Routine: DUMPPTR
;******************************************************************
DUMPPTR:
M0A23: DI ;leave us alone
LD HL,PRBUF ;point to the printer buffer
LD B,$08 ;eight scan lines
M0A29: PUSH BC ;save scan line counter
CALL PRSCAN ;output the buffer to the printer
POP BC ;restore the scan line counter
DJNZ M0A29 ;back around for all of the scan lines
M0A30: LD A,$04 ;/motor off
OUT ($FB),A ;\
EI ;interrupts now allowed
CLPRBUF:
M0A35: LD HL,PRBUF ;point to the printer buffer
LD (IY+OPRCC),L ;the printer "cursor" now points
; to the first location of the
; printer buffer
XOR A ;zero the accum
LD B,A ;FOR 256 bytes
M0A3D: LD (HL),A ;/
INC HL ;|zero the printer buffer
DJNZ M0A3D ;\
RES PRLEFT,(IY+OFLAGS2) ;force printer buffer empty indication
LD C,$21 ;
JP STTVC ;
;******************************************************************
; Module: IO_2
; Routine: PRSCAN
; output the bytes at (HL) to the printer. generally, this will be
; one scan line of character data
; ENTRY: HL points to a 32 byte buffer
; B contains a printer config byte.
;******************************************************************
PRSCAN:
M0A4A: LD A,B ;/if B<3 set motor speed slow,
CP $03 ;|else set high
SBC A,A ;\
AND $02 ;save the motor speed bit
OUT ($FB),A ;turn motor on at selected speed
LD D,A ;save the printer configuration
M0A53: CALL BREAK ;/jump if break not pressed
JR C,M0A62 ;\
LD A,$04 ;/turn printer motor off
OUT ($FB),A ;\
EI ;enable interrupts
CALL CLPRBUF ;clear the printer buffer and
; force buffer flag to EMPTY
RST $08 ;error: BREAK – CONT REPEATS
DEFB $0C ;
M0A62: IN A,($FB) ;read printer port
ADD A,A ;/return if printer "NOT CONFIGURED"
RET M ;\
JR NC,M0A53 ;jump if not "START OF PAPER"
; (paper out?)
LD C,$20 ;FOR 32 characters
M0A6A: LD E,(HL) ;get the first byte to output
INC HL ;point to the next
LD B,$08 ;FOR 8 bits
M0A6E: RL D ;/rotate a bit into bit 7 of
RL E ;| D
RR D ;\
M0A74: IN A,($FB) ;/wait until printer is ready
RRA ;| for the next pixel
JR NC,M0A74 ;\
LD A,D ;/output the pixel to the
OUT ($FB),A ;\ printer
DJNZ M0A6E ;loop until the bit counter is zero
DEC C ;/loop until the byte counter is
JR NZ,M0A6A ;\ zero
RET ;done
;******************************************************************
; Module: IO_2
; Routine: EDIT_K
;******************************************************************
EDIT_K:
M0A82: LD HL,(ERRSP) ;/push the error stack pointer onto
PUSH HL ;\the stack
M0A86: LD HL,$0BE5 ;/stack $0BE5
PUSH HL ;\
LD (ERRSP),SP ;put the current stack pointer int ERRSP
; will be $0E3A on entry to BASIC
M0A8E: CALL RDCH ;get a character from the current channel
PUSH AF ;save the char
LD D,$00 ;/
LD E,(IY+(-$01)) ;|keyboard click
LD HL,$00C8 ;|
CALL PARP ;\
POP AF ;get the character
LD HL,$0A8E ;/return address
PUSH HL ;\
CP $0C ;/jump if not DELETE
JR NZ,M0AB2 ;\
BIT 5,(IY+OFLAGS2) ;/jump if DELETE key
JR NZ,M0AB2 ;\held down
BIT 3,(IY+OFLAGS) ;/jump if not "L" mode
JR Z,M0AE7 ;\
M0AB2: CP $18 ;/jump if possibly a letter
JR NC,M0AE7 ;\ or token
CP $07 ;/jump if not an editing
JR C,M0AE7 ;\key
CP $10 ;/jump if an editing key
JR C,M0AF8 ;\
LD BC,$0002 ;
LD D,A ;save A
CP $16 ;
JR C,M0AD2 ;
;AT,TAB
INC BC ;
BIT 7,(IY+OFLAGX) ;
JP Z ,M0B84 ;
CALL RDCH ;
LD E,A ;
;
;INK,PAPER,FLASH,BRIGHT,INVERT,OVER
;
M0AD2: CALL RDCH ;
PUSH DE ;
LD HL,(KCUR) ;
RES 0,(IY+OMODE) ;MODE
CALL INSERT ;
POP BC ;
INC HL ;
LD (HL),B ;
INC HL ;
LD (HL),C ;
JR M0AF1 ;
;******************************************************************
; Module: IO_2
; Routine: INSA
;******************************************************************
INSA:
M0AE7: RES 0,(IY+OMODE) ;forces either K/L mode or G mode
LD HL,(KCUR) ;point current character in input buffer
CALL M12B8 ;move character into free RAM
M0AF1: LD (DE),A
INC DE
LD (KCUR),DE
RET
;
;EDIT,CSR_LT,CSR_RT,CSR_DN,CSR_UP,DELETE,CR,SLUG,UNUSED
;
M0AF8: LD E,A ;/
LD D,$00 ;|form the address into the
LD HL,M0B06-EDITKEY ;|lookup table at M0B06
ADD HL,DE ;\
LD E,(HL) ;/form the address of the
ADD HL,DE ;\edit key handler
PUSH HL ;stack it
LD HL,(KCUR) ;point to the char in the input buffer
RET ;jump to the edit key handler
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
M0B06: DEFB EDITCMD-ASMPC ;EDIT $09
DEFB CSR_LTCMD-ASMPC ;CSR_LT $66
DEFB CSR_RTCMD-ASMPC ;CSR_RT $6A
DEFB CSR_DNCMD-ASMPC ;CSR_DN $50
DEFB CSR_UPCMD-ASMPC ;CSR_UP $B5
DEFB DELETECMD-ASMPC ;DELETE $70
DEFB CRCMD-ASMPC ;CR $7E
DEFB SLUGCMD-ASMPC ;SLUG $CF
DEFB UNUSEDKEYCMD-ASMPC ;UNUSED $D4
EDITCMD:
LD HL,(EPPC) ;
BIT 5,(IY+OFLAGX) ;FLAGX
JP NZ,DEL_C ;
CALL FIND_L ;
CALL GET_LN ;
LD A,D ;
OR E ;
JP Z ,DEL_C ;
PUSH HL ;
INC HL ;
LD C,(HL) ;
INC HL ;
LD B,(HL) ;
LD HL,$000A ;
ADD HL,BC ;
LD B,H ;
LD C,L ;
CALL CHK_SZ ;
CALL DEL_C ;
LD HL,(CURCHL) ;
EX (SP),HL ;
PUSH HL ;
LD A,$FF ;/stream -1 (RAM write)
CALL SELECT ;\
POP HL
DEC HL
DEC (IY+OEPPC) ;EPPC
CALL M15AC
INC (IY+OEPPC) ;EPPC
LD HL,(ELINE)
INC HL
INC HL
INC HL
INC HL
LD (KCUR),HL
POP HL
CALL M1248
RET
CSR_DNCMD:
BIT 5,(IY+OFLAGX) ;/jump if expecting user input rather
JR NZ,M0B67 ;\ a program line
LD HL,EPPC ;HL now contains the pointer to the
; current line in a program listing
CALL NEXT_L ;point to the next line
JR M0BD4 ;
M0B67: LD (IY+OERRNR),$10 ;
JR CRCMD
CSR_LTCMD:
CALL M0B97
JR M0B77
CSR_RTCMD:
LD A,(HL)
CP $0D
RET Z
INC HL
M0B77: LD (KCUR),HL
RET
DELETECMD:
CALL M0B97
;******************************************************************
; Module: IO_2
; Routine: DELSYM
;
; ENTER: HL contains the address of the item to be deleted
;******************************************************************
DELSYM:
LD BC,$0001 ;/delete one byte at (HL)
JP DELREC ;\
M0B84: CALL RDCH ;/read two characters from
CALL RDCH ;\ the current channel
CRCMD: POP HL ;
POP HL ;
M0B8C: POP HL ;
LD (ERRSP),HL ;
BIT 7,(IY+OERRNR) ;/return if error 0/0:0
RET NZ ;\
LD SP,HL ;
RET ;
M0B97: SCF ;force input from input line
CALL M0CFB ;DE points to WORKSP
SBC HL,DE ;
ADD HL,DE ;
INC HL ;
POP BC ;
RET C ;
PUSH BC ;
LD B,H ;
LD C,L ;
M0BA4: LD H,D ;
LD L,E ;
INC HL ;
LD A,(DE) ;
AND $F0 ;
CP $10 ;
JR NZ,M0BB7 ;
INC HL ;
LD A,(DE) ;
SUB $17 ;
ADC A,$00 ;
JR NZ,M0BB7 ;
INC HL ;
M0BB7: AND A ;
SBC HL,BC ;
ADD HL,BC ;
EX DE,HL ;
JR C,M0BA4 ;
RET ;
CSR_UPCMD:
BIT INPLN,(IY+OFLAGX) ;/return if expecting input from
RET NZ ;\ the input line
LD HL,(EPPC) ;get listing "current" line number
CALL FIND_L ;find the line
EX DE,HL ;
CALL GET_LN ;DE=line number
LD HL,EPPC+1 ;
CALL DE_HL ;
M0BD4: CALL TSLIST ;list the line
LD A,$00 ;/stream 0 (lower screen)
JP SELECT ;\
SLUGCMD:
BIT 7,(IY+OFLAGX) ;FLAGX
JR Z,CRCMD
UNUSEDKEYCMD:
JP M0AE7
M0BE5: BIT RETPOS,(IY+OFLAGS2) ;/return if retype is not possible after
JR Z,M0B8C ;\ an error
LD (IY+OERRNR),$FF ;error 0
LD D,$00 ;/
LD E,(IY+(-$02)) ;|
LD HL,$1A90 ;\
CALL PARP ;make the noise
JP M0A86 ;
;******************************************************************
; Module: IO_2
; Routine: DEL_C
;******************************************************************
DEL_C:
M0BFD: PUSH HL ;
CALL M0CF6 ;
DEC HL ;points to the ENTER in the edit buffer
CALL DEL_DE ;deletes the bytes between (HL)
; and (DE)
LD (KCUR),HL ;
LD (IY+OMODE),00 ;force "K" mode
POP HL ;restore HL
RET ;
;******************************************************************
; Module: IO_2
; Routine: IN_K
;******************************************************************
IN_K:
BIT ECHREQ,(IY+OTVFLAG) ;/call if echo to screen requested
CALL NZ,M0C83 ;\
AND A ;
BIT KEYHIT,(IY+OFLAGS) ;
RET Z ;
LD A,(LASTK) ;
RES KEYHIT,(IY+OFLAGS) ;
PUSH AF ;
BIT CLHS,(IY+OTVFLAG) ;
CALL NZ,M08A9 ;
POP AF ;
CP $20 ;
JR NC,M0C81 ;
CP $10 ;
JR NC,M0C60 ;
CP $06 ;
JR NC,M0C41 ;
LD B,A ;
AND $01 ;
LD C,A
LD A,B
RRA
ADD A,$12
JR M0C6B
M0C41: JR NZ,M0C4C
LD HL,FLAGS2
LD A,$08
XOR (HL)
LD (HL),A
JR M0C5A
M0C4C: CP $0E
RET C
SUB $0D
LD HL,MODE
CP (HL)
LD (HL),A
JR NZ,M0C5A
LD (HL),$00
M0C5A: SET 3,(IY+OTVFLAG) ;TVFLAG
CP A
RET
M0C60: LD B,A
AND $07
LD C,A
LD A,$10
BIT 3,B
JR NZ,M0C6B
INC A
M0C6B: LD (IY+(-$2D)),C ;KDATA
LD DE,$0C73
JR M0C79
LD A,(KDATA)
LD DE,$0C0E
M0C79: LD HL,(CHANS)
INC HL
INC HL
LD (HL),E
INC HL
LD (HL),D
M0C81: SCF
RET
M0C83: CALL DO_ATTS ;set up the attributes
RES ECHREQ,(IY+OTVFLAG) ;force no echo
RES CLHS,(IY+OTVFLAG) ;force no clearing of lower half screen
LD HL,(SPOSNLCOL) ;/get and save the print line and column
PUSH HL ;\
LD HL,(ERRSP) ;/get and save the error stack pointer
PUSH HL ;\
LD HL,M0CCD ;/new error stack pointer
PUSH HL ;|
LD (ERRSP),SP ;\
LD HL,(ECHOE) ;/"jump" address
PUSH HL ;\
SCF ;
;******************************************************************
; Module: IO_2
; Routine: ECHO
;******************************************************************
ECHO:
CALL M0CFB ;returns with DE pointing to the WORKSP
; or ELINE if expecting user input
EX DE,HL ;
CALL M15C9 ;
EX DE,HL ;
CALL M162D ;
LD HL,(SPOSNLCOL) ;
EX (SP),HL ;
EX DE,HL ;
CALL DO_ATTS ;
M0CB6: LD A,(SPOSNLLIN) ;
SUB D ;
JR C,M0CE2 ;
JR NZ,M0CC4 ;
LD A,E
SUB (IY+OSPOSNLCOL) ;SPOSNLCOL
JR NC,M0CE2
M0CC4: LD A,$20
PUSH DE
CALL SENDTV
POP DE
JR M0CB6
M0CCD: LD D,$00
LD E,(IY+(-$02)) ;RASP
LD HL,$1A90
CALL PARP
LD (IY+OERRNR),$FF ;ERRNR
LD DE,(SPOSNLCOL)
JR M0CE4
M0CE2: POP DE
POP HL
M0CE4: POP HL
LD (ERRSP),HL
POP BC
PUSH DE
CALL STTVC
POP HL
LD (ECHOE),HL
LD (IY+(OXPTR+1)),00 ;
RET
M0CF6: LD HL,(WORKSP) ;point to the workspace
DEC HL ;points to the $80 byte
AND A ;
M0CFB: LD DE,(ELINE) ;point to the edit buffer
BIT INPLN,(IY+OFLAGX) ;/return if expecting program line
RET Z ;\
LD DE,(WORKSP) ;/input from input line
RET C ;\
LD HL,(STKBOT) ;/???
RET ;\
;******************************************************************
; Module: IO_2
; Routine: DESLUG
; deslugs a line until it reaches $0D
;******************************************************************
DESLUG:
M0D0D: LD A,(HL) ;get the current char
CP $0E ;is it a slug
LD BC,$0006 ;number of bytes to skip
CALL Z,DELREC ;delete the fp number
LD A,(HL) ;get the next char
INC HL ;bump pointer
CP $0D ;end of line?
JR NZ,M0D0D ;back around until the end of line
RET
;******************************************************************
; Module: EDIT
; Routine: K_NEW
;******************************************************************
K_NEW:
DI ;no interrupts
LD A,$FF ;NEW flag
LD DE,(RAMTOP) ;get sys variables to be saved
EXX ;
LD BC,(PRAMT) ;
LD DE,(RASP) ;
LD HL,(UDG) ;
EXX ;
;******************************************************************
; Module: EDIT
; Routine: INIT
; System initialization. Enter with A=0 and DE=FFFF
; and interrrupts disabled.
;******************************************************************
INIT:
M0D31: LD B,A ;zero out B
LD A,$07 ;/set border to
OUT ($FE),A ;\white
LD A,$3F ;/initialize I?
LD I,A ;|and set A to bottom of ram
;\3FFF
NOP ;
NOP ;
NOP ;
NOP ;
NOP ;
NOP ;
;start memory test
LD H,D ;/HL=FFFF
LD L,E ;\
M0D42: LD (HL),$02 ;/
DEC HL ;|fill ram from $FFFF
CP H ;|to $4000 with $02
JR NZ,M0D42
M0D48: AND A ;reset carry for subtract
SBC HL,DE ;/
ADD HL,DE ;|step through addresses
INC HL ;|
JR NC,M0D55
DEC (HL) ;decrement memory location
JR Z,M0D55
;set RAMTOP
DEC (HL) ;decrement memory again
JR Z,M0D48
;loop again
M0D55: DEC HL ;point to the last valid memory address
;
;fill system variables with their old values via K_NEW
; these will be zero on power-on
;
EXX ;swap to the alternate registers
LD (PRAMT),BC ;
LD (RASP),DE ;
LD (UDG),HL ;
EXX ;to normal registers
INC B ;/jump if NEW
JR Z,M0D7F ;\
LD (PRAMT),HL ;set P_RAMTOP to discovered value
LD DE,$3EAF ;/initialize the UDG area
LD BC,$00A8 ;|transfer the character data at $3EAF – $3F57
EX DE,HL ;|to the top of RAM
LDDR ;\
EX DE,HL ;
INC HL ;
LD (UDG),HL ;set UDG to point to transferred data
DEC HL ;point just below UDG
LD BC,$0040 ;
LD (RASP),BC ;set RASP=40, PIP=0
M0D7F: LD (RAMTOP),HL ;set BASIC’s RAMTOP to just below the
; UDG area
;******************************************************************
; Module: EDIT
; Routine: NEW
;******************************************************************
NEW:
LD HL,$3C00 ;/set CHARS
LD (CHARS),HL ;\
LD HL,$6200 ;/set MSBOT – address of
LD (MSTBOT),HL ;\location above machine stack
DEC HL ;point to machine stack
LD (HL),$3E ;initialize to $3E
DEC HL ;/we finally have a stack
LD SP,HL ;\
DEC HL ;/
DEC HL ;|set ERR_SP
LD (ERRSP),HL ;\
IM 1 ;set interrupt mode 1
NOP ;wait a bit
LD IY,ERRNR ;initialize IY to address of
; ERR_NR
LD HL,$6840 ;/set CHANS to point to
LD (CHANS),HL ;\channels buffer
LD DE,$11AA ;/
LD BC,$0015 ;|transfer channel data
EX DE,HL ;|to RAM buffer
LDIR ;\
EX DE,HL ;
LD A,$38 ;/
LD (ATTRP),A ;|set ATTR_P
LD (ATTRT),A ;|set ATTR_T
LD (BORDCR),A ;\set BORDCR – border color
LD HL,$0523 ;/
LD (REPDEL),HL ;\set REPDEL
DEC (IY+(-$3A)) ;set KSTATE to FF? assumed because ;KS_A1
; RAM test should have left it 0
; this should indicate no key pressed
DEC (IY+(-$36)) ;set $5C40(23556) to FF ;KS_A2
LD HL,$11C1 ;/
LD DE,STRMS ;|initialize the stream table
LD BC,$000E ;|
LDIR ;\
XOR A ;/1. enable dock bank selection
OUT ($FF),A ;|2. enable 16mS interrupt
;|3. set normal video mode
;\4. set attrib to black on white
SET PR,(IY+OFLAGS) ;force printing to printer
CALL CLPRBUF ;
LD (IY+ODFSZ),02 ;set DF_SZ to 2 lines ;DFSZ
CALL M08A6 ;clear the screen?
XOR A ;zero A
SET 4,(IY+OFLAGS) ;set bit in FLAGS ;FLAGS
LD DE,$1117 ;??? DE gets munged early on in PUTMES
CALL PUTMES ;print banner message?
SET 5,(IY+OTVFLAG) ;set flag in TV_FLAG ;TVFLAG
LD HL,$0E0B ;/
LD DE,$6000 ;|tranfer the routine that
LD BC,$001D ;|moves the function dispatcher
LDIR ;\code from EXROM to RAM
CALL M6000 ;call the transfer routine
LD HL,$65CE ;/initialize the bank stack pointer
LD ($65CE),HL ;\in the function dispatcher
LD HL,$08E7 ;/jumps to $08E7 in the EXROM
CALL M6815 ;|the return address is popped into
;\IX and then…
;******************************************************************
; these instructions are transferred to 6000 by init @ 0DED
; then called. this routine transfers the function dispatcher
; from the EXROM to its initial RAM location
LD A,$01 ;/enable the dock bank
OUT ($F4),A ;\in the HSR
IN A,($FF) ;/
SET 7,A ;|now enable the EXROM
OUT ($FF),A ;\
LD HL,$1000 ;/
LD DE,$6200 ;|transfer the function
LD BC,$0630 ;|dispatcher code
LDIR ;\
RES 7,A ;/disable the EXROM
OUT ($FF),A ;\
XOR A ;/back to home bank
OUT ($F4),A ;\
RET ;done
;******************************************************************
M0E28: LD (IY+ODFSZ),02 ;DFSZ
CALL TSLIST
;******************************************************************
; Module: EDIT
; Routine: LED18
; BASIC entry point?
;******************************************************************
LED18:
M0E2F: CALL M133F ;initialize ELINE,KCUR, and WORKSP pointers
M0E32: LD A,$00 ;/stream 0 (lower screen)
CALL SELECT ;\
CALL EDIT_K
CALL M1A27
BIT 7,(IY+OERRNR) ;ERRNR
JR NZ,M0E55
BIT 4,(IY+OFLAGS2) ;FLAGS2
JR Z,M0E8D
LD HL,(ELINE)
CALL M0D0D
LD (IY+OERRNR),$FF ;ERRNR
JR M0E32
M0E55: LD HL,(ELINE)
LD (CHADD),HL
CALL M1768
LD A,B
OR C
JP NZ,M1158
RST $18 ;get current char
CP $0D
JR Z,M0E28
BIT 0,(IY+OFLAGS2) ;FLAGS2
CALL NZ,CLS
CALL M08A9
LD A,$19
SUB (IY+OSPOSNLIN) ;SPOSNLIN
LD (SCRCT),A
SET 7,(IY+OFLAGS) ;FLAGS
LD (IY+OERRNR),$FF ;ERRNR
LD (IY+ONSPPC),01 ;NSPPC
LD (IY+OERRLN),00 ;ERRLN
CALL M1AD8
M0E8D: HALT
LD A,(IY+OERRNR) ;ERRNR
CP $FF
JR Z,M0EC8
BIT 7,(IY+(OERRLN+1)) ;
JR Z,M0EC8
SET 6,(IY+(OERRLN+1)) ;
INC A
LD (ERRT),A
LD (IY+OERRNR),$FF ;ERRNR
LD HL,(PPC)
LD (ERRC),HL
LD A,(SUBPPC)
LD (ERRS),A
LD HL,(ERRLN)
RES 7,H
RES 6,H
LD (NEWPPC),HL
LD (IY+ONSPPC),01 ;NSPPC
LD HL,$0E8D
PUSH HL
JP M1AB9
M0EC8: LD A,$07
OUT ($F5),A
LD A,$FF
OUT ($F6),A
RES 3,(IY+OTVFLAG) ;TVFLAG
RES 5,(IY+OFLAGS) ;FLAGS
BIT 1,(IY+OFLAGS2) ;FLAGS2
CALL NZ,M0A23
LD A,(ERRNR)
INC A
M0EE3: PUSH AF
LD HL,$0000
LD (IY+OFLAGX),H ;FLAGX
LD (IY+(OXPTR+1)),H ;
LD (DEFADD),HL
LD HL,$0001
LD (CH_0),HL
CALL M133F
RES 5,(IY+OFLAGX) ;FLAGX
CALL M08A9
SET 5,(IY+OTVFLAG) ;TVFLAG
POP AF
LD B,A
CP $0A
JR C,M0F0C
ADD A,$07
M0F0C: CALL M11EA
LD A,$20
RST $10
LD A,B
LD DE,$0F65
CALL PUTMES
XOR A
LD DE,$1115
CALL PUTMES
LD BC,(PPC)
CALL M1788
LD A,$3A
RST $10
LD C,(IY+OSUBPPC) ;SUBPPC
LD B,$00
CALL M1788
CALL DEL_C
LD A,(ERRNR)
INC A
JR Z,M0F56
CP $09
JR Z,M0F43
CP $15
JR NZ,M0F46
M0F43: INC (IY+OSUBPPC) ;SUBPPC
M0F46: LD BC,$0003
LD DE,OSPCC
LD HL,NSPPC
BIT 7,(HL)
JR Z,M0F54
ADD HL,BC
M0F54: LDDR
M0F56: LD (IY+ONSPPC),$FF ;NSPPC
RES 3,(IY+OFLAGS) ;FLAGS
RES 3,(IY+OTVFLAG) ;TVFLAG
JP M0E32
ADD A,B
LD C,A
;******************************************************************
; Module: EDIT
; Routine: ERRMSGS
;******************************************************************
ERRMSGS:
DEFB $CB
DEFM "NEXT without FO"&(‘R’+$80)
DEFM "Variable not foun"&(‘d’+$80)
DEFM "Subscript wron"&(‘g’+$80)
DEFM "Out of memor"&(‘y’+$80)
DEFM "Out of scree"&(‘n’+$80)
DEFM "Number too bi"&(‘g’+$80)
DEFM "RETURN without GOSU"&(‘B’+$80)
DEFM "End of fil"&(‘e’+$80)
DEFM "STOP statemen"&(‘t’+$80)
DEFM "Invalid argumen"&(‘t’+$80)
DEFM "Integer out of rang"&(‘e’+$80)
DEFM "Nonsense in BASI"&(‘C’+$80)
DEFM "BREAK – CONT repeat"&(‘s’+$80)
DEFM "Out of DAT"&(‘A’+$80)
DEFM "Invalid file nam"&(‘e’+$80)
DEFM "No room for lin"&(‘e’+$80)
DEFM "STOP in INPU"&(‘T’+$80)
DEFM "FOR without NEX"&(‘T’+$80)
DEFM "Invalid I/O devic"&(‘e’+$80)
DEFM "Invalid colo"&(‘r’+$80)
DEFM "BREAK into progra"&(‘m’+$80)
DEFM "RAMTOP no goo"&(‘d’+$80)
DEFM "Statement los"&(‘t’+$80)
DEFM "Invalid strea"&(‘m’+$80)
DEFM "FN without DE"&(‘F’+$80)
DEFM "Parameter erro"&(‘r’+$80)
DEFM "Tape loading erro"&(‘r’+$80)
DEFM "Missing LRO"&(‘S’+$80)
DEFM ‘,’&(‘ ‘+$80)
DEFM $7F&" 1982 Sinclair Research Ltd"&$0D&$0D
DEFM $7F&" 1983 Timex Computer Cor"&(‘p’+$80)
;******************************************************************
; Module: EDIT
; Routine: UNKEDIT
;******************************************************************
UNKEDIT:
LD A,$10
LD BC,$0000
JP M0EE3
M1158: LD (EPPC),BC
LD HL,(CHADD)
EX DE,HL
LD HL,$1150
PUSH HL
LD HL,(WORKSP)
SCF
SBC HL,DE
PUSH HL
LD H,B
LD L,C
CALL FIND_L
JR NZ,M1178
CALL RECLEN
CALL DELREC
M1178: POP BC
LD A,C
DEC A
OR B
JR Z,M11A6
PUSH BC
INC BC
INC BC
INC BC
INC BC
DEC HL
LD DE,(PROG)
PUSH DE
CALL INSERT
POP HL
LD (PROG),HL
POP BC
PUSH BC
INC DE
LD HL,(WORKSP)
DEC HL
DEC HL
LDDR
LD HL,(EPPC)
EX DE,HL
POP BC
LD (HL),B
DEC HL
LD (HL),C
DEC HL
LD (HL),E
DEC HL
LD (HL),D
M11A6: POP AF
JP M0E28
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;******************************************************************
; Module: EDIT
; Routine: CHINIT
; channels initialization data
;******************************************************************
CHINIT:
DEFB $00
DEFB $05
DEFB $0E
DEFB $0C
DEFB $4B
DEFB $00
DEFB $05
DEFB $BF
DEFB $11
DEFB $53
DEFB $E7
DEFB $0A
DEFB $BF
DEFB $11
DEFB $52
DEFB $00
DEFB $05
DEFB $BF
DEFB $11
DEFB $50
DEFB $80
INVI: RST $08
DEFB 12H ;’INVALID I/O’
;******************************************************************
; Module: EDIT
; Routine: SMINIT
; streams initialization data
;******************************************************************
SMINIT:
DEFB $01
DEFB $00
DEFB $06
DEFB $00
DEFB $0B
DEFB $00
DEFB $01
DEFB $00
DEFB $01
DEFB $00
DEFB $06
DEFB $00
DEFB $10
DEFB $00
;******************************************************************
; Module: EDIT
; Routine: RDCH
; read a character from the current channel,
; deposit it in A
;******************************************************************
RDCH:
M11CF: BIT CLHS,(IY+OTVFLAG) ;/jump if not clearing LHS
JR NZ,M11D9 ;\ on key press
SET ECHREQ,(IY+OTVFLAG) ;force echo keyboard input
M11D9: CALL INCH ;input a character from the current
; channel
RET C ;return with the character
JR Z,M11D9 ;back around for the next
; character
RST $08 ;/error 8: END OF FILE
DEFB $07 ;\
;******************************************************************
; Module: EDIT
; Routine: INCH
; input a character from the current channel in CURCHL (into A?)
;******************************************************************
INCH:
M11E1: EXX ;to alt regesters
PUSH HL ;briefly save HL
LD HL,(CURCHL) ;get current channel routine address
INC HL ;/point to the input routine
INC HL ;\
JR M11F2 ;get the character
;******************************************************************
; Module: EDIT
; Routine: PUTDIG
; send a decimal digit whose binary value is in A to the current
; channel
;******************************************************************
PUTDIG:
M11EA: LD E,$30 ;/make the digit ASCII
ADD A,E ;\
;******************************************************************
; Module: EDIT
; Routine: SENDCH
; send a character in A to the current stream
;******************************************************************
SENDCH:
M11ED: EXX ;to the alt registers
PUSH HL ;save HL
LD HL,(CURCHL) ;get CURCHL – the current channel
;
;this entry point outputs to the channel whose output routine address
; is in H’L’ if CRCBN is 0 or 1.
;on entry registers MUST point to the alt reg set
;
M11F2: EX AF,AF’ ;to alt accum
LD A,(CRCBN) ;get the current channel bank number
CP $02 ;
JR NC,M1205 ;
EX AF,AF’ ;back to normal accum
LD E,(HL) ;/
INC HL ;|get output routine address
LD D,(HL) ;\for the current channel
EX DE,HL ;output rtn adr to HL, CURCHL to DE
CALL M1264 ;"CALL" channel handler
POP HL ;restore HL
EXX ;back to the normal regs
RET
M1205: EX AF,AF’ ;back to normal accum
LD HL,(CURCHL) ;get the current channel pointer
LD B,(HL) ;
LD C,$88 ;
;this trashes A, the character we wish to send
; bug?
LD A,(ARSFLG) ;cartridge variable, zero on power up
BIT 0,A ;/jump if AROS is running
JR NZ,M1215 ;\
INC HL ;/get the
INC HL ;\
M1215: LD A,(STRMN) ;get current stream number
LD E,A ;/put in DE to save it
LD D,$00 ;\
PUSH DE ;save the stream pointer
LD DE,$0007 ;
ADD HL,DE ;
PUSH HL ;call address
PUSH BC ;C=horiz sel, B=bank
LD BC,$0002 ;two parameters out
PUSH BC ;
LD BC,$0000 ;no parameters in
PUSH BC ;
CALL M65D0 ;CALL_BANK
POP HL ;restore the current stream number
EXX ;
RET
;******************************************************************
; Module: EDIT
; Routine: SELECT
; select a stream
; select the stream number in A
;******************************************************************
SELECT:
M1230: ADD A,A ;double stream number
ADD A,$16 ;add offset into stream table
LD L,A ;/form address in HL
LD H,$5C ;\
LD E,(HL) ;/get pointer to the stream
INC HL ;|routine
LD D,(HL) ;\
LD A,D ;/is entry zero?
OR E ;\
JR NZ,M123F ;jump if stream entry is not zero
;******************************************************************
; Module: EDIT
; Routine: ERRO
;******************************************************************
ERRO:
M123D: RST $08 ;/error: INVALID STREAM
DEFB $17 ;\
M123F: CP $80 ;/jump if stream number is negative
JR NC,M1265 ;\
DEC DE ;
LD HL,(CHANS) ;get CHANS
ADD HL,DE ;
;******************************************************************
; Module: EDIT
; Routine: SEL_HL
; select the channel whose address is in HL
;******************************************************************
SEL_HL:
M1248: LD (CURCHL),HL ;make the channel address in HL the
; current channel
LD A,$00 ;/force bank number of current channel
LD (CRCBN),A ;\ to be zero
RES 4,(IY+OFLAGS2) ;force no retype possible after syntax error
INC HL ;
INC HL ;
INC HL ;
INC HL ;
LD C,(HL) ;get channel type (K,S,P)
LD HL,KLOOK ;/find in the table
CALL SEARCH ;\
RET NC ;return if not found (not K,S,P)
LD D,$00 ;/
LD E,(HL) ;|form the address to the routine
ADD HL,DE ;\
M1264: JP (HL) ;jump to the output routine
M1265: LD HL,(SYSCON) ;get SYSCON
SUB $80 ;
LD D,A ;
ADD HL,DE ;
LD (CURCHL),HL ;get CURCHL
LD A,(HL)
LD (CRCBN),A ;store in CURCBN
RES 4,(IY+OFLAGS2) ;FLAGS2
INC HL
INC HL
INC HL
INC HL
INC HL
INC HL
LD A,(CRCBN) ;get CURCBN
LD B,A ;
LD C,$88 ;
LD D,(HL) ;
INC HL ;
LD E,(HL) ;
LD H,D ;
LD L,E ;
PUSH HL ;call adr
PUSH BC ;C=horiz sel, B=bank
LD BC,$0000 ;no params
PUSH BC ;
PUSH BC ;
CALL M65D0 ;CALL_BANK
RET
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
KLOOK:
DEFM "K"
DEFB KANALK-ASMPC
DEFM "S"
DEFB KANALS-ASMPC
DEFM "P"
DEFB KANALP-ASMPC
DEFB 0 ;end of table
KANALK: SET LHS,(IY+OTVFLAG) ;force printing to the lower half of the screen
RES KEYHIT,(IY+OFLAGS) ;force no keyhit
SET RETPOS,(IY+OFLAGS2) ;no retype possible after syntax error
JR KANS1
KANALS: RES LHS,(IY+OTVFLAG) ;print to the top half of the screen
KANS1: RES PR,(IY+OFLAGS) ;print to TV
JP DO_ATTS ;jump to set the attributes
KANALP: SET PR,(IY+OFLAGS) ;force print to printer
RET
;******************************************************************
; Module: EDIT
; Routine: INSI
; insert 1 byte at (HL)
;******************************************************************
INSI:
M12B8: LD BC,$0001
;******************************************************************
; Module: EDIT
; Routine: INSERT
; make BC bytes available
; move BC items at (HL), into spare RAM if available
; ENTRY: BC – # of items to move
; HL – start address of area to move
;
; EXIT: HL – original address-1
; DE – HL+BC
;******************************************************************
INSERT:
M12BB: PUSH HL ;save insertion address
CALL CHK_SZ ;check for sufficient RAM
; error 4 if not
POP HL ;restore insertion address
CALL REMGSZ ;adjust various pointers in the system variables
;DE now points to the old STKEND (just before the free RAM) and HL points to
; the fence value (will be discarded). BC will contain the length of the
; memory block to be moved. this will usually be different from the entry
; value
LD HL,(STKEND) ;get STKEND (updated start of spare space)
EX DE,HL ;HL = entry value, DE = HL + BC
LDDR ;move the bytes up to open buffer
RET ;
;******************************************************************
; Module: EDIT
; Routine: REMGSZ
; this routine updates various pointers in the system variables.
; ENTRY: HL = memory address
; BC = bytes to move
; on entry HL contains a memory address that is compared to pointers
; starting with ARSBUF. if any pointer points to an address below
; the value stored in HL, the pointer is incremented by BC and restored
; to its original place.
;
; EXIT: DE = contains old value of STKEND
; HL = the fence
; BC = updated to the block size to move. this will, in general,
; be different than the entry value because the system will
; need to move large numbers of bytes to allow insertion of
; program lines.
;******************************************************************
REMGSZ:
M12CA: PUSH AF ;/save registers
PUSH HL ;\
;
;this section of code adjusts the pointer to the AROS buffer stored
; in ARSBUF, if needed
;
LD HL,ARSBUF ;get AROS buffer pointer
LD E,(HL) ;/copy to DE, DE now points to the
INC HL ;|AROS buffer
LD D,(HL) ;\
EX (SP),HL ;save ARSBUF and get old HL
AND A ;/set carry if HL<de
SBC HL,DE ;|(if address in HL is lower than the
ADD HL,DE ;\AROS buffer) (does CP HL,DE)
EX (SP),HL ;get ARSBUF back and save HL
JR NC,M12E0 ;jump if the address in HL is after the AROS
EX DE,HL ;DE now has ARSBUF
; and HL has the address of the AROS buffer
ADD HL,BC ;adjust the address of the AROS buffer
; by BC bytes
EX DE,HL ;HL now has ARSBUF and DE
; has the new address of the AROS buffer
LD (HL),D ;/
DEC HL ;|store the value in ARSBUF
LD (HL),E ;\
; HL DE STACK
;this section adjusts the system variables VARS through STKEND
;
M12E0: LD HL,VARS ;get the address for VARS POINTER LIMIT
LD A,$0E ;number of variables to update
M12E5: CP $09 ;/NXTLIN – needs to be tested against ARSFLG
JR Z,M12ED ;\because it may be in the AROS buffer
CP $08 ;/DATADD – data statement address,
JR NZ,M12FA ;\same situation as NXTLIN
;
;test the AROS present flag, if an AROS is present, skip the pointer update
;
M12ED: PUSH HL ;briefly save HL POINTER POINTER,LIMIT
LD HL,ARSFLG ;/ ARSFLG POINTER,LIMIT
LD L,(HL) ;|get the AROS flag and test
BIT 7,L ;\to see if an AROS is present
POP HL ;restore HL POINTER LIMIT
JR Z,M12FA ;jump if AROS not present
INC HL ;point to the high byte of the pointer
JR M130E ;skip the addition routine
;
;update a pointer by determining if it points above the fence address in HL. if it does,
; add BC to the pointer and then stuff it back into the system variables
;
M12FA: LD E,(HL) ;/get address pointer at (HL) into DE POINTER (POINTER) LIMIT
INC HL ;| perhaps VARS from M12E0
LD D,(HL) ;\
EX (SP),HL ;save VARS and get HL LIMIT (POINTER) POINTER
AND A ;/
SBC HL,DE ;|jump if HL>= (POINTER);
ADD HL,DE ;|(doesn’t neede updataing since we are
EX (SP),HL ;| moving stuff above where it points) POINTER (POINTER) LIMIT
JR NC,M130E ;\
;
;adjust the pointer by adding BC to it, then save it back to the system variables
;
PUSH DE ;save variables area address POINTER (POINTER) (POINTER),LIMIT
EX DE,HL ;HL=(VARS), DE=address (POINTER) POINTER (POINTER),LIMIT
ADD HL,BC ;/adjust the variables pointer (POINTER+) POINTER (POINTER),LIMIT
EX DE,HL ;\by BC POINTER (POINTER+) (POINTER),LIMIT
LD (HL),D ;/
DEC HL ;|
LD (HL),E ;\
INC HL ;point to MSB of just adjusted pointer
POP DE ; POINTER (POINTER) LIMIT
;
;now look at the next pointer and decrement the counter in A that tells us
; how many pointers are left to update. if there are more, loop back again
;
M130E: INC HL ;bump pointer pointer to next pointer
DEC A ;decrement item counter
JR NZ,M12E5 ;back around to update more pointers
EX DE,HL ; (POINTER) POINTER+2 LIMIT
POP DE ; (POINTER) LIMIT AF
POP AF ; (POINTER) LIMIT RETURN ADR
AND A ;
SBC HL,DE ;/find the number of bytes between the fence
LD B,H ;|and where old STKEND pointed and copy it to
LD C,L ;|BC. this sets the size of the memory block to
;\be moved
INC BC ;bump BC
ADD HL,DE ;restore HL
EX DE,HL ;HL again contains the fence, DE contains old STKEND
;
RET ;weebiedun
DUMMYLINE:
DEFW $0000
M1320: EX DE,HL ;point to the previous line
LD DE,DUMMYLINE ;allow an exit by pointing to
; a dummy line number
;******************************************************************
; Module: EDIT
; Routine: GET_LN
; get the line number into DE from (HL)
; ENTRY: HL points to the program line number
; DE points to the previous progam line number
; EXIT: HL points to the low byte of the line number
; DE contains the line number
;******************************************************************
GET_LN:
M1324: LD A,(HL) ;get the high byte of the line number
AND $C0 ;/jump if not a line number
JR NZ,M1320 ;\
LD D,(HL) ;/
INC HL ;|load the line number into DE
LD E,(HL) ;\
RET ;exit
;******************************************************************
; Module: EDIT
; Routine: LCU2
; insert BC items at (STKBOT) (the temporary work space).
; moves the calc stack up BC bytes.
; ENTRY: BC – number of items to insert
; STACK: (tos) new WORKSP pointer, value for BC
; EXIT: DE points to the first byte of of the reserved area
; HL = points two bytes into into the moved memory block
; BC updated from stack
;******************************************************************
LCU2:
M132D: LD HL,(STKBOT) ;get STKBOT
DEC HL ;point to address just below
;calc stack
CALL INSERT ;insert BC items at (HL), updataing system variables
INC HL ;
INC HL ;
POP BC ;/get saved value for WORKSP and put it there
LD (WORKSP),BC ;\
POP BC ;pop number of items to insert
EX DE,HL ;
INC HL ;HL = 2 bytes into the moved memory block
;DE = the first byte of the new block
RET ;
M133F: LD HL,(ELINE) ;point to the edit line
LD (HL),$0D ;drop a newline there
LD (KCUR),HL ;current character pointer
INC HL ;/put sentinal byte in ELINE buffer
LD (HL),$80 ;\
INC HL ;/initialize the workspace pointer
LD (WORKSP),HL ;\
;******************************************************************
; Module: EDIT
; Routine: X_CALC
;******************************************************************
X_CALC:
M134E: LD HL,(WORKSP)
LD (STKBOT),HL
;******************************************************************
; Module: EDIT
; Routine: RESET
; reset the floating point stack and floating point memory pointers
; EXIT with STKBOT in HL
;******************************************************************
RESET:
M1354: LD HL,(STKBOT) ;/collapse the fp stack
LD (STKEND),HL ;\
PUSH HL ;save STKBOT
LD HL,MEMBOT ;/
LD (MEM),HL ;\reset fp memory pointer
POP HL ;restore STKBOT
RET ;done
;******************************************************************
; Module: EDIT
; Routine: X_T_HL
;******************************************************************
X_T_HL:
LD DE,(ELINE)
JP M174D
;******************************************************************
; Module: EDIT
; Routine: SEARCH
; searches for an item in C starting at (HL). terminates when item
; found or when 0 found.
; on exit HL points one past the item if found or to the 0 byte if
; 0 was found. CF=0 if zero found, else CF=1 if item in C was found
;******************************************************************
M136A: INC HL
SEARCH:
M136B: LD A,(HL) ;get byte
AND A ;test for zero
RET Z ;return if zero (CF reset)
CP C ;compare with C
INC HL ;bump the pointer
JR NZ,M136A ;dint find it, so back around
SCF ;found the byte, so set C
RET ;done
;******************************************************************
; Module: EDIT
; Routine: SRCHSC
; search the system configuration table for the item in C
;******************************************************************
SRCHSC:
M1374: LD HL,(SYSCON) ;get SYSCON
LD DE,$000C ;/step past the AROS and LROS
ADD HL,DE ;\entries
M137B: LD A,(HL) ;get syscon table item
CP $80 ;end of table?
JR Z,M139A
; desired entry
INC HL ;/
INC HL ;\
CP $01 ;/bank not in use, so check
JR NZ,M138A
LD A,(HL) ;/check for bank signature,
CP C ;|if found exit routine
JR Z,M139C
M138A: PUSH HL ;save pointer
EX DE,HL ;/
LD DE,$0018 ;|skip to next syscon table
ADD HL,DE ;\entry+2
EX DE,HL ;DE points to new entry
POP HL ;get old pointer
PUSH DE ;save new pointer
LD DE,$0016 ;/make old pointer point
ADD HL,DE ;\to new syscon entry
POP DE ;restore DE
JR M137B
M139A: AND A ;adjust flags
RET ;exit
;found the item
M139C: DEC HL ;go back to point to ??
SCF ;set the carry
RET ;exit
;******************************************************************
; Module: CHANS
; Routine: CLOSE
;******************************************************************
CLOSE: CALL M140F ;get the stream whose number is on the
; top of the calculator stack
LD A,B ;/
OR C ;|return if the stream routine
RET Z ;\address is zero (invalid stream)
CALL M13BE
;******************************************************************
; Module: CHANS
; Routine: RSTSTR
; reset stream?
;******************************************************************
RSTSTR:
M13A8: LD BC,$0000 ;
LD DE,$A3E2 ;
EX DE,HL ;
ADD HL,DE ;
JR C,M13B9 ;
LD BC,$11CF ;address of RD_CH
ADD HL,BC ;
LD C,(HL) ;
INC HL ;
LD B,(HL) ;
M13B9: EX DE,HL ;
LD (HL),C ;
INC HL ;
LD (HL),B ;
RET ;
;******************************************************************
; Module: CHANS
; Routine: CLCHAN
; close a channel
; ENTER: HL points to stream address pointer
; BC is the address of the stream routine
;******************************************************************
CLCHAN:
M13BE: PUSH HL ;save stream address pointer
LD A,B ;/jump if the stream is negative
CP $80 ;|
JR NC,M13D8 ;\
LD HL,(CHANS) ;get the address of the CHANS area
ADD HL,BC ;add
INC HL ;
INC HL ;
INC HL ;
LD C,(HL) ;get the stream type "K’,’S", or "P"
EX DE,HL ;save the pointer in HL
LD HL,CSTRTA ;point to the close stream table
CALL SEARCH ;search for the stream type
LD C,(HL) ;/get the offset and add it to
LD B,$00 ;|HL to give the address of the
ADD HL,BC ;\close stream routine
JP (HL) ;close the stream
M13D8: SUB $80 ;normalize the number
LD B,A ;
LD HL,(SYSCON)
ADD HL,BC
LD A,(HL)
CP $00
RET Z
CP $80
RET Z
INC HL
LD B,(HL)
INC HL
INC HL
INC HL
INC HL
LD E,(HL)
INC HL
LD D,(HL)
LD H,D
LD L,E
LD A,(STRMN)
LD E,A
LD D,$00
PUSH DE
PUSH HL
PUSH BC ;C=horiz sel,B=bank
LD BC,$0002 ;/PARAM_OUT
PUSH BC ;\
LD BC,$0000 ;no PARAM_IN
;******************************************************************
; Module: CHANS
; Routine: CLEL
; when entered the caller MUST have set up the stack with all
; but the PARAM_IN parameter for a CALL_BANK. BC must contain
; the PARAM_IN parameter
;******************************************************************
CLEL: PUSH BC ;push PARAM_IN parameter
CALL M65D0 ;CALL_BANK
POP HL
RET
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; close stream table
;
CSTRTA: DEFM "K"
DEFB CLOSTR-ASMPC
DEFM "S"
DEFB CLOSTR-ASMPC
DEFM "P"
DEFB CLOSTR-ASMPC
CLOSTR: POP HL
RET
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
M140F: CALL INS_U1 ;convert the top of the calculator stack
; to a byte in A. if the number is greater
; than 255, we won’t return here
LD (STRMN),A ;update current stream number
CP $10 ;/jump if stream number is valid,
JR C,M141B ;\
M1419: RST $08 ;error: INVALID STREAM
DEFB $17 ;
M141B: ADD A,$03 ;first 3 streams cannot be messed with
RLCA ;/
LD HL,STRMS ;|point to entry in streams table
LD C,A ;|
LD B,$00 ;|
ADD HL,BC ;\
LD C,(HL) ;/get the address for the
INC HL ;| stream routine to BC
LD B,(HL) ;\
DEC HL ;restore HL
RET ;
;******************************************************************
; Module: CHANS
; Routine: OPEN
; enter with ??? in A
;******************************************************************
OPEN: CP ‘,’ ;/jump if current character is a comma
JR Z,M1433
CALL ENDQ ;will return if interpreting, else
; will exit via ENDTEM
JR M143E
M1433: CALL INTPTQ ;/jump if interpreting
JR NZ,M143E ;\
CALL SKIPIT ;skip to the end of a statement
CALL ENDQ ;
M143E: RST $28 ;calc entry
DEFB $01 ;SWAP ;
DEFB $38 ;QUIT ;
CALL M140F ;jump to error
LD A,B ;
OR C ;
JR Z,M145E
EX DE,HL ;
LD HL,(CHANS) ;
ADD HL,BC ;
INC HL ;
INC HL ;
INC HL ;
LD A,(HL) ;
EX DE,HL ;
CP $4B ;
JR Z,M145E
CP $53 ;
JR Z,M145E
CP $50 ;
JR NZ,M1419
M145E: CALL M1465 ;
LD (HL),E ;
INC HL ;
LD (HL),D ;
RET
;******************************************************************
; Module: CHANS
; Routine: OPCHAN
;******************************************************************
OPCHAN:
M1465: PUSH HL
CALL PGPSTR ;get a string descriptor
DEC BC ;/
LD A,B ;|jump if the string length
OR C ;| is one
JR Z,M1472 ;\
M146E: RST $08 ;/error: INVALID IO DEVICE
DEFB $12 ;\
M1470: RST $08 ;/error: INVALID SAVE NAME
DEFB $0E ;\no name or name more than 10 chars
M1472: INC BC ;restore the channel designator string length
PUSH BC ;briefly save it
LD A,(DE) ;get the channel designator character
AND $DF ;force upper case
LD C,A ;/find the channel type in the channel open
LD HL,OPTAB ;|table
CALL SEARCH ;\
JR NC,M1486 ;not in the table to jump to INVALID IO DEVICE
LD C,(HL) ;/
LD B,$00 ;|form the address of the needed open routine
ADD HL,BC ;\
POP BC ;restore the string length
JP (HL) ;jump to the open routine
M1486: JR M146E
M1488: CALL M1374
JR NC,M146E
POP BC
DEC BC
LD A,B
OR C
JR NZ,M146E
PUSH DE
EX DE,HL
CALL M25B9
EX DE,HL
LD B,(HL) ;get bank
LD C,$88 ;all chunks but chunk 0 assigned to new bank
INC HL
INC HL
LD E,(HL)
INC HL
LD D,(HL)
LD H,D
LD L,E
LD A,(STRMN)
LD E,A
LD D,$00
PUSH DE ;
PUSH HL ;call address
PUSH BC ;B=horiz sel, C=bank
LD HL,(STKEND) ;/
LD C,(HL) ;\get required number of output parameters
DEC HL ;trash the parameter
LD (STKEND),HL ;resave STKEND
LD B,$00 ;
INC BC ;/bump output params count by 2
INC BC ;\
PUSH BC ;push output parameters
LD BC,$0000 ;/
PUSH BC ;\no input parameters
CALL M65D0 ;CALL_BANK
POP DE
LD A,D
ADD A,$80
LD D,A
POP HL
RET
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;Table for opening streams
OPTAB: DEFM "K"
DEFB OPENK-ASMPC
DEFM "S"
DEFB OPENS-ASMPC
DEFM "P"
DEFB OPENP-ASMPC
DEFB 0
OPENK: LD E,1
JR M14DB
OPENS: LD E,6
JR M14DB
OPENP: LD E,10H
M14DB: DEC BC
LD A,B
OR C
JP NZ,M1470
LD D,A
POP HL
RET
;******************************************************************
; Module: TSLIST
; Routine: TSLIST
;******************************************************************
TSLIST:
M14E1: LD (LISTSP),SP ;save the stack pointer for the listing
LD (IY+OTVFLAG),$10 ;force output automatic listing
;clear the upper screen
CALL CLS ;clear the upper screen
;clear the lower screen
SET LHS,(IY+OTVFLAG) ;force printing to lower half of screen
LD B,(IY+ODFSZ) ;get lower screen size
CALL CLS_B ;clear the lower screen for B lines
RES LHS,(IY+OTVFLAG) ;release writing to the lower screen
SET ALOS,(IY+OFLAGS2) ;force auto listing on screen
LD HL,(EPPC) ;get the current listing line number
LD DE,(STOP) ;get the line listed at top of screen
AND A ;/
SBC HL,DE ;|CP HL,DE
ADD HL,DE ;\
JR C,M152D ;jump if top line is greater than
; the current listing line
PUSH DE ;save the top line
CALL FIND_L ;find the current line
LD DE,$02C0 ;
EX DE,HL ;
SBC HL,DE ;
EX (SP),HL ;
CALL FIND_L ;
POP BC
M151A: PUSH BC
CALL RECLEN
POP BC
ADD HL,BC
JR C,M1530
EX DE,HL
LD D,(HL)
INC HL
LD E,(HL)
DEC HL
LD (STOP),DE
JR M151A
M152D: LD (STOP),HL
M1530: LD HL,(STOP)
CALL FIND_L
JR Z,M1539
EX DE,HL
M1539: CALL M157F
RES 4,(IY+OTVFLAG) ;TVFLAG
RET
;******************************************************************
; Module: LIST
; Routine: K_LLST
;******************************************************************
K_LLST:
LD A,$03
JR M1547
;******************************************************************
; Module: LIST
; Routine: K_LIST
;******************************************************************
K_LIST:
LD A,$02 ;stream 2 (print/list)
M1547: LD (IY+OTVFLAG),00 ; printing to upper half of screen
; not outputting line for edit or number for string
; no keyboard echo
; no automatic listing
; do not clear lower half screen when key pressed
CALL INTPTQ ;/select stream 2 if interpreting
CALL NZ,SELECT ;\
RST $18 ;get current character
CALL STRITO ;update the current stream for "bank" devices
JR C,M156B ;jump if not valid instruction
RST $18 ;get current character
CP ‘;’ ;/
JR Z,M1560 ;\
CP ‘,’ ;
JR NZ,M1566 ;
M1560: RST $20 ;get next char
CALL TEM6 ;get the first line to be listed
JR M156E ;
M1566: CALL STKFP0 ;stack fp zero if not syntax checking
JR M156E ;
M156B: CALL M1C49 ;list from line "zero"
M156E: CALL ENDQ ;we will return here if executing
CALL FIX_U ;get the first line number to be listed
LD A,B ;/force the number to be a valid
AND $3F ;\ line number
LD H,A ;/load the line number into HL
LD L,C ;\
LD (EPPC),HL ;update the current line number in the listing
CALL FIND_L ;
M157F: LD E,$01 ;
M1581: CALL M15A1 ;
RST $10 ;
BIT 4,(IY+OTVFLAG) ;TVFLAG
JR Z,M1581
LD A,(DFSZ)
SUB (IY+OSPOSNLIN) ;SPOSNLIN
JR NZ,M1581
XOR E
RET Z
PUSH HL
PUSH DE
LD HL,STOP
CALL NEXT_L
POP DE
POP HL
JR M1581
;******************************************************************
; Module: LIST
; Routine: PUT_SR
;******************************************************************
PUT_SR:
M15A1: LD BC,(EPPC)
CALL M16E8
LD D,$3E
JR Z,M15B1
;******************************************************************
; Module: LIST
; Routine: LPO
;******************************************************************
LPO:
M15AC: LD DE,$0000
RL E
M15B1: LD (IY+OBREG),E ;BREG
LD A,(HL)
CP $40
POP BC
RET NC
PUSH BC
CALL M1795
INC HL
INC HL
INC HL
RES 0,(IY+OFLAGS) ;FLAGS
LD A,D
AND A
JR Z,M15CD
RST $10
;******************************************************************
; Module: LIST
; Routine: PUT
;******************************************************************
PUT:
M15C9: SET SPC,(IY+OFLAGS) ;force space before tokens
M15CD: PUSH DE ;
EX DE,HL ;
RES L_STR,(IY+OFLAGS2) ;
LD HL,FLAGS ;/force "K" mode at current
RES LMODE1,(HL) ;\ character
BIT INPLN,(IY+OFLAGX) ;/jump if expecting program
JR Z,M15E0 ;\ line
SET LMODE1,(HL) ;force "L" mode at current
;character
M15E0: LD HL,(XPTR) ;get pointer to 1st char that in not syntactically
; ok
AND A ;/SUB HL,DE
SBC HL,DE ;\
JR NZ,M15ED ;
LD A,$3F ;
CALL M160D ;
M15ED: CALL M162D ;
EX DE,HL ;
LD A,(HL) ;
CALL M1602 ;
INC HL ;
CP $0D ;
JR Z,M1600 ;
EX DE,HL ;
CALL M1683 ;
JR M15E0 ;
M1600: POP DE ;
RET ;
M1602: CP $0E ;
RET NZ ;
INC HL ;
INC HL ;
INC HL ;
INC HL ;
INC HL ;
INC HL ;
LD A,(HL) ;
RET ;
;******************************************************************
; Module: LIST
; Routine: FLASHA
;******************************************************************
FLASHA:
M160D: EXX
LD HL,(ATTRT)
PUSH HL
RES 7,H
SET 7,L
LD (ATTRT),HL
LD HL,PFLAG
LD D,(HL)
PUSH DE
LD (HL),$00
CALL SENDTV
POP HL
LD (IY+OPFLAG),H ;PFLAG
POP HL
LD (ATTRT),HL
EXX
RET
;******************************************************************
; Module: LIST
; Routine: PR_CUR
;******************************************************************
PR_CUR:
M162D: LD HL,(KCUR)
AND A
SBC HL,DE
RET NZ
LD A,(MODE)
RLC A
JR Z,M163F
ADD A,$43
JR M1655
M163F: LD HL,FLAGS
RES 3,(HL)
LD A,$4B
BIT 2,(HL)
JR Z,M1655
SET 3,(HL)
INC A
BIT 3,(IY+OFLAGS2) ;FLAGS2
JR Z,M1655
LD A,$43
M1655: PUSH DE
CALL M160D
POP DE
RET
;******************************************************************
; Module: LIST
; Routine: NEXT_L
; find the next line number
; ENTRY: HL: pointer to the line number to be founc
; EXIT:
;******************************************************************
NEXT_L:
M165B: LD E,(HL) ;/get the number of the line
INC HL ;| to be found
LD D,(HL) ;\
PUSH HL ;save the pointer
EX DE,HL ;HL now contains the line number to be found
INC HL ;look for the next line number
CALL FIND_L ;find the line number in BC at (HL)
CALL GET_LN ;get the line number into DE
POP HL ;restore the program line number
;******************************************************************
; Module: LIST
; Routine: DE_HL
;
; ENTRY: HL points to the program line line number location
; DE contains the line number
; EXIT: HL points to the low byte of the program line number
; DE contains the line number
;******************************************************************
DE_HL:
M1668: BIT INPLN,(IY+OFLAGX) ;/return if looking for input rather than
RET NZ ;\a program line
LD (HL),D ;/store the line number at
DEC HL ;| its location
LD (HL),E ;\
RET ;
M1671: LD A,E
AND A
RET M
JR M1683
M1676: XOR A
M1677: ADD HL,BC
INC A
JR C,M1677
SBC HL,BC
DEC A
JR Z,M1671
JP M11EA
M1683: RES 4,(IY+OFLAGS) ;
BIT 2,(IY+OFLAGS) ;
JR Z,M1691
SET 4,(IY+OFLAGS) ;
M1691: CALL DIGITQ
JR NC,M16D4
CP $0C
JR Z,M16D0
CP $21
JR C,M16D4
RES 2,(IY+OFLAGS) ;
CP $7B
JR NZ,M16AC
BIT 4,(IY+OFLAGS) ;
JR Z,M16D4
M16AC: CP $CB
JR Z,M16D4
CP $3A
JR NZ,M16C2
BIT 5,(IY+OFLAGX) ;/jump if expecting input rather than
JR NZ,M16D0 ;\ program line
BIT L_STR,(IY+OFLAGS2) ;/jump if not inside of a string
JR Z,M16D4 ;\
JR M16D0
M16C2: CP $22
JR NZ,M16D0
PUSH AF
LD A,(FLAGS2)
XOR $04
LD (FLAGS2),A
POP AF
M16D0: SET 2,(IY+OFLAGS) ;FLAGS
M16D4: RST $10
RET
;******************************************************************
; Module: LIST
; Routine: FIND_L
; find the position of the line whose number is in HL.
; This routine returns with HL pointing to the line
; whose number is greater than or equal to the line number in BC
; ENTRY: HL contains the line number to be found
; EXIT: HL points to the line whose number is greater than or equal
; to the requested line number
; DE points to the previous line
; BC contains the line number
;******************************************************************
FIND_L:
M16D6: PUSH HL ;save the line number
LD HL,(PROG) ;point to the start of the program text
LD D,H ;/copy it to DE
LD E,L ;\
M16DC: POP BC ;pop the line number
CALL CP_BC ;compare the line number in BC to (HL)
RET NC ;return if the current line number is
; greater than or equal to the number
; in BC
PUSH BC ;save the desired line number
CALL RECLEN ;get the length of the record
EX DE,HL ;HL now points to the next line
;DE points to the previous line
JR M16DC ;back around for the next line
;******************************************************************
; Module: LIST
; Routine: CP_BC
; compare the line number at (HL) with the number in BC
; EXIT: ZF set if a match
; CF set if BC < (HL)
;******************************************************************
CP_BC:
M16E8: LD A,(HL) ;/compare the first byte of the
CP B ;\line number to the desired line number
RET NZ ;return if no match
INC HL ;/get the next byte of the line number
LD A,(HL) ;\
DEC HL ;restore the pointer
CP C ;compare to the low byte of the requested
; number
RET ;return
;******************************************************************
; Module: LIST
; Routine: SUBLIN
;******************************************************************
SUBLIN:
INC HL
INC HL
INC HL
;******************************************************************
; Module: LIST
; Routine: SUBLIN1
; find the sub-line whose value is in D
; ENTRY: D has the subline number (starting with 1)
;******************************************************************
SUBLIN1:
M16F3: LD (CHADD),HL ;
LD C,$00 ;
M16F8: DEC D ;/return if the first sub-line –
RET Z ;\ we are already there
RST $20 ;get next char
CP E ;/
JR NZ,M1702 ;\
AND A
RET
M1700: INC HL
LD A,(HL)
M1702: CALL M1602
LD (CHADD),HL
CP $22 ;/not a quote, so continue
JR NZ,M170D ;\
DEC C
M170D: CP $3A
JR Z,M1715
CP $CB
JR NZ,M1719
M1715: BIT 0,C
JR Z,M16F8
M1719: CP $0D
JR NZ,M1700
DEC D
SCF
RET
;******************************************************************
; Module: LIST
; Routine: RECLEN
; find the next BASIC line or variable starting at HL
; ENTRY: HL = point from which to start looking
; EXIT: HL same as entry
; DE = address of next record
; BC = length record
;******************************************************************
RECLEN:
M1720: PUSH HL ;save the character pointer
LD A,(HL) ;get the next byte
CP $40 ;/jump if this is a BASIC line
JR C,M173D ;\(line numbers are less than $40)
BIT 5,A ;/jump if and array or a string
JR Z,M173E ;\
ADD A,A ;/jump if single letter or
JP M ,M172F ;\FOR-NEXT
CCF ;
M172F: LD BC,$0005 ;assume single letter variable name
JR NC,M1736 ;jump if indeed single letter
LD C,$12 ;length of FOR-NEXT variable
M1736: RLA ;/
INC HL ;|gobble characters until bit 7
LD A,(HL) ;|is set (name of FOR-NEXT or last
JR NC,M1736 ;\letter of multi-letter name)
JR M1743 ;got all of name, so move on to
; adjust memory pointer
;handle a BASIC line
M173D: INC HL ;bump for a BASIC line
M173E: INC HL ;2nd bump for BASIC line or bump to
; access length for number arrays or
; string entities
LD C,(HL) ;/
INC HL ;|get the length into BC
LD B,(HL) ;\
INC HL ;point to the next byte
M1743: ADD HL,BC ;form the address for the next record
POP DE ;restore the character pointer
;put the difference between HL and DE into BC
M1745: AND A ;
SBC HL,DE ;
LD B,H ;
LD C,L ;
ADD HL,DE ;
EX DE,HL ;
RET ;
;******************************************************************
; Module: LIST
; Routine: DEL_DE
; delete the bytes between HL and DE
;******************************************************************
DEL_DE:
M174D: CALL M1745
;******************************************************************
; Module: LIST
; Routine: DELREC
; delete BC bytes from memory. move memory and adjust system
; variables.
; ENTER HL = start address of block to delete
; BC = number of bytes to delete
;******************************************************************
DELREC:
M1750: PUSH BC ;save BC
LD A,B ;/
CPL ;|
LD B,A ;|form the 2’s complement
LD A,C ;|of BC
CPL ;|
LD C,A ;|
INC BC ;\
PUSH BC ;save BC
CALL REMGSZ ;adjust system variable pointers down BC bytes
EX (SP),HL ;get BC back and save HL
ADD HL,BC ;
LD C,L ;
LD B,H ;
POP DE ;
POP HL ;
ADD HL,DE ;
PUSH DE ;
LDIR ;
POP HL ;
RET ;
;******************************************************************
; Module: LIST
; Routine: LINNG
;******************************************************************
LINNG:
M1768: LD HL,(ELINE)
DEC HL
LD (CHADD),HL
RST $20 ;get next char
LD HL,MEMBOT
LD (STKEND),HL
CALL ININT
CALL FP2BC
JR C,M1782
LD HL,$D8F0
ADD HL,BC
M1782: JP C ,M1BED ;error – BAD BASIC
JP RESET
;******************************************************************
; Module: LIST
; Routine: PUT_BC
;******************************************************************
PUT_BC:
M1788: PUSH DE
PUSH HL
XOR A
BIT 7,B
JR NZ,M17AF
LD H,B
LD L,C
LD E,$FF
JR M179D
;******************************************************************
; Module: LIST
; Routine: PUT_LN
;******************************************************************
PUT_LN:
M1795: PUSH DE
LD D,(HL)
INC HL
LD E,(HL)
PUSH HL
EX DE,HL
LD E,$20
M179D: LD BC,$FC18
CALL M1676
LD BC,$FF9C
CALL M1676
LD C,$F6
CALL M1676
LD A,L
M17AF: CALL M11EA
POP HL
POP DE
RET
M17B5: PUSH BC
LD BC,$FF00
CALL M6499
POP BC
CALL INSERT
LD HL,(SYSCON)
LD DE,$0004
ADD HL,DE
LD A,(HL)
LD B,$00
LD C,A
CALL M6499
RET
;******************************************************************
; Module: AROS
; Routine: GETAL
; find the line number in BC in the AROS cartridge
; ENTRY: BC contains the line number
; EXIT: HL points to the first byte of the line number
;******************************************************************
GETAL:
M17CF: LD HL,(SYSCON) ;/get the address of the
INC HL ;| code in the AROS
INC HL ;\ cartridge
LD E,(HL) ;/
INC HL ;|DE now points to the code
LD D,(HL) ;\ in the cart
EX DE,HL ;… make that HL
;
;search for the AROS line number
;
M17D8: LD A,(HL) ;/we didn’t find it so
CP B ;| move on
JR NZ,M17E0 ;\
INC HL ;bump the pointer
LD A,(HL) ;get the next byte
DEC HL ;point back to where we were
CP C ;
M17E0: RET NC ;return if we have passed the required
; line number – that exact number does not
; exist, but we are past it
INC HL ;/get past the line number
INC HL ;\
LD E,(HL) ;/
INC HL ;|DE now has the line length
LD D,(HL) ;\
INC HL ;HL points to the first byte of
; code in the line
ADD HL,DE ;HL now points to the start of the next
; line
JR M17D8 ;back around for the next line
;******************************************************************
; Module: AROS
; Routine: AR_LN
;******************************************************************
AR_LN:
M17EA: PUSH HL ;save the line pointer
LD HL,(SYSCON) ;/
LD DE,$0004 ;|get the address of the
ADD HL,DE ;\
LD A,(HL) ;/get the chunk map
LD C,A ;\pass to C
LD B,$00 ;specify dock bank
CALL BANK_ENABLE ;
POP BC ;
CALL M17CF ;
JR M1818 ;
;******************************************************************
; Module: AROS
; Routine: AR_NXT
;******************************************************************
AR_NXT:
M17FF: CALL INTPTQ ;/return if syntax checking
RET Z ;\
LD HL,(SYSCON) ;
LD DE,$0004 ;
ADD HL,DE ;
LD A,(HL) ;/get the chunk map
LD C,A ;\pass to C
LD B,$00 ;dock bank
CALL BANK_ENABLE ;
LD HL,(NXTLIN) ;
LD (IY+ONSPPC),00 ;NSPPC
M1818: LD A,(HL) ;
AND $C0 ;
JR Z,M1824 ;
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
RET ;
M1824: LD D,(HL) ;
INC HL ;
LD E,(HL) ;
LD (PPC),DE ;
INC HL ;
LD E,(HL) ;
INC HL ;
LD D,(HL) ;
INC HL ;
PUSH HL ;
ADD HL,DE ;
LD (NXTLIN),HL ;
PUSH DE ;
LD HL,(CHANS) ;
DEC HL ;
LD DE,(ARSBUF) ;
AND A ;
SBC HL,DE ;
LD DE,$00D0 ;
EX DE,HL ;
AND A ;
SBC HL,DE ;
JR NC,M186E ;
LD A,L ;
CPL ;
LD C,A ;
LD A,H ;
CPL ;
LD B,A ;
INC BC ;
INC BC ;
LD HL,(ARSBUF) ;
PUSH BC ;
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
POP BC ;
CALL DELREC ;
LD HL,(SYSCON) ;
LD DE,$0004 ;
ADD HL,DE ;
LD A,(HL) ;get the chunk map
LD B,$00 ;dock bank
LD C,A ;chunk map to C
CALL BANK_ENABLE ;
M186E: POP HL ;
PUSH HL ;
LD DE,$00CF ;
DEC HL ;
AND A ;
SBC HL,DE ;
JR C,M1883 ;
LD C,L ;
LD B,H ;
INC BC ;
LD HL,(CHANS) ;
DEC HL ;
CALL M17B5 ;
M1883: POP BC ;
POP DE ;
LD HL,$00FF ;
PUSH HL ;
PUSH DE ;
LD HL,(ARSBUF) ;
LD (HL),$0D ;
LD (CHADD),HL ;
INC HL ;
PUSH HL ;
PUSH BC ;
LD BC,$0001 ;
PUSH BC ;
CALL M6722 ;
LD A,(IY+ONSPPC) ;NSPPC
LD (IY+ONSPPC),$FF ;NSPPC
CP $01 ;
ADC A,$00 ;
DEC A ;
PUSH AF ;
LD (SUBPPC),A ;
LD (IY+OERRNR),$FF ;ERRNR
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
POP AF ;
JP Z ,LS4 ;
INC A ;
LD D,A ;
LD E,$00 ;
CALL SUBLIN1 ;
JP Z ,M1B4A ;
RST $08 ;/error: STATEMENT LOST
DEFB $16 ;\
;******************************************************************
; Module: AROS
; Routine: AROS
;******************************************************************
AROS:
LD HL,ARSFLG
LD (HL),$80
LD BC,$00D0
LD HL,$6840
DEC HL
CALL INSERT
LD HL,$6840
LD (ARSBUF),HL
LD HL,(SYSCON)
LD DE,$0006
ADD HL,DE
LD C,(HL)
INC HL
LD B,(HL)
LD HL,$6840
DEC HL
CALL INSERT
LD HL,(SYSCON)
LD DE,$0004
ADD HL,DE
LD A,(HL) ;get chunk map
LD B,$00 ;dock bank
LD C,A ;chunk map to C
CALL BANK_ENABLE ;
LD HL,(SYSCON)
INC HL
INC HL
LD E,(HL)
INC HL
LD D,(HL)
EX DE,HL
LD D,(HL)
INC HL
LD E,(HL)
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
LD HL,(SYSCON)
LD BC,$0005
ADD HL,BC
LD A,(HL)
CP $00
JR Z,M1941
LD (NEWPPC),DE
CALL M08A6
LD HL,(SYSCON)
INC HL
INC HL
LD E,(HL)
INC HL
LD D,(HL)
EX DE,HL
DEC HL
LD (DATADD),HL
LD (IY+OERRNR),$FF ;ERRNR
SET 7,(IY+OFLAGS) ;FLAGS
LD (IY+ONSPPC),00 ;NSPPC
LD HL,$0E8D
PUSH HL
LD HL,$1AB9
EI
JP (HL) ;
M1941: EI
JP M0E2F
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
KEWTBL: DEFB PADEFN-ASMPC
DEFB PACAT-ASMPC
DEFB PAFORM-ASMPC
DEFB PAMOVE-ASMPC
DEFB PAERA-ASMPC
DEFB PAOPEN-ASMPC
DEFB PACLOS-ASMPC
DEFB PAMERG-ASMPC
DEFB PAVERI-ASMPC
DEFB PABEEP-ASMPC
DEFB PACIRC-ASMPC
DEFB PAINK-ASMPC
DEFB PAPAPE-ASMPC
DEFB PAFLAS-ASMPC
DEFB PABRIG-ASMPC
DEFB PAINVE-ASMPC
DEFB PAOVER-ASMPC
DEFB PAOUT-ASMPC
DEFB PALPRI-ASMPC
DEFB PALLIS-ASMPC
DEFB PASTOP-ASMPC
DEFB PAREAD-ASMPC
DEFB PADATA-ASMPC
DEFB PAREST-ASMPC
DEFB PANEW-ASMPC
DEFB PABORD-ASMPC
DEFB PACONT-ASMPC
DEFB PADIM-ASMPC
DEFB PAREM-ASMPC
DEFB PAFOR-ASMPC
DEFB PAGOTO-ASMPC
DEFB PAGOSU-ASMPC
DEFB PAINPU-ASMPC
DEFB PALOAD-ASMPC
DEFB PALIST-ASMPC
DEFB PALET-ASMPC
DEFB PAPAUS-ASMPC
DEFB PANEXT-ASMPC
DEFB PAPOKE-ASMPC
DEFB PAPRIN-ASMPC
DEFB PAPLOT-ASMPC
DEFB PARUN-ASMPC
DEFB PASAVE-ASMPC
DEFB PARAND-ASMPC
DEFB PAIF-ASMPC
DEFB PACLS-ASMPC
DEFB PADRAW-ASMPC
DEFB PACLEA-ASMPC
DEFB PARETU-ASMPC
DEFB PACOPY-ASMPC
KEWTBL2:
DEFB PADEL-ASMPC ;DELETE
DEFB PAONERR-ASMPC ;ONERR
DEFB PARESET-ASMPC ;RESET
DEFB PASND-ASMPC ;SOUND
PALET: DEFB 1 ;class 1
DEFM "=" ;3D
DEFB 2 ;class 2
PAGOTO: DEFB 6 ;class 6
DEFB 0 ;class 0
DEFW M1EF1 ;
PAIF: DEFB 6 ;class 6
DEFB $CB ;"THEN"
DEFB 5 ;class 5
DEFW TSIF ;
PAGOSU: DEFB 6 ;class 6
DEFB 0 ;class 0
DEFW GO_SUB ;
PASTOP: DEFB 0 ;class 0
DEFW TSSTOP ;
PARETU: DEFB 0 ;class 0
DEFW RETURN ;
PAFOR: DEFB 4 ;class 4
DEFM "=" ;
DEFB 6 ;class 6
DEFB $CC ;"TO"
DEFB 6 ;class 6
DEFB 5 ;class 5
DEFW FOR ;
PANEXT: DEFB 4 ;class 4
DEFB 0 ;class 0
DEFW NEXT ;
PAPRIN: DEFB 5 ;class 5
DEFW K_PRIN ;
PAINPU: DEFB 5 ;class 5
DEFW INPUT ;
PADIM: DEFB 5 ;class 5
DEFW DIM ;
PAREM: DEFB 5 ;class 5
DEFW M1B00 ;
PANEW: DEFB 0 ;class 0
DEFW K_NEW ;1D0D
PARUN: DEFB 3 ;class 3
DEFW RUN ;
PALIST: DEFB 5 ;class 5
DEFW K_LIST ;
PAPOKE: DEFB 8 ;class 8
DEFB 0 ;class 0
DEFW POKE ;
PARAND: DEFB 3 ;class 3
DEFW RAND ;
PACONT: DEFB 0 ;class 0
DEFW CONT ;
PACLEA: DEFB 3 ;class 3
DEFW CLEAR ;
PACLS: DEFB 0 ;class 0
DEFW K_CLS ;
PAPLOT: DEFB 9 ;class 9
DEFB 0 ;class 0
DEFW PLOT ;
PAPAUS: DEFB 6 ;class 6
DEFB 0 ;class 0
DEFW PAUSE ;
PAREAD: DEFB 5 ;class 5
DEFW READ ;
PADATA: DEFB 5 ;class 5
DEFW DATA ;
PAREST: DEFB 3 ;class 3
DEFW M1E9D ;
PADRAW: DEFB 9 ;class 9
DEFB 5 ;class 5
DEFW DRAW ;
PACOPY: DEFB 0 ;class 0
DEFW K_DUMP ;
PALPRI: DEFB 5 ;class 5
DEFW K_LPR ;
PALLIS: DEFB 5 ;class 5
DEFW K_LLST ;
PASAVE: DEFB 11 ;class B
PALOAD: DEFB 11 ;class B
PAVERI: DEFB 11 ;class B
PAMERG: DEFB 11 ;class B
PABEEP: DEFB 8 ;class 8
DEFB 0 ;class 0
DEFW BEEP ;
PACIRC: DEFB 9 ;class 9
DEFB 5 ;class 5
DEFW CIRCLE ;
PAINK: DEFB 7 ;class 7
PAPAPE: DEFB 7 ;class 7
PAFLAS: DEFB 7 ;class 7
PABRIG: DEFB 7 ;class 7
PAINVE: DEFB 7 ;class 7
PAOVER: DEFB 7 ;class 7
PAOUT: DEFB 8 ;class 8
DEFB 0 ;class 0
DEFW K_OUTPUT ;
PABORD: DEFB 6 ;class 6
DEFB 0 ;class 0
DEFW M243E ;
PADEFN: DEFB 5 ;class 5
DEFW DEF ;
PAOPEN: DEFB 6 ;class 6
DEFB ‘,’ ;
DEFB 10 ;class 10
DEFB 05 ;class 5
DEFW OPEN ;
PACLOS: DEFB 6 ;class 6
DEFB 0 ;class 0
DEFW CLOSE ;
PAFORM: DEFB 10 ;class 10
DEFB ‘,’ ;
DEFB 05 ;class 5
DEFW FORMAT ;CC25
PAMOVE: DEFB $0A ;class A
DEFB ‘,’ ;
DEFB $05 ;class 5
DEFW MOVE ;D025
PAERA: DEFB $0A ;class A
DEFB ‘,’ ;
DEFB $05 ;class 5
DEFW ERASE ;
PACAT: DEFB 10 ;class 10
DEFB ‘,’ ;
DEFB $05 ;class 5
DEFW CAT ;
PADEL: DEFB $05 ;class 5
DEFW $20D1 ;
PAONERR:
DEFB $05 ;class 5
DEFW $2080 ;
PARESET:
DEFB $05 ;class 5
DEFW RSET ;
PASND: DEFB $05 ;class 5
DEFW SOUND ;
;******************************************************************
; Module: SYNTAX
; Routine: SYNTAX
;******************************************************************
SYNTAX:
M1A27: RES 7,(IY+OFLAGS) ;FLAGS
CALL M1768
LD A,B
OR C
JR Z,M1A3A
LD A,(ARSFLG)
BIT 7,A
JP NZ,M1BED ;error – BAD BASIC
M1A3A: XOR A
LD (SUBPPC),A
DEC A
LD (ERRNR),A
JR M1A45
;******************************************************************
; Module: SYNTAX
; Routine: LS4
;******************************************************************
M1A44:
LS4: RST $20 ;get next char to A
M1A45: CALL X_CALC ;reset pointers to STKBOT and STKEND to (WORKSP)
M1A48: INC (IY+OSUBPPC) ;/bump the substatement and jump if too many
JP M ,M1BED ;\error – BAD BASIC
RST $18 ;get current character
LD B,$00 ;set up B for later
CP $0D ;/jump if the end of a line
JP Z ,M1B09 ;\
CP ‘:’ ;/jump if the end of a sub line
JR Z,LS4 ;\
LD HL,$1AB9 ;/this address leads to
PUSH HL ;\EXECUTE
LD C,A ;save the present character
RST $20 ;gobble the next char (point to the next char)
LD A,C ;restore the last character
CP $0C ;/jump if token is DELETE
JR Z,M1A7F ;\
CP $7B ;/jump if char can’t be a keyword token
JR C,M1A71 ;\
CP $80 ;/jump if char might be a keyword token
JR NC,M1A71 ;\
BIT 0,A ;/jump if token is for keywords
JR NZ,M1A7F ;\ONERR, SOUND, RESET
M1A71: SUB $CE ;/error if not a keyword (not function etc.)
JP C ,M1BED ;\error – BAD BASIC
LD C,A ;/make the address to look into the
LD HL,KEWTBL ;|keyword table offset table
M1A7A: ADD HL,BC ;\
LD C,(HL) ;/make the address to look into the
ADD HL,BC ;\syntax table
JR M1A98 ;
M1A7F: CP $0C ;/jump if token is not DELETE
JR NZ,M1A87 ;\
LD A,$00 ;/force A to zero and bypass
JR M1A8F ;\ next test
M1A87: SUB $7A ;A=1 for ONERR, 3 for SOUND, 5 for RESET
CP $05 ;/jump if token not RESET
JR NZ,M1A8F ;\
LD A,$02 ;force A (RESET) to 2
M1A8F: LD HL,KEWTBL2 ;second half of keyword table
LD C,A ;move the massaged token to C
JR M1A7A ;do the table look-up thang
M1A95: LD HL,(TADDR) ;the class handler returns here from the
; address pushed below
M1A98: LD A,(HL) ;get the first (or next) byte of the syntax table –
; the instruction’s "class" (first byte) or the required
; token or class (succeeding bytes)
INC HL ;point to the next byte in the syntax table
LD (TADDR),HL ;store its address in TADDR
LD BC,M1A95 ;/"return" address from class handler
PUSH BC ;\
LD C,A ;save the "class"
CP $20 ;/jump if the "class" is not in the range $00..$11
JR NC,M1AB2 ;| this means it could be the next value in the syntax
;\ table.
LD HL,CLASTBL ;/form address of offset into the expression
LD B,$00 ;| class routine offset table
ADD HL,BC ;\
LD C,(HL) ;/get offset from the table
ADD HL,BC ;|and form addrss of the actual "class"
;\handler …
PUSH HL ;… and push it onto the stack
RST $18 ;get current character
DEC B ;B=$FF ???
RET ;jump to the class handler
M1AB2: RST $18 ;get current character
CP C ;check the current character in A against
; the value from the syntax table.
; declare an error if they don’t match –
; the syntax is wrong
JP NZ,M1BED ;error – BAD BASIC
RST $20 ;get next char
RET ;either done or back around for the
; next byte in then syntax table
;******************************************************************
; Module: SYNTAX
; Routine: ENDBTT
;******************************************************************
ENDBTT:
M1AB9: CALL BREAK ;/jump if BREAK was not
JR C,M1AC0 ;\ pressed
RST $08 ;error: BREAK
DEFB $14 ;
M1AC0: BIT 7,(IY+ONSPPC) ;/
JP NZ,M1B4A ;\
LD HL,(NEWPPC) ;
BIT 7,H ;
JR NZ,M1AD8 ;
LD A,(ARSFLG) ;
BIT 7,A ;
JP NZ,M17EA ;
JR M1AEC ;
;******************************************************************
; Module: SYNTAX
; Routine: EXECUTE
;******************************************************************
EXECUTE:
M1AD8: LD HL,$FFFE
LD (PPC),HL
LD HL,(WORKSP)
DEC HL
LD DE,(ELINE)
DEC DE
LD A,(NSPPC)
JR M1B27
M1AEC: CALL FIND_L
LD A,(NSPPC)
JR Z,M1B15
AND A
JR NZ,M1B42
LD B,A
LD A,(HL)
AND $C0
LD A,B
JR Z,M1B15
RST $08 ;/????
RST $38 ;\
M1B00: POP BC
LD A,(ARSFLG)
BIT 7,A
JP NZ,M17FF
M1B09: CALL INTPTQ ;/return if syntax checking
RET Z ;\
LD HL,(NXTLIN) ;get the address of the next line
LD A,$C0 ;/
AND (HL) ;|return if not a valid line number
RET NZ ;\
XOR A ;force first subline, no forced jump
M1B15: CP $01 ;/will give 1 for A=0, else will
ADC A,$00 ;\give A
LD D,(HL) ;/
INC HL ;|put the new line number into the
LD E,(HL) ;| "line currently being interpreted"
LD (PPC),DE ;\ pointer
INC HL ;/
LD E,(HL) ;|get the line length
INC HL ;|
LD D,(HL) ;\
EX DE,HL ;/point to the next line and put the pointer
ADD HL,DE ;| into the "next line to be interpreted"
INC HL ;| pointer
M1B27: LD (NXTLIN),HL ;\
EX DE,HL ;/put the new line’s address into the
LD (CHADD),HL ;\ interpreter code pointer
LD D,A ;/save the subline in D
LD E,$00 ;\
LD (IY+ONSPPC),$FF ;load a value that will not force a jump to the new subline
DEC D ;/put the desired sub-line into its pointer
LD (IY+OSUBPPC),D ;\
JP Z ,LS4 ;we don’t need to find a sub-line, so move on
INC D ;normalize the value in D
CALL SUBLIN1 ;
JR Z,M1B4A ;
M1B42: RST $08 ;/error: STATEMENT LOST
DEFB $16 ;\
;******************************************************************
; Module: SYNTAX
; Routine: ENDQ
; checks the interpret flag (bit 7 of FLAGS) and returns to
; the caller if the machine is running code, else ????
;******************************************************************
ENDQ:
M1B44: CALL INTPTQ ;will return NZ if we are interpreting
RET NZ ;interpreting, so return to execute
; the code
;syntax checking, so move on
POP BC ;trash caller’s return address
POP BC ;
;******************************************************************
; Module: SYNTAX
; Routine: ENDTEM
;******************************************************************
ENDTEM:
M1B4A: RST $18 ;get current character
CP $0D ;/jump if not the end
JR NZ,M1B5C ;\ of the a line
LD HL,(NXTLIN) ;get the pointer to the next BASIC line
LD A,(ARSFLG) ;/
BIT 7,A ;|jump if we is in an AROS
JP NZ,M17FF ;\
JR M1B09 ;normal line execution
M1B5C: CP ‘:’ ;
JP Z ,LS4 ;
JP M1BED ;error – BAD BASIC
CLASTBL:
DEFB TEM0-ASMPC
DEFB TEM1-ASMPC
DEFB TEM2-ASMPC
DEFB TEM3-ASMPC
DEFB TEM4-ASMPC
DEFB TEM5-ASMPC
DEFB TEM6-ASMPC
DEFB TEM7-ASMPC
DEFB TEM8-ASMPC
DEFB TEM9-ASMPC
DEFB TEM10-ASMPC
DEFB TEM11-ASMPC
TEM3: CALL M1C49
TEM0: CP A
TEM5: POP BC
CALL Z ,ENDQ
EX DE,HL
LD HL,(TADDR)
LD C,(HL)
INC HL
LD B,(HL)
EX DE,HL
PUSH BC
RET
;******************************************************************
; Module: SYNTAX
; Routine: TEM1
;******************************************************************
TEM1:
M1B82: CALL FIND_N
M1B85: LD (IY+OFLAGX),00 ;FLAGX
JR NC,M1B93
SET 1,(IY+OFLAGX) ;FLAGX
JR NZ,M1BA9
;******************************************************************
; Module: SYNTAX
; Routine: ERR2
;******************************************************************
ERR2:
M1B91: RST $08 ;/error: VARIABLE NOT FOUND
DEFB $01 ;\
M1B93: CALL Z,M2D54
BIT 6,(IY+OFLAGS) ;FLAGS
JR NZ,M1BA9
XOR A
CALL INTPTQ ;/return if interpreting
CALL NZ,PGPSTR ;\
LD HL,FLAGX
OR (HL)
LD (HL),A
EX DE,HL
M1BA9: LD (STRLEN),BC
LD (DEST),HL
RET
TEM2: POP BC
CALL M1BB9
CALL ENDQ
RET
M1BB9: LD A,(FLAGS)
;******************************************************************
; Module: SYNTAX
; Routine: LT22
;******************************************************************
LT22:
M1BBC: PUSH AF
CALL EXPRN
POP AF
LD D,(IY+OFLAGS) ;FLAGS
XOR D
AND $40
JR NZ,M1BED ;error – BAD BASIC
BIT 7,D
JP NZ,M2EBD
RET
TEM4: CALL FIND_N
PUSH AF
LD A,C
OR $9F
INC A
JR NZ,M1BED ;error – BAD BASIC
POP AF
JR M1B85
;******************************************************************
; Module: SYNTAX
; Routine: DYADIC
;******************************************************************
DYADIC:
M1BDC: RST $20 ;get next char
TEM8: CALL TEM6 ;evaluate the next expression
CP ‘,’ ;/jump if another argument is
JR NZ,M1BED ;\not available
RST $20 ;get next char, fall through to
; evaluate the next expression
;******************************************************************
; Module: SYNTAX
; Routine: TEM6
; evaluate the next expression and return if it is numeric
;******************************************************************
TEM6:
M1BE5: CALL EXPRN ;evaluate an expression
BIT NUM,(IY+OFLAGS) ;/return if the expression was an integer
RET NZ ;\
;******************************************************************
; Module: SYNTAX
; Routine: SYNERR
;******************************************************************
SYNERR:
M1BED: RST $08 ;/error: NONSENSE IN BASIC
DEFB $0B ;\
;******************************************************************
; Module: SYNTAX
; Routine: TEM10
; evaluate an expression. if the expression is not a string
; bounce to ERROR C
;******************************************************************
TEM10:
M1BEF: CALL EXPRN ;evaluate the next expression
BIT NUM,(IY+OFLAGS) ;/return if the last expression
RET Z ;\ was a number
JR M1BED ;error – BAD BASIC
;******************************************************************
; Module: SYNTAX
; Routine: TEM7
; evaluate an expression. if the expression is not a string
; bounce to ERROR C
;******************************************************************
TEM7: BIT 7,(IY+OFLAGS) ;FLAGS
RES 0,(IY+OTVFLAG) ;TVFLAG
CALL NZ,DO_ATTS
POP AF
LD A,(TADDR)
LD HL,(TADDR)
LD DE,$1914
AND A
SBC HL,DE
LD A,L
CALL M23A6
CALL ENDQ
LD HL,(ATTRT)
LD (ATTRP),HL
LD HL,PFLAG
LD A,(HL)
RLCA
XOR (HL)
AND $AA
XOR (HL)
LD (HL),A
RET
TEM9: CALL INTPTQ ;/jump if syntax checking
JR Z,M1C41 ;\
RES 0,(IY+OTVFLAG) ;TVFLAG
CALL DO_ATTS
LD HL,MASKT
LD A,(HL)
OR $F8
LD (HL),A
RES 6,(IY+OPFLAG) ;PFLAG
RST $18 ;get current character
;******************************************************************
; Module: SYNTAX
; Routine: STK_O
;******************************************************************
STK_O:
M1C41: CALL M238C
JR TEM8 ;evalute the next two comma separated expressions
TEM11: JP NEWDEV
;******************************************************************
; Module: SYNTAX
; Routine: OPTNO
; stack a fp zero unless we are syntax checking and at the end of
; a line or statement
;******************************************************************
OPTNO:
M1C49: CP $0D ;/jump if the end of line
JR Z,M1C51 ;\
CP ‘:’ ;/jump to evaluate a numeric
JR NZ,TEM6 ;| expression if not the end of
;\ statement
STKFP0:
M1C51: CALL INTPTQ ;/return if syntax checking
RET Z ;\
;stack a zero to the fp stack
RST $28 ;calc entry
DEFB $A0 ;CONST 0 (0)
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: SYNTAX
; Routine: STOP
;******************************************************************
TSSTOP:
RST $08 ;error: STOP
DEFB $08 ;
TSIF:
POP BC
CALL INTPTQ ;/jump if syntax checking
JR Z,M1C75 ;\
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $38 ;QUIT
EX DE,HL
CALL M3904
JR NC,M1C75
LD A,(ARSFLG)
BIT 7,A
JP NZ,M17FF
JP M1B09
M1C75: JP M1A45
;******************************************************************
; Module: SYNTAX
; Routine: FOR
;******************************************************************
FOR:
CP $CD
JR NZ,M1C85
RST $20 ;get next char
CALL TEM6
CALL ENDQ
JR M1C8B
M1C85: CALL ENDQ
RST $28 ;calc entry
DEFB $A1 ;CONST 1 (256)
DEFB $38 ;QUIT
M1C8B: RST $28 ;calc entry
DEFB $C0 ;T -> MEM 0
DEFB $02 ;DROP
DEFB $01 ;SWAP
DEFB $E0 ;MEM 0 -> T
DEFB $01 ;SWAP
DEFB $38 ;QUIT
CALL M2EBD
LD (MEM),HL
DEC HL
LD A,(HL)
SET 7,(HL)
LD BC,$0006
ADD HL,BC
RLCA
JR C,M1CA9
LD C,$0D
CALL INSERT
INC HL
M1CA9: PUSH HL
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $02 ;DROP
DEFB $38 ;QUIT
POP HL
EX DE,HL
LD C,$0A
LDIR
LD HL,(PPC)
EX DE,HL
LD (HL),E
INC HL
LD (HL),D
LD D,(IY+OSUBPPC) ;SUBPPC
INC D
INC HL
LD (HL),D
CALL M1D84
RET NC
LD HL,(PPC)
LD (NEWPPC),HL
LD A,(SUBPPC)
NEG
LD D,A
LD HL,(SYSCON)
INC HL
LD A,(HL)
CP $02
JR NZ,M1CF2
INC HL
INC HL
INC HL
LD A,(HL) ;get the chunk map
AND $0F ;only accept the lower half of the chunk
; spec
LD C,A ;chunks map to C
LD B,$00 ;specify dock bank
CALL BANK_ENABLE ;
LD BC,(PPC)
CALL M17CF
LD H,B
LD L,C
DEC HL
JR M1CF5
M1CF2: LD HL,(CHADD)
M1CF5: LD E,$F3
M1CF7: LD BC,(NXTLIN)
CALL M1D28
LD (NXTLIN),BC
LD B,(IY+OSTRLEN) ;STRLEN
JR C,M1D26
RST $20 ;get next char
OR $20
CP B
JR Z,M1D10
RST $20 ;get next char
JR M1CF7
M1D10: RST $20 ;get next char
LD A,$01
SUB D
LD (NSPPC),A
LD HL,ARSFLG
LD L,(HL)
BIT 7,L
JR Z,M1D25
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
M1D25: RET
M1D26: RST $08 ;error: FOR WITHOUT NEXT
DEFB $11 ;
;******************************************************************
; Module: SYNTAX
; Routine: SKIP
;******************************************************************
SKIP:
M1D28: LD A,(HL)
CP $3A
JR Z,M1D4D
M1D2D: INC HL
LD A,(HL)
AND $C0
SCF
RET NZ
LD A,E
CP $E4
JR NZ,M1D3B
LD (ADATLN),HL
M1D3B: LD B,(HL)
INC HL
LD C,(HL)
LD (NEWPPC),BC
INC HL
LD C,(HL)
INC HL
LD B,(HL)
PUSH HL
ADD HL,BC
LD B,H
LD C,L
POP HL
LD D,$00
M1D4D: PUSH BC
CALL SUBLIN1
POP BC
RET NC
JR M1D2D
;******************************************************************
; Module: SYNTAX
; Routine: NEXT
;******************************************************************
NEXT:
BIT 1,(IY+OFLAGX) ;FLAGX
JP NZ,M1B91
LD HL,(DEST)
BIT 7,(HL)
JR Z,M1D82
INC HL
LD (MEM),HL
RST $28 ;calc entry
DEFB $E0 ;MEM 0 -> T
DEFB $E2 ;MEM 2 -> T
DEFB $0F ;ADD
DEFB $C0 ;T -> MEM 0
DEFB $02 ;DROP
DEFB $38 ;QUIT
CALL M1D84
RET C
LD HL,(MEM)
LD DE,$000F
ADD HL,DE
LD E,(HL)
INC HL
LD D,(HL)
INC HL
LD H,(HL)
EX DE,HL
JP M1EFD
M1D82: RST $08 ;error: NEXT WITHOUT FOR
DEFB $00 ;
M1D84: RST $28 ;calc entry
DEFB $E1 ;MEM 1 -> T
DEFB $E0 ;MEM 0 -> T
DEFB $E2 ;MEM 2 -> T
DEFB $36 ;MINUSQ
DEFB $00,$02 ;IFJUMP 1D8C
DEFB $01 ;SWAP
DEFB $03 ;SUB
DEFB $37 ;PLUSQ
DEFB $00,$04 ;IFJUMP 1D93
DEFB $38 ;QUIT
AND A
RET
JR C,M1DCC
RET
M1D96: RST $20 ;get next char
;******************************************************************
; Module: SYNTAX
; Routine: READ
;******************************************************************
READ:
CALL M1B82
CALL INTPTQ ;/jump if syntax checking
JP Z ,M1E78 ;\
RST $18 ;get current character
LD (XPTR),HL
LD HL,ARSFLG
LD L,(HL)
BIT 7,L
JP Z ,M1E52
LD HL,(SYSCON)
LD DE,$0004
ADD HL,DE
LD A,(HL) ;get the chunk map
AND $0F ;only accept the lower half of the chunk map
LD B,$00 ;dock bank
LD C,A ;chunk map to C
CALL BANK_ENABLE ;
LD HL,(DATADD)
LD A,(HL)
CP $2C
JR Z,M1DD8
LD E,$E4
CALL M1D28
JR NC,M1DD5
M1DCC: LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
JP M1E62
M1DD5: LD (DATADD),HL
M1DD8: LD HL,(ADATLN)
INC HL
INC HL
LD C,(HL)
INC HL
LD B,(HL)
LD (DTLNLN+1),BC
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
LD BC,(DTLNLN+1)
LD HL,(CHANS)
PUSH HL
DEC HL
CALL INSERT
POP DE
LD HL,$00FF
PUSH HL
LD HL,(ADATLN)
INC HL
INC HL
INC HL
INC HL
PUSH HL
PUSH DE
LD BC,(DTLNLN+1)
PUSH BC
LD BC,$0001
PUSH BC
CALL M6722
LD HL,(ADATLN)
LD DE,(DTLNLN+1)
ADD HL,DE
LD DE,$0004
ADD HL,DE
LD BC,(DATADD)
AND A
SBC HL,BC
LD B,H
LD C,L
LD HL,(CHANS)
AND A
SBC HL,BC
PUSH HL
INC HL
LD (CHADD),HL
CALL M1BB9
POP DE
LD HL,(CHADD)
AND A
SBC HL,DE
LD DE,(DATADD)
ADD HL,DE
LD (DATADD),HL
LD HL,(CHANS)
LD BC,(DTLNLN+1)
AND A
SBC HL,BC
CALL DELREC
JP M1E6E
M1E52: LD HL,(DATADD)
LD A,(HL)
CP $2C
JP Z ,M1E64
LD E,$E4
CALL M1D28
JR NC,M1E64
M1E62: RST $08 ;/error: OUT OF DATA
DEFB $0D ;\
M1E64: CALL M0077
CALL M1BB9
RST $18 ;get current character
LD (DATADD),HL
M1E6E: LD HL,(XPTR)
LD (IY+(OXPTR+1)),00 ;
CALL M0078
M1E78: RST $18 ;get current character
CP $2C
JP Z ,M1D96
CALL ENDQ
RET
;******************************************************************
; Module: SYNTAX
; Routine: DATA
;******************************************************************
DATA:
CALL INTPTQ ;/jump if interpreting
JR NZ,M1E92 ;\
M1E87: CALL EXPRN
CP $2C
CALL NZ,ENDQ
RST $20 ;get next char
JR M1E87
M1E92: LD A,$E4
M1E94: LD B,A ;
CPDR ;
LD DE,$0200 ;
JP SUBLIN1 ;
M1E9D: CALL FIX_U ;
LD HL,(SYSCON)
INC HL
LD A,(HL)
CP $02
JR NZ,M1ECA
INC HL
INC HL
INC HL
LD A,(HL)
AND $0F
PUSH BC ;briefly save BC
LD C,A ;chunk map to C
LD B,$00 ;dock bank
CALL BANK_ENABLE ;
POP BC ;restore BC
CALL M17CF
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
JR M1EC5
CALL FIND_L
M1EC5: DEC HL
LD (DATADD),HL
RET
;******************************************************************
; Module: SYNTAX
; Routine: RESTBC
;******************************************************************
RESTBC:
M1ECA: LD H,B
LD L,C
CALL FIND_L
DEC HL
LD (DATADD),HL
RET
;******************************************************************
; Module: SYNTAX
; Routine: RAND
;******************************************************************
RAND:
CALL FIX_U
LD A,B
OR C
JR NZ,M1EDF
LD BC,(FRAMES)
M1EDF: LD (SEED),BC
RET
;******************************************************************
; Module: SYNTAX
; Routine: CONT
;******************************************************************
CONT:
LD HL,(OLDPPC)
INC H
JP Z ,M1B42
DEC H
LD D,(IY+OOSPCC) ;OSPCC
JR M1EFD
;******************************************************************
; Module: SYNTAX
; Routine: JUMP
; GOTO
;******************************************************************
JUMP:
M1EF1: CALL FIX_U ;top of FP stack to BC
LD H,B ;/transfer BC to HL
LD L,C ;\
LD D,$00 ;force sub line 0
LD A,H ;/jump if line number is
CP $F0 ;|too large
JR NC,M1F29 ;\
M1EFD: LD (NEWPPC),HL ;put new line number into BASIC’s
; program jump instruction pointer
LD (IY+ONSPPC),D ;force jump subline pointer to 0
RET ;return to the interpreter
K_OUTPUT:
CALL M1F0F
OUT (C),A
RET
POKE:
CALL M1F0F
LD (BC),A
RET
M1F0F: CALL FP2A
JR C,M1F29
JR Z,M1F18
NEG
M1F18: PUSH AF
CALL FIX_U
POP AF
RET
;******************************************************************
; Module: SYNTAX
; Routine: INS_U1
;******************************************************************
INS_U1:
M1F1E: CALL FP2A ;to of fp stack to A
JR M1F26 ;to error checking
;******************************************************************
; Module: SYNTAX
; Routine: FIX_U
; put the top of the fp stack onto BC. declare error if number
; is too big
;******************************************************************
FIX_U:
M1F23: CALL FP2BC ;top of calculator stack to BC
M1F26: JR C,M1F29 ;error – number too large
RET Z ;return if no
;******************************************************************
; Module: SYNTAX
; Routine: ERRB
;******************************************************************
ERRB:
M1F29: RST $08 ;/error: INTEGER OUT OF RANGE
DEFB $0A ;\
RUN:
CALL JUMP ;call GOTO (JUMP)
LD BC,$0000
CALL M1ECA
JR M1F39
;******************************************************************
; Module: SYNTAX
; Routine: CLEAR
;******************************************************************
CLEAR:
CALL FIX_U
;******************************************************************
; Module: SYNTAX
; Routine: CLR_BC
;******************************************************************
CLR_BC:
M1F39: LD A,B
OR C
JR NZ,M1F41
LD BC,(RAMTOP)
M1F41: PUSH BC
LD DE,(VARS)
LD HL,(ELINE)
DEC HL
CALL M174D
CALL M08A6
LD HL,ARSFLG
LD L,(HL)
BIT 7,L
JR Z,M1F67
LD HL,(SYSCON)
INC HL
INC HL
LD E,(HL)
INC HL
LD D,(HL)
EX DE,HL
DEC HL
LD (DATADD),HL
JR M1F6E
M1F67: LD HL,(PROG)
DEC HL
LD (DATADD),HL
M1F6E: LD HL,(STKEND)
LD DE,$0032
ADD HL,DE
POP DE
SBC HL,DE
JR NC,M1F82
LD HL,(PRAMT)
AND A
SBC HL,DE
JR NC,M1F84
M1F82: RST $08 ;error: RAMTOP NO GOOD
DEFB $15 ;
M1F84: EX DE,HL
LD (RAMTOP),HL
POP DE
POP BC
LD HL,(MSTBOT)
DEC HL
LD (HL),$3E
DEC HL
LD SP,HL
PUSH BC
LD (ERRSP),SP
EX DE,HL
JP (HL)
;******************************************************************
; Module: SYNTAX
; Routine: GO_SUB
; this routine saves PPC and SUBPPC on the machine stack
; then uses GOTO to put the target address into NEWPPC and NSPPC
;******************************************************************
GO_SUB: POP DE ;get return adr off stack
LD H,(IY+OSUBPPC) ;get sub line that is executing
INC H ;point to next subline
EX (SP),HL ;/stack it and save return address
INC SP ;\(8 bit PUSH)
LD BC,(PPC) ;get current line number
PUSH BC ;save it
PUSH HL ;put return address back onto the stack
LD (ERRSP),SP ;save the error stack pointer
PUSH DE ;put ret adr back on stack
CALL JUMP ;call GOTO to set up NEWPPC and NSPPC
LD HL,(MSTBOT) ;get address above machine stack
DEC H ;one page down
LD DE,$0010 ;need 16 bytes
ADD HL,DE ;point to address
SBC HL,SP ;/stack pointer is still above the
RET C ;\required end address, so proceed
JR M1FCF ;out of space
;******************************************************************
; Module: SYNTAX
; Routine: CHK_SZ
; checks to see if sufficient RAM is available below RAMTOP
; to give caller BC bytes of room. if not exits to error 4
;******************************************************************
CHK_SZ:
M1FBB: LD HL,(STKEND) ;get STKEND (start of spare space)
ADD HL,BC ;add the number of bytes requested
JR C,M1FCF ;
EX DE,HL ;DE points to final address
LD HL,$0050 ;/add safety margin for machine stack
ADD HL,DE ;|point to > $FFFF, so error 4
JR C,M1FCF
LD DE,(RAMTOP) ;get RAMTOP – top of BASIC’s memory
SBC HL,DE ;/exit if requested < RAMTOP
RET C ;\
;******************************************************************
; Module: SYNTAX
; Routine: ERR4
;******************************************************************
ERR4:
M1FCF: LD L,$03 ;/give error 4
JP M0055 ;\- OUT OF MEMORY
;******************************************************************
; Module: SYNTAX
; Routine: RETURN
; removes the line number and sub-line number from the machine stack
; then jumps into the GOTO routine to put them into NEWPPC and NSPPC
;******************************************************************
RETURN:
POP BC ;save the return address
POP HL ;
POP DE ;pop return line number
LD A,D ;/jump if not a valid line number
CP $3E ;|
JR Z,M1FE7 ;\
DEC SP ;adjust SP to get return sub-line number
EX (SP),HL ;get sub-line number and save HL
EX DE,HL ;sub-line number in D, line number in HL
LD (ERRSP),SP ;
PUSH BC ;save the machine return address
JP M1EFD ;GOTO the GOSUB return address
M1FE7: PUSH DE ;save DE
PUSH HL ;save HL
RST $08 ;/error – RETURN WITHOUT GOSUB
DEFB $06 ;\
;******************************************************************
; Module: SYNTAX
; Routine: PAUSE
;******************************************************************
PAUSE: RES KEYHIT,(IY+OFLAGS) ;reset keyhit flag
CALL FIX_U ;put top of fp stack into BC
M1FF2: HALT ;wait for IM1
DEC BC ;decrement the PAUSE counter
LD A,B ;/
OR C ;|jump if BC = 0, PAUSE timed
JR Z,M2004 ;\ out
LD A,B ;/
AND C ;|if BC <> $FFFF jump to examine
INC A ;|the key hit
JR NZ,M1FFE ;\
INC BC ;BC = $FFFF, therefore no timeout
M1FFE: BIT KEYHIT,(IY+OFLAGS) ;/jump back to wait if a key has
JR Z,M1FF2 ;\ not been hit
M2004: RES KEYHIT,(IY+OFLAGS) ;force no KEYHIT
RET
;******************************************************************
; Module: SYNTAX
; Routine: BREAK?
; test BREAK key. Return NC if break pressed
;******************************************************************
BREAK:
M2009: LD A,$7F ;/
IN A,($FE) ;|read the keyboard
RRA ;\
RET C ;return if BREAK not pressed
BIT 6,(IY+(OERRLN+1)) ;/if we running a progrm
JR Z,M2017 ;\ check for the CAPS SHIFT key too
SCF ;force no BREAK
RET ;
M2017: LD A,$FE ;/carry will be set if
IN A,($FE) ;|CAPS SHIFT is depressed
RRA ;\
RET ;
;******************************************************************
; Module: SYNTAX
; Routine: DEF
;******************************************************************
DEF:
CALL INTPTQ ;/jump if syntax checking
JR Z,M2027 ;\
LD A,$CE ;load A with DEF FN token
JP M1E94
M2027: SET NUM,(IY+OFLAGS) ;force a numerical result
CALL ALPHAQ
JR NC,M2046
RST $20 ;get next char
CP $24
JR NZ,M203A
RES 6,(IY+OFLAGS) ;FLAGS
RST $20 ;get next char
M203A: CP $28
JR NZ,M207A
RST $20 ;get next char
CP $29
JR Z,M2063
M2043: CALL ALPHAQ
M2046: JP NC,M1BED ;error – BAD BASIC
EX DE,HL
RST $20 ;get next char
CP $24
JR NZ,M2051
EX DE,HL
RST $20 ;get next char
M2051: EX DE,HL
LD BC,$0006
CALL INSERT
INC HL
INC HL
LD (HL),$0E
CP $2C
JR NZ,M2063
RST $20 ;get next char
JR M2043
M2063: CP $29
JR NZ,M207A
RST $20 ;get next char
CP $3D
JR NZ,M207A
RST $20 ;get next char
LD A,(FLAGS)
PUSH AF
CALL EXPRN
POP AF
XOR (IY+OFLAGS) ;FLAGS
AND $40
M207A: JP NZ,M1BED ;error – BAD BASIC
CALL ENDQ
RST $18 ;get current character
CP $7F
JR Z,M20AE
CP $EC
JR Z,M20BC
CP $E8
JP NZ,M1BED ;error – BAD BASIC
RST $20 ;get next char
CALL ENDQ
BIT 7,(IY+(OERRLN+1)) ;
RET Z
LD HL,(ERRC)
LD (NEWPPC),HL
LD A,(ERRS)
LD (NSPPC),A
RES 6,(IY+(OERRLN+1)) ;
M20A7: POP HL
LD DE,$0007
ADD HL,DE
PUSH HL
RET
M20AE: RST $20 ;get next char
CALL ENDQ
RES 7,(IY+(OERRLN+1)) ;
RES 6,(IY+(OERRLN+1)) ;
JR M20A7
M20BC: RST $20 ;get next char
CALL TEM6
CALL ENDQ
CALL FP2BC
LD A,B
AND $3F
OR $80
LD B,A
LD (ERRLN),BC
RET
RST $18 ;get current character
CP $2C
JR NZ,M20E0
CALL INTPTQ ;/jump if syntax checking
JR Z,M20E7 ;\
RST $28 ;calc entry
DEFB $A1 ;CONST 1 (256)
DEFB $38 ;QUIT
JR M20E7
M20E0: CALL TEM6
CP $2C
JR NZ,M211C
M20E7: RST $20 ;get next char
CP $0D
JR Z,M20F5
CP $3A
JR Z,M20F5
CALL TEM6
JR M20FE
M20F5: LD BC,$270F
CALL INTPTQ ;/call if interpreting
CALL NZ,STK_BC ;\
M20FE: CALL ENDQ
CALL M211E
INC HL
CALL FIND_L
PUSH HL
CALL M211E
CALL FIND_L
EX DE,HL
POP HL
PUSH HL
SCF
SBC HL,DE
JR C,M211C
POP HL
CALL M174D
RET
M211C: RST $08 ;error: NONSENSE IN BASIC
DEFB $0B ;
M211E: CALL FP2BC
LD A,B
AND $3F
LD H,A
LD L,C
RET
M2127: RST $20 ;get next char
;******************************************************************
; Module: SYNTAX
; Routine: SOUND
;******************************************************************
SOUND:
CALL TEM8 ;evalute the next two comma separated expressions
CALL INTPTQ ;/jump if syntax checking
JR Z,M2146 ;\
CALL FP2A ;/convert the top of fp stack to A
PUSH AF ;\and save the result (data value)
CALL FP2A ;convert the next argument to A (register number)
CP $11 ;/jump if the register number is too large
JP NC,M1BED ;\error – BAD BASIC
DEC A ;/jump if A >= $80
INC A ;|
JP M ,M1BED ;\error – BAD BASIC
OUT ($F5),A ;output register number to AY8910 address register
POP AF ;get the data value
OUT ($F6),A ;output to the AY8910 data register
M2146: RST $18 ;get current character
CP ‘;’ ;/jump back around for the next
JR Z,M2127 ;\set of arguments
CALL ENDQ ;will return if interpreting
RET
M214F: CALL INTPTQ ;check mode (syntax checking or interpreting
POP HL ;
RET Z ;return if syntax checking
JP (HL)
;******************************************************************
; Module: SYNTWO
; Routine: K_LPR
;******************************************************************
K_LPR:
LD A,$03
JR M2163
;******************************************************************
; Module: SYNTWO
; Routine: K_PRIN
;******************************************************************
K_PRIN:
LD A,(ARSFLG) ;
RES 0,A ;
LD (ARSFLG),A ;
LD A,$02 ;stream 2 (print/list)
M2163: CALL INTPTQ ;/call if interpreting
CALL NZ,SELECT ;\
CALL INTPTQ ;/call if interpreting
CALL NZ,M2179 ;\
CALL DO_ATTS ;
CALL M217E ;
CALL ENDQ ;
RET ;
M2179: SET 4,(IY+OFLAGS) ;
RET ;
;******************************************************************
; Module: SYNTWO
; Routine: P_SEQ
;******************************************************************
P_SEQ:
M217E: RST $18 ;get current character
CALL M21E4
JR Z,M2191
M2184: CALL M21ED
JR Z,M2184
CALL M219B
CALL M21ED
JR Z,M2184
M2191: CP $29
RET Z
M2194: CALL M214F
LD A,$0D
RST $10
RET
M219B: RST $18 ;get current character
CP $AC
JR NZ,M21AD
CALL DYADIC
CALL M214F
CALL M2660
LD A,$16
JR M21BD
M21AD: CP $AD
JR NZ,M21C3
RST $20 ;get next char
CALL TEM6
CALL M214F
CALL FIX_U
LD A,$17
M21BD: RST $10
LD A,C
RST $10
LD A,B
RST $10
RET
M21C3: CALL M239C
RET NC
CALL STRITO
RET NC
CALL EXPRN
CALL M214F
BIT 6,(IY+OFLAGS) ;FLAGS
CALL Z ,PGPSTR
JP NZ,M31A1
M21DB: LD A,B
OR C
DEC BC
RET Z
LD A,(DE)
INC DE
RST $10
JR M21DB
M21E4: CP $29 ;/return if close paren
RET Z ;\
;******************************************************************
; Module: SYNTWO
; Routine: TERMQ
; checks for termination of a line
; if end of statement (newline or ":") return with ZF=1
;******************************************************************
TERMQ:
CP $0D ;/return if end of line
RET Z ;\
CP $3A ;/return if colon
RET ;\
M21ED: RST $18 ;get current char
CP $3B ;/jump if semi-colon
JR Z,M2206 ;\
CP $2C ;/jump if comma
JR NZ,M2200 ;\
CALL INTPTQ ;/jump if syntax checking
JR Z,M2206 ;\
LD A,$06 ;
RST $10 ;WRITECHAR
JR M2206 ;
M2200: CP $27 ;/return if not apostrophe
RET NZ ;\
CALL M2194 ;
M2206: RST $20 ;get next char
CALL M21E4 ;recursive call to check character
JR NZ,M220D ;
POP BC ;
M220D: CP A ;
RET ;
;*********************************************************
; Module: SYNTWO
; Routine: STRITO
; update the current stream for "bank" devices
;*********************************************************
STRITO:
M220F: CP ‘#’ ;is the character a number sign?
SCF ;declare error
RET NZ ;return if not #
RST $20 ;get next char
CALL TEM6 ;evaluate a numeric expression
AND A ;
CALL M214F ;"CALL" to (HL) if interpreting
CALL INS_U1 ;convert the fp top of stack to a value in A
LD (STRMN),A ;put into stream number for "bank" devices
CP $10 ;/jump to invalid stream if
JP NC,M123D ;\requested stream # > 16
CALL SELECT ;select the stream in A
AND A ;
RET
;******************************************************************
; Module: SYNTWO
; Routine: INPUT
;******************************************************************
INPUT:
LD A,(ARSFLG)
SET 0,A
LD (ARSFLG),A
CALL INTPTQ ;/jump if syntax checking
JR Z,M2240 ;\
LD A,$01 ;/stream 1 (input command)
CALL SELECT ;\
CALL M08A9
M2240: LD (IY+OTVFLAG),01 ;TVFLAG
CALL M226B
CALL ENDQ
LD BC,(SPOSNCOL)
LD A,(DFSZ)
CP B
JR C,M2257
LD C,$21
LD B,A
M2257: LD (SPOSNCOL),BC
LD A,$19
SUB B
LD (SCRCT),A
RES 0,(IY+OTVFLAG) ;TVFLAG
CALL STTVC
JP M08A9
;******************************************************************
; Module: SYNTWO
; Routine: I_SEQ
;******************************************************************
I_SEQ:
M226B: CALL M21ED
JR Z,M226B
CP $28
JR NZ,M2282
RST $20 ;get next char
CALL M217E
RST $18 ;get current character
CP $29
JP NZ,M1BED ;error – BAD BASIC
RST $20 ;get next char
JP M235C
M2282: CP $CA
JR NZ,M2297
RST $20 ;get next char
CALL M1B82
SET 7,(IY+OFLAGX) ;FLAGX
BIT 6,(IY+OFLAGS) ;FLAGS
JP NZ,M1BED ;error – BAD BASIC
JR M22A4
M2297: CALL ALPHAQ
JP NC,M2359
CALL M1B82
RES 7,(IY+OFLAGX) ;FLAGX
M22A4: CALL INTPTQ ;/jump if syntax checking
JP Z ,M235C ;\
CALL M134E
LD HL,FLAGX
RES 6,(HL)
SET 5,(HL)
LD BC,$0001
BIT 7,(HL)
JR NZ,M22C6
LD A,(FLAGS)
AND $40
JR NZ,M22C4
LD C,$03
M22C4: OR (HL)
LD (HL),A
M22C6: RST $30
LD (HL),$0D
LD A,C
RRCA
RRCA
JR NC,M22D3
LD A,$22
LD (DE),A
DEC HL
LD (HL),A
M22D3: LD (KCUR),HL
BIT 7,(IY+OFLAGX) ;FLAGX
JR NZ,M2308
LD HL,(CHADD)
PUSH HL
LD HL,(ERRSP)
PUSH HL
LD HL,$22E4
PUSH HL
BIT 4,(IY+OFLAGS2) ;FLAGS2
JR Z,M22F2
LD (ERRSP),SP
M22F2: LD HL,(WORKSP)
CALL M0D0D
LD (IY+OERRNR),$FF ;ERRNR
CALL EDIT_K
RES 7,(IY+OFLAGS) ;FLAGS
CALL M2363
JR M230B
M2308: CALL EDIT_K
M230B: LD (IY+(OKCUR+1)),00 ;
CALL M2380
JR NZ,M231E
CALL M0C83
LD BC,(ECHOE)
CALL STTVC
M231E: LD HL,FLAGX
RES 5,(HL)
BIT 7,(HL)
RES 7,(HL)
JR NZ,M2345
POP HL
POP HL
LD (ERRSP),HL
POP HL
LD (XPTR),HL
SET 7,(IY+OFLAGS) ;FLAGS
CALL M2363
LD HL,(XPTR)
LD (IY+(OXPTR+1)),00 ;
LD (CHADD),HL
JR M235C
M2345: LD HL,(STKBOT)
LD DE,(WORKSP)
SCF
SBC HL,DE
LD B,H
LD C,L
CALL M2E70
CALL M2EBD
JR M235C
M2359: CALL M219B
M235C: CALL M21ED
JP Z ,M226B
RET
M2363: LD HL,(WORKSP)
LD (CHADD),HL
RST $18 ;get current character
CP $E2
JR Z,M237A
LD A,(FLAGX)
CALL M1BBC
RST $18 ;get current character
CP $0D
RET Z
RST $08 ;error: NONSENSE IN BASIC
DEFB $0B ;
M237A: CALL INTPTQ ;/return if syntax checking
RET Z ;\
;******************************************************************
; Module: SYNTWO
; Routine: ERRH
;******************************************************************
ERRH:
RST $08 ;error: STOP IN INPUT
DEFB $10 ;
;******************************************************************
; Module: SYNTWO
; Routine: NOTKBQ
;******************************************************************
NOTKBQ:
M2380: LD HL,(CURCHL)
INC HL
INC HL
INC HL
INC HL
LD A,(HL)
CP $4B
RET
M238B: RST $20 ;get next char
;******************************************************************
; Module: SYNTWO
; Routine: GR_COL
;******************************************************************
GR_COL:
M238C: CALL M239C
RET C
RST $18 ;get current character
CP $2C
JR Z,M238B
CP $3B
JR Z,M238B
JP M1BED ;error – BAD BASIC
M239C: CP $D9
RET C
CP $DF
CCF
RET C
PUSH AF
RST $20 ;get next char
POP AF
;******************************************************************
; Module: SYNTWO
; Routine: COLITM
;******************************************************************
COLITM:
M23A6: SUB $C9
PUSH AF
CALL TEM6
POP AF
AND A
CALL M214F
PUSH AF
CALL INS_U1
LD D,A
POP AF
RST $10
LD A,D
RST $10
RET
;******************************************************************
; Module: SYNTWO
; Routine: TV_COL
;******************************************************************
TV_COL:
M23BB: SUB $11
ADC A,$00
JR Z,M23DE
SUB $02
ADC A,$00
JR Z,M241D
CP $01
LD A,D
LD B,$01
JR NZ,M23D2
RLCA
RLCA
LD B,$04
M23D2: LD C,A
LD A,D
CP $02
JR NC,M23EE
LD A,C
LD HL,PFLAG
JR M2416
;******************************************************************
; Module: SYNTWO
; Routine: COLOUR
;******************************************************************
COLOUR:
M23DE: LD A,D
LD B,$07
JR C,M23E8
RLCA
RLCA
RLCA
LD B,$38
M23E8: LD C,A
LD A,D
CP $0A
JR C,M23F0
M23EE: RST $08 ;error: INVALID COLOR
DEFB $13 ;
M23F0: LD HL,ATTRT
CP $08
JR C,M2402
LD A,(HL)
JR Z,M2401
OR B
CPL
AND $24
JR Z,M2401
LD A,B
M2401: LD C,A
M2402: LD A,C
CALL M2416
LD A,$07
CP D
SBC A,A
CALL M2416
RLCA
RLCA
AND $50
LD B,A
LD A,$08
CP D
SBC A,A
M2416: XOR (HL)
AND B
XOR (HL)
LD (HL),A
INC HL
LD A,B
RET
;******************************************************************
; Module: SYNTWO
; Routine: HIFLSH
;******************************************************************
HIFLSH:
M241D: SBC A,A
LD A,D
RRCA
LD B,$80
JR NZ,M2427
RRCA
LD B,$40
M2427: LD C,A
LD A,D
CP $08
JR Z,M2431
CP $02
JR NC,M23EE
M2431: LD A,C
LD HL,ATTRT
CALL M2416
;******************************************************************
; Module: SYNTWO
; Routine: BORDER
;******************************************************************
BORDER:
; LD D,$24
LD A,C
RRCA
RRCA
RRCA
JR M2416
M243E: CALL INS_U1
CP $08
JR NC,M23EE
OUT ($FE),A
RLCA
RLCA
RLCA
BIT 5,A
JR NZ,M2450
XOR $07
M2450: LD (BORDCR),A
RET
;******************************************************************
; Module: SYNTWO
; Routine: RSET
;******************************************************************
RSET:
RST $18 ;get current character
CP $2A
JR NZ,M247F
CALL M0020
CALL ENDQ
RET
LD A,$10
LD HL,CH_0
M2465: CALL M13A8
INC HL
INC HL
DEC A
JR NZ,M2465
LD HL,$09F4
PUSH HL
LD B,$FE
M2473: LD C,$88
PUSH BC
LD BC,$0000
PUSH BC
PUSH BC
CALL M65D0
RET
M247F: CP $23
JR Z,M2498
CALL ENDQ
RET
LD HL,$0C4C
PUSH HL
LD BC,$FEFE
PUSH BC
LD BC,$0000
PUSH BC
PUSH BC
CALL M65D0
RET
M2498: RST $20 ;get next char
CALL TEM6
CALL ENDQ
CALL INS_U1
CP $11
JR NC,M24B7
AND A
JP M ,M24B7
ADD A,A
ADD A,$16
LD L,A
LD H,$5C
LD E,(HL)
INC HL
LD D,(HL)
LD A,D
OR E
JR NZ,M24B9
M24B7: RST $08 ;error INVALID STREAM
DEFB $17 ;
M24B9: LD A,D
CP $80
RET C
JP M2567
SUB $80
LD D,A
LD DE,(SYSCON)
ADD HL,DE
INC HL
LD B,(HL)
LD D,$00
LD E,$12
ADD HL,DE
PUSH HL
JR M2473
;******************************************************************
; Module: SYNTWO
; Routine: NEWDEV
;******************************************************************
NEWDEV:
M24D2: RST $18 ;get current character
CP ‘*’ ;
JP NZ,DOSAVE ;save the program
RST $20 ;get next char
CALL M1BEF
CP ‘,’
JP NZ,M1BED ;error – BAD BASIC
CALL INTPTQ ;/jump if interpreting
JR NZ,M24EC ;\
CALL SKIPIT
CALL ENDQ
M24EC: JR M2567
CALL PGPSTR
DEC BC
LD A,B
OR C
JR NZ,M2567
LD A,(DE)
AND $DF
LD C,A
CALL M1374
JP NC,M2567
PUSH HL
LD DE,$0014
ADD HL,DE
LD A,(HL)
BIT 1,A
JP Z ,M2567
POP HL
EX DE,HL
CALL M25B9
EX DE,HL
LD A,(TADDR)
AND A
CP $00
JR C,M253F
JR Z,M2543
ADD A,$D4
LD C,A
M251E: PUSH BC
LD D,(HL)
LD E,$88
LD BC,$000C
ADD HL,BC
LD C,(HL)
INC HL
LD B,(HL)
PUSH BC
PUSH DE
LD HL,(STKEND)
DEC HL
LD C,(HL)
INC C
LD (STKEND),HL
LD B,$00
PUSH BC
LD BC,$0000
PUSH BC
CALL M65D0
RET
M253F: LD C,$F8
JR M251E
M2543: LD C,$EF
JR M251E
;
;jump to the save command in the EXROM
;
DOSAVE: POP AF
LD BC,SLVM ;
PUSH BC ;
LD BC,$FEFE ;dock bank, chunk 0 active
PUSH BC ;
LD BC,$0000 ;no in or out params
PUSH BC ;
PUSH BC ;
LD A,(VIDMOD) ;/determine where the function
AND A ;\ dispatcher is
JR NZ,M2562 ;has been moved to high memory, so
; call there
CALL M65D0 ;CALL_BANK
M255E: CALL ENDQ
RET
M2562: CALL MFD90 ;high mem function dispatcher call
JR M255E
M2567: RST $08 ;/error INVALID IO DEVICE
DEFB $12 ;\
;******************************************************************
; Module: SYNTWO
; Routine: SKIPIT
; skip the rest of a line. gobble characters until a newline ($0D)
; a colon (:) or quote mark is found.
;******************************************************************
SKIPIT:
M2569: LD A,(ARSFLG) ;/reset string quote
RES 1,A ;|flag
LD (ARSFLG),A ;\
PUSH BC ;briefly save BC
RST $18 ;get current character
;loop until the end of a subline, end of line or quote
; is found
M2573: CP $22 ;/jump if a quote
JR Z,M2582 ;\
CP ‘:’ ;/jump if colon (subline marker)
JR Z,M2582 ;\
CP $0D ;/jump if newline
JR Z,M2582 ;\
RST $20 ;/get next char
JR M2573 ;\and loop back around
M2582: CP ‘:’ ;/jump if not end of a subline
JR NZ,M258D ;\
LD A,(ARSFLG) ;/jump if still in a string literal
BIT 1,A ;|delimited by quote marks
JR NZ,M25B6 ;\
;
;look back as many as five characters to determine whether or not
; the quote, :, or newline are actually components of a floating
; point number
M258D: PUSH HL ;save current character pointer
LD B,$05 ;set up to look for "number slug"
M2590: DEC HL ;point back
LD A,(HL) ;/
CP $0E ;|look back 5 characters to determine
JR Z,M25B5 ;|if the character was part of a
DJNZ M2590 ;\floating point number
POP HL ;restore the character pointer
RST $18 ;get current character
CP $22 ;/jump if not a quote
JR NZ,M25B3 ;\
;at this point we have found a quote in a literal string.
; we check the quote flag to determine whether this is the
; first or second quote found. if the first, set the quote
; flag, else reset it
LD A,(ARSFLG) ;/jump to reset the
BIT 1,A ;|quote flag
JR NZ,M25AC ;\
SET 1,A ;/no previous quote, so
LD (ARSFLG),A ;|set the flag and move on
JR M25B6 ;\to the next characters
M25AC: RES 1,A ;/reset the quote flag
LD (ARSFLG),A ;|and move on
JR M25B6 ;\
M25B3: POP BC ;restore BC
RET ;return to caller. HL and
;CHADD point to the next character
;to be interpreted
M25B5: POP HL ;restore the character pointer
M25B6: RST $20 ;get next char
JR M2573 ;back around to gobble more characters
;******************************************************************
; Module: SYNTWO
; Routine: PASSEM
;******************************************************************
PASSEM:
M25B9: LD BC,$FEFE ;enable the EXROM for chunk 0
CALL BANK_ENABLE ;BANK_ENABLE
CALL M0F09
LD BC,$FF00 ;enable the home ROM in all chunks
CALL BANK_ENABLE ;BANK_ENABLE
;******************************************************************
; Module: SYNTWO
; Routine: CAT
;******************************************************************
CAT:
LD B,$CF ;load B with "CAT" token
JR M25D6 ;jumps to error if interpreting
;******************************************************************
; Module: SYNTWO
; Routine: FORMAT
;******************************************************************
FORMAT:
LD B,$D0 ;load B with "FORMAT" token
JR M25D6 ;jumps to error if interpreting
;******************************************************************
; Module: SYNTWO
; Routine: MOVE
;******************************************************************
MOVE:
LD B,$D1 ;load B with "MOVE" token
JR M25D6 ;jumps to error if interpreting
;******************************************************************
; Module: SYNTWO
; Routine: ERASE
;******************************************************************
ERASE:
LD B,$D2 ;load B with "ERASE" token
M25D6: CALL INTPTQ ;/jump if interpreting
JR NZ,M25E1 ;\goes to error routine
CALL SKIPIT ;skip the rest of the line
CALL ENDQ ;returns here if interpreting
M25E1: JP M2567 ;error – INVALID IO DEVICE
LD BC,$000C ;offset into jump table
;CALL_BANK with HL pointing to a jump table, BC containing
; an offset into it and DE containing the bank and horiz sel
; respectively. the top of the FP stack at (STKEND) contains
; a byte with the number of parameters out expected
;
ADD HL,BC ;/
LD C,(HL) ;|get jump addresss
INC HL ;|
LD B,(HL) ;\
PUSH BC ;push address onto stack
PUSH DE ;push horiz sel and bank
LD HL,(STKEND) ;/
DEC HL ;|get the number of params out
LD C,(HL) ;|from CALL_BANK from the
INC C ;|free space
LD (STKEND),HL ;\
LD B,$00 ;/number of parameters out
PUSH BC ;\
LD BC,$0000 ;/no parameters in
PUSH BC ;\
CALL M65D0 ;CALL_BANK
RET
RST $08 ;/error – INVALID IO DEVICE
DEFB $12 ;\
;******************************************************************
; Module: GRAPHS
; Routine: SCRMBL
;******************************************************************
SCRMBL:
M2603: LD A,$AF
SUB B
JP C ,M2852
LD B,A
AND A
RRA
SCF
RRA
AND A
RRA
XOR B
AND $F8
XOR B
LD H,A
LD A,C
RLCA
RLCA
RLCA
XOR B
AND $C7
XOR B
RLCA
RLCA
LD L,A
LD A,C
AND $07
RET
;******************************************************************
; Module: GRAPHS
; Routine: F_PNT
;******************************************************************
F_PNT:
M2624: CALL M2660
CALL M2603
LD B,A
INC B
LD A,(HL)
M262D: RLCA
DJNZ M262D
AND $01
JP M30E6 ;stack A on calc stack
;******************************************************************
; Module: GRAPHS
; Routine: PLOT
;******************************************************************
PLOT:
M2635: CALL M2660
CALL M263E
JP DO_ATTS
;******************************************************************
; Module: GRAPHS
; Routine: PLOTBC
;******************************************************************
PLOTBC:
M263E: LD (XCOORD),BC
CALL M2603
LD B,A
INC B
LD A,$FE
M2649: RRCA
DJNZ M2649
LD B,A
LD A,(HL)
LD C,(IY+OPFLAG) ;PFLAG
BIT 0,C
JR NZ,M2656
AND B
M2656: BIT 2,C
JR NZ,M265C
XOR B
CPL
M265C: LD (HL),A
JP M0710
;******************************************************************
; Module: GRAPHS
; Routine: GET_XY
; return with X and Y in D and E and the sign of the numbers in
; B and C ($01 signifies positive, $FF signifies negative)
;******************************************************************
GET_XY:
M2660: CALL M266D ;get the first parameter
LD B,A ;save the number
PUSH BC ;save number (B) and the sign info (C)
CALL M266D ;get the second parameter
LD E,C ;load the sign info into E
POP BC ;get the first parameter back
LD D,C ;put the first parameter sign in D
LD C,A ;put the second parameter in C
RET
M266D: CALL FP2A ;get the top of the fp stack to A
JP C ,M2852 ;error B
LD C,$01 ;/return if if the number was positive
RET Z ;\
LD C,$FF ;indicate a negative value
RET
;******************************************************************
; Module: GRAPHS
; Routine: CIRCLE
;******************************************************************
CIRCLE:
RST $18 ;get current character
CP $2C
JP NZ,M1BED ;error – BAD BASIC
RST $20 ;get next char
CALL TEM6
CALL ENDQ
RST $28 ;calc entry
DEFB $2A ;ABS
DEFB $3D ;FLOAT
DEFB $38 ;QUIT
LD A,(HL)
CP $81
JR NC,M2694
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $38 ;QUIT
JR M2635
M2694: RST $28 ;calc entry
DEFB $A3 ;CONST 3 (PI/2)
DEFB $38 ;QUIT
LD (HL),$83
RST $28 ;calc entry
DEFB $C5 ;T -> MEM 5
DEFB $02 ;DROP
DEFB $38 ;QUIT
CALL M27D6
PUSH BC
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $E1 ;MEM 1 -> T
DEFB $04 ;TIMES
DEFB $38 ;QUIT
LD A,(HL)
CP $80
JR NC,M26B3
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $02 ;DROP
DEFB $38 ;QUIT
POP BC
JP M2635
M26B3: RST $28 ;calc entry
DEFB $C2 ;T -> MEM 2
DEFB $01 ;SWAP
DEFB $C0 ;T -> MEM 0
DEFB $02 ;DROP
DEFB $03 ;SUB
DEFB $01 ;SWAP
DEFB $E0 ;MEM 0 -> T
DEFB $0F ;ADD
DEFB $C0 ;T -> MEM 0
DEFB $01 ;SWAP
DEFB $31 ;DUP
DEFB $E0 ;MEM 0 -> T
DEFB $01 ;SWAP
DEFB $31 ;DUP
DEFB $E0 ;MEM 0 -> T
DEFB $A0 ;CONST 0 (0)
DEFB $C1 ;T -> MEM 1
DEFB $02 ;DROP
DEFB $38 ;QUIT
INC (IY+(MEM2-Y)) ;
CALL INS_U1
LD L,A
PUSH HL
CALL INS_U1
POP HL
LD H,A
LD (XCOORD),HL
POP BC
JP M2779
;******************************************************************
; Module: GRAPHS
; Routine: DRAW
;******************************************************************
DRAW:
RST $18 ;get current character
CP $2C
JR Z,M26E6
CALL ENDQ
JP M27D0
M26E6: RST $20 ;get next char
CALL TEM6
CALL ENDQ
RST $28 ;calc entry
DEFB $C5 ;T -> MEM 5
DEFB $A2 ;CONST 1 (0.5)
DEFB $04 ;TIMES
DEFB $1F ;SIN
DEFB $31 ;DUP
DEFB $30 ;NOT
DEFB $30 ;NOT
DEFB $00,$06 ;IFJUMP 26FC
DEFB $02 ;DROP
DEFB $38 ;QUIT
JP M27D0
RET NZ
LD (BC),A
POP BC
LD (BC),A
LD SP,$E12A
LD BC,$2AE1
RRCA
RET PO
DEC B
LD HL,($01E0)
DEC A
JR C,M278D
CP $81
JR NC,M271A
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $02 ;DROP
DEFB $38 ;QUIT
JP M27D0
M271A: CALL M27D6
PUSH BC
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $E1 ;MEM 1 -> T
DEFB $01 ;SWAP
DEFB $05 ;DIV
DEFB $C1 ;T -> MEM 1
DEFB $02 ;DROP
DEFB $01 ;SWAP
DEFB $31 ;DUP
DEFB $E1 ;MEM 1 -> T
DEFB $04 ;TIMES
DEFB $C2 ;T -> MEM 2
DEFB $02 ;DROP
DEFB $01 ;SWAP
DEFB $31 ;DUP
DEFB $E1 ;MEM 1 -> T
DEFB $04 ;TIMES
DEFB $E2 ;MEM 2 -> T
DEFB $E5 ;MEM 5 -> T
DEFB $E0 ;MEM 0 -> T
DEFB $03 ;SUB
DEFB $A2 ;CONST 1 (0.5)
DEFB $04 ;TIMES
DEFB $31 ;DUP
DEFB $1F ;SIN
DEFB $C5 ;T -> MEM 5
DEFB $02 ;DROP
DEFB $20 ;COS
DEFB $C0 ;T -> MEM 0
DEFB $02 ;DROP
DEFB $C2 ;T -> MEM 2
DEFB $02 ;DROP
DEFB $C1 ;T -> MEM 1
DEFB $E5 ;MEM 5 -> T
DEFB $04 ;TIMES
DEFB $E0 ;MEM 0 -> T
DEFB $E2 ;MEM 2 -> T
DEFB $04 ;TIMES
DEFB $0F ;ADD
DEFB $E1 ;MEM 1 -> T
DEFB $01 ;SWAP
DEFB $C1 ;T -> MEM 1
DEFB $02 ;DROP
DEFB $E0 ;MEM 0 -> T
DEFB $04 ;TIMES
DEFB $E2 ;MEM 2 -> T
DEFB $E5 ;MEM 5 -> T
DEFB $04 ;TIMES
DEFB $03 ;SUB
DEFB $C2 ;T -> MEM 2
DEFB $2A ;ABS
DEFB $E1 ;MEM 1 -> T
DEFB $2A ;ABS
DEFB $0F ;ADD
DEFB $02 ;DROP
DEFB $38 ;QUIT
LD A,(DE)
CP $81
POP BC
JP C ,M27D0
PUSH BC
RST $28 ;calc entry
DEFB $01 ;SWAP
DEFB $38 ;QUIT
LD A,(XCOORD)
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $C0 ;T -> MEM 0
DEFB $0F ;ADD
DEFB $01 ;SWAP
DEFB $38 ;QUIT
LD A,(YCOORD)
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $C5 ;T -> MEM 5
DEFB $0F ;ADD
DEFB $E0 ;MEM 0 -> T
DEFB $E5 ;MEM 5 -> T
DEFB $38 ;QUIT
POP BC
M2779: DEC B
JR Z,M27B8
JR M2792
M277E: RST $28 ;calc entry
DEFB $E1 ;MEM 1 -> T
DEFB $31 ;DUP
DEFB $E3 ;MEM 3 -> T
DEFB $04 ;TIMES
DEFB $E2 ;MEM 2 -> T
DEFB $E4 ;MEM 4 -> T
DEFB $04 ;TIMES
DEFB $03 ;SUB
DEFB $C1 ;T -> MEM 1
DEFB $02 ;DROP
DEFB $E4 ;MEM 4 -> T
DEFB $04 ;TIMES
DEFB $E2 ;MEM 2 -> T
DEFB $E3 ;MEM 3 -> T
M278D: DEFB $04 ;TIMES
DEFB $0F ;ADD
DEFB $C2 ;T -> MEM 2
DEFB $02 ;DROP
DEFB $38 ;QUIT
M2792: PUSH BC
RST $28 ;calc entry
DEFB $C0 ;T -> MEM 0
DEFB $02 ;DROP
DEFB $E1 ;MEM 1 -> T
DEFB $0F ;ADD
DEFB $31 ;DUP
DEFB $38 ;QUIT
LD A,(XCOORD)
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $03 ;SUB
DEFB $E0 ;MEM 0 -> T
DEFB $E2 ;MEM 2 -> T
DEFB $0F ;ADD
DEFB $C0 ;T -> MEM 0
DEFB $01 ;SWAP
DEFB $E0 ;MEM 0 -> T
DEFB $38 ;QUIT
LD A,(YCOORD)
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $03 ;SUB
DEFB $38 ;QUIT
CALL M2810
POP BC
DJNZ M277E
M27B8: RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $02 ;DROP
DEFB $01 ;SWAP
DEFB $38 ;QUIT
LD A,(XCOORD)
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $03 ;SUB
DEFB $01 ;SWAP
DEFB $38 ;QUIT
LD A,(YCOORD)
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $03 ;SUB
DEFB $38 ;QUIT
M27D0: CALL M2810
JP DO_ATTS
M27D6: RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $28 ;ROOT
DEFB $34,$32,$00 ;LITERAL 8200000000 ( 2),27DC
DEFB $01 ;SWAP
DEFB $05 ;DIV
DEFB $E5 ;MEM 5 -> T
DEFB $01 ;SWAP
DEFB $05 ;DIV
DEFB $2A ;ABS
DEFB $38 ;QUIT
CALL FP2A
JR C,M27EE
AND $FC
ADD A,$04
JR NC,M27F0
M27EE: LD A,$FC
M27F0: PUSH AF
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $E5 ;MEM 5 -> T
DEFB $01 ;SWAP
DEFB $05 ;DIV
DEFB $31 ;DUP
DEFB $1F ;SIN
DEFB $C4 ;T -> MEM 4
DEFB $02 ;DROP
DEFB $31 ;DUP
DEFB $A2 ;CONST 1 (0.5)
DEFB $04 ;TIMES
DEFB $1F ;SIN
DEFB $C1 ;T -> MEM 1
DEFB $01 ;SWAP
DEFB $C0 ;T -> MEM 0
DEFB $02 ;DROP
DEFB $31 ;DUP
DEFB $04 ;TIMES
DEFB $31 ;DUP
DEFB $0F ;ADD
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $1B ;NEGATE
DEFB $C3 ;T -> MEM 3
DEFB $02 ;DROP
DEFB $38 ;QUIT
POP BC
RET
;******************************************************************
; Module: GRAPHS
; Routine: DRAW_L
;******************************************************************
DRAW_L:
M2810: CALL M2660
;******************************************************************
; Module: GRAPHS
; Routine: DRAWLN
;******************************************************************
DRAWLN:
LD A,C
CP B
JR NC,M281D
LD L,C
PUSH DE
XOR A
LD E,A
JR M2824
M281D: OR C
RET Z
LD L,B
LD B,C
PUSH DE
LD D,$00
M2824: LD H,B
LD A,B
RRA
M2827: ADD A,L
JR C,M282D
CP H
JR C,M2834
M282D: SUB H
LD C,A
EXX
POP BC
PUSH BC
JR M2838
M2834: LD C,A
PUSH DE
EXX
POP BC
M2838: LD HL,(XCOORD)
LD A,B
ADD A,H
LD B,A
LD A,C
INC A
ADD A,L
JR C,M2850
JR Z,M2852
M2845: DEC A
LD C,A
CALL M263E
EXX
LD A,C
DJNZ M2827
POP DE
RET
M2850: JR Z,M2845
M2852: RST $08 ;error: INTEGER OUT OF RANGE
DEFB $0A ;
;******************************************************************
; Module: EXPRN
; Routine: EXPRN
; evaluate an expression
;******************************************************************
EXPRN:
M2854: RST $18 ;get current character into A
LD B,$00 ;/save C
PUSH BC ;\
;this will search the table at M294C for the character in A. if
; the operator or token is found, the routine will jump to the
; handler for it.
M2858: LD C,A ;/
LD HL,M294C ;|find C at (HL)
CALL SEARCH ;\
LD A,C ;restore the character to A
JP NC,M2A42 ;jump if item not found
LD B,$00 ;/get offset value
LD C,(HL) ;\
ADD HL,BC ;/form target address and
JP (HL) ;\jump to it
M2868: CALL NEXTCH ;get the next character
INC BC ;
CP $0D ;/can’t be newline
JP Z ,M1BED ;\error – BAD BASIC
CP $22 ;/jump if not quote
JR NZ,M2868 ;\
CALL NEXTCH ;get the next character
CP $22 ;compare to quote
RET ;
M287B: RST $20 ;get next char with filtering
CP ‘(‘ ;/jump if not open paren
JR NZ,M2886 ;\
CALL DYADIC ;evaluate the next comma delimited pair
; or parameters
RST $18 ;get current character
CP ‘)’ ;/jump if not close paren
M2886: JP NZ,M1BED ;\error – BAD BASIC
;******************************************************************
; Module: EXPRN
; Routine: INPT?
; checks the interpret flag
; returns ZF=1 if syntax check, ZF = 0 if interpreting statement
; (condition NZ if interpreting)
;******************************************************************
INTPTQ:
M2889: BIT 7,(IY+OFLAGS) ;FLAGS
RET
;******************************************************************
; Module: EXPRN
; Routine: F_SCRN
;******************************************************************
F_SCRN:
M288E: CALL M2660 ;get the x and y screen coords
LD HL,(CHARS) ;get the pointer to the character bit map table
LD DE,$0100 ;point to the bit map
ADD HL,DE ;point to the position in the
LD A,C ;
RRCA ;
RRCA ;
RRCA ;
AND $E0 ;
XOR B ;
LD E,A ;
LD A,C ;
AND $18 ;
XOR $40
LD D,A
LD B,$60
M28A8: PUSH BC
PUSH DE
PUSH HL
LD A,(DE)
XOR (HL)
JR Z,M28B3
INC A
JR NZ,M28CC
DEC A
M28B3: LD C,A
LD B,$07
M28B6: INC D
INC HL
LD A,(DE)
XOR (HL)
XOR C
JR NZ,M28CC
DJNZ M28B6
POP BC
POP BC
POP BC
LD A,$80
SUB B
LD BC,$0001
RST $30
LD (DE),A
JR M28D6
M28CC: POP HL
LD DE,$0008
ADD HL,DE
POP DE
POP BC
DJNZ M28A8
LD C,B
M28D6: RET
;******************************************************************
; Module: EXPRN
; Routine: F_ATTR
;******************************************************************
F_ATTR:
M28D7: CALL M2660
LD A,C
RRCA
RRCA
RRCA
LD C,A
AND $E0
XOR B
LD L,A
LD A,C
AND $03
XOR $58
LD H,A
LD A,(HL)
JP M30E6 ;stack A on calc stack
CALL INTPTQ ;/jump if interpreting
JR Z,M28F5 ;\
RST $28 ;calc entry
DEFB $A3 ;CONST 3 (PI/2)
DEFB $38 ;QUIT
M28F5: JP M2A81
M28F8: CALL M287B
CALL NZ,M2902
RST $20 ;get next char
M28FF: JP M2A81
M2902: CALL M2660
LD A,B
CALL M292B
LD A,C
CALL M292B
LD D,C
LD A,$0E
OUT ($F5),A
LD C,$F6
IN A,(C)
CPL
LD B,D
DJNZ M2926
AND $0F
CP $0F
JR C,M2922
AND $00
M2922: CALL M30E6 ;stack A on calc stack
RET
M2926: RLCA
AND $01
M2929: JR M2922
M292B: SUB $02
ADC A,$00
JR NZ,M2932
RET
M2932: RST $08 ;error: INVALID ARGUMENT
DEFB $09 ;
M2934: CALL INTPTQ ;/jump if syntax checking
JR Z,M2948 ;\
M2939: LD HL,(RAMTOP)
LD DE,(STKEND)
AND A
SBC HL,DE
LD C,L
LD B,H
CALL STK_BC
M2948: RST $20 ;get next char
JP M2A81
M294C: DEFB $22 ;QUOTE
DEFB $24 ;(2971-$) AND $00FF *
DEFB ‘(‘ ;
DEFB $57 ;(29A6-$) AND $00FF *
DEFB ‘.’ ;
DEFB $FA ;(2A4B-$) AND $00FF *
DEFB ‘+’ ;
DEFB $1A ;(296D-$) AND $00FF *
DEFB $7C ;SOUND or }
DEFB $16 ;(296B-$) AND $00FF *
DEFB $7E ;FREE
DEFB $12 ;(2969-$) AND $00FF *
DEFB $A8 ;FN
DEFB $5A ;(29B3-$) AND $00FF *
DEFB $A5 ;RND
DEFB $5B ;(29B6-$) AND $00FF *
DEFB $A7 ;PI
DEFB $88 ;(F_PI-$) AND $00FF *
DEFB $A6 ;INKEY$
DEFB $93 ;(F_INKEY-$) AND $00FF
DEFB $C4 ;BIN
DEFB $EA ;(2A4B-$) AND $00FF *
DEFB $AA ;SCREEN$
DEFB $C3 ;(2A26-$) AND $00FF *
DEFB $AB ;ATTR
DEFB $CB ;(2A30-$) AND $00FF *
DEFB $A9 ;POINT
DEFB $D2 ;(2A39-$) AND $00FF *
DEFB $00 ;end of table
M2969: JR M2934
M296B: JR M28F8
M296D: RST $20 ;get next char
M296E: JP M2858
M2971: RST $18 ;get current character
INC HL
PUSH HL
M2975: LD BC,$0000
CALL M2868
; DEFB $CD,$68,$28
JR NZ,M2997
M297C: CALL M2868
JR Z,M297C
CALL INTPTQ ;/jump if syntax checking
JR Z,M2997 ;\
RST $30
POP HL
PUSH DE
M2989: LD A,(HL)
INC HL
LD (DE),A
INC DE
CP $22
JR NZ,M2989
LD A,(HL)
INC HL
CP $22
JR Z,M2989
M2997: DEC BC
POP DE
M2999: LD HL,FLAGS
RES 6,(HL)
BIT 7,(HL)
CALL NZ,M2E70
JP M2AD0
M29A6: RST $20 ;get next char
CALL EXPRN
CP $29
JP NZ,M1BED ;error – BAD BASIC
RST $20 ;get next char
JP M2AD0
; JP M2B7B
M29B3: DEFB $C3,$7B,$2B
;******************************************************************
; Module: EXPRN
; Routine: RND
;******************************************************************
RND:
CALL INTPTQ ;/jump if syntax checking
JR Z,M29E3 ;\
LD BC,(SEED)
CALL STK_BC
RST $28 ;calc entry
DEFB $A1 ;CONST 1 (256)
DEFB $0F ;ADD
DEFB $34,$37,$16 ;LITERAL 8716000000 ( 75),29C8
DEFB $04 ;TIMES
DEFB $34,$80,$41,$00,$00,$80 ;LITERAL 9100008000 ( 65537),29CF
DEFB $32 ;INTDIV
DEFB $02 ;DROP
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $31 ;DUP
DEFB $38 ;QUIT
CALL FP2BC
LD (SEED),BC
LD A,(HL)
AND A
JR Z,M29E3
SUB $10
LD (HL),A
M29E3: JR M29EE
;******************************************************************
; Module: EXPRN
; Routine: F_PI
;******************************************************************
F_PI:
CALL INTPTQ ;/jump if syntax checking
JR Z,M29EE ;\
RST $28 ;calc entry
DEFB $A3 ;CONST 3 (PI/2)
DEFB $38 ;QUIT
INC (HL)
M29EE: RST $20 ;get next char
JP M2A81
;******************************************************************
; Module: EXPRN
; Routine: F_INKY
;******************************************************************
F_INKY:
LD BC,$105A
RST $20 ;get next char
CP $23
JP Z ,M2ACB
LD HL,FLAGS
RES 6,(HL)
BIT 7,(HL)
JR Z,M2A23
CALL M02B0
LD C,$00
JR NZ,M2A1E
CALL M035C
JR NC,M2A1E
DEC D
LD E,A
CALL M0371
PUSH AF
LD BC,$0001
RST $30
POP AF
LD (DE),A
LD C,$01
M2A1E: LD B,$00
CALL M2E70
M2A23: JP M2AD0
M2A26: CALL M287B
CALL NZ,M288E
RST $20 ;get next char
JP M2999
M2A30: CALL M287B
CALL NZ,M28D7
RST $20 ;get next char
JR M2A81
M2A39: CALL M287B
CALL NZ,M2624
RST $20 ;get next char
JR M2A81
M2A42: CALL ALNUMQ ;/jump if A was not
JR NC,M2A9D ;\ alphanumeric
CP ‘A’ ;/jump if a letter
JR NC,M2A87 ;\
M2A4B: CALL INTPTQ ;/jump if interpreting
JR NZ,M2A73 ;\
CALL M3059
RST $18 ;get current character
LD BC,$0006 ;/open a space for a floating point
CALL INSERT ;\ number
INC HL ;/drop in the number slug
LD (HL),$0E ;\
INC HL ;/
EX DE,HL ;|
LD HL,(STKEND) ;|transfer in the fp number
LD C,$05 ;|
AND A ;|
SBC HL,BC ;|
LD (STKEND),HL ;|
LDIR ;\
EX DE,HL
DEC HL ;point back to the last byte of the fp number
CALL M0077 ;get the byte at ++HL
JR M2A81 ;jump to indicate a numeric result
;
;step over the ASCII digits of a number until the
; slug character is reached
M2A73: RST $18 ;get current character
;(RST $18 puts CHADD into HL)
M2A74: INC HL ;/
LD A,(HL) ;|loop until then number
CP $0E ;|slug is found
JR NZ,M2A74 ;\
INC HL ;point to the fp number
CALL STK_M ;stack the fp value at (HL)
LD (CHADD),HL ;update CHADD
M2A81: SET NUM,(IY+OFLAGS) ;indicate a number result
JR M2A9B
M2A87: CALL FIND_N ;find a variable in the variables area
JP C ,M1B91 ;
CALL Z ,M2D54
LD A,(FLAGS)
CP $C0
JR C,M2A9B
INC HL
CALL STK_M
M2A9B: JR M2AD0
M2A9D: LD BC,$09DB
CP $2D
JR Z,M2ACB
LD BC,$1018
CP $AE
JR Z,M2ACB
SUB $AF
JP C ,M1BED ;error – BAD BASIC
LD BC,$04F0
CP $14
JR Z,M2ACB
JP NC,M1BED ;error – BAD BASIC
LD B,$10
ADD A,$DC
LD C,A
CP $DF
JR NC,M2AC5
RES 6,C
M2AC5: CP $EE
JR C,M2ACB
RES 7,C
M2ACB: PUSH BC
RST $20 ;get next char
JP M2858
M2AD0: RST $18 ;get current character
M2AD1: CP $28
JR NZ,M2AE1
BIT 6,(IY+OFLAGS) ;FLAGS
JR NZ,M2AF2
CALL M2E10
RST $20 ;get next char
JR M2AD1
M2AE1: LD B,$00
LD C,A
LD HL,OPTBL
CALL SEARCH
JR NC,M2AF2
LD C,(HL)
LD HL,OPPRI-$C3
ADD HL,BC
LD B,(HL)
M2AF2: POP DE
LD A,D
CP B
JR C,M2B31
AND A
JP Z ,M0018
PUSH BC
LD HL,FLAGS
LD A,E
CP $ED
JR NZ,M2B0A
BIT 6,(HL)
JR NZ,M2B0A
LD E,$99
M2B0A: PUSH DE
CALL INTPTQ ;/jump if syntax checking
JR Z,M2B19 ;\
LD A,E
AND $3F
LD B,A
RST $28 ;calc entry
DEFB $3B ;XEQTB
DEFB $38 ;QUIT
JR M2B22
M2B19: LD A,E
XOR (IY+OFLAGS) ;FLAGS
AND $40
M2B1F: JP NZ,M1BED ;error – BAD BASIC
M2B22: POP DE
LD HL,FLAGS
SET 6,(HL)
BIT 7,E
JR NZ,M2B2E
RES 6,(HL)
M2B2E: POP BC
JR M2AF2
M2B31: PUSH DE
LD A,C
BIT 6,(IY+OFLAGS) ;FLAGS
JR NZ,M2B4E
AND $3F
ADD A,$08
LD C,A
CP $10
JR NZ,M2B46
SET 6,C
JR M2B4E
M2B46: JR C,M2B1F
CP $17
JR Z,M2B4E
SET 7,C
M2B4E: PUSH BC
RST $20 ;get next char
JP M2858
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
OPTBL: DEFB ‘+’ ;ADD
DEFB $CF ;2B7A
DEFB ‘-‘ ;SUBTRACT
DEFB $C3 ;2B6E
DEFB ‘*’ ;MULTIPLY
DEFB $C4 ;2B6F
DEFB ‘/’ ;DIVIDE
DEFB $C5 ;2B70
DEFB ‘^’ ;POWER
DEFB $C6 ;2B71
DEFB ‘=’ ;EQUALS
DEFB $CE ;2B79
DEFB ‘>’ ;GREATER THAN
DEFB $CC ;2B77
DEFB ‘<‘ ;LESS THAN
DEFB $CD ;2B78
DEFB $C7 ;<=
DEFB $C9 ;2B74
DEFB $C8 ;>=
DEFB $CA ;2B75
DEFB $C9 ;<>
DEFB $CB ;2B76
DEFB $C5 ;OR
DEFB $C7 ;2B72
DEFB $C6 ;AND
DEFB $C8 ;2B73
DEFB $00
;operation priority table
OPPRI: DEFB $06
DEFB $08
DEFB $08
DEFB $0A
DEFB $02
DEFB $03
DEFB $05
DEFB $05
DEFB $05
DEFB $05
DEFB $05
DEFB $05
DEFB $06
;was M29B3
M2B7B: CALL INTPTQ ;/jump if not syntax checking
JR NZ,M2BB5 ;\
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
M2B80: RST $20 ;get next char
CALL ALPHAQ
JP NC,M1BED ;error – BAD BASIC
RST $20 ;get next char
CP $24
PUSH AF
JR NZ,M2B8E
RST $20 ;get next char
M2B8E: CP $28
JR NZ,M2BA4
RST $20 ;get next char
CP $29
JR Z,M2BA7
M2B97: CALL EXPRN
RST $18 ;get current character
CP $2C
JR NZ,M2BA2
M2B9F: RST $20 ;get next char
JR M2B97
M2BA2: CP $29
M2BA4: JP NZ,M1BED ;error – BAD BASIC
M2BA7: RST $20 ;get next char
LD HL,FLAGS
M2BAB: RES 6,(HL)
POP AF
JR Z,M2BB2
SET 6,(HL)
M2BB2: JP M2AD0
M2BB5: RST $20 ;get next char
AND $DF
M2BB8: LD B,A
RST $20 ;get next char
SUB $24
LD C,A
JR NZ,M2BC0
RST $20 ;get next char
M2BC0: RST $20 ;get next char
PUSH HL
LD HL,(PROG)
DEC HL
M2BC6: LD DE,$00CE
PUSH BC
CALL M1D28
POP BC
JR NC,M2BD2
RST $08 ;error: FN WITHOUT DEF FN
DEFB $18 ;
M2BD2: PUSH HL
CALL M2C69
AND $DF
CP B
JR NZ,M2BE3
CALL M2C69
SUB $24
CP C
JR Z,M2BEF
M2BE3: POP HL
DEC HL
LD DE,$0200
PUSH BC
CALL SUBLIN1
POP BC
JR M2BC6
M2BEF: AND A
CALL Z ,M2C69
POP DE
POP DE
LD (CHADD),DE
CALL M2C69
PUSH HL
CP $29
JR Z,M2C43
M2C01: INC HL
LD A,(HL)
CP $0E
LD D,$40
JR Z,M2C10
DEC HL
CALL M2C69
INC HL
LD D,$00
M2C10: INC HL
PUSH HL
PUSH DE
CALL EXPRN
POP AF
XOR (IY+OFLAGS) ;FLAGS
AND $40
JR NZ,M2C49
POP HL
EX DE,HL
LD HL,(STKEND)
LD BC,$0005
SBC HL,BC
LD (STKEND),HL
LDIR
EX DE,HL
DEC HL
CALL M2C69
CP $29
JR Z,M2C43
PUSH HL
RST $18 ;get current character
CP $2C
JR NZ,M2C49
RST $20 ;get next char
POP HL
CALL M2C69
JR M2C01
M2C43: PUSH HL
RST $18 ;get current character
CP $29
JR Z,M2C4B
M2C49: RST $08 ;error: PARAMETER ERROR
DEFB $19 ;
M2C4B: POP DE
EX DE,HL
LD (CHADD),HL
LD HL,(DEFADD)
EX (SP),HL
LD (DEFADD),HL
PUSH DE
RST $20 ;get next char
RST $20 ;get next char
CALL EXPRN
POP HL
LD (CHADD),HL
POP HL
LD (DEFADD),HL
RST $20 ;get next char
JP M2AD0
;******************************************************************
; Module: EXPRN
; Routine: NXT_HL
;******************************************************************
NXT_HL:
M2C69: INC HL
LD A,(HL)
CP $21
JR C,M2C69
RET
;******************************************************************
; Module: IDENT
; Routine: FIND_N
; find a number in the FP variables area
; ENTER: HL = pointer to the first character of the variable name
;
; EXIT: CHADD points to the first character after the variable
; name as it occurs in the BASIC line.
; if no matching name was found:
; 1. the carry flag is set
; 2. the zero flag is set when the search was for an array variable
; 3. HL points to the first letter of the variable name
; if the search found a match:
; 1. the carry flag is reset
; 2. the zero flag is set for both simple string variables and
; all array variables.
; 3. HL points to the letter of a single letter variable name or
; the last character of a multi variable name as it appears
; in the variable list
; bit 6 of the C register is reset when dealing with an array of
; numbers and set when dealing with an array of strings
; bit 7 of C is reset during line execution and set during syntax
; checking
;
;******************************************************************
FIND_N:
M2C70: SET 6,(IY+OFLAGS) ;FLAGS
RST $18 ;get current character
CALL ALPHAQ ;/jump if not a letter
JP NC,M1BED ;\error – BAD BASIC
PUSH HL ;save the pointer to the first letter
AND $1F ;make it lower case
LD C,A ;put letter in c
RST $20 ;get next char
PUSH HL ;save the pointer to the second char
CP ‘(‘ ;/jump if an array
JR Z,M2CAD ;\
SET 6,C ;set bit 6
CP ‘$’ ;/jump if a string
JR Z,M2C9C ;\
SET 5,C ;set bit 5
CALL ALNUMQ ;/jump if not alphanumeric
JR NC,M2CA1 ;\
M2C92: CALL ALNUMQ ;/
JR NC,M2CAD ;\
RES 6,C ;
RST $20 ;get next char
JR M2C92
;start handling strings here
M2C9C: RST $20 ;get next char
RES NUM,(IY+OFLAGS) ;indicate a string result
M2CA1: LD A,(DEFADD+1) ;get high byte of DEF FN argument
AND A ;/jump if no argument present
JR Z,M2CAD ;\
CALL INTPTQ ;/jump if interpreting
JP NZ,M2D0F ;\
;start looking for the variable
M2CAD: LD B,C ;put character in B
CALL INTPTQ ;/jump if interpeting
JR NZ,M2CBB ;\
LD A,C ;put the var name into A
AND $E0 ;keep the type bits
SET 7,A ;ensure bit 7 is set
LD C,A ;put it back into C
JR M2CF2 ;jump fwd for syntax checking
M2CBB: LD HL,(VARS) ;point to the variables region
M2CBE: LD A,(HL) ;get the first byte of the variable
; name
AND $7F ;/jump if we found the $80
JR Z,M2CF0 ;\sentinal at the end of the vars region
CP C ;/jump if this is not the name
JR NZ,M2CE8 ;\ for which we are looking for
RLA ;/rotate and double to test
ADD A,A ;\for different variable types
JP P ,M2CFD ;strings and arrays
JR C,M2CFD ;simple numeric and FOR-NEXT
POP DE ;get the pointer to the 2nd char
PUSH DE ;save it again
PUSH HL ;save the variable pointer
M2CD0: INC HL ;look at the next character
M2CD1: LD A,(DE) ;point to the next character
INC DE ;and get it
CP ‘ ‘ ;/ignore spaces
JR Z,M2CD1 ;\
OR $20 ;ensure lower case (cheap and nasty, but works)
CP (HL) ;/we matched, so keep looking
JR Z,M2CD0 ;\ at the name
OR $80 ;/see if maybe it is the last letter
CP (HL) ;\of a multi-letter name…
JR NZ,M2CE7 ;nope, so move on
LD A,(DE) ;get the next character
CALL ALNUMQ ;/jump if not alpha-num
JR NC,M2CFC ;\
M2CE7: POP HL ;fetch the variable pointer
M2CE8: PUSH BC ;briefly save BC
CALL RECLEN ;move past the present variable
EX DE,HL ;get the pointer back into HL
POP BC ;restore BC
JR M2CBE ;back around for another
M2CF0: SET 7,B ;tell the world no variable was found
M2CF2: POP DE ;trash the pointer to the 2nd character
RST $18 ;get current character
CP ‘(‘ ;/
JR Z,M2D01 ;\
SET 5,B ;indicate not an array
JR M2D09 ;
M2CFC: POP DE ;trash the saved variable pointer
M2CFD: POP DE ;drop the second char pointer
POP DE ;drop the first letter pointer
PUSH HL ;save the last letter pointer
RST $18 ;get current character
;move past the characters in a multi-character name
M2D01: CALL ALNUMQ ;/jump when we have reached the
JR NC,M2D09 ;\last character (bit 7 set)
RST $20 ;get next char
JR M2D01 ;back to test it
M2D09: POP HL ;HL now points to the first or
; last character
RL B ;
BIT 6,B ;
RET ;done
M2D0F: LD HL,(DEFADD)
LD A,(HL)
CP $29
JP Z ,M2CAD
M2D18: LD A,(HL)
OR $60
LD B,A
INC HL
LD A,(HL)
CP $0E
JR Z,M2D29
DEC HL
CALL M2C69
INC HL
RES 5,B
M2D29: LD A,B
CP C
JR Z,M2D3F
INC HL
INC HL
INC HL
INC HL
INC HL
CALL M2C69
CP $29
JP Z ,M2CAD
CALL M2C69
JR M2D18
M2D3F: BIT 5,C
JR NZ,M2D4F
INC HL
LD DE,(STKEND)
CALL M377F
EX DE,HL
LD (STKEND),HL
M2D4F: POP DE
POP DE
XOR A
INC A
RET
;******************************************************************
; Module: IDENT
; Routine: GET_EL
;******************************************************************
GET_EL:
M2D54: XOR A
LD B,A
BIT 7,C
JR NZ,M2DA5
BIT 7,(HL)
JR NZ,M2D6C
INC A
M2D5F: INC HL
LD C,(HL)
INC HL
LD B,(HL)
INC HL
EX DE,HL
CALL M2E70
RST $18 ;get current character
JP M2E07
M2D6C: INC HL
INC HL
INC HL
LD B,(HL)
BIT 6,C
JR Z,M2D7E
DEC B
JR Z,M2D5F
EX DE,HL
RST $18 ;get current character
CP $28
JR NZ,M2DDE
EX DE,HL
M2D7E: EX DE,HL
JR M2DA5
M2D81: PUSH HL
RST $18 ;get current character
POP HL
CP $2C
JR Z,M2DA8
BIT 7,C
JR Z,M2DDE
BIT 6,C
JR NZ,M2D96
CP $29
JR NZ,M2DD0
RST $20 ;get next char
RET
M2D96: CP $29
JR Z,M2E06
CP $CC
JR NZ,M2DD0
M2D9E: RST $18 ;get current character
DEC HL
LD (CHADD),HL
JR M2E03
M2DA5: LD HL,$0000
M2DA8: PUSH HL
RST $20 ;get next char
POP HL
LD A,C
CP $C0
JR NZ,M2DB9
RST $18 ;get current character
CP $29
JR Z,M2E06
CP $CC
JR Z,M2D9E
M2DB9: PUSH BC
PUSH HL
CALL M2EAC
EX (SP),HL
EX DE,HL
CALL M2E8A
JR C,M2DDE
DEC BC
CALL M2EB2
ADD HL,BC
POP DE
POP BC
DJNZ M2D81
BIT 7,C
M2DD0: JR NZ,M2E38
PUSH HL
BIT 6,C
JR NZ,M2DEA
LD B,D
LD C,E
RST $18 ;get current character
CP $29
JR Z,M2DE0
M2DDE: RST $08 ;error: SUBSCRIPT WRONG
DEFB $02 ;
M2DE0: RST $20 ;get next char
POP HL
LD DE,$0005
CALL M2EB2
ADD HL,BC
RET
M2DEA: CALL M2EAC
EX (SP),HL
CALL M2EB2
POP BC
ADD HL,BC
INC HL
LD B,D
LD C,E
EX DE,HL
CALL M2E6F
RST $18 ;get current character
CP $29
JR Z,M2E06
CP $2C
JR NZ,M2DDE
M2E03: CALL M2E10
M2E06: RST $20 ;get next char
M2E07: CP $28
JR Z,M2E03
RES 6,(IY+OFLAGS) ;FLAGS
RET
;******************************************************************
; Module: IDENT
; Routine: SLICER
;******************************************************************
SLICER:
M2E10: CALL INTPTQ ;/call if interpreting
CALL NZ,PGPSTR ;\
RST $20 ;get next char
CP $29
JR Z,M2E6B
PUSH DE
XOR A
PUSH AF
PUSH BC
LD DE,$0001
RST $18 ;get current character
POP HL
CP $CC
JR Z,M2E3F
POP AF
CALL M2E8B
PUSH AF
LD D,B
LD E,C
PUSH HL
RST $18 ;get current character
POP HL
CP $CC
JR Z,M2E3F
CP $29
M2E38: JP NZ,M1BED ;error – BAD BASIC
LD H,D
LD L,E
JR M2E52
M2E3F: PUSH HL
RST $20 ;get next char
POP HL
CP $29
JR Z,M2E52
POP AF
CALL M2E8B
PUSH AF
RST $18 ;get current character
LD H,B
LD L,C
CP $29
JR NZ,M2E38
M2E52: POP AF
EX (SP),HL
ADD HL,DE
DEC HL
EX (SP),HL
AND A
SBC HL,DE
LD BC,$0000
JR C,M2E66
INC HL
AND A
JP M ,M2DDE
LD B,H
LD C,L
M2E66: POP DE
RES 6,(IY+OFLAGS) ;FLAGS
M2E6B: CALL INTPTQ ;/return if syntax checking
RET Z ;\
M2E6F: XOR A
;******************************************************************
; Module: IDENT
; Routine: PSHSTR
;******************************************************************
PSHSTR:
M2E70: RES 6,(IY+OFLAGS) ;FLAGS
;******************************************************************
; Module: IDENT
; Routine: PAEDCB
; stack AEDCB onto the fp stack
;******************************************************************
PAEDCB:
M2E74: PUSH BC ;save BC briefly
CALL ROOMQ ;determine if enough memory for one fp number
POP BC ;restore BC
LD HL,(STKEND) ;get pointer to the top of the FP stack
LD (HL),A ;/
INC HL ;|
LD (HL),E ;|
INC HL ;|put the registers on the
LD (HL),D ;|fp stack
INC HL ;|
LD (HL),C ;|
INC HL ;|
LD (HL),B ;|
INC HL ;\
LD (STKEND),HL ;update fp stack pointer
M2E89: RET ;done
M2E8A: XOR A ;
M2E8B: PUSH DE
PUSH HL
PUSH AF
CALL TEM6
POP AF
CALL INTPTQ ;/jump if syntax checking
JR Z,M2EA9 ;\
PUSH AF
CALL FIX_U
POP DE
LD A,B
OR C
SCF
JR Z,M2EA6
POP HL
PUSH HL
AND A
SBC HL,BC
M2EA6: LD A,D
SBC A,$00
M2EA9: POP HL
POP DE
RET
M2EAC: EX DE,HL
INC HL
LD E,(HL)
INC HL
LD D,(HL)
RET
M2EB2: CALL INTPTQ ;/return if syntax checking
RET Z ;\
CALL M3468
JP C ,M1FCF
RET
;******************************************************************
; Module: IDENT
; Routine: LET
;******************************************************************
LET:
M2EBD: LD HL,(DEST)
BIT 1,(IY+OFLAGX) ;FLAGX
JR Z,M2F24
LD BC,$0005
M2EC9: INC BC
M2ECA: INC HL
LD A,(HL)
CP $20
JR Z,M2ECA
JR NC,M2EDD
CP $10
JR C,M2EE7
CP $16
JR NC,M2EE7
INC HL
JR M2ECA
M2EDD: CALL ALNUMQ
JR C,M2EC9
CP $24
JP Z ,M2F7E
M2EE7: LD A,C
LD HL,(ELINE)
DEC HL
CALL INSERT
INC HL
INC HL
EX DE,HL
PUSH DE
LD HL,(DEST)
DEC DE
SUB $06
LD B,A
JR Z,M2F0D
M2EFC: INC HL
LD A,(HL)
CP $21
JR C,M2EFC
OR $20
INC DE
LD (DE),A
DJNZ M2EFC
OR $80
LD (DE),A
LD A,$C0
M2F0D: LD HL,(DEST)
XOR (HL)
OR $20
POP HL
CALL M2FA8
M2F17: PUSH HL
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $38 ;QUIT
POP HL
LD BC,$0005
AND A
SBC HL,BC
JR M2F64
M2F24: BIT 6,(IY+OFLAGS) ;FLAGS
JR Z,M2F30
LD DE,$0006
ADD HL,DE
JR M2F17
M2F30: LD HL,(DEST)
LD BC,(STRLEN)
BIT 0,(IY+OFLAGX) ;FLAGX
JR NZ,M2F6D
LD A,B
OR C
RET Z
PUSH HL
RST $30
PUSH DE
PUSH BC
LD D,H
LD E,L
INC HL
LD (HL),$20
LDDR
PUSH HL
CALL PGPSTR
POP HL
EX (SP),HL
AND A
SBC HL,BC
ADD HL,BC
JR NC,M2F59
LD B,H
LD C,L
M2F59: EX (SP),HL
EX DE,HL
LD A,B
OR C
JR Z,M2F61
LDIR
M2F61: POP BC
POP DE
POP HL
M2F64: EX DE,HL
LD A,B
OR C
RET Z
PUSH DE
LDIR
POP HL
RET
M2F6D: DEC HL
DEC HL
DEC HL
LD A,(HL)
PUSH HL
PUSH BC
CALL M2F84
POP BC
POP HL
INC BC
INC BC
INC BC
JP DELREC
M2F7E: LD A,$DF
LD HL,(DEST)
AND (HL)
M2F84: PUSH AF
CALL PGPSTR
EX DE,HL
ADD HL,BC
PUSH BC
DEC HL
LD (DEST),HL
INC BC
INC BC
INC BC
LD HL,(ELINE)
DEC HL
CALL INSERT
LD HL,(DEST)
POP BC
PUSH BC
INC BC
LDDR
EX DE,HL
INC HL
POP BC
LD (HL),B
DEC HL
LD (HL),C
POP AF
M2FA8: DEC HL
LD (HL),A
LD HL,(ELINE)
DEC HL
RET
;******************************************************************
; Module: IDENT
; Routine: PGPSTR
; pop BC, DE, and A from the FP stack
;******************************************************************
PGPSTR:
M2FAF: LD HL,(STKEND) ;get end of FP stack
DEC HL ;point to the byte
LD B,(HL) ;/
DEC HL ;|get a string length
LD C,(HL) ;\
DEC HL ;/
LD D,(HL) ;|get a string’s location
DEC HL ;|
LD E,(HL) ;\
DEC HL ;/unused byte for strings
LD A,(HL) ;\
LD (STKEND),HL ;save the new STKEND
RET ;
;******************************************************************
; Module: IDENT
; Routine: DIM
;******************************************************************
DIM:
CALL FIND_N ;/jump if array not found
M2FC3: JP NZ,M1BED ;\error – BAD BASIC
CALL INTPTQ ;/jump if interpreting
JR NZ,M2FD3 ;\
RES 6,C
CALL M2D54
CALL ENDQ
M2FD3: JR C,M2FDD
PUSH BC
CALL RECLEN
CALL DELREC
POP BC
M2FDD: SET 7,C
LD B,$00
PUSH BC
LD HL,$0001
BIT 6,C
JR NZ,M2FEB
LD L,$05
M2FEB: EX DE,HL
M2FEC: RST $20 ;get next char
LD H,$FF
CALL M2E8A
JP C ,M2DDE
POP HL
PUSH BC
INC H
PUSH HL
LD H,B
LD L,C
CALL M2EB2
EX DE,HL
RST $18 ;get current character
CP $2C
JR Z,M2FEC
CP $29
JR NZ,M2FC3
RST $20 ;get next char
POP BC
LD A,C
LD L,B
LD H,$00
INC HL
INC HL
ADD HL,HL
ADD HL,DE
JP C ,M1FCF
PUSH DE
PUSH BC
PUSH HL
LD B,H
LD C,L
LD HL,(ELINE)
DEC HL
CALL INSERT
INC HL
LD (HL),A
POP BC
DEC BC
DEC BC
DEC BC
INC HL
LD (HL),C
INC HL
LD (HL),B
POP BC
LD A,B
INC HL
LD (HL),A
LD H,D
LD L,E
DEC DE
LD (HL),$00
BIT 6,C
JR Z,M303A
LD (HL),$20
M303A: POP BC
LDDR
M303D: POP BC
LD (HL),B
DEC HL
LD (HL),C
DEC HL
DEC A
JR NZ,M303D
RET
;******************************************************************
; Module: IDENT
; Routine: ALNUMQ
; return with carry set if the character in A is
; an digit or a letter.
;******************************************************************
ALNUMQ:
M3046: CALL DIGITQ ;/return if char was a
CCF ;|digit
RET C ;\
;******************************************************************
; Module: IDENT
; Routine: ALPHAQ
; return with carry set if an alpha character
;******************************************************************
ALPHAQ:
M304B: CP ‘A’ ;/return with carry
CCF ;|reset – not a digit
RET NC ;\
CP ‘[‘ ;/character was in
RET C ;\A..Z so return with carry set
CP ‘a’ ;/below "a" so return
CCF ;|
RET NC ;\
CP ‘{‘ ;/character was in
RET ;\a..z so return
;******************************************************************
; Module: INOUT
; Routine: STKUSN
; stack a binary number onto the fp stack
;******************************************************************
STKUSN:
M3059: CP $C4 ;/jump if not BINary number
JR NZ,M3076 ;\
LD DE,$0000 ;initialize the accumulator
M3060: RST $20 ;get next char
SUB ‘1’ ;/this forces A to be zero for a "1"
ADC A,$00 ;\ and one for a "0"
JR NZ,M3071 ;jump if character was not a "1" or "0"
EX DE,HL ;/
CCF ;|carry will be 1 for 1 and 0 for 0
ADC HL,HL ;\transfer the "1" into the accumulator
JP C ,ERR6 ;number too big
EX DE,HL ;put accum back into DE and char ptr into HL
JR M3060 ;back around for the next digit
M3071: LD B,D ;/
LD C,E ;|transfer DE to BC then stack BC
JP STK_BC ;\ to the fp stack
;******************************************************************
; Module: INOUT
; Routine: STKNUM
; stack an ASCII number onto the fp stack
;******************************************************************
STKNUM:
M3076: CP ‘.’ ;/jump if character is a decimal point
JR Z,M3089 ;\
CALL ININT ;stack the integer portion of the number
CP ‘.’ ;/jump if not decimal point and check
JR NZ,M30A9 ;\ for an exponent
;
;handle the decimal part of the number
;
RST $20 ;get next char
CALL DIGITQ ;/not a digit, so see if
JR C,M30A9 ;\ it is an "E" or "e" for an exponent
JR M3093 ;jump to assemble the fractional portion of the number
;
;handle a lone fractional part
;
M3089: RST $20 ;get next char
CALL DIGITQ ;/jump if A is not a decimal digit
M308D: JP C ,M1BED ;\error – BAD BASIC
;
;stack an accumulator on the fp stack
;
RST $28 ;calc entry
DEFB $A0 ;CONST 0 (0)
DEFB $38 ;QUIT
M3093: RST $28 ;calc entry
DEFB $A1 ;CONST 1 (256)
DEFB $C0 ;T -> MEM 0 (MEM 0 contains fp 1)
DEFB $02 ;DROP
DEFB $38 ;QUIT
M3098: RST $18 ;get current character
CALL ASC2BIN ;/jump if the character was not
JR C,M30A9 ;\ a decimal digit
RST $28 ;calc entry
DEFB $E0 ;MEM 0 -> T
DEFB $A4 ;CONST 4 (2560)
DEFB $05 ;DIV
DEFB $C0 ;T -> MEM 0
DEFB $04 ;TIMES
DEFB $0F ;ADD
DEFB $38 ;QUIT
RST $20 ;get next char
JR M3098
M30A9: CP ‘E’ ;/jump if an exponent is present
JR Z,M30B0 ;\
CP ‘e’ ;/return if no exponent
RET NZ ;\
M30B0: LD B,$FF ;
RST $20 ;get next char
CP $2B ;
JR Z,M30BC ;
CP $2D ;
JR NZ,M30BD ;
INC B ;
M30BC: RST $20 ;get next char
M30BD: CALL DIGITQ ;/jump if A is not a decimal digit
JR C,M308D ;\
PUSH BC
CALL ININT
CALL FP2A
POP BC
JP C ,ERR6
AND A
JP M ,ERR6
INC B
JR Z,M30D6
NEG
M30D6: JP M310D
;******************************************************************
; Module: INOUT
; Routine: DIGITQ
; checks to see if a character is between ‘0’ and ‘9’
; will return with carry set if not a digit
; ENTRY: A = character to be checked
;
; EXIT: CF = O if a digit
; CF = 1 if not a digit
;******************************************************************
DIGITQ:
M30D9: CP $30 ;/return if less than ‘0’
RET C ;\
CP $3A ;/
CCF ;|make carry correct for return
RET ;\
;******************************************************************
; Module: INOUT
; Routine: ASC2BIN
; makes an ASCII character for a decimal digit into its binary
; representation.
; ENTRY: A = character to be checked
;
; EXIT: A = binary representation of a valid ASCII digit, else
; no change
; CF = 1 if not a digit
;******************************************************************
ASC2BIN:
M30E0: CALL DIGITQ ;/return if A is not a digit
RET C ;\
SUB $30 ;make A the binary value of the digit
;******************************************************************
; Module: INOUT
; Routine: STK_A
; put A onto the floating point stack
; munges BC
;******************************************************************
STK_A:
M30E6: LD C,A ;/save A to BC
LD B,$00 ;\
;******************************************************************
; Module: INOUT
; Routine: STK_BC
; puts BC onto the fp stack
;******************************************************************
STK_BC:
M30E9: LD IY,ERRNR ;???
XOR A ;/zero the A and E registers
LD E,A ;\(exp and sign byte of the integer form
LD D,C ;/fill in the active bytes
LD C,B ;\
LD B,A ;zero the pad byte
CALL PAEDCB ;place the byte on the fp stack
RST $28 ;/update the calculator with the
DEFB $38 ;\new value
AND A
RET
;******************************************************************
; Module: INOUT
; Routine: ININT
; places an ASCII integer number on the fp stack as a fp number
; ENTER A = first digit of the number to be stacked
;
; EXIT CF set if character is not a decimal digit
;******************************************************************
ININT:
M30F9: PUSH AF ;save the character
RST $28 ;calc entry
DEFB $A0 ;CONST 0 (0) stack a fp 0 (zero the accumulator
DEFB $38 ;QUIT
POP AF ;restore the character
M30FE: CALL ASC2BIN ;put the binary value in A onto the fp stack
RET C ;return if the character was not a digit
RST $28 ;calc entry
DEFB $01 ;SWAP digit to the top of the stack
DEFB $A4 ;CONST 4 (2560)
DEFB $04 ;TIMES
DEFB $0F ;ADD
DEFB $38 ;QUIT
CALL NEXTCH ;get the next character
JR M30FE ;jump around for the next digit
;******************************************************************
; Module: INOUT
; Routine: XEY
;******************************************************************
FP_XEY:
M310D: RLCA
RRCA
JR NC,M3113
CPL
INC A
M3113: PUSH AF
LD HL,MEMBOT
CALL M3926
RST $28 ;calc entry
DEFB $A4 ;CONST 4 (2560)
DEFB $38 ;QUIT
POP AF
M311E: SRL A
JR NC,M312F
PUSH AF
RST $28 ;calc entry
DEFB $C1 ;T -> MEM 1
DEFB $E0 ;MEM 0 -> T
DEFB $00,$04 ;IFJUMP 312B
DEFB $04 ;TIMES
DEFB $33,$02 ;JUMP 312C
DEFB $05 ;DIV
DEFB $E1 ;MEM 1 -> T
DEFB $38 ;QUIT
POP AF
M312F: JR Z,M3139
PUSH AF
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $04 ;TIMES
DEFB $38 ;QUIT
POP AF
JR M311E
M3139: RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $38 ;QUIT
RET
;Entry point from FLOAT routine
;******************************************************************
; Module: INOUT
; Routine: INT2COMPL
; This routine forms the twos complement of the integer form
; at (HL) and places it in DE. HL points to the sign byte of
; the integer value. C has the sign byte.
;******************************************************************
INT2COMPL:
M313D: INC HL ;point to the sign byte
LD C,(HL) ;get integer form sign byte to C
INC HL ;/get LSByte of integer
LD A,(HL) ;\
XOR C ;/generate the two’s complement
SUB C ;|of the LSByte and store to
LD E,A ;\E
INC HL ;/
LD A,(HL) ;|generate the two’s complement
ADC A,C ;|of the MSByte and store to
XOR C ;|E
LD D,A ;\
RET
;******************************************************************
; Module: INOUT
; Routine: STDE_U
; store the number in DE as an unsigned integer
;******************************************************************
STDE_U:
LD C,$00 ;zero the sign byte and press on
;******************************************************************
; Module: INOUT
; Routine: STDE_S
; store the integer number in CDE to (HL). tank the 2s complement
; of the number prior to storage
;******************************************************************
STDE_S:
M314C: PUSH HL ;save number pointer
LD (HL),$00 ;save integer exponent
INC HL ;/save integer sign
LD (HL),C ;\
INC HL ;/
LD A,E ;|
XOR C ;|
SUB C ;|
LD (HL),A ;|
INC HL ;|form and save 2’s complement
LD A,D ;|of DE
ADC A,C ;|
XOR C ;|
LD (HL),A ;\
INC HL ;/zero last byte of
LD (HL),$00 ;\integer value
POP HL ;restore the number pointer
RET
;******************************************************************
; Module: INOUT
; Routine: FP2BC
; makes the top of the calculator stack an integer by rounding
; if it’s a floating point value.
; RETURNS:
; DE = integer value of calculator (bombs out via calculator’s
; integer routine if the number is too large)
; A = copy of E
; ZF = 1 if the result was an integer
; CF = 1 if the sign byte was not zero
;******************************************************************
FP2BC:
M3160: RST $28 ;calc entry /this construct loads HL with the
DEFB $38 ;QUIT \address of the "current value"
LD A,(HL) ;/
AND A ;|jump if the top of the calc stack is already
JR Z,M316B ;\an integer
RST $28 ;calc entry round the value on the calc stack
DEFB $A2 ;CONST 1 (0.5) (0.5)
DEFB $0F ;ADD
DEFB $27 ;INT
DEFB $38 ;QUIT
M316B: RST $28 ;calc entry /drop the top of the calc stack
DEFB $02 ;DROP |since it will now be put in the
DEFB $38 ;QUIT \BC register
PUSH HL ;/save the registers
PUSH DE ;\DE contains the address of the dropped value
EX DE,HL ;HL now points to the dropped value
LD B,(HL) ;save the sign byte
CALL INT2COMPL ;form the 2s complement of the value at (HL) and put it
; into DE
XOR A ;clear the accumulator
SUB B ;this will set the carry if the result is not an integer
BIT 7,C ;this will set the zero flag if the sign is negative
LD B,D ;/transfer the newly minted value to BC
LD C,E ;\
LD A,E ;copy E to A
POP DE ;/restore registers
POP HL ;\
RET ;done
M317F: LD D,A ;
RLA ;
SBC A,A ;
LD E,A ;
LD C,A ;
XOR A ;
LD B,A ;
CALL PAEDCB
RST $28 ;calc entry
DEFB $34,$EF,$1A,$20,$9A,$85 ;LITERAL 7F1A209A85 ( .301029995665886),3190
DEFB $04 ;TIMES
DEFB $27 ;INT
DEFB $38 ;QUIT
;******************************************************************
; Module: INOUT
; Routine: FP2A
; convert the top of the fp stack to an integer in A
; B will contain the sign byte of the original value
; carry will be set if the value was negative
; zero will be set if the value was positive
;******************************************************************
FP2A:
M3193: CALL FP2BC ;convert the top of fp stack to BC
RET C ;return if number was greater than 255
PUSH AF ;save a
DEC B ;/
INC B ;|jump if the sign byte is 0
JR Z,M319F ;\
POP AF ;restore the value
SCF ;set carry as value was negative
RET ;return
M319F: POP AF ;restore the value
RET ;restore the value
;******************************************************************
; Module: INOUT
; Routine: OUTPUT
;******************************************************************
OUTPUT:
M31A1: RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $36 ;MINUSQ
DEFB $00,$0B ;IFJUMP 31B0
DEFB $31 ;DUP
DEFB $37 ;PLUSQ
DEFB $00,$0D ;IFJUMP 31B6
DEFB $02 ;DROP
DEFB $38 ;QUIT
LD A,$30
RST $10
RET
LD HL,($3E38)
DEC L
RST $10
RST $28 ;calc entry
DEFB $A0 ;CONST 0 (0)
DEFB $C3 ;T -> MEM 3
DEFB $C4 ;T -> MEM 4
DEFB $C5 ;T -> MEM 5
DEFB $02 ;DROP
DEFB $38 ;QUIT
EXX
PUSH HL
EXX
M31BF: RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $27 ;INT
DEFB $C2 ;T -> MEM 2
DEFB $03 ;SUB
DEFB $E2 ;MEM 2 -> T
DEFB $01 ;SWAP
DEFB $C2 ;T -> MEM 2
DEFB $02 ;DROP
DEFB $38 ;QUIT
LD A,(HL)
AND A
JR NZ,M3215
CALL INT2COMPL
LD B,$10
LD A,D
AND A
JR NZ,M31DC
OR E
JR Z,M31E2
LD D,E
LD B,$08
M31DC: PUSH DE
EXX
POP DE
EXX
JR M323A
M31E2: RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $E2 ;MEM 2 -> T
DEFB $38 ;QUIT
LD A,(HL)
SUB $7E
CALL M317F
LD D,A
LD A,(MEM5+1)
SUB D
LD (MEM5+1),A
LD A,D
CALL M310D
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $27 ;INT
DEFB $C1 ;T -> MEM 1
DEFB $03 ;SUB
DEFB $E1 ;MEM 1 -> T
DEFB $38 ;QUIT
CALL FP2A
PUSH HL
LD (MEM3),A
DEC A
RLA
SBC A,A
INC A
LD HL,MEM5
LD (HL),A
INC HL
ADD A,(HL)
LD (HL),A
POP HL
JP M328E
M3215: SUB $80
CP $1C
JR C,M322E
CALL M317F
SUB $07
LD B,A
LD HL,MEM5+1
ADD A,(HL)
LD (HL),A
LD A,B
NEG
CALL M310D
JR M31BF
M322E: EX DE,HL
CALL M3379
EXX
SET 7,D
LD A,L
EXX
SUB $80
LD B,A
M323A: SLA E
RL D
EXX
RL E
RL D
EXX
LD HL,MEM4+4
LD C,$05
M3249: LD A,(HL)
ADC A,A
DAA
LD (HL),A
DEC HL
DEC C
JR NZ,M3249
DJNZ M323A
XOR A
LD HL,MEM4
LD DE,MEM3
LD B,$09
RLD
LD C,$FF
M3260: RLD
JR NZ,M3268
DEC C
INC C
JR NZ,M3272
M3268: LD (DE),A
INC DE
INC (IY+(MEM5-Y)) ;
INC (IY+(MEM5-Y+1)) ;
LD C,$00
M3272: BIT 0,B
JR Z,M3277
INC HL
M3277: DJNZ M3260
LD A,(MEM5)
SUB $09
JR C,M328A
DEC (IY+(MEM5-Y)) ;
LD A,$04
CP (IY+(MEM4-Y+3)) ;
JR M32CB
M328A: RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $E2 ;MEM 2 -> T
DEFB $38 ;QUIT
M328E: EX DE,HL
CALL M3379
EXX
LD A,$80
SUB L
LD L,$00
SET 7,D
EXX
CALL M339C
M329E: LD A,(IY+(MEM5-Y)) ;
CP $08
JR C,M32AB
EXX
RL D
EXX
JR M32CB
M32AB: LD BC,$0200
M32AE: LD A,E
CALL M334A
LD E,A
LD A,D
CALL M334A
LD D,A
PUSH BC
EXX
POP BC
DJNZ M32AE
LD HL,MEM3
LD A,C
LD C,(IY+(MEM5-Y)) ;
ADD HL,BC
LD (HL),A
INC (IY+(MEM5-Y)) ;
JR M329E
M32CB: PUSH AF
LD HL,MEM3
LD C,(IY+(MEM5-Y)) ;
LD B,$00
ADD HL,BC
LD B,C
POP AF
M32D7: DEC HL
LD A,(HL)
ADC A,$00
LD (HL),A
AND A
JR Z,M32E4
CP $0A
CCF
JR NC,M32EC
M32E4: DJNZ M32D7
LD (HL),$01
INC B
INC (IY+(MEM5-Y+1)) ;
M32EC: LD (IY+(MEM5-Y)),B ;
RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $38 ;QUIT
EXX
POP HL
EXX
LD BC,(MEM5)
LD HL,MEM3
LD A,B
CP $09
JR C,M3305
CP $FC
JR C,M332B
M3305: AND A
CALL Z ,M11EA
M3309: XOR A
SUB B
JP M ,M3311
LD B,A
JR M331D
M3311: LD A,C
AND A
JR Z,M3318
LD A,(HL)
INC HL
DEC C
M3318: CALL M11EA
DJNZ M3311
M331D: LD A,C
AND A
RET Z
INC B
LD A,$2E
M3323: RST $10
LD A,$30
DJNZ M3323
LD B,C
JR M3311
M332B: LD D,B
DEC D
LD B,$01
CALL M3309
LD A,$45
RST $10
LD C,D
LD A,C
AND A
JP P ,M3342
NEG
LD C,A
LD A,$2D
JR M3344
M3342: LD A,$2B
M3344: RST $10
LD B,$00
JP M1788
M334A: PUSH DE
LD L,A
LD H,$00
LD E,L
LD D,H
ADD HL,HL
ADD HL,HL
ADD HL,DE
ADD HL,HL
LD E,C
ADD HL,DE
LD C,H
LD A,L
POP DE
RET
M335A: LD A,(HL)
LD (HL),$00
AND A
RET Z
INC HL
BIT 7,(HL)
SET 7,(HL)
DEC HL
RET Z
PUSH BC
LD BC,$0005
ADD HL,BC
LD B,C
LD C,A
SCF
M336E: DEC HL
LD A,(HL)
CPL
ADC A,$00
LD (HL),A
DJNZ M336E
LD A,C
POP BC
RET
;******************************************************************
; Most of the explanations in this file come from
; "The Complete Timex TS1000/Sinclair ZX81 ROM Disassembly"
; by Dr. Ian Logan and Dr. Frank O’Hara
; (C) 1982 by the authors
; Published by Melbourne House Publishers
; ISBN 0 86161 113 6
;
;******************************************************************
; Module: SUMS
; Routine: SUMSLD
; This routine is called by the addition, multiplication, and
; division routines to fetch two floating point numbers to the
; main and alternate register sets. When called from the
; multiplication and division routines, the sign of the result
; is stored in the second byte of the first number (M2)
; On entry, HL points to one number M1,M2,M3,M4,M5 and
; DE points to another number N1,N2,N3,N4,N5
; On exit, HL points to the first number
; H’B’C’CB = M1 M2 M3 M4 M5
; L’D’E’DE = N1 N2 N3 N4 N5
;******************************************************************
SUMSLD:
M3379: PUSH HL ;/save HL and AF
PUSH AF ;\
LD C,(HL) ;M1 to C
INC HL ;point to M2
LD B,(HL) ;M2 to B
LD (HL),A ;save the sign of the result
INC HL ;point to M3
LD A,C ;M1 to A
LD C,(HL) ;M3 to C
PUSH BC ;save M2 & M3
INC HL ;point to M4
LD C,(HL) ;M4 to C
INC HL ;point to M5
LD B,(HL) ;M5 to B
EX DE,HL ;HL now points to N1
LD D,A ;M1 to D
LD E,(HL) ;N1 to E
PUSH DE ;Save M1 & N1
INC HL ;point to N2
LD D,(HL) ;N2 to D
INC HL ;point to N3
LD E,(HL) ;N3 to E
PUSH DE ;save N2 & N3
EXX ;to alternate register set
POP DE ;D’ = N2, E’ = N3
POP HL ;H’ = M1, L’ = N1
POP BC ;B’ = M2, C’ = M3
EXX ;back to normal reg set
INC HL ;point to N4
LD D,(HL) ;D = N4
INC HL ;point to N5
LD E,(HL) ;E = N5
POP AF ;restore AF
POP HL ;/restore the pointer to the first
;\number
RET ;done
;******************************************************************
; Module: SUMS
; Routine: SHIFT
;
; This subroutine will shift a number up to 32 places to the right
; to properly align it for addition. Prior to this routine, the number
; with the small exponent has been put in the addend position. Any
; overflow to the right, into the carry, is ripped right back to the
; beginning of the number then the nuber is set to zero so that addtion
; will not alter the other number (augend)
;******************************************************************
SHIFT:
M339C: AND A ;/if shift argrument is zero no
RET Z ;|shift is needed
;\
CP $21 ;/if we shift more than 32 bits
JR NC,M33B8
PUSH BC ;save BC briefly
LD B,A ;load the DJNZ counter
M33A4: EXX ;
SRA L ;/
RR D ;|execute one 40 bit right
RR E ;|shift L’D’E’DE ->
EXX ;|
RR D ;|
RR E ;\
DJNZ M33A4
POP BC ;restore the BC register
RET NC ;done if no carry to retriev
CALL M33C3 ;contend with carry
RET NZ ;return unless carry rippled
;right back. if so, zero the result
M33B8: EXX ;/
XOR A ;|clear the accum
M33BA: LD L,$00 ;|zero out the FP
LD D,A ;|value
LD E,L ;|
EXX ;|
LD DE,$0000 ;\
RET ;done
M33C3: INC E ;/
RET NZ ;|
INC D ;|propagate the carry through
RET NZ ;| D’E’DE
EXX ;|
INC E ;|
JR NZ,M33CC
INC D ;|
M33CC: EXX ;|
RET ;\
;******************************************************************
; Module: SUMS
; Routine: SUB
;******************************************************************
FP_SUB:
M33CE: EX DE,HL ;swap the number pointers
CALL M382D ;negate the subtrahend
EX DE,HL ;restore the number pointers
;continue on with addition
;******************************************************************
; Module: SUMS
; Routine: ADD
;
;******************************************************************
FP_ADD:
LD A,(DE) ;/if both numbers are not
OR (HL) ;|internal integer format,
JR NZ,M33FD
PUSH DE ;save the second number pointer
INC HL ;/point to the sign byte of the
PUSH HL ;\first number and save it
INC HL ;point to the LSByte of M
LD E,(HL) ;get it
INC HL ;point to MSByte of M
LD D,(HL) ;DE = M
INC HL ;points to unused byte of M
INC HL ;point to exponent byte of N
INC HL ;point to sign of N
LD A,(HL) ;save N sign
INC HL ;point to N LSByte
LD C,(HL) ;get it
INC HL ;point to N MSByte
LD B,(HL) ;BC = N
POP HL ;Point to sign of N1
EX DE,HL ;HL = N, DE points to N sign
ADD HL,BC ;HL = M + N
EX DE,HL ;DE = M + N, HL points to N1 sign
ADC A,(HL) ;/if the signs were the same and if
RRCA ;| the result generated a carry,
ADC A,$00 ;| we have overflowed 32 bits so
JR NZ,M33FB
;at this point CF=1 if the result is
; negative, CF=0 if positive
SBC A,A ;generate $FF for negative $00 for
; positive
LD (HL),A ;store sign byte
INC HL ;
LD (HL),E ;store LSByte
INC HL ;
LD (HL),D ;store MSByte
DEC HL ;/
DEC HL ;|HL now points to M exponent byte
DEC HL ;\
POP DE ;restore pointer to N
RET ;
M33FB: DEC HL ;/restore number pointers
POP DE ;\
M33FD: CALL M3652 ;convert operand to FP form suitable
; for further math
EXX ;/save next literal address
PUSH HL ;|
EXX ;\
PUSH DE ;save addend pointer
PUSH HL ;save augend pointer
CALL M335A ;prepare the augend
LD B,A ;save its exponent
EX DE,HL ;/prepare the addend
CALL M335A ;\
LD C,A ;save addend exponent
CP B ;/
JR NC,M3414
LD A,B ;|smaller exponent, swap the
LD B,C ;|numbers
EX DE,HL ;\
M3414: PUSH AF ;save the larger exponent
SUB B ;get the difference in exponents
CALL M3379 ;get the numbers into the machine
;registers from the calc stack
CALL M339C ;shift the addend right
POP AF ;restore the larger exponent
POP HL ;HL points to the result
LD (HL),A ;save the exponent of the result
PUSH HL ;save the result address
LD L,B ;/M4 to H and M5 to L
LD H,C ;\
ADD HL,DE ;add the two right bytes
EXX ;/
EX DE,HL ;|add the two left bytes with
ADC HL,BC ;\carry
EX DE,HL ;/
LD A,H ;|add H’L’ and the carry; the
ADC A,L ;|result will ensure that a
LD L,A ;|single shift right is called
RRA ;|if two positive numbers overflowed
XOR L ;|or two negs has not overflowed left
EXX ;\
EX DE,HL ;the result is now in D’E’DE
POP HL ;get the result pointer
RRA ;the test for shift. (H’L’ were
; $00 for positive numbers and $FF
JR NC,M343B
LD A,$01 ;do a single right shift
CALL M339C ;perform the shift
INC (HL) ;add one to the exponent
JR Z,M345E
M343B: EXX ;/
LD A,L ;|test for negative result
AND $80 ;|
EXX ;\
INC HL ;/store the sign
LD (HL),A ;\
DEC HL ;point back to the exponent
JR Z,M3464
LD A,E ;/
NEG ;|
CCF ;|
LD E,A ;|
LD A,D ;|
CPL ;|perform the 2’s compl
ADC A,$00 ;|
LD D,A ;|
EXX ;|
LD A,E ;|
CPL ;|
ADC A,$00 ;|
LD E,A ;|
LD A,D ;|
CPL ;|
ADC A,$00 ;\
JR NC,M3462
RRA ;/get .5 into the mantissa and
EXX ;|increment the exponent. This
INC (HL) ;|will be necessary when two
;|negative numbers add to a power of
;\2
M345E: JP Z ,ERR6 ;report overflow
EXX ;/store the last byte
M3462: LD D,A ;|
EXX ;\
M3464: XOR A ;clear the carry
JP M3514 ;normalize the result
;******************************************************************
; Module: SUMS
; Routine: MULT
;******************************************************************
MULT:
M3468: PUSH BC ;save the result sign byte
LD B,$10 ;for 16 bits
LD A,H
LD C,L
LD HL,$0000 ;zero accumulator
M3470: ADD HL,HL ;left shift accumulator
JR C,M347D
RL C ;/shift multiplier 1 bit
RLA ;\
JR NC,M347B
ADD HL,DE ;bit was 1 so add
JR C,M347D
M347B: DJNZ M3470
M347D: POP BC ;restore sign info
RET ;end
M347F: CALL M3904
RET C
INC HL
XOR (HL)
SET 7,(HL)
DEC HL
RET
;******************************************************************
; Module: SUMS
; Routine: TIMES
;******************************************************************
FP_TIMES:
LD A,(DE) ;/if N’s and M’s exponents
OR (HL) ;|not both zero to to
JR NZ,M34AF
PUSH DE ;save N’s pointer
PUSH HL ;save M’s pointer
PUSH DE ;working copy of N’s pointer
CALL INT2COMPL ;form the 2′ complement of (HL) in DE
EX DE,HL ;M to DE
EX (SP),HL ;get N’s pointer, saving M
LD B,C ;save M’s sign byte
CALL INT2COMPL ;get the 2’s complement
LD A,B ;save N’s sign byte
XOR C ;get the result of the sign
LD C,A ;save the sign
POP HL ;get M
CALL M3468 ;perform a 32 bit multiply
EX DE,HL ;transfer product to DE
POP HL ;get N’s pointer
JR C,M34AE
;promote to FP multiply
LD A,D ;/
OR E ;|if product <> 0 jump
JR NZ,M34A9
LD C,A ;zero for exponent
M34A9: CALL M314C ;form 2’s compl and save product
POP DE ;restore N’s pointer
RET ;done
M34AE: POP DE ;get M’s pointer
M34AF: CALL M3652 ;convert operand to FP form suitable
; for further math
XOR A ;set A to zero for sign of first number
CALL M347F ;prepare the first number
RET C ;zero, so nothing need be done
EXX ;/
PUSH HL ;|save next literal pointer
EXX ;\
PUSH DE ;save N’s pointer
EX DE,HL ;/
CALL M347F ;|prepare N for multiplication
EX DE,HL ;\
JR C,M351C
PUSH HL ;save M’s pointer
CALL M3379 ;get the numbers into the machine
;registers from the calc stack
LD A,B ;M5 to A
AND A ;reset carry flag
SBC HL,HL ;/initialize accumulator
EXX ;|
PUSH HL ;|save M1 and N1
SBC HL,HL ;|
EXX ;\
LD B,$21 ;for 33 bits
JR M34E4
M34D3: JR NC,M34DA
ADD HL,DE ;/add multiplicand
EXX ;|in D’E’DE to
ADC HL,DE ;|accumulator in H’L’HL
EXX ;\
M34DA: EXX ;/
RR H ;|
RR L ;|shift multiplicand to
EXX ;|test for addition
RR H ;|
RR L ;|
;|
M34E4: EXX ;|
RR B ;|
RR C ;|
EXX ;|
RR C ;|
RRA ;\
DJNZ M34D3
EX DE,HL ;/
EXX ;|move H’L’HL to D’E’de
EX DE,HL ;|
EXX ;\
POP BC ;restore the exponents
POP HL ;restore the pointer to the result
LD A,B ;/add the exponents
ADD A,C ;\
JR NZ,M34FA
AND A ;\carry, else leave unchanged
M34FA: DEC A ;/prepare to increse exponent
CCF ;\by $80
M34FC: RLA ;/
CCF ;|"add" $80 to exponent
RRA ;\
JP P ,M3505 ;no overflow
JR NC,ERR6
AND A ;clear carry
M3505: INC A ;the exponent is complete
JR NZ,M3510
JR C,M3510
EXX ;if there is not carry set and the
BIT 7,D ;result is already in normal form
EXX ;(bit 7 of D’ set) then there is no
JR NZ,ERR6
;the result is just in range, i.e. just
;under 2^127
M3510: LD (HL),A ;store the exponent
EXX ;pass the fifth result byte to A for
LD A,B ;the normalization sequence, i.e.
EXX ;the overflow from L to B’
;*******************************************************************
; Module: SUMS
; Routine: TESTNORML
;******************************************************************
TESTNORML:
M3514: JR NC,M352B
LD A,(HL) ;else, deal with underflow (zero)
AND A ;or near underflow
M3518: LD A,$80 ;(result 2^-128)
JR Z,M351D
M351C: XOR A ;zero (case 2^-128) and if so
M351D: EXX ;produce 2^-128 if number is normal;
AND D ;otherwise rocude zero.
CALL M33BA ;the exponent must then be set to
RLCA ;zero (for zero) or 1 (for 2^-128)
LD (HL),A ;restore the exponent byte
JR C,M3554
INC HL ;otherwise, put zero into second
LD (HL),A ;byte of result on calculator
DEC HL ;stack
JR M3554
;******************************************************************
; Module: SUMS
; Routine: NORML
;******************************************************************
NORML:
M352B: LD B,$20 ;normaise the result by up to 32
M352D: EXX ;decimal shifts left of
BIT 7,D ;D’E’DE (with A adjoined), until bit
EXX ;7 of D’ is set. A hold zero after
JR NZ,M3545
RLCA ;gained or lost. A hold the fifth
RL E ;byte fro B’ after multiplication or
RL D ;division; but as only about 32
EXX ;bits can be correct, no precision
RL E ;lost. Note that A is rotated
RL D ;circularly with branch at carry …
EXX ;…eventually a random process
DEC (HL) ;The exponent is decremented
;on each shift
JR Z,M3518
;numbers from 2^-129 are rounded
;up to 2^-128
DJNZ M352D
JR M351C
;whole result is zero
M3545: RLA ;after normalization, add back any
JR NC,M3554
CALL M33C3 ;jump forward if the carry does not
JR NZ,M3554
EXX ;if it should ripple back, then
LD D,$80 ;set the mantissa to 0.5 and increment
EXX ;the exponent
INC (HL) ;
JR Z,ERR6
M3554: PUSH HL ;save the result pointer
INC HL ;point to the sign byte of the result
EXX ;/the result is moved from
PUSH DE ;|D’E’DE to BCDE
EXX ;|then to ACDE
POP BC ;\
LD A,B ;retreive the sign bit
RLA ;and put into bit 7 of the
RL (HL) ;mantissa
RRA ;/
LD (HL),A ;|
INC HL ;|store the result
LD (HL),C ;|
INC HL ;|
LD (HL),D ;|
INC HL ;|
LD (HL),E ;\
POP HL ;restore the result pointer
POP DE ;restore the pointer to N
EXX ;/
POP HL ;|restore the next literal
EXX ;\pointer
RET ;done
;******************************************************************
; Module: SUMS
; Routine: ERR6
;******************************************************************
ERR6:
M356C: RST $08 ;/error: NUMBER TOO BIG
DEFB $05 ;\
;******************************************************************
; Module: SUMS
; Routine: DIVIDE
;******************************************************************
FP_DIVIDE:
CALL M3652 ;convert operand to FP form suitable
EX DE,HL ;exchange N and M pointers
XOR A ;clear the exponent register
CALL M347F ;prepare the divisor
JR C,ERR6
EX DE,HL ;restore the pointers
CALL M347F ;prepare the dividend
RET C ;return if 0, already done
EXX ;/
PUSH HL ;|save next literal pointer
EXX ;\
PUSH DE ;/save number pointers
PUSH HL ;\
CALL M3379 ;fetch the numbers to the machine registers
EXX ;
PUSH HL ;save M1 and N1 on the stack
LD H,B ;/
LD L,C ;|copy the dividend from
EXX ;|B’C’CB to H’L’HL
LD H,C ;|
LD L,B ;\
XOR A ;clear the carry
LD B,$DF ;count from -33 to -1
JR M35A1
M3591: RLA ;/
RL C ;|
EXX ;|rotate the quotient register
RL C ;|collecting the result from
RL B ;|the last subtract via the
EXX ;\RLA instruction
M359A: ADD HL,HL ;/
EXX ;|rotate the dividend
ADC HL,HL ;|one bit
EXX ;\
JR C,M35B1
M35A1: SBC HL,DE ;/
EXX ;|trial subtract
SBC HL,DE ;|
EXX ;\
JR NC,M35B8
ADD HL,DE ;/
EXX ;|the subtract didn’t go,
ADC HL,DE ;|so restore HL
EXX ;\
AND A ;no bit to the quotient
JR M35B9
M35B1: AND A ;/
SBC HL,DE ;|subtract without restore
EXX ;|to pick up the bit lost at
SBC HL,DE ;|$359F
EXX ;\
M35B8: SCF ;force a bit into the quotient
M35B9: INC B ;step the loop count
JP M ,M3591 ;loop 32 times
PUSH AF ;save any 33 bit
JR Z,M359A
;34th bit PUSH AF above saves this
;bit too
LD E,A ;/move the mantissa from
LD D,C ;|B’C’CA to D’E’DE
EXX ;|
LD E,C ;|
LD D,B ;\
POP AF ;/
RR B ;|put any 33rd or 34th
POP AF ;|bits into the B’ to
RR B ;|be used in normalization
EXX ;\
POP BC ;restore exponents
POP HL ;restore result pointer
LD A,B ;/compute exponent difference
SUB C ;\
JP M34FC ;exit via the exponent routine
;in the multiplication routine
;*******************************************************************
; Module: SUMS
; Routine: TRUNC
;******************************************************************
FP_TRUNC:
LD A,(HL) ;get the exponent byte
AND A ;/result is an integer
RET Z ;\so return
CP $81 ;/jump if exponent is >= $81
JR NC,M35E0
LD (HL),$00 ;/number is <1, so prepare
LD A,$20 ;\to zero out all 32 bits
JR M3631
M35E0: CP $91 ;/if the number does not
JR NZ,M35FE
;the following tests to see if the number is
; 9180000000 (-65536). if so, it changes the number to
; 00FF000000 then proceed to the normal routine
; I believe this attempts to fix a problem with the original TS1000/ZX81
; ROM routine but creates its own at 35F5
INC HL ;/
INC HL ;|test the 2nd and 3rd
INC HL ;|mantissa bytes for
LD A,$80 ;|1’s anywhere
AND (HL) ;|
DEC HL ;|
OR (HL) ;\
DEC HL ;point to the 1st mantissa byte
JR NZ,M35F2
;the number now must be
;91xx000000
LD A,$80 ;/test the 1st mantissa byte
XOR (HL) ;|for the value $80
;\
M35F2: DEC HL ;point to the exponent
JR NZ,M362B
;9180000000 (-65536)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;here starts something real bad. I get -1 (8180000000) when I take
; INT(-65536). seems like all that need be done is to clean up
; the pointers in HL and DE and exit this routine.
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LD (HL),A ;put zero into the exponent?
INC HL ;/set all of the bits in the
LD (HL),$FF ;|1st mantissa byte to 1’S
;\
DEC HL ;point back to the exponent
LD A,$18 ;we gonna reset 24 bits
JR M3631
M35FE: JR NC,M362C
;or more integer bits
;the number has only 16 integer bits so convert to internal
; integer format
PUSH DE ;save STKEND
CPL ;/effectively subtracts
ADD A,$91 ;\A-1 from $91
INC HL ;point to 1st mantissa byte
LD D,(HL) ;store in D
INC HL ;point to 2nd mantissa byte
LD E,(HL) ;store in E
DEC HL ;/point back to exponent
DEC HL ;\
LD C,$00 ;assume positive number
BIT 7,D ;check for high bit set in DE
JR Z,M3611
DEC C ;was negative, so make negative
;integer sign byte
M3611: SET 7,D ;set DE[7] to make true binary
LD B,$08 ;/
SUB B ;|test to see how many bits
ADD A,B ;\to shift
JR C,M361D
LD E,D ;/8 bits or less, so
LD D,$00 ;\adjust DE
SUB B ;get residual number of bits
M361D: JR Z,M3626
; the operation
LD B,A ;set up the shift counter
M3620: SRL D ;/shift DE right to provide the
RR E ;|needed number of bits
DJNZ M3620
M3626: CALL M314C ;form the 2’s complement of CDE
; and save at (HL)
POP DE ;restore STKEND
RET ;done
M362B: LD A,(HL) ;get the exponent to A
;if and when we get here, we have either a valid floating point value
; that is not a 16 bit or less number
M362C: SUB $A0 ;if the number’s exponent is
RET P ;at least $A0,there are no fractional
;bits: the number is already a (large)
;integer so return as done
NEG ;the number of bits to
;entry point if number was 9180000000 (-65536). number is now
; 00FF000000 with A set to $18
M3631: PUSH DE ;save STKEND
EX DE,HL ;HL now points one past the 5th byte of X
DEC HL ;point to the 5th byte of X
LD B,A ;get the number of bits to be 0
SRL B ;/divide by 8 to determine
SRL B ;|the number of whole bytes
SRL B ;\to change
JR Z,M3642
M363D: LD (HL),$00 ;/
DEC HL ;|reset the whole bytes
DJNZ M363D
M3642: AND $07 ;determine the number of bits
JR Z,M364F
LD B,A ;initialize the bit counter
LD A,$FF ;set up the mask
M3649: SLA A ;/shift 0’s into the mask
DJNZ M3649
AND (HL) ;/zero the unwanted bits
LD (HL),A ;\and store
M364F: EX DE,HL ;restore HL
POP DE ;restore STKEND
RET ;done
M3652: CALL M3655 ;tricky way to convert (DE) and
; (HL) to floating point
M3655: EX DE,HL ;exit via FLOAT
;******************************************************************
; Module: SUMS
; Routine: FLOAT
;******************************************************************
FP_FLOAT:
M3656: LD A,(HL) ;get exponent
AND A ;/if not zero is already FP
RET NZ ;\number
PUSH DE ;save pointer to number N
CALL INT2COMPL ;get sign-magnitude of (HL)
;from the 2’s complement to DE
XOR A ;zero the accum
INC HL ;point to M5
LD (HL),A ;zero it out
DEC HL ;point to M4
LD (HL),A ;zero it
LD B,$91 ;exponent for 16 bit number
LD A,D ;/check to see if number>255,
AND A ;|if so, continue
JR NZ,M3670
OR E ;get the LSByte of the number
LD B,D ;stage the MSByte
JR Z,M367C
;we are done converting
LD D,E ;transfer 8 bit LSByte to D
LD E,B ;zero out the LSByte in E
LD B,$89 ;exponent for 8 bit number
M3670: EX DE,HL ;HL now has number, DE has pointer
M3671: DEC B ;/for every left shift
ADD HL,HL ;|decrement the exponent once
JR NC,M3671
RRC C ;/put the MSBit back
RR H ;|
RR L ;\
EX DE,HL ;swap the pointer and value
M367C: DEC HL ;/fill in M3
LD (HL),E ;\
DEC HL ;/fill in M2
LD (HL),D ;\
DEC HL ;/fill in M1 (exponent)
LD (HL),B ;\
POP DE ;restore the pointer to N
RET ;exit
;******************************************************************
; Module: CALC
; Routine: FPCONST
;******************************************************************
FPCONST:
DEFB $00,$B0,$00 ;0000000000 ( 0),3687
DEFB $40,$B0,$00,$01 ;0000010000 ( 256),368B
DEFB $30,$00 ;8000000000 ( .5),368D
DEFB $F1,$49,$0F,$DA,$A2 ;81490FDAA2 ( 1.57079632673413),3692
DEFB $40,$B0,$00,$0A ;00000A0000 ( 2560),3696
;******************************************************************
; Module: CALC
; Routine: FPJMPTBL
;******************************************************************
FPJMPTBL:
DEFW $3AAA ;IFJUMP FP_IFJUMP
DEFW $37FB ;SWAP FP_SWAP
DEFW $3760 ;DROP FP_DROP
DEFW $33CE ;SUB FP_SUB
DEFW $3489 ;TIMES FP_TIMES
DEFW $356E ;DIV FP_DIVIDE
DEFW $3C6C ;POWER FP_TO_THE
DEFW $3936 ;OR FP_OR
DEFW $393F ;AND FP_AND
DEFW $3956 ;LE FP_LE
DEFW $3956 ;GE FP_GE
DEFW $3956 ;NE FP_NE
DEFW $3956 ;GT FP_GT
DEFW $3956 ;LT FP_LT
DEFW $3956 ;EQU FP_EQU
DEFW $33D3 ;ADD FP_ADD
DEFW $3948 ;STGAND FP_STGAND
DEFW $3956 ;STLE FP_STLE
DEFW $3956 ;STGE FP_STGE
DEFW $3956 ;STNE FP_STNE
DEFW $3956 ;STGT FP_STGT
DEFW $3956 ;STLT FP_STLT
DEFW $3956 ;STEQU FP_STEQU
DEFW $39B7 ;CONCAT FP_CONCAT
DEFW $39F9 ;VALS FP_VALS
DEFW $38D7 ;USRS FP_USRS
DEFW $3A60 ;INKEY FP_INKEY
DEFW $382D ;NEGATE FP_NEGATE
DEFW $3A84 ;CODE FP_CODE
DEFW $39F9 ;VAL FP_VALS
DEFW $3A8F ;LEN FP_LEN
DEFW $3BD0 ;SIN FP_SIN
DEFW $3BC5 ;COS FP_COS
DEFW $3BF5 ;TAN FP_TAN
DEFW $3C4E ;ASN FP_ASN
DEFW $3C5E ;ACS FP_ACS
DEFW $3BFD ;ATN FP_ATN
DEFW $3B2E ;LN FP_LN
DEFW $3ADF ;EXP FP_EXP
DEFW $3ACA ;INT FP_INT
DEFW $3C65 ;ROOT FP_ROOT
DEFW $3851 ;SGN FP_SGN
DEFW $3829 ;ABS FP_ABS
DEFW $386B ;PEEK FP_PEEK
DEFW $3864 ;IN FP_IN
DEFW $3872 ;USR FP_USR
DEFW $3A3A ;STR FP_STR
DEFW $39E4 ;CHR FP_CHR
DEFW $391C ;NOT FP_NOT
DEFW $377F ;DUP FP_DUP
DEFW $3ABB ;INTDIV FP_INTDIV
DEFW $3AA1 ;JUMP FP_JUMP
DEFW $3785 ;LITERAL FP_LIT
DEFW $3A95 ;LOOP FP_LOOP
DEFW $3921 ;MINUSQ FP_MINUSQ
DEFW $3914 ;PLUSQ FP_PLUSQ
DEFW $3AB6 ;QUIT FP_QUIT
DEFW $3B9E ;ANGLE FP_ANGLE
DEFW $35D3 ;TRUNC FP_TRUNC
DEFW $3761 ;XEQTB FP_XEQTB
DEFW $310D ;XEY FP_XEY
DEFW $3656 ;CBSV FP_FLOAT
DEFW $3808 ;GET CONST
DEFW $37DA ;TO MEM FP_TO_MEM
DEFW $37EC ;FROM MEM FP_FROM_MEM
DEFW $37CE ;?? FP_UNKNOWN
;******************************************************************
; Module: CALC
; Routine: UNKNOWN
;******************************************************************
UNKNOWN:
M371A: CALL M39DA
M371D: LD A,B
LD (BREG),A
M3721: EXX
EX (SP),HL
EXX
LD (STKEND),DE
EXX
LD A,(HL)
INC HL
M372B: PUSH HL
AND A
JP P ,M373F
LD D,A
AND $60
RRCA
RRCA
RRCA
RRCA
ADD A,$7C
LD L,A
LD A,D
AND $1F
JR M374D
M373F: CP $18
JR NC,M374B
EXX
LD BC,$FFFB
LD D,H
LD E,L
ADD HL,BC
EXX
M374B: RLCA
LD L,A
M374D: LD DE,$3696
LD H,$00
ADD HL,DE
LD E,(HL)
INC HL
LD D,(HL)
LD HL,$3724
EX (SP),HL
PUSH DE
EXX
LD BC,(STKEND+1)
FP_DROP:
RET
FP_XEQTB:
POP AF
LD A,(BREG)
EXX
JR M372B
;******************************************************************
; Module: CALC
; Routine: ROOMQ
; determine if there is room enough for one floating point value
; bombs via error 4
;******************************************************************
ROOMQ:
M3768: PUSH DE ;/save registers
PUSH HL ;\
LD BC,$0005 ;one fp number size
CALL CHK_SZ ;check for room
;if we returned, there was room
POP HL ;/retstore the registers
POP DE ;\
RET
;******************************************************************
; Module: CALC
; Routine: STK_M
; stack a number at (HL) onto the calc stack
;******************************************************************
STK_M:
M3773: LD DE,(STKEND) ;destination is the calc stack
CALL M377F ;move the number
LD (STKEND),DE ;update the calc stack pointer
RET ;done
;******************************************************************
; Module: CALC
; Routine: RAMNO
; move BC bytes from (HL) to (DE)
;******************************************************************
RAMNO:
FP_DUP:
M377F: CALL ROOMQ ;find out if there is room
LDIR ;do the move
RET ;
;******************************************************************
; Module: CALC
; Routine: FPLIT
; stack a floating point literal
;******************************************************************
FP_LIT: LD H,D ;
LD L,E ;
M3787: CALL ROOMQ ;determine if there is room
EXX ;
PUSH HL ;
EXX ;
EX (SP),HL ;
PUSH BC ;
LD A,(HL) ;
AND $C0 ;
RLCA ;
RLCA ;
LD C,A ;
INC C ;
LD A,(HL) ;
AND $3F ;
JR NZ,M379D ;
INC HL ;
LD A,(HL) ;
M379D: ADD A,$50 ;
LD (DE),A ;
LD A,$05 ;
;******************************************************************
; Module: CALC
; Routine: CTRO
;******************************************************************
CTRO:
; DEC B
SUB C
INC HL
INC DE
LD B,$00
LDIR
POP BC
EX (SP),HL
EXX
POP HL
EXX
LD B,A
XOR A
M37B0: DEC B
RET Z
LD (DE),A
INC DE
JR M37B0
M37B6: AND A
M37B7: RET Z
PUSH AF
PUSH DE
LD DE,$0000
CALL M3787
POP DE
POP AF
DEC A
JR M37B7
;******************************************************************
; Module: CALC
; Routine: ARRAY
; form the address of the FP item with index in A at address (HL)
; BC is munged
;******************************************************************
ARRAY:
M37C5: LD C,A ;/
RLCA ;| A = 5 * A
RLCA ;|
ADD A,C ;\
LD C,A ;|
LD B,$00 ;/form the address in HL
ADD HL,BC ;\
RET ;
FP_UNKNOWN:
PUSH DE
LD HL,(MEM)
CALL M37C5
CALL M377F
POP HL
RET
FP_TO_MEM:
LD H,D
LD L,E
EXX
PUSH HL
LD HL,$3684
EXX
CALL M37B6
CALL M3787
EXX
POP HL
EXX
RET
FP_FROM_MEM:
PUSH HL
EX DE,HL
LD HL,(MEM)
CALL M37C5
EX DE,HL
CALL M377F
EX DE,HL
POP HL
RET
FP_SWAP:
M37FB: LD B,$05
M37FD: LD A,(DE)
LD C,(HL)
EX DE,HL
LD (DE),A
LD (HL),C
INC HL
INC DE
DJNZ M37FD
EX DE,HL
RET
;FP_FLOAT:
LD B,A ;47
CALL M371D ;CD1D37
LD SP,$C00F ;310FC0
LD (BC),A ;02
AND B ;A0
; JP NZ,ME031
DEFB $C2,$31,$E0 ;C231E0
INC B ;04
; JP PO ,M03C1
DEFB $E2,$C1,$03 ;E2C103
; JR C,M37E7
DEFB $38,$CD ;38CD
ADD A,L ;85
SCF ;37
CALL M3721 ;CD2137
RRCA ;0F
LD BC,$02C2 ;01C202
DEC (HL) ;35
XOR $E1 ;EEE1
INC BC ;03
; JR C,M37F2
DEFB $38,$C9 ;38C9
FP_ABS:
LD B,$FF ;06FF
JR M3833 ;1806
;******************************************************************
; Module: CALC
; Routine: NEGATE
; negate the value at (HL)
;
; ENTRY:
; B – if bit 7 of B is set, this forces (HL) to be positive
; (ABS?)
;******************************************************************
FP_NEGATE:
M382D: CALL M3904 ;return if FP (HL) is zero
RET C ;
LD B,$00 ;prep B
M3833: LD A,(HL) ;jump if (HL) is a FP integer format
AND A ;
JR Z,M3842 ;
INC HL ;point to the mantissa
LD A,B ;get the sign mask
AND $80 ;/get the FP number’s sign
OR (HL) ;\
RLA ;/this will negate (HL) if B < $80,
CCF ;|or force (HL) positive if B > $7F
RRA ;\
LD (HL),A ;restore the mantissa high byte
DEC HL ;point back to the exponent
RET ;weebiedun
M3842: PUSH DE ;save the working registers
PUSH HL ;
CALL INT2COMPL ;return the integer 2’s complement of (HL)
; in DE
POP HL ;restore HL
LD A,B ;get the sign mask
OR C ;form the sign byte
; A = B if B = 00 else
; A = FF if B = FF
CPL ;C = 0 if A = FF and B = FF else
LD C,A ;C = NOT(C) if B = 0
CALL M314C ;store the two’s complement in CDE to (HL)
POP DE ;restore DE
RET ;exit
CALL M3904 ;return if FP at (HL) is zero
RET C ;
FP_SGN:
;save -1 if (HL) < 0, else save +1
PUSH DE ;save DE
LD DE,$0001 ;we are saving +/- 1
INC HL ;point to the sign byte
RL (HL) ;CF = MSBit of sign
DEC HL ;point back to start of number
SBC A,A ;A = FF if MSBit of sign = 1
LD C,A ;save sign in C
CALL M314C ;store CDE to (HL)
POP DE ;restore DE
RET ;exit
FP_IN:
CALL FIX_U ;get top of FP stack to BC
IN A,(C) ;get the data from the port
JR M386F
FP_PEEK:
CALL FIX_U ;get top of FP stack to BC
LD A,(BC) ;get the memory value to A
M386F: JP M30E6 ;stack A on calc stack
FP_USR:
CALL FIX_U ;get top of FP stack to BC
CALL M388E
; LD HL,$3882
LD HL,USRRET
PUSH HL ;
; LD HL,$30E9
LD HL,STK_BC
PUSH HL
PUSH BC
RET
;******************************************************************
; Module: CALC
; Routine: USRRET
;******************************************************************
USRRET:
POP AF
INC A
RET Z
PUSH BC
LD BC,$FF00 ;home bank, all chunks
CALL BANK_ENABLE ;
POP BC
RET
M388E: LD HL,(SYSCON)
INC HL
LD A,(HL)
CP $02
JR NZ,M38C5
INC HL
INC HL
INC HL
LD A,B
BIT 7,A
JR Z,M38C5
AND $06
JR Z,M38BE
SUB $04
JP M ,M38B7
JR Z,M38B0
LD A,(HL)
JP M ,M38C5
JR M38CB
M38B0: LD A,(HL)
BIT 6,A
JR Z,M38CB
JR M38C5
M38B7: LD A,(HL)
BIT 5,A
JR Z,M38CB
JR M38C5
M38BE: LD A,(HL)
BIT 4,A
JR Z,M38CB
JR M38C5
M38C5: POP HL
LD A,$FF
PUSH AF
PUSH HL
RET
M38CB: POP HL
PUSH AF
PUSH HL
PUSH BC ;briefly save BC
LD C,A ;chunk map to C
LD B,$00 ;dock bank
CALL BANK_ENABLE ;
POP BC ;restore BC
RET
FP_USRS:
CALL PGPSTR
DEC BC
LD A,B
OR C
JR NZ,M3902
LD A,(DE)
CALL ALPHAQ
JR C,M38EE
SUB $90
JR C,M3902
CP $15
JR NC,M3902
INC A
M38EE: DEC A
ADD A,A
ADD A,A
ADD A,A
CP $A8
JR NC,M3902
LD BC,(UDG)
ADD A,C
LD C,A
JR NC,M38FF
INC B
M38FF: JP STK_BC
M3902: RST $08 ;error: INVALID ARGUMENT
DEFB $09 ;
;******************************************************************
; Module: CALC
; Routine: TEST0
; test the value (FP or integer) at (HL) for zero.
; Entry:
; HL – points to number to check
;
; Exit:
; NZ, NC if (HL) is not zero
; Z, C if (HL) is zero
;******************************************************************
TEST0:
M3904: PUSH HL ;/save HL, BC, and A
PUSH BC ;|
LD B,A ;\
LD A,(HL) ;OR all of the components of the
INC HL ; FP value together. this will
OR (HL) ; produce zero iff the number is zero
INC HL ;
OR (HL) ;
INC HL ;
OR (HL) ;
LD A,B ;/restore HL, BC, and A
POP BC ;|
POP HL ;\
RET NZ ;return if not zero
SCF ;set carry and return if zero
RET ;
FP_PLUSQ:
M3914: CALL M3904 ;
RET C ;return if (HL) is zero
LD A,$FF ;A <- -1
JR M3922
FP_NOT:
M391C: CALL M3904 ;test (HL) for zero
JR M3926
FP_MINUSQ:
XOR A
M3922: INC HL ;point to the next byte of the integer to be tested
XOR (HL) ;set the bits
DEC HL ;point back to the integer
RLCA ;CF = 1, A = $FE
;******************************************************************
; Module: CALC
; Routine: STBOOL
; store a boolean integer value to (HL)
; this routine will store a FP integer $0001 to (HL) if the CF
; is set upon entry, else will store $0000
;
; Entry:
; CF indicates value to store
;******************************************************************
STBOOL:
M3926: PUSH HL ;save HL
LD A,$00 ;
LD (HL),A ;store 0 into the first bytes
INC HL ;(exponent and integer flag)
LD (HL),A ;
INC HL ;
RLA ;put carry flag into the lsb of the integer
LD (HL),A ; this will give $0001 if the carry is set
; else $0000 if the carry is clear
RRA ;restore A and drop zeros into the
INC HL ; remainder of the integer
LD (HL),A ;
INC HL ;
LD (HL),A ;
POP HL ;restore HL and return
RET ;
;(DE) zero
; this routine will put a FP integer $0001 at (HL) if FP integer at (DE)
; is zero.
FP_OR:
EX DE,HL ;test (DE) for zero
CALL M3904 ;
EX DE,HL ;
RET C ;return if (DE) is zero
SCF ;put 1 into (HL)
JR M3926 ;
;(DE) not zero
; this routine will put a FP integer $0001 at (HL) if FP integer at (DE)
; is not zero.
FP_AND:
EX DE,HL ;test (DE) for zero…
CALL M3904 ;
EX DE,HL ;
RET NC ;… and return if not.
AND A ;put $0001 into (HL) if (DE) was zero
JR M3926 ;
FP_STGAND:
EX DE,HL ;test (DE) for zero and return if it is
CALL M3904 ; not
EX DE,HL ;
RET NC ;
PUSH DE
DEC DE
XOR A
LD (DE),A
DEC DE
LD (DE),A
POP DE
RET
FP_LE:
FP_GE:
FP_NE:
FP_GT:
FP_LT:
FP_EQU:
FP_STLE:
FP_STGE:
FP_STNE:
FP_STGT:
FP_STLT:
FP_STEQU:
LD A,B
SUB $08
BIT 2,A
JR NZ,M395E
DEC A
M395E: RRCA
JR NC,M3969
PUSH AF
PUSH HL
CALL M37FB
POP DE
EX DE,HL
POP AF
M3969: BIT 2,A
JR NZ,M3974
RRCA
PUSH AF
CALL M33CE
JR M39A7
M3974: RRCA
PUSH AF
CALL PGPSTR
PUSH DE
PUSH BC
CALL PGPSTR
POP HL
M397F: LD A,H
OR L
EX (SP),HL
LD A,B
JR NZ,M3990
OR C
M3986: POP BC
JR Z,M398D
POP AF
CCF
JR M39A3
M398D: POP AF
JR M39A3
M3990: OR C
JR Z,M39A0
LD A,(DE)
SUB (HL)
JR C,M39A0
JR NZ,M3986
DEC BC
INC DE
INC HL
EX (SP),HL
DEC HL
JR M397F
M39A0: POP BC
POP AF
AND A
M39A3: PUSH AF
RST $28 ;calc entry
DEFB $A0 ;CONST 0 (0)
DEFB $38 ;QUIT
M39A7: POP AF
PUSH AF
CALL C ,M391C
POP AF
PUSH AF
CALL NC,M3914
POP AF
RRCA
CALL NC,M391C
RET
FP_CONCAT:
CALL PGPSTR
PUSH DE
PUSH BC
CALL PGPSTR
POP HL
PUSH HL
PUSH DE
PUSH BC
ADD HL,BC
LD B,H
LD C,L
RST $30
CALL M2E70
POP BC
POP HL
LD A,B
OR C
JR Z,M39D2
LDIR
M39D2: POP BC
POP HL
LD A,B
OR C
JR Z,M39DA
LDIR
M39DA: LD HL,(STKEND)
LD DE,$FFFB
PUSH HL
ADD HL,DE
POP DE
RET
FP_CHR:
CALL FP2A
JR C,M39F7
JR NZ,M39F7
PUSH AF
LD BC,$0001
RST $30
POP AF
LD (DE),A
CALL M2E70
EX DE,HL
RET
M39F7: RST $08 ;error: INTEGER OUT OF RANGE
DEFB $0A ;
FP_VALS:
LD HL,(CHADD)
PUSH HL
LD A,B
ADD A,$E3
SBC A,A
PUSH AF
CALL PGPSTR
PUSH DE
INC BC
RST $30
POP HL
LD (CHADD),DE
PUSH DE
LDIR
EX DE,HL
DEC HL
LD (HL),$0D
RES 7,(IY+OFLAGS) ;FLAGS
CALL EXPRN
RST $18 ;get current character
CP $0D
JR NZ,M3A27
POP HL
POP AF
XOR (IY+OFLAGS) ;FLAGS
AND $40
M3A27: JP NZ,M1BED ;error – BAD BASIC
LD (CHADD),HL
SET 7,(IY+OFLAGS) ;FLAGS
CALL EXPRN
POP HL
LD (CHADD),HL
JR M39DA
FP_STR:
LD BC,$0001
RST $30
LD (KCUR),HL
PUSH HL
LD HL,(CURCHL)
PUSH HL
LD A,$FF ;/stream -1 (RAM write)
CALL SELECT ;\
CALL M31A1
POP HL
CALL M1248
POP DE
LD HL,(KCUR)
AND A
SBC HL,DE
LD B,H
LD C,L
CALL M2E70
EX DE,HL
RET
FP_INKEY:
CALL INS_U1 ;convert top of fp stack to value in A
CP $10 ;/invalid stream # if > 16
JP NC,M1F29 ;\
LD HL,(CURCHL) ;/get the current channel pointer
PUSH HL ;\and save it
CALL SELECT ;select the requested stream
CALL M11E1
LD BC,$0000
JR NC,M3A7A
INC C
RST $30
LD (DE),A
M3A7A: CALL M2E70
POP HL
CALL M1248
JP M39DA
FP_CODE:
CALL PGPSTR
LD A,B
OR C
JR Z,M3A8C
LD A,(DE)
M3A8C: JP M30E6 ;stack A on calc stack
FP_LEN:
CALL PGPSTR
JP STK_BC
FP_LOOP:
EXX
PUSH HL
LD HL,BREG
DEC (HL)
POP HL
JR NZ,M3AA2
INC HL
EXX
RET
FP_JUMP:
M3AA1: EXX
M3AA2: LD E,(HL)
LD A,E
RLA
SBC A,A
LD D,A
ADD HL,DE
EXX
RET
FP_IFJUMP:
INC DE
INC DE
LD A,(DE)
DEC DE
DEC DE
AND A
JR NZ,M3AA1
EXX
INC HL
EXX
RET
FP_QUIT:
POP AF
EXX
EX (SP),HL
EXX
RET
;******************************************************************
; Module: FUNCTS
; Routine: INTDIV
;******************************************************************
FP_INTDIV:
RST $28 ;calc entry
DEFB $C0 ;T -> MEM 0
DEFB $02 ;DROP
DEFB $31 ;DUP
DEFB $E0 ;MEM 0 -> T
DEFB $05 ;DIV
DEFB $27 ;INT
DEFB $E0 ;MEM 0 -> T
DEFB $01 ;SWAP
DEFB $C0 ;T -> MEM 0
DEFB $04 ;TIMES
DEFB $03 ;SUB
DEFB $E0 ;MEM 0 -> T
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: INT
;******************************************************************
FP_INT:
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $36 ;MINUSQ
DEFB $00,$04 ;IFJUMP 3AD2
DEFB $3A ;TRUNC
DEFB $38 ;DUP QUIT
DEFB $C9 ;MINUSQ RET
DEFB $31 ;DUP DUP
DEFB $3A ;MINUSQ TRUNC
DEFB $C0 ;DUP T -> MEM 0
DEFB $03 ;MINUSQ SUB
DEFB $E0 ;DUP MEM 0 -> T
DEFB $01 ;MINUSQ SWAP
DEFB $30 ;NOT
DEFB $00,$03 ;IFJUMP 3ADD
DEFB $A1 ;DUP CONST 1 (256)
DEFB $03 ;MINUSQ SUB
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: EXP
;******************************************************************
FP_EXP:
M3ADF: RST $28 ;calc entry
DEFB $3D ;FLOAT
DEFB $34,$F1,$38,$AA,$3B,$29 ;LITERAL 8138AA3B29 ( 1.44269504072145),3AE7
DEFB $04 ;TIMES
DEFB $31 ;DUP
DEFB $27 ;INT
DEFB $C3 ;T -> MEM 3
DEFB $03 ;SUB
DEFB $31 ;DUP
DEFB $0F ;ADD
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $88 ;CBSV 8
DEFB $13,$36 ;6336000000 ( 1.32422428578138E-9),3AF3
DEFB $58,$65,$66 ;6865660000 ( 5.3410985856317E-8),3AF6
DEFB $9D,$78,$65,$40 ;6D78654000 ( 1.85069075087085E-6),3AFA
DEFB $A2,$60,$32,$C9 ;726032C900 ( 5.3453059081221E-5),3AFE
DEFB $E7,$21,$F7,$AF,$24 ;7721F7AF24 ( 1.23571408221324E-3),3B03
DEFB $EB,$2F,$B0,$B0,$14 ;7B2FB0B014 ( 2.14465559984092E-2),3B08
DEFB $EE,$7E,$BB,$94,$58 ;7E7EBB9458 ( .248762433882803),3B0D
DEFB $F1,$3A,$7E,$F8,$CF ;813A7EF8CF ( 1.45699987513945),3B12
DEFB $E3 ;MEM 3 -> T
DEFB $38 ;QUIT
CALL FP2A
JR NZ,M3B20
JR C,M3B1E
ADD A,(HL)
JR NC,M3B27
M3B1E: RST $08 ;error: NUMBER TOO BIG
DEFB $05 ;
M3B20: JR C,M3B29
SUB (HL)
JR NC,M3B29
NEG
M3B27: LD (HL),A
RET
M3B29: RST $28 ;calc entry
DEFB $02 ;DROP
DEFB $A0 ;CONST 0 (0)
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: LN
;******************************************************************
FP_LN:
RST $28 ;calc entry
DEFB $3D ;FLOAT
DEFB $31 ;DUP
DEFB $37 ;PLUSQ
DEFB $00,$04 ;IFJUMP 3B37
DEFB $38 ;QUIT
RST $08 ;error: INVALID ARGUMENT
DEFB $09 ;
DEFB $A0 ;CONST 0 (0)
DEFB $02 ;DROP
DEFB $38 ;QUIT
LD A,(HL)
LD (HL),$80
CALL M30E6 ;stack A on calc stack
RST $28 ;calc entry
DEFB $34,$38,$00 ;LITERAL 8800000000 ( 128),3B44
DEFB $03 ;SUB
DEFB $01 ;SWAP
DEFB $31 ;DUP
DEFB $34,$F0,$4C,$CC,$CC,$CD ;LITERAL 804CCCCCCD ( .800000000046566),3B4D
DEFB $03 ;SUB
DEFB $37 ;PLUSQ
DEFB $00,$08 ;IFJUMP 3B58
DEFB $01 ;SWAP
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $01 ;SWAP
DEFB $38 ;QUIT
INC (HL)
RST $28 ;calc entry
DEFB $01 ;SWAP
DEFB $34,$F0,$31,$72,$17,$F8 ;LITERAL 80317217F8 ( .693147180601954),3B5F
DEFB $04 ;TIMES
DEFB $01 ;SWAP
DEFB $A2 ;CONST 1 (0.5)
DEFB $03 ;SUB
DEFB $A2 ;CONST 1 (0.5)
DEFB $03 ;SUB
DEFB $31 ;DUP
DEFB $34,$32,$20 ;LITERAL 8220000000 ( 2.5),3B69
DEFB $04 ;TIMES
DEFB $A2 ;CONST 1 (0.5)
DEFB $03 ;SUB
DEFB $8C ;CBSV 12
DEFB $11,$AC ;61AC000000 (-3.12866177409887E-10),3B6F
DEFB $14,$09 ;6409000000 ( 1.99361238628626E-9),3B71
DEFB $56,$DA,$A5 ;66DAA50000 (-1.2726786735584E-8),3B74
DEFB $59,$30,$C5 ;6930C50000 ( 8.23147274786606E-8),3B77
DEFB $5C,$90,$AA ;6C90AA0000 (-5.38915628567338E-7),3B7A
DEFB $9E,$70,$6F,$61 ;6E706F6100 ( 3.58276179213135E-6),3B7E
DEFB $A1,$CB,$DA,$96 ;71CBDA9600 (-2.43012727878522E-5),3B82
DEFB $A4,$31,$9F,$B4 ;74319FB400 ( 1.69395294506103E-4),3B86
DEFB $E7,$A0,$FE,$5C,$FC ;77A0FE5CFC (-1.22828373969242E-3),3B8B
DEFB $EA,$1B,$43,$CA,$36 ;7A1B43CA36 ( 9.47661158716073E-3),3B90
DEFB $ED,$A7,$9C,$7E,$5E ;7DA79C7E5E (-.081841456645634),3B95
DEFB $F0,$6E,$23,$80,$93 ;806E238093 ( .930229221237823),3B9A
DEFB $04 ;TIMES
DEFB $0F ;ADD
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: ANGLE
;******************************************************************
FP_ANGLE:
RST $28 ;calc entry
DEFB $3D ;FLOAT
DEFB $34,$EE,$22,$F9,$83,$6E ;LITERAL 7E22F9836E ( .1591549430741),3BA6
DEFB $04 ;TIMES
DEFB $31 ;DUP
DEFB $A2 ;CONST 1 (0.5)
DEFB $0F ;ADD
DEFB $27 ;INT
DEFB $03 ;SUB
DEFB $31 ;DUP
DEFB $0F ;ADD
DEFB $31 ;DUP
DEFB $0F ;ADD
DEFB $31 ;DUP
DEFB $2A ;ABS
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $31 ;DUP
DEFB $37 ;PLUSQ
DEFB $C0 ;T -> MEM 0
DEFB $00,$04 ;IFJUMP 3BBC
DEFB $02 ;DROP
DEFB $38 ;QUIT
DEFB $C9 ;RET
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $01 ;SWAP
DEFB $36 ;MINUSQ
DEFB $00,$02 ;IFJUMP 3BC3
DEFB $1B ;NEGATE
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: COS
;******************************************************************
FP_COS:
RST $28 ;calc entry
DEFB $39 ;ANGLE
DEFB $2A ;ABS
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $E0 ;MEM 0 -> T
DEFB $00,$06 ;IFJUMP 3BD2
DEFB $1B ;NEGATE
DEFB $33,$03 ;JUMP 3BD2
;******************************************************************
; Module: FUNCTS
; Routine: SIN
;******************************************************************
FP_SIN:
RST $28 ;calc entry
DEFB $39 ;ANGLE
DEFB $31 ;DUP
DEFB $31 ;DUP
DEFB $04 ;TIMES
DEFB $31 ;DUP
DEFB $0F ;ADD
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $86 ;CBSV 6
DEFB $14,$E6 ;64E6000000 (-3.34694050252438E-9),3BDC
DEFB $5C,$1F,$0B ;6C1F0B0000 ( 5.92481228522956E-7),3BDF
DEFB $A3,$8F,$38,$EE ;738F38EE00 (-6.8293753429316E-5),3BE3
DEFB $E9,$15,$63,$BB,$23 ;791563BB23 ( 4.55900800261588E-3),3BE8
DEFB $EE,$92,$0D,$CD,$ED ;7E920DCDED (-.142630784597714),3BED
DEFB $F1,$23,$5D,$1B,$EA ;81235D1BEA ( 1.27627896238118),3BF2
DEFB $04 ;TIMES
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: TAN
;******************************************************************
FP_TAN:
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $1F ;SIN
DEFB $01 ;SWAP
DEFB $20 ;COS
DEFB $05 ;DIV
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: ATN
;******************************************************************
FP_ATN:
CALL M3656
LD A,(HL)
CP $81
JR C,M3C13
RST $28 ;calc entry
DEFB $A1 ;CONST 1 (256)
DEFB $1B ;NEGATE
DEFB $01 ;SWAP
DEFB $05 ;DIV
DEFB $31 ;DUP
DEFB $36 ;MINUSQ
DEFB $A3 ;CONST 3 (PI/2)
DEFB $01 ;SWAP
DEFB $00,$06 ;IFJUMP 3C15
DEFB $1B ;NEGATE
DEFB $33,$03 ;JUMP 3C15
M3C13: DEFB $EF ;MEM 15 -> T
DEFB $A0 ;CONST 0 (0)
DEFB $01 ;SWAP
DEFB $31 ;DUP
DEFB $31 ;DUP
DEFB $04 ;TIMES
DEFB $31 ;DUP
DEFB $0F ;ADD
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $8C ;CBSV 12
DEFB $10,$B2 ;60B2000000 (-1.61890056915581E-10),3C20
DEFB $13,$0E ;630E000000 ( 1.03318598121405E-9),3C22
DEFB $55,$E4,$8D ;65E48D0000 (-6.65170318825403E-9),3C25
DEFB $58,$39,$BC ;6839BC0000 ( 4.32446540798992E-8),3C28
DEFB $5B,$98,$FD ;6B98FD0000 (-2.84962879959494E-7),3C2B
DEFB $9E,$00,$36,$75 ;6E00367500 ( 1.91051844922185E-6),3C2F
DEFB $A0,$DB,$E8,$B4 ;70DBE8B400 (-1.31075976241846E-5),3C33
DEFB $63,$42,$C4 ;7342C40000 ( 9.28714871406555E-5),3C36
DEFB $E6,$B5,$09,$36,$BE ;76B50936BE (-6.90597501943557E-4),3C3B
DEFB $E9,$36,$73,$1B,$5D ;7936731B5D ( 5.56792102906911E-3),3C40
DEFB $EC,$D8,$DE,$63,$BE ;7CD8DE63BE (-5.29464622668456E-2),3C45
DEFB $F0,$61,$A1,$B3,$0C ;8061A1B30C ( .881373587064445),3C4A
DEFB $04 ;TIMES
DEFB $0F ;ADD
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: ASN
;******************************************************************
FP_ASN:
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $31 ;DUP
DEFB $04 ;TIMES
DEFB $A1 ;CONST 1 (256)
DEFB $03 ;SUB
DEFB $1B ;NEGATE
DEFB $28 ;ROOT
DEFB $A1 ;CONST 1 (256)
DEFB $0F ;ADD
DEFB $05 ;DIV
DEFB $24 ;ATN
DEFB $31 ;DUP
DEFB $0F ;ADD
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: ACS
;******************************************************************
FP_ACS:
RST $28 ;calc entry
DEFB $22 ;ASN
DEFB $A3 ;CONST 3 (PI/2)
DEFB $03 ;SUB
DEFB $1B ;NEGATE
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: FUNCTS
; Routine: ROOT
;******************************************************************
FP_ROOT:
RST $28 ;calc entry
DEFB $31 ;DUP
DEFB $30 ;NOT
DEFB $00,$1E ;IFJUMP 3C87
DEFB $A2 ;CONST 1 (0.5)
DEFB $38 ;QUIT
;******************************************************************
; Module: FUNCTS
; Routine: TO_THE
;******************************************************************
FP_TO_THE:
RST $28 ;calc entry
DEFB $01 ;SWAP
DEFB $31 ;DUP
DEFB $30 ;NOT
DEFB $00,$07 ;IFJUMP 3C78
DEFB $25 ;LN
DEFB $04 ;TIMES
DEFB $38 ;QUIT
JP M3ADF
DEFB $02 ;DROP
DEFB $31 ;DUP
DEFB $30 ;NOT
DEFB $00,$09 ;IFJUMP 3C85
DEFB $A0 ;CONST 0 (0)
DEFB $01 ;SWAP
DEFB $37 ;PLUSQ
DEFB $00,$06 ;IFJUMP 3C87
DEFB $A1 ;CONST 1 (256)
DEFB $01 ;SWAP
DEFB $05 ;DIV
DEFB $02 ;DROP
DEFB $A1 ;CONST 1 (256)
DEFB $38 ;QUIT
RET
;******************************************************************
; Module: TAPEMSG
; Routine: SEPRMT
;******************************************************************
SEPRMT:
M3C89: DEFM $80&"Start tape, then press any key"&(‘.’+$80)
DEFM $0D&"Program:"&(‘ ‘+$80)
DEFM $0D&"Number array:"&(‘ ‘+$80)
DEFM $0D&"Character array:"&(‘ ‘+$80)
DEFM $0D&"Bytes:"&(‘ ‘+$80)
DEFB $FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF
DEFB $FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF
DEFB $FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF
DEFB $FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF
DEFB $FF,$FF,$FF,$FF
;******************************************************************
; Module: CH_SET
; Routine: CHRSET
;******************************************************************
CHRSET:
DEFB $00,$00,$00,$00,$00,$00,$00,$00 ;
DEFB $00,$10,$10,$10,$10,$00,$10,$00 ;
DEFB $00,$24,$24,$00,$00,$00,$00,$00 ;
DEFB $00,$24,$7E,$24,$24,$7E,$24,$00 ;
DEFB $00,$08,$3E,$28,$3E,$0A,$3E,$08 ;
DEFB $00,$62,$64,$08,$10,$26,$46,$00 ;
DEFB $00,$10,$28,$10,$2A,$44,$3A,$00 ;
DEFB $00,$08,$10,$00,$00,$00,$00,$00 ;
DEFB $00,$04,$08,$08,$08,$08,$04,$00 ;
DEFB $00,$20,$10,$10,$10,$10,$20,$00 ;
DEFB $00,$00,$14,$08,$3E,$08,$14,$00 ;
DEFB $00,$00,$08,$08,$3E,$08,$08,$00 ;
DEFB $00,$00,$00,$00,$00,$08,$08,$10 ;
DEFB $00,$00,$00,$00,$3E,$00,$00,$00 ;
DEFB $00,$00,$00,$00,$00,$18,$18,$00 ;
DEFB $00,$00,$02,$04,$08,$10,$20,$00 ;
DEFB $00,$3C,$46,$4A,$52,$62,$3C,$00 ;
DEFB $00,$18,$28,$08,$08,$08,$3E,$00 ;
DEFB $00,$3C,$42,$02,$3C,$40,$7E,$00 ;
DEFB $00,$3C,$42,$0C,$02,$42,$3C,$00 ;
DEFB $00,$08,$18,$28,$48,$7E,$08,$00 ;
DEFB $00,$7E,$40,$7C,$02,$42,$3C,$00 ;
DEFB $00,$3C,$40,$7C,$42,$42,$3C,$00 ;
DEFB $00,$7E,$02,$04,$08,$10,$10,$00 ;
DEFB $00,$3C,$42,$3C,$42,$42,$3C,$00 ;
DEFB $00,$3C,$42,$42,$3E,$02,$3C,$00 ;
DEFB $00,$00,$00,$10,$00,$00,$10,$00 ;
DEFB $00,$00,$10,$00,$00,$10,$10,$20 ;
DEFB $00,$00,$04,$08,$10,$08,$04,$00 ;
DEFB $00,$00,$00,$3E,$00,$3E,$00,$00 ;
DEFB $00,$00,$10,$08,$04,$08,$10,$00 ;
DEFB $00,$3C,$42,$04,$08,$00,$08,$00 ;
DEFB $00,$3C,$4A,$56,$5E,$40,$3C,$00 ;
DEFB $00,$3C,$42,$42,$7E,$42,$42,$00 ;
DEFB $00,$7C,$42,$7C,$42,$42,$7C,$00 ;
DEFB $00,$3C,$42,$40,$40,$42,$3C,$00 ;
DEFB $00,$78,$44,$42,$42,$44,$78,$00 ;
DEFB $00,$7E,$40,$7C,$40,$40,$7E,$00 ;
DEFB $00,$7E,$40,$7C,$40,$40,$40,$00 ;
DEFB $00,$3C,$42,$40,$4E,$42,$3C,$00 ;
DEFB $00,$42,$42,$7E,$42,$42,$42,$00 ;
DEFB $00,$3E,$08,$08,$08,$08,$3E,$00 ;
DEFB $00,$02,$02,$02,$42,$42,$3C,$00 ;
DEFB $00,$44,$48,$70,$48,$44,$42,$00 ;
DEFB $00,$40,$40,$40,$40,$40,$7E,$00 ;
DEFB $00,$42,$66,$5A,$42,$42,$42,$00 ;
DEFB $00,$42,$62,$52,$4A,$46,$42,$00 ;
DEFB $00,$3C,$42,$42,$42,$42,$3C,$00 ;
DEFB $00,$7C,$42,$42,$7C,$40,$40,$00 ;
DEFB $00,$3C,$42,$42,$52,$4A,$3C,$00 ;
DEFB $00,$7C,$42,$42,$7C,$44,$42,$00 ;
DEFB $00,$3C,$40,$3C,$02,$42,$3C,$00 ;
DEFB $00,$FE,$10,$10,$10,$10,$10,$00 ;
DEFB $00,$42,$42,$42,$42,$42,$3C,$00 ;
DEFB $00,$42,$42,$42,$42,$24,$18,$00 ;
DEFB $00,$42,$42,$42,$42,$5A,$24,$00 ;
DEFB $00,$42,$24,$18,$18,$24,$42,$00 ;
DEFB $00,$82,$44,$28,$10,$10,$10,$00 ;
DEFB $00,$7E,$04,$08,$10,$20,$7E,$00 ;
DEFB $00,$0E,$08,$08,$08,$08,$0E,$00 ;
DEFB $00,$00,$40,$20,$10,$08,$04,$00 ;
DEFB $00,$70,$10,$10,$10,$10,$70,$00 ;
DEFB $00,$10,$38,$54,$10,$10,$10,$00 ;
DEFB $00,$00,$00,$00,$00,$00,$00,$FF ;
DEFB $00,$1C,$22,$78,$20,$20,$7E,$00 ;
DEFB $00,$00,$38,$04,$3C,$44,$3C,$00 ;
DEFB $00,$20,$20,$3C,$22,$22,$3C,$00 ;
DEFB $00,$00,$1C,$20,$20,$20,$1C,$00 ;
DEFB $00,$04,$04,$3C,$44,$44,$3C,$00 ;
DEFB $00,$00,$38,$44,$78,$40,$3C,$00 ;
DEFB $00,$0C,$10,$18,$10,$10,$10,$00 ;
DEFB $00,$00,$3C,$44,$44,$3C,$04,$38 ;
DEFB $00,$40,$40,$78,$44,$44,$44,$00 ;
DEFB $00,$10,$00,$30,$10,$10,$38,$00 ;
DEFB $00,$04,$00,$04,$04,$04,$24,$18 ;
DEFB $00,$20,$28,$30,$30,$28,$24,$00 ;
DEFB $00,$10,$10,$10,$10,$10,$0C,$00 ;
DEFB $00,$00,$6C,$92,$92,$92,$92,$00 ;
DEFB $00,$00,$78,$44,$44,$44,$44,$00 ;
DEFB $00,$00,$38,$44,$44,$44,$38,$00 ;
DEFB $00,$00,$78,$44,$44,$78,$40,$40 ;
DEFB $00,$00,$3C,$44,$44,$3C,$04,$06 ;
DEFB $00,$00,$1C,$20,$20,$20,$20,$00 ;
DEFB $00,$00,$38,$40,$38,$04,$78,$00 ;
DEFB $00,$10,$38,$10,$10,$10,$0C,$00 ;
DEFB $00,$00,$44,$44,$44,$44,$38,$00 ;
DEFB $00,$00,$44,$44,$28,$28,$10,$00 ;
DEFB $00,$00,$92,$92,$92,$92,$6C,$00 ;
DEFB $00,$00,$44,$28,$10,$28,$44,$00 ;
DEFB $00,$00,$44,$44,$44,$3C,$04,$38 ;
DEFB $00,$00,$7C,$08,$10,$20,$7C,$00 ;
DEFB $00,$0E,$08,$30,$08,$08,$0E,$00 ;
DEFB $00,$08,$08,$08,$08,$08,$08,$00 ;
DEFB $00,$70,$10,$0C,$10,$10,$70,$00 ;
DEFB $00,$14,$28,$00,$00,$00,$00,$00 ;
DEFB $3C,$42,$99,$A1,$A1,$99,$42,$3C ;
[/sourcecode]