DEVICE ZXSPECTRUM128
include "../_sdk/sys_h.asm"
;title TURBO PASCAL Compiler for CP/M 80
;name ('TURBO')
; DASMed version of TURBO.COM, v3.0
; By W. Cirsovius
;; +++l6f66 l446c l7124 l2da4 l3135 l2df8
; l731f -> $STR$ in Teil 6
;;; RTL l0af5
;;; MENUE -----
;;; EDITOR l42a1 l3918 l2fc1 l324b l32f5 (SEARCH)
;;; COMPILER l5039
;.z80
;aseg
;org 0100h
org PROGSTART
begin
FALSE equ 0
_TRUE equ 1
TERM equ _TRUE;FALSE
OS equ 0000h
DU equ 0004h ;TODO change to GETPATH and subdirs
BDOS equ 0005h
;TPAtop equ BDOS+1
NEDOOSMEMTOP=0xff00;0xdc06 ;TODO 0x0000?
Number equ 005dh
;TPA equ 0100h
;CP/M function codes:
;_resdsk equ 13 ;TODO
;_seldsk equ 14 ;
_open equ 15 ;
_close equ 16 ;
_srcfrs equ 17 ;
_srcnxt equ 18 ;
_delete equ 19 ;
_rdseq equ 20 ;
_wrseq equ 21 ;
_make equ 22 ;
_rename equ 23 ;TODO
_retdsk equ 25 ;TODO (return A=current drive)
_setdma equ 26 ;
_getalv equ 27 ;TODO
_getdpb equ 31 ;TODO
_rndrd equ 33 ;
_rndwr equ 34 ;
_filsiz equ 35 ;TODO (lib?)
RecLng equ 128 ; Standard record length
Dirlng equ 15
MaxParams equ 31
a_const equ 2
a_conin equ 3
a_conout equ 4
a_list equ 5
a_auxout equ 6
a_auxin equ 7
_.const equ (a_const-1)*3
_.conin equ (a_conin-1)*3
_.conout equ (a_conout-1)*3
_.list equ (a_list-1)*3
_.auxout equ (a_auxout-1)*3
_.auxin equ (a_auxin-1)*3
Fdrv equ 1
Fname equ 8
Fext equ 3
_SYS equ 10
_ex equ 12
DIRlen equ 16
_rrn equ 33 ;shift to random record number in FCB
FCBlen equ 36
FIB.rec equ 4 ; Pointer #records
FIB.reclen equ 6 ; Pointer record length
FIB.cur equ 8 ; Pointer to current record
FIB.FCB equ 12 ; Pointer to FCB
FIBlen equ FIB.FCB+FCBlen ; FIB length less buffer
FIB.buff equ FIBlen ; Pointer to buffer
FIBtype equ 00001111b
rd.bit equ 4
wr.bit equ 5
out.bit equ 6
in.bit equ 7
_.in equ 10000000b
_.out equ 01000000b
_.read equ 00010000b
FixRecLen equ 4 ; Fixed record length
Rec.Wr.bit equ 0
Rec.New.bit equ 1
Rec.Wr equ 01b
Rec.New equ 10b
RAMdevice equ 6
HeapLen equ 4 ; Heap administration
HeapLOadr equ 0 ; Address location
HeapHIadr equ 1
HeapLOlen equ 2 ; Length location
HeapHIlen equ 3
null equ 00h
bs equ 08h
tab equ 09h
lf equ 0ah
cr equ 0dh
eof equ 1ah
esc equ 1bh
CtrlC equ 'C'-'@'
Xoff equ 'S'-'@'
a_CAN equ 'U'-'@'
CtrlX equ 'X'-'@'
;DEL equ 7fh
LoMask equ 00001111b
DPBMASK equ 00011111b
NOMSB equ 01111111b
MSB equ 10000000b
LSB equ 00000001b
MMSB equ 1000000000000000b
MINWID equ 56 ; Min width for filename
MAXINT equ 32767
DefSTR equ 8
_LB equ 0
_MB equ 7
sgn.bit equ 7
sign.bit equ 10000000b
mant.len equ 5 ; Byte length of mantissa
Real.Len equ 6 ; Length of real
bit.len equ 8 ; Bits in a byte
exp.offset equ 080h ; Offset in exponent
Exp.One equ exp.offset+1 ; Exponent for >=1.0
int.max equ exp.offset+15 ; Max exponent for an integer
mant.bits equ mant.len*bit.len
real.dig equ 24 ; Length of mantissa
real.field equ 7 ; Real field size
real.ASCII equ 12 ; Decimal places
ExpFix equ 77 ; Exponent fix for real to ASCII
ExpRange equ 0d9h ; Exponent range
sqr.exp equ 014h ; SQRT exponent fix
sin.min equ 06ch ; SIN/COS minimum exponent
ln.min equ 067h ; LN minimum exponent
exp.max equ 088h ; EXP maximum exponent
dot.bit equ 6 ; Status of dot in real
exps.bit equ 5 ; Sign of exponent
exp.bit equ 4 ; Exponent
l00fe equ 254 ; Mystery editor size
MEMGAP equ 708 ; Memory gap at top of memory
StkSpc equ 1024 ; Stack space
_SavLen equ 8192
_RST equ 7 ; ** CAUTION **
RSTADDR equ _RST*8 ;SHL 3 ; RST address (0x0038H)
RST equ 11000111b + RSTADDR; RST instruction (0xFFH)
a_OVLADR equ 9000h ; Overlay load address
_LD.A equ 03eh ; LD A,xx
_LD.BC equ 001h ; LD BC,xxxx
_LD.DE equ 011h ; LD DE,xxxx
_LD.HL equ 021h ; LD HL,xxxx
_LD.SP equ 031h ; LD SP,xxxx
_LD_a_DE equ 5bedh ; LD DE,(xxxx)
_LD_a_HL equ 02ah ; LD HL,(xxxx)
_LDHL_a equ 022h ; LD (xxxx),HL
_LDA_a equ 032h ; LD (xxxx),A
_JP equ 0c3h ; JP xxxx
_CALL equ 0cdh ; CALL addr
_JPZ equ 0cah ; JP Z,xxxx
_EXX equ 0d9h ; EXX
_POP.HL equ 0e1h ; POP HL
_PUSH.HL equ 0e5h ; PUSH HL
_INC.HL equ 023h ; PUSH HL
_DEC.HL equ 02bh ; PUSH HL
;
skip equ 03eh ; LD A,xx
skip.2 equ 001h ; LD BC,xx
skip.3 equ 011h ; LD DE,xx
_LinLen equ 127
_MaxBuf equ 126 ; Max line input
_MaxSamp equ 30 ; Max sample input
_Ahead equ 20 ; Size of ahead buffer
set.len equ 32
DefWITH equ 2
_Byte equ 1
_Addr equ 2
_Array equ 1
_Record equ 2
_Set equ 3
_Ptr equ 4
_RecF equ 5
_TxtF equ 6
_UntF equ 7
_String equ 8
_Real equ 9
_Integ equ 10
_Bool equ 11
_Char equ 12
;13=element of a set?
_Label equ 1
_Const equ 2
_Type equ 3
_Var equ 4
_Proc equ 5
_Overly equ 7
_Begin equ 8
;
; Option selection bits
;
__Ropt equ 00000010b
__Uopt equ 00001000b
;
_Iopt equ 0
_Ropt equ 1
_Aopt equ 2
_Uopt equ 3
_Xopt equ 4
_Vopt equ 5
_Bopt equ 6
_Copt equ 7
;
; Search option list
;
_W equ 0
_N equ 1
_U equ 2
_G equ 3
_B equ 4
;
; Error levels
;
_BRK equ 0 ; User break
_IO equ 1 ; I/O error
_RT equ 2 ; Run time error
;
; BREAK error
;
_CBRK equ 1
;
; Compiler errors
;
_ColExp equ 1
_SemiExp equ 2
_CommaExp equ 3
_LftPar equ 4
_RgtPar equ 5
_EquExp equ 6
_AssigExp equ 7
_LftBrExp equ 8
_RgtBrExp equ 9
_DotExp equ 10
_TwoDots equ 11
_BEGINexp equ 12
_NoDO equ 13
_End equ 14
_NoOF equ 15
_SUBexp equ 16
_StrIdx equ 17
_NoDOWN_TO equ 18
_BoolExp equ 20
_FileVarExp equ 21
_IntConst equ 22
_IntExpr equ 23
_IntVarExp equ 24
_IntRealCexp equ 25
_NumExprExp equ 26
_NumVarExp equ 27
_PtrVarExp equ 28
_RecVarExp equ 29
_SimTyp equ 30
_SimpExpr equ 31
_StrgConExp equ 32
_StrgExpExp equ 33
_StrgVarExp equ 34
_MustTextFile equ 35
_TypeExp equ 36
_UntFileExp equ 37
_UnkLabel equ 40
_Undef equ 41
_InkPointer equ 42
_DoubleLab equ 43
_InvType equ 44
_ConstRange equ 45
_IllCASE equ 46
_IllOps equ 47
_InvResult equ 48
_IllStrgLen equ 49
_StrConst equ 50
_IllSkalar equ 51
_IllLimit equ 52
_ResWord equ 53
_IllAss equ 54
_StrConLong equ 55
_IntegErr equ 56
_RealErr equ 57
_IllChar equ 58
_IllConst equ 60
_InvFilPtr equ 61
_NoStruktVar equ 62
_IllTxtFile equ 63
_IllFileType equ 64
_NoUntypeFile equ 65
_InvIO equ 66
_VarFile equ 67
_FileF equ 68
_InvSetOrder equ 69
_IllSetRange equ 70
_IllGOTO equ 71
_IllLabel equ 72
_UndefFORW equ 73
_IllINLINE equ 74
_InvalABS equ 75
_OvlFORW equ 76
_OvlDirErr equ 77
_NoFileErr equ 90
_IllSrcEnd equ 91
_NoOvl equ 92
_CompDirec equ 93
_INCLerr equ 96
_TooManyWITH equ 97
_MemOvfl equ 98
_CompOvfl equ 99
_IndxErr equ 144
_RngErr equ 145
_ABORT equ 202
_FndRTerr equ 200
_DskFull equ 250
;
; Run-Time errors
;
_FLPovfl equ 1 ; 0x01
_DivZero equ 2 ; 0x02
_NegSqrt equ 3 ; 0x03
_LNerr equ 4 ; 0x04
_StrLenErr equ 16 ; 0x10
_TruncOvl equ 146 ; 0x92
_OVLerr equ 240 ; 0xf0
_HeapErr equ 255 ; 0xff
;
; Run-Time I/O errors
;
_NoFile equ 1 ; 0x01
_NoRead equ 2 ; 0x02
_NoWrite equ 3 ; 0x03
_BlkErr equ 4 ; 0x04
_IllNum equ 16 ; 0x10
_IllIO equ 32 ; 0x20
_DirErr equ 33 ; 0x21
_StdAssErr equ 34 ; 0x22
_InvRec equ 144 ; 0x90
_SeekEOF equ 145 ; 0x91
_IllEOF equ 153 ; 0x99
_WrErr equ 240 ; 0xF0
_DirFull equ 241 ; 0xF1
_OvflErr equ 242 ; 0xF2
_NoClose equ 255 ; 0xFF
TPhead equ 21 ; Header code length for ERROR
_Video equ 7 ; Status
a_DUMMY equ 04d2h
;l0300 equ 0300h
;l0800 equ 0800h
l07d0 equ 07d0h
l00a0 equ 00a0h ; Keypressed
l00a3 equ 00a3h ; Read KBD
l00a6 equ 00a6h ; Console output
l00a9 equ 00a9h ; List output
l00ac equ 00ach ; Auxiliary output
l00af equ 00afh ; Auxiliary input
l00b2 equ 00b2h ; Console output
l00b5 equ 00b5h ; Read USR
l00b8 equ 00b8h ; Base FIB
l00ba equ 00bah ; ConinFIB
l00bc equ 00bch ; LstFIB
l00be equ 00beh ; AuxFIB
l00c0 equ 00c0h ; UsrFIB
l00c2 equ 00c2h ; StdIOdev
l00c4 equ 00c4h ; Heap pointer
l00c6 equ 00c6h ; Recursion pointer
l00c8 equ 00c8h ; Four byte random value
l00cc equ 00cch ; Base PC
l00ce equ 00ceh ; Current PC
l00d0 equ 00d0h ; I/O result
l00d1 equ 00d1h ; Buffer length
l00d2 equ 00d2h ; RTL top of memory
l00d4 equ 00d4h ; Current pointer
l00d6 equ 00d6h ; Top pointer
l00d8 equ 00d8h ; Run mode
l00d9 equ 00d9h ; + JP xxxx
l00da equ 00dah ; + Restart vector
l00dc equ 00dch ; Overlay drive
l00dd equ 00ddh ; $C mode
l00e0 equ 00e0h ; Video mode
l00e8 equ 00e8h ; Pointer ????
l00f4 equ 00f4h ; Available memory
l0000 equ 00h
l0001 equ 01h
l0002 equ 02h
l0005 equ 05h
l0008 equ 08h
l000c equ 0ch
l000d equ 0dh ;for save environment
l0015 equ 15h
;l0019 equ 19h
l0024 equ 24h
l0030 equ 30h
l005c equ 5ch
l0080 equ 80h
l0081 equ 81h
l00b0 equ 00b0h
l00de equ 0deh
l00e2 equ 0e2h
l00e4 equ 0e4h
l00e6 equ 0e6h
l00e9 equ 0e9h
l00ea equ 0eah
l00ec equ 0ech
l00ed equ 0edh
l00f0 equ 0f0h
l00f2 equ 0f2h
l00f6 equ 0f6h
l00f8 equ 0f8h
lfff3 equ 0fff3h
lfffc equ 0fffch
lffff equ 0ffffh
l0100:
if TERM
call initstdio
else
OS_HIDEFROMPARENT
ld e,6 ;textmode
OS_SETGFX
endif
progstartaddr=$+1
jp l20e2 ; Jump over Run Time Library
;
; %%%%%%%%%%%%%%%%%%%%%%%%%
; %%% RUN TIME ROUTINES %%%
; %%%%%%%%%%%%%%%%%%%%%%%%%
;
db 0cdh,0abh
db 'Copyright (C) 1985 BORLAND Inc',null
l0124:
db 4 ; CPU speed
db 0,0a1h,'B'
;
; &&&&&&&&&&&&&&&&&&
; &&& PATCH AREA &&&
; &&&&&&&&&&&&&&&&&&
;
l0128:
cp 0fch ; Test special key
jp z,l2e8f
cp esc ; Test ESCape
jp z,l2e8f
jp l2e88
;
ds 30
;
l0153:
db TermLen
db 'NedoOS BDOS';'Schneider Joyce'
TermLen equ $-l0153-1
db '12864'
l0168:
db 80;90 ; Screen columns
l0169:
dw 25;31 ; Screen lines
;
; Lead in sequence: Leave 24x80 mode
;
l016b:
db 0;db 2,esc,'y'
;
db 1bh,'Y ',1,1,1dh
db 3,3,1bh,1bh,1bh,0d5h
;
; Lead out sequence: Enter 24x80 mode
;
l017b:
db 0;db 2,esc,'x'
;
db 0,0,1ch,0,17h,17h
db 1dh,17h,17h,0efh,9eh,0cdh,0bdh
;
;setxy sequence
;not used in NedoOS
l018b:
db 4,esc,'Y',0,0
ds 11
ll018b equ $-l018b
l019b:
db 1 ; Binary indicator (1 is binary)
l019c:
db ' ' ; Offset for column
l019d:
db ' ' ; Offset for row
l019e:
db 4 ; Position of column
l019f:
db 3 ; Position of row
l01a0:
dw 0
;
; Clear display
;not used in NedoOS
l01a2:
db 2,esc,'E'
ds 3
;
; Home cursor
;not used in NedoOS
l01a8:
db 2,esc,'H'
ds 3
;
; Insert line
;if zero in first byte, function not implemented in this terminal
l01ae:
db 0;db 2,esc,'L'
ds 3
;
; Delete line
;if zero in first byte, function not implemented in this terminal
l01b4:
db 0;db 2,esc,'M'
ds 3
l01ba:
dw 0
;
; Clear to end of line
;if zero in first byte, function not implemented in this terminal
l01bc:
if TERM
db 1
else
db 0;db 2,esc,'K'
endif
ds 3
;
; Turn off inverse
;
l01c2:
db 2,esc,'q'
ds 3
;
; Turn on inverse
;
l01c8:
db 2,esc,'p'
ds 3
l01ce:
dw 0
;
; Print control string ^HL on console
; C set if control not defined
;
l01d0:
ld a,(hl) ; Get character
or a ; Test defined
scf
ret z ; Nope as C set says
l01d4:
inc hl
push af
push hl
push ix ;TODO remove?
push iy
ld a,(hl) ; Get character
if TERM
PRCHAR_ ;call l01e8 ; Put to console
else
PRCHAR ;call l01e8 ; Put to console
endif
pop iy
pop ix ;TODO remove?
pop hl
pop af
dec a
ret z
jr l01d4
;
; Give new line on console
;
l01e1:
call l0200
db cr,lf,null
ret
;
; Put character on console
;
l01e8:
push ix ;TODO remove?
push iy
;ld l,a
;push hl ; Push onto stack
if TERM
PRCHAR_ ;call l00a6 ; Put to console
else
PRCHAR ;call l00a6 ; Put to console
endif
pop iy
pop ix ;TODO remove?
ret
;
; Check character for attribute
; MSB set for normal output
;
l01ee:
cp MSB ; Test attribute set
call c,setlowvideo ; Nope, set invers video
call nc,setnormvideo ; Yeap, set normal video
and NOMSB ; Strip off attribute
jr l01e8
;
; Print immediate control string on console
;
l01fa:
push hl
ld hl,l01ee ; Get new output routine
jr l0204
;
; Print immediate string on console
;
l0200:
push hl
ld hl,l01e8 ; Get new output routine
l0204:
ld (l0213),hl ; Change output vector
pop hl
ex (sp),hl ; Get pointer to string
push af
push bc
push de
l020c:
ld a,(hl) ; Get character
inc hl
or a ; Test end
jr z,l0218 ; Yeap
push hl
l0213 equ $+1
call a_DUMMY ; Process output
pop hl
jr l020c
l0218:
pop de
pop bc
pop af
ex (sp),hl
ret
;
; Delay by value in reg HL
;
l021d:
ld a,l
or h ; Test any value given
ret z ; Nope
ld a,(l0124) ; Get CPU speed
add a,a
add a,a
add a,a ; Build delay value
l0226:
ex (sp),hl ; 5 cycles
ex (sp),hl ; 10 cycles
ex (sp),hl ; 15 cycles
ex (sp),hl ; 20 cycles
push bc ; 23 cycles
ld bc,1234 ; 26 cycles
pop bc ; 29 cycles
dec a ; 30 cycles
jr nz,l0226
dec hl
jr l021d
;
; Give control and delay if control defined
;
l0235:
call l01d0 ; Give control
ret c ; Not defined
ld hl,(l01ce) ; Get value
jr l021d ; Delay
;
; Clear screen
;
l023e:
push af
push bc
push de
push hl
if 1==1
push ix ;TODO remove?
push iy ;needed!!!
if TERM
ld de,0
SETXY_
CLS_ ;print 25 lines of spaces except one
else
ld e,0
OS_CLS
endif
pop iy
pop ix ;TODO remove?
else
ld hl,l01a8
call l0235 ; Home cursor
ld hl,l01a2
l024b:
call l01d0 ; Clear display
endif
ld hl,(l01ba)
call nc,l021d ; Delay if defined
pop hl
pop de
pop bc
pop af
ret
;
; Delete line
;
l0259:
if 1==1
;jr $ ;TODO
else
push af
push bc
push de
push hl
ld hl,l01b4
jr l024b ; Delete line
endif
;
; Insert line
;
l0262:
if 1==1
;jr $ ;TODO
else
push af
push bc
push de
push hl
ld hl,l01ae
jr l024b ; Insert line
endif
;
; Set low video
;
setlowvideo:
push af
ld a,(l00e0) ; Get video mode
or a ; Test low mode already set
jr z,l0282 ; Yeap, skip
if 1==1
push bc
push de
push hl
push ix
push iy
xor a
ld (l00e0),a ; Set video mode
if TERM
ld de,0x0007
else
ld e,0x07;0x38
endif
l027c:
if TERM
SETCOLOR_
else
OS_SETCOLOR
endif
pop iy
pop ix
pop hl
pop de
pop bc
else
push bc
push de
push hl
xor a
ld (l00e0),a ; Set video mode
ld hl,l01c8 ; Set attribute
l027c:
call l0235 ; Give control
pop hl
pop de
pop bc
endif
l0282:
pop af
ret
;
; Set normal video
;
setnormvideo:
push af
ld a,(l00e0) ; Get video mode
cp -1 ; Test normal mode already set
jr z,l0282 ; Yeap, skip
if 1==1
push bc
push de
push hl
push ix
push iy
ld a,-1
ld (l00e0),a ; Set video mode
if TERM
ld de,0x000f
else
ld e,0x47;0x07
endif
jr l027c
else
push bc
push de
push hl
ld a,-1
ld (l00e0),a ; Set video mode
ld hl,l01c2 ; Reset attribute
jr l027c
endif
;
; Erase to end of line
;
l0299:
if 1==1
push af
push bc
push de
push hl
if TERM
push ix
push iy
call clearrestofline
pop iy
pop ix
endif
pop hl
pop de
pop bc
pop af
ret
else
push af
push bc
push de
push hl
ld hl,l01bc ; Clear to end of line
jr l027c
endif
;
; Position cursor with X (column) in reg H and y (row) in reg L
;
l02a2:
if 1==1
push af
push bc
push de
push hl
push ix
push iy
ld d,l
ld e,h
;dec d
;dec e
if TERM
SETXY_
else
OS_SETXY
endif
pop iy
pop ix
pop hl
pop de
pop bc
pop af
ret
else
push af
push bc
push de
push hl
push hl
ld de,l00f0
ld hl,l018b
ld bc,ll018b
ldir ; Unpack control string
pop de ; Get back coordinates
ld a,(l019e) ; Get position of column
ld c,a
ld a,(l019c) ; Get offset for column
add a,d ; Build real value
push de
call l02dc ; Store it
pop de
ld a,(l019f) ; Get position of row
ld c,a
ld a,(l019d) ; Get offset for row
add a,e ; Build real value
call l02dc ; Store it
ld hl,l00f0
call l01d0 ; Give control
ld hl,(l01a0) ; Get delay value
call l021d ; Delay a bit
pop hl
pop de
pop bc
pop af
ret
endif
;
; Store Accu in position in reg C
;
l02dc:
ld hl,l00f0
ld b,0
add hl,bc ; Position in string
ex de,hl
ld hl,l019b
inc (hl) ; Test binary
dec (hl)
jr z,l02ec ; Nope, build ASCII
ld (de),a ; Store value
ret
l02ec:
dec de ; Fix for hi ASCII
dec de
ld hl,l0307+3 ; Point to divisor
ld b,3 ; Set length
l02f3:
dec hl
ld c,'0'-1 ; Init ASCII
l02f6:
inc c ; Fix quotient
sub (hl) ; Divide
jr nc,l02f6
add a,(hl) ; Build last value
push af
ld a,c
cp '0' ; Test zero
jr z,l0302 ; Skip if so
ld (de),a ; Store ASCII
l0302:
inc de
pop af
djnz l02f3
ret
;
l0307:
db 1,10,100
;
; Set lead in
;
l030a:
ld hl,l016b ; Give lead in
jp l0235
;
; Set lead out
;
l0310:
ld hl,l017b ; Give lead out
jp l0235
;
; Test key pressed
; EXIT Reg HL holds 1 if key pressed
;
l0316:
;ld de,_.const
;call l035f ; Get state
;and 1 ; Extract the bit
xor a ;TODO
jr l0326 ; Expand result to 16 bit
;
; Read character from console
; EXIT Reg HL holds character
;
l0320:
ld de,_.conin
l0323:
;call l035f ; Get input
push ix ;TODO remove?
push iy
if TERM
l0323_nokey
GETKEY_
or a
jr z,l0323_nokey
else
GET_KEY
endif
pop iy
pop ix ;TODO remove?
l0326:
ld l,a ; Expand result to 16 bit
ld h,0
ret
;
; Read character from auxiliary device
; EXIT Reg HL holds character
;
l032a:
jr l0320 ;??? from console
;ld de,_.auxin ; Set function
;jr l0323 ; Do thru BIOS
;
; Write character to list device
; ENTRY Character on stack
;
l032f:
jr l0339 ;??? to screen
;ld de,_.list ; Set function
;jr l033c ; Do thru BIOS
;
; Write character to auxiliary device
; ENTRY Character on stack
;
l0334:
jr l0339 ;??? to screen
;ld de,_.auxout ; Set function
;jr l033c ; Do thru BIOS
;
; Write character to console
; ENTRY Character on stack
;
l0339:
pop hl
pop bc ; Get character
push hl
ld a,c
push af
push bc
push de
push hl
push ix
push iy
if TERM
PRCHAR_
else
PRCHAR
endif
pop iy
pop ix
pop hl
pop de
pop bc
pop af
ret
if TERM
include "../_sdk/stdio.asm"
endif
if 1==0
;ld de,_.conout ; Set function
l033c:
pop hl
pop bc ; Get character
push hl
ld a,(l00dd) ; Get $C mode
or a
jr z,l035f ; $C-, so skip testing
push de
push bc
call l00a0 ; Test key pressed
ld a,h
or l ; Nope
jr z,l035d
call readfromkbd ; Read character
cp Xoff ; Test XOFF
jr nz,l035d
call readfromkbd
cp CtrlC ; Test abort
jp z,l20d4 ; Halt if so
l035d:
pop bc
pop de
;
; Do BIOS internal call
;de=jp addr
l035f:
ret
;ld hl,(OS+1) ; Fetch base vector
;add hl,de ; Add osffset
;jp (hl) ; Go
endif
;
; Init TURBO program
; ENTRY Reg HL holds top of RAM
; Reg B holds break mode
; ($C- B=00)
; ($C+ B=FF)
; Reg C holds interrupt mode
; ($U- C=00)
; ($U+ C=rst)
; [rst may be the opcode for the requested
; RST opcode, typically F7 or EF]
;
l0364:
ld (l00d2),hl ; Save address
ld a,b
ld (l00dd),a ; Set $C mode
ld a,c ; Get $U
or a
jr z,l037a ; No interrupt
;ld a,_JP ; Set JP to interrupt
;ld (RSTADDR),a
;ld hl,l1ffb
;ld (RSTADDR+1),hl ; Change vector ;???
l037a:
ld hl,l03a5
ld de,l00a0
ld bc,ll0018
ldir ; Unpack I/O
ld hl,l03bd
ld de,l00b8
ld bc,ll000c
ldir ; Init FIB
xor a
ld l,a
ld h,a
ld (l00d0),a ; Clear I/O error
ld (l00d4),hl ; Clear some pointers
ld (l00d6),hl
ld a,_MaxBuf
ld (l00d1),a ; Set buffer length
ld (l00e0),a ; Set video mode
ret
;
; Character I/O table moved into 0x00A0
;
l03a5:
jp l0316 ; 0x00A0 : Keypressed
jp l0320 ; 0x00A3 : Read KBD
jp l0339 ; 0x00A6 : Console output
jp l032f ; 0x00A9 : List output
jp l0334 ; 0x00AC : Auxiliary output
jp l032a ; 0x00AF : Auxiliary input
jp l0339 ; 0x00B2 : Console output
jp l0320 ; 0x00B5 : Read KBD
ll0018 equ $-l03a5
;
; Standard IO control table
;
l03bd:
db 11000001b ; 0x00B8 : Input Output for CON
db 0
db 10000010b ; 0x00BA : Input for KBD
db 0
db 01000011b ; 0x00BC : Output for LST
db 0
db 11000100b ; 0x00BE : Input Output for AUX
db 0
db 11000101b ; 0x00C0 : Input Output for USR
db 0
db 11000001b ; 0x00C2 : Input Output for CON
db 0
ll000c equ $-l03bd
;
; Put character to console
;
puttoconsole_a:
push bc
push de
push hl
push ix
push iy
push af
if TERM
PRCHAR_
else
PRCHAR
endif
;ld l,a
;ld h,0
;push hl
;call l00a6 ; Put to console
pop af
l03d9:
pop iy
pop ix
pop hl
pop de
pop bc
ret
;
; Read character from keyboard
;
readfromkbd:
push bc
push de
push hl
push ix
push iy
if TERM
readfromkbd_nokey
call yieldgetkeyloop ;YIELDGETKEYLOOP
or a
jr z,readfromkbd_nokey
else
ld e,0x78
OS_PRATTR
YIELDGETKEYLOOP
push af
ld e,0x47
OS_PRATTR
pop af
endif
;call l00a3 ; Read KBD
;ld a,l
jr l03d9
;
; Parse file, allow wildcards
;
l03ee:
ld c,0xff-FALSE ; Set flag
jr l03fe
;
; Parse file, wildcards not allowed
;
l03f2:
ld c,FALSE
ld de,(l00d2) ; Get top of memory for input
l03f8:
inc de
ld a,(de)
cp ' ' ; Skip blanks
jr z,l03f8
l03fe:
ld hl,l005c+Fdrv+Fname
ld b,Fext
call l047b ; Blank extension
l0406:
ld a,(de) ; Get character
call doupcase ; Convert to upper case
cp 'A' ; Test posible drive
jr c,l0420
cp 'P'+1
jr nc,l0420
ld b,a ; Save drive
inc de
ld a,(de)
cp ':' ; Verify drive
jr nz,l041f
ld a,b
sub 'A'-1 ; Make binary
inc de
jr l0421
l041f:
dec de
l0420:
xor a ; Set default drive
l0421:
ld hl,l005c
ld (hl),a ; Save drive
inc hl
inc c ; Test wildcards allowed
dec c
jr z,l0443 ; Nope
ld a,(de) ; Get character
call l0482 ; Test delimiter
jr nz,l0443 ; Nope
cp '?' ; Test single wildcard
jr z,l0443 ; Yeap
cp '*' ; Test wildcard
jr z,l0443 ; Yeap
cp '.' ; Test dot
jr z,l0443 ; Yeap
ld b,Fname+Fext
call l0477 ; Set wildcard
jr l0453 ; Go init remainder
l0443:
ld b,Fname
call l045e ; Parse name
ld a,(de)
cp '.' ; Test extension delimiter
jr nz,l0453 ; Nope
inc de
ld b,Fext
call l045e ; Parse extension
l0453:
ld hl,l005c+_ex
ld b,FCBlen-_ex
l0458:
ld (hl),0 ; Clear remainder of FCB
inc hl
djnz l0458
ret
;
; Parse B characters
;
l045e:
ld a,(de) ; Get character
inc c ; Test wildcard allowed
dec c
jr z,l046b ; Nope
cp '?' ; Test single wildcard
jr z,l0470 ; Save it
cp '*' ; Test multiple wildcards
jr z,l0476 ; Map them
l046b:
call l0482 ; Test delimiter
jr z,l047b ; Yeap
l0470:
ld (hl),a ; Store character
inc hl
inc de
djnz l045e
ret
l0476:
inc de
;
; Set B wildcards
;
l0477:
ld a,'?' ; Set wildcard character
jr l047d
;
; Blank B positions in ^HL
;
l047b:
ld a,' '
l047d:
ld (hl),a ; Save character
inc hl
djnz l047d
ret
;
; Test delimiter
; Z set says yes
;
l0482:
call doupcase ; Convert to upper case
cp ' ' ; Test control
jr c,l0496 ; Yeap, it's a delimiter
push hl
push bc
ld hl,l0498
ld bc,ll0498
cpir ; Find in table
pop bc
pop hl
ret
l0496:
cp a
ret
;
l0498:
db ' .,;:=?*[]<>{}'
ll0498 equ $-l0498
;
; Convert character to UPPER case
;
doupcase:
cp 'a' ; Test range
ret c
cp 'z'+1
ret nc
sub 'a'-'A' ; Convert to upper case
ret
;
; Print hex word in reg HL
;
l04af:
ld a,h ; Get hi
call l04b4 ; Print it
ld a,l ; Followed by lo
;
; Print hex byte in Accu
;
l04b4:
push af
rra ; Isolate hi bits
rra
rra
rra
call l04bd ; Convert them
pop af
l04bd:
and LoMask ; Mak bits
add a,090h ; Dirty trick
daa
adc a,040h
daa
jp puttoconsole_a ; Put to console
;
; Get byte from 16 bit
; ENTRY Reg HL holds 16 bit signed integer
; EXIT Accu holds 0 and carry set if HL<0
; Accu holds -1 and carry reset if HL>256
; Accu holds low part and carry reset else
;
l04c8:
xor a
scf
bit 7,h ; Test sign bit
ret nz ; Return 0 and C set if HL<0
ld a,h
or a
ld a,l
ret z ; Return LO if HI=0
ld a,-1 ; Else return -1
ret
;
; Test enough space
; ENTRY Reg HL holds 1st free address
; Reg DE holds last free address
; Reg BC holds top of ram
; Accu holds run mode
;
l04d4:
ld (l00d8),a ; Re/Set runmode (0 is TP menue)
push bc
call l1eaf ; Init heap
pop bc
ld hl,NEDOOSMEMTOP;ld hl,(TPAtop)
or a
sbc hl,bc ; Test memory available
jp c,l20a8 ; Nope, exit
ex de,hl
pop de ; Get caller
ld sp,hl ; Set new stack
ld bc,-StkSpc
add hl,bc ; Allow some stack space
ld (l00c6),hl ; Set recursion pointer
xor a
ld l,a
ld h,a
ld (l00ce),hl ; Reset current PC
ld (l00dc),a ; Reset overlay drive
ld a,_JP
ld (l00d9),a ; Init restart
ld hl,l20de
ld (l00da),hl ; Set error vector
ex de,hl
ld (l00cc),hl ; Set base PC
jp (hl) ; Jump back to caller
;
; Start of recursive procedure or function
; ENTRY Reg BC holds bytes to be preserved
; Reg HL holds address of save area
;
l0508:
push hl
ld hl,(l00c6) ; Get recursion pointer
or a
sbc hl,bc ; Calculate new pointer
ld (l00c6),hl
ld de,(l00c4) ; Get heap pointer
or a
sbc hl,de ; Test against it
add hl,de
ex de,hl
pop hl
jp c,l1d75 ; Error if overlapping
ldir
ret
;
; End of recursive procedure or function
; ENTRY Reg BC holds bytes to be preserved
; Reg DE holds address of save area
;
l0522:
ld hl,(l00c6) ; Get recursion pointer
ldir ; Reload code
ld (l00c6),hl ; Update pointer
exx
ret
;
; Load real into registers
; ENTRY Reg HL points to real variable
; EXIT Regs HL,DE,BC hold number
;
l052c:
ld e,(hl) ; Get exponent
inc hl
ld d,(hl) ; Get LSB
inc hl
push de
ld e,(hl) ; Get 4th mantissa byte
inc hl
ld d,(hl) ; Get 3rd mantissa byte
inc hl
ld c,(hl) ; Get 2nd mantissa byte
inc hl
ld b,(hl) ; Get MSB
pop hl
ret
;
; move string to stack
; ENTRY Reg HL points to string
;
l053a:
pop ix ; Get caller
ex de,hl
ld a,(de) ; Get length of string
ld c,a
ld b,0
cpl ; Negate
ld l,a
ld h,-1
add hl,sp ; Fix stack
ld sp,hl
ex de,hl
inc bc
ldir ; move to stack
jp (ix) ; Exit
;
; move immediate string to stack
; ENTRY String started with length after caller
;
l054d:
pop de ; Get string pointer
ld a,(de) ; Get length
ld c,a
ld b,0 ; Expand for 16 bit
cpl ; Negate
ld l,a
ld h,-1
add hl,sp ; Fix stack
ld sp,hl
ex de,hl
inc bc
ldir ; move to stack
jp (hl)
;
; Push set onto stack
; ENTRY Reg HL points to set variable
; Reg C holds set length in bits
; Reg B holds set to be cleared
;
l055d:
pop ix ; Get caller
ex de,hl
ld hl,-set.len
add hl,sp ; Adjust stack for max set length
ld sp,hl
ex de,hl
push bc
inc b ; Test bits to clear
dec b
jr z,l0570 ; Nope
xor a
l056c:
ld (de),a ; Clear a part
inc de
djnz l056c
l0570:
ldir ; Save set on stack
pop bc
ld a,set.len
sub b
sub c ; Test remaining bits to clear
jr z,l057f ; Nope
ld b,a
xor a
l057b:
ld (de),a ; Clear bits
inc de
djnz l057b
l057f:
jp (ix)
;
; Initialize a set on stack
;
l0581:
pop ix ; Get caller
ld hl,-set.len
add hl,sp ; Fix stack
ld sp,hl
ld b,set.len ; Set count
xor a
l058b:
ld (hl),a ; Init set
inc hl
djnz l058b
jp (ix)
;
; Init one set element
; ENTRY Reg HL holds set value to be set
;
l0591:
pop ix
ld b,l ; Get value
call l05ba ; Get bit
l0597:
or (hl) ; Insert it
ld (hl),a
l0599:
jp (ix)
;
; Init a contiguous set value
; ENTRY Reg HL holds upper limit
; On stack pushed lower limit
;
l059b:
pop ix
pop de ; Get lower limit
ld a,l
sub e
jr c,l0599 ; Out of range
inc a
ld c,a
ld b,e ; Get low value
call l05ba ; Get bit
ld e,a
ld b,c ; Copy loop value
xor a
l05ab:
or e
sla e ; Shift bit
jr nc,l05b6
or (hl) ; Insert
ld (hl),a
inc hl ; Point to next
xor a
ld e,1 ; Init low bit for next
l05b6:
djnz l05ab
jr l0597 ; Set final one
;
; Access one set bit
; ENTRY Reg B holds numeric value of set element
; EXIT Accu holds bit
; Reg HL points to set loacation
;
l05ba:
ld a,b ; Get value
and 11111000b ; Mask it
rrca ; Divide by eight
rrca
rrca
add a,2 ; Fix position for stack
ld l,a
ld h,0
add hl,sp ; Get position
ld a,b
and 00000111b ; Mask bits
inc a
ld b,a
xor a
scf ; Init 1
l05cd:
rla ; Shift bit into correct position
djnz l05cd
ret
;
; Save real number
; ENTRY Reg HL points to real variable
; Alternative regs HL,DE,BC hold number
;
l05d1:
push hl ; Save pointer
exx
ex de,hl
ex (sp),hl ; Get back pointer
ld (hl),e ; Save exponent
inc hl
ld (hl),d ; Save LSB
inc hl
pop de
ld (hl),e ; Save 4th mantissa byte
inc hl
ld (hl),d ; Save 3rd byte
inc hl
ld (hl),c ; Save 2nd byte
inc hl
ld (hl),b ; Save MSB
ret
;
; Assign string from stack
; ENTRY Reg HL points to string to be assigned
; Reg B holds max length of this string
;
l05e2:
pop ix ; Get caller
ld a,b ; Get max
ex de,hl ; Swap pointer
ld hl,0
ld b,h
add hl,sp ; Fix stack for start of string
ld c,(hl) ; Get this length
push hl
add hl,bc ; Calculate new stack
l05ee:
inc hl
ex (sp),hl
cp c ; Test length
jr c,l05f4
ld a,c ; Get smaller one
l05f4:
ld (de),a ; Unpack length
inc de
inc hl
or a ; Test any character
jr z,l05fd ; Nope
ld c,a
ldir ; Unpack if so
l05fd:
pop hl
ld sp,hl
jp (ix)
;
; Assign string from stack
; ENTRY Reg B holds max length of string
;
l0601:
pop ix ; Get caller
ld a,b ; Get max
ld hl,0
ld b,h
add hl,sp ; Fix stack for start of string
ld c,(hl) ; Get this length
push hl
add hl,bc ; Calculate new stack
inc hl
ld e,(hl) ; Fetch address of string
inc hl
ld d,(hl)
jr l05ee ; Unpack it
;
; Assign set variable
; ENTRY Reg HL points to variable
; Reg BC holds length of set
;
l0612:
pop ix ; Get caller
ex de,hl
ld l,b ; Copy length
ld h,0
ld b,h
add hl,sp ; Point to start location
ldir ; Unpack set variable
ld hl,set.len
l061f:
add hl,sp ; Fix stack
ld sp,hl
jp (ix) ; Exit
;
; Assign set variable
; ENTRY Reg BC holds length of set
;
l0623:
pop ix ; Get caller
ld hl,set.len
add hl,sp ; Point to destination
ld e,(hl) ; Get it
inc hl
ld d,(hl)
ld l,b ; Copy length
ld h,0
ld b,h
add hl,sp ; Point to start location
ldir
ld hl,set.len+2 ; Remember address
jr l061f ; Fix stack
;
; Set set to stack
; ENTRY Reg HL holds address of set
; Reg B holds length of set
;
l0638:
pop ix ; Get caller
ex de,hl ; Swap source
ld a,b
cpl
ld l,a
ld h,-1 ; Get -length
add hl,sp ; Fix stack
ld sp,hl ; Set new
ld (hl),b ; Set length
inc hl
ld c,b ; Expand length
ld b,0
ex de,hl ; Get back source
ldir ; move to stack
jp (ix)
;
; Index check on compiler directive {$R+}
; ENTRY Reg HL holds current index
; Reg DE holds max index
;
l064c:
or a
sbc hl,de ; Verify limit ok
add hl,de
ret c ; Yeap
ld a,_IndxErr
jp l2027 ; Else process error
;
; Range check on compiler directive {$R+}
; ENTRY Reg HL holds actual value
; Reg DE holds low limit
; Reg BC holds range of value
;
l0656:
or a
sbc hl,de
or a
sbc hl,bc ; Test max
jr nc,l0661 ; Error
add hl,bc ; Restore value
add hl,de
ret
l0661:
ld a,_RngErr
jp l2027 ; Set error
;
; Set up FOR .. TO loop
; ENTRY Reg DE holds start value
; Reg HL holds end value
; EXIT Reg DE holds loops
; Reg HL holds start value
;
l0666:
or a
sbc hl,de ; Get difference
ex de,hl ; Into reg DE
l066a:
inc de ; Fix loop count
jp pe,l0671 ; Check any loop
ret p
jr l0672
l0671:
ret m
l0672:
ld de,0 ; Set no loop
ret
;
; Set up FOR .. DOWNTO loop
; ENTRY Reg DE holds start value
; Reg HL holds end value
; EXIT Reg DE holds loops
; Reg HL holds start value
;
l0676:
push de
ex de,hl
or a
sbc hl,de ; Get difference
ex de,hl
pop hl
jr l066a ; Build loop
;
; ################## The comparison package ###################
; # TRUE set (=1 on TURBO) if relation matches #
; # #
; # On all relational functions the assignment is as follows: #
; # #
; # INTEGER : DE:HL #
; # REAL : (Regs):(Regs)' #
; # STRING : (Stack):(next_stack) #
; # #
; #############################################################
;
; ********************************
; ********** Relation = **********
; ********************************
;
; %%%%%%%%%%%%%
; %% INTEGER %%
; %%%%%%%%%%%%%
;
l067f:
or a
sbc hl,de ; Get difference
l0682:
ld hl,_TRUE ; Init TRUE
ret z ; Ok, same
dec hl ; Fix for FALSE
ret
;
; %%%%%%%%%%
; %% REAL %%
; %%%%%%%%%%
;
l0688:
call l0bdf ; Compare
jr l0682 ; Set result
;
; %%%%%%%%%%%%
; %% STRING %%
; %%%%%%%%%%%%
;
l068d:
call l09b0 ; Compare
jr l0682 ; Set result
;
; *********************************
; ********** Relation <> **********
; *********************************
;
; %%%%%%%%%%%%%
; %% INTEGER %%
; %%%%%%%%%%%%%
;
l0692:
or a
sbc hl,de ; Get difference
l0695:
ld hl,_TRUE ; Init TRUE
ret nz ; Ok, not same
dec hl ; Fix for FALSE
ret
;
; %%%%%%%%%%
; %% REAL %%
; %%%%%%%%%%
;
l069b:
call l0bdf ; Compare
jr l0695 ; Set result
;
; %%%%%%%%%%%%
; %% STRING %%
; %%%%%%%%%%%%
;
l06a0:
call l09b0 ; Compare
jr l0695 ; Set result
;
; *********************************
; ********** Relation >= **********
; *********************************
;
; %%%%%%%%%%%%%
; %% INTEGER %%
; %%%%%%%%%%%%%
;
l06a5:
call l0772 ; Check operands
l06a8:
ld hl,_TRUE ; Init TRUE
ret nc ; Ok if .GTE.
dec hl ; Else fix for FALSE
ret
;
; %%%%%%%%%%
; %% REAL %%
; %%%%%%%%%%
;
l06ae:
call l0bdf ; Compare
jr l06a8 ; Set result
;
; %%%%%%%%%%%%
; %% STRING %%
; %%%%%%%%%%%%
;
l06b3:
call l09b0 ; Compare
jr l06a8 ; Set result
;
; *********************************
; ********** Relation <= **********
; *********************************
;
; %%%%%%%%%%%%%
; %% INTEGER %%
; %%%%%%%%%%%%%
;
l06b8:
call l0772 ; Check operands
l06bb:
ld hl,_TRUE ; Init TRUE
ret z ; Ok if .EQ.
ret c ; Ok if .LT.
dec hl ; Else fix for FALSE
ret
;
; %%%%%%%%%%
; %% REAL %%
; %%%%%%%%%%
;
l06c2:
call l0bdf ; Compare
jr l06bb ; Set result
;
; %%%%%%%%%%%%
; %% STRING %%
; %%%%%%%%%%%%
;
l06c7:
call l09b0 ; Compare
jr l06bb ; Set result
;
; ********************************
; ********** Relation > **********
; ********************************
;
; %%%%%%%%%%%%%
; %% INTEGER %%
; %%%%%%%%%%%%%
;
l06cc:
call l0772 ; Check operands
l06cf:
ld hl,FALSE ; Init FALSE
ret z ; Ok if .EQ.
ret c ; Ok if .LT.
inc hl ; Else fix for TRUE
ret
;
; %%%%%%%%%%
; %% REAL %%
; %%%%%%%%%%
;
l06d6:
call l0bdf ; Compare
jr l06cf ; Set result
;
; %%%%%%%%%%%%
; %% STRING %%
; %%%%%%%%%%%%
;
l06db:
call l09b0 ; Compare
jr l06cf ; Set result
;
; ********************************
; ********** Relation < **********
; ********************************
;
; %%%%%%%%%%%%%
; %% INTEGER %%
; %%%%%%%%%%%%%
;
l06e0:
call l0772 ; Check operands
l06e3:
ld hl,_TRUE ; Init TRUE
ret c ; Ok if .LT.
dec hl ; Else fix for FALSE
ret
;
; %%%%%%%%%%
; %% REAL %%
; %%%%%%%%%%
;
l06e9:
call l0bdf ; Compare
jr l06e3 ; Set result
;
; %%%%%%%%%%%%
; %% STRING %%
; %%%%%%%%%%%%
;
l06ee:
call l09b0 ; Compare
jr l06e3 ; Set result
;
; ################# End of comparison package #################
;
; Function SQR(integer):integer;
; ENTRY Reg HL holds number
; EXIT Reg HL holds power
;
l06f3:
ld d,h ; Copy number
ld e,l
;
; Operator *
; Multiply signed integers
; ENTRY Reg DE holds multiplicand
; Reg HL holds multiplier
; EXIT Reg HL holds product
;
l06f5:
ld c,e ; Copy multiplicand
ld b,d
ex de,hl
ld hl,0 ; Init product
ld a,d
or a ; Test word
ld a,16
jr nz,l0704 ; Yeap, set bit count
ld d,e
ld a,8 ; Change bit count
l0704:
add hl,hl ; Do the multiplication
ex de,hl
add hl,hl
ex de,hl
jr nc,l070b
add hl,bc
l070b:
dec a
jr nz,l0704
ret
;
; Operator DIV
; Divide signed integers
; ENTRY Reg DE holds dividend
; Reg HL holds divisor
; EXIT Reg HL holds quotient
; Reg DE holds remainder
;
l070f:
ld a,h ; Test zero divisor
or l
jp z,l0a03 ; Divide by zero
ld a,h
xor d ; Calculate sign
push af
call l0780 ; Make both numbers positive
ex de,hl
call l0780
ex de,hl
ld b,h ; Copy divisor
ld c,l
xor a
ld h,a ; Clear result
ld l,a
ld a,17 ; Set bit count
l0726:
adc hl,hl ; Perform division
sbc hl,bc
jr nc,l072e
add hl,bc
scf
l072e:
ccf
rl e
rl d
dec a ; Test done
jr nz,l0726 ; Nope, loop on
ex de,hl
pop af ; Get resulting sign
ret p
jr l0783 ; Negate result
;
; Function RANDOM(integer):integer
; ENTRY Reg HL holds integer limit
; EXIT Reg HL holds random
;
l073b:
push hl
call l0792 ; Get random value
srl h ; Make positive, dividing by 2
rr l
pop de
ex de,hl
;
; Operator MOD
; Get modulo of signed integers
; ENTRY Reg DE holds dividend
; Reg HL holds divisor
; EXIT Reg HL holds remainder
;
l0745:
call l070f ; HL:=DE DIV HL;DE:=DE MOD HL
ex de,hl ; Swap remainder
bit 7,d ; Test result
ret z
jr l0783 ; Negate
;
; Operator SHL
; Shift left number
; ENTRY Reg DE holds number to be shifted
; Reg HL holds shift count
; EXIT Reg HL holds result
;
l074e:
call l0761 ; Get shift values
ret z ; End on zero
l0752:
add hl,hl ; Shift
djnz l0752
ret
;
; Operator SHR
; Shift right number
; ENTRY Reg DE holds number to be shifted
; Reg HL holds shift count
; EXIT Reg HL holds result
;
l0756:
call l0761 ; Get shift values
ret z ; End on zero
l075a:
srl h ; Shift
rr l
djnz l075a
ret
;
; Set shift values
; ENTRY Reg HL holds number to be shifted
; Reg DE holds shift count
; EXIT Reg B holds shift count
; Zero flag set on nothing to be shifted
; Reg HL may be preset to zero
;
l0761:
ex de,hl ; Swap factor
ld a,d ; Test hi zero value
or a
jr nz,l076e ; Nope, should be
ld a,e
cp 16 ; Test max length
jr nc,l076e ; Overflow
ld b,a
or a
ret
l076e:
xor a
ld h,a ; Clear result
ld l,a
ret
;
; Compare signed integers
; ENTRY Reg DE holds 1st number
; Reg HL holds 2nd number
; EXIT Zero flag set if DE=HL
; Carry flag set if DE<HL
;
l0772:
ex de,hl
ld a,h
xor d ; Test same signs
ld a,h
jp m,l077e ; Nope, fix carry
cp d ; Compare hi
ret nz
ld a,l
cp e ; Compare lo if hi is same
ret
l077e:
rla ; Get sign of first number
ret
;
; Function ABS(integer):integer;
; ENTRY Reg HL holds signed integer
; EXIT Reg HL holds positive integer
;
l0780:
bit _MB,h ; Test sign
ret z ; Already positive
l0783:
ld a,h ; Build one's complement
cpl
ld h,a
ld a,l
cpl
ld l,a
inc hl ; Fix for two's complement
ret
;
; Function ODD(integer):boolean
;
l078b:
ld a,l ; Get lo byte
and LSB ; Extract bit
ld l,a ; Expand to 16 bit
ld h,0
ret
;
; Get random value
; EXIT Regs BC and HL hold byte 3 and 4 of resulting random
; Reg DE holds middle part of real number
;
l0792:
ld bc,(l00c8+2) ; Load old values
ld de,(l00c8)
push bc ; Save them
push de
ld a,b ; Expand to 40 bits
ld b,c
ld c,d
ld d,e
ld e,0
rra ; Shift them all
rr b
rr c
rr d
rr e
pop hl
add hl,de ; Add to old
ex de,hl
pop hl
adc hl,bc
ld b,h
ld c,l
ld hl,0110001011101001b
add hl,de ; Fix them - add 62E9H
ld (l00c8),hl ; Save new values
ex de,hl
ld hl,0011011000011001b
adc hl,bc ; Add 3619H
ld (l00c8+2),hl
ld b,h ; Copy result
ld c,l
ret
;
; Convert positive integer to ASCII number
; ENTRY Reg IX points to ASCII buffer
; Reg HL holds integer
; EXIT Buffer filled
;
l07c6:
ld b,0 ; Init flag
ld de,10000
call l07e2 ; Start with 10000s
ld de,1000
call l07e2 ; Then 1000s
ld de,100
call l07e2 ; Then 100s
ld e,10
call l07e2 ; Then 10s
ld a,l ; Get remainder
jr l07ef
l07e2:
xor a ; Clear quotient
l07e3:
inc a ; Advance quotient
sbc hl,de ; Divide
jr nc,l07e3 ; Still positive
add hl,de ; Fix for last number
inc b ; Access flag
dec a ; Test zero digit
jr nz,l07ef ; Nope, so store result
dec b ; Test flag
ret z ; No leading zeroes
l07ef:
add a,'0' ; Make ASCII
ld (ix+0),a ; Save it
inc ix ; Advance buffer
ret
;
; Convert ASCII number to integer
; ENTRY Reg IX points to ASCII number
; EXIT Reg HL holds integer
; Carry set on overflow
;
cnv_int:
ld a,(ix+0)
sub '$' ; Test hex indicator
ld c,a ; Save flag
ld hl,0 ; Init result
jr nz,l0804
l0802:
inc ix ; Skip indicator
l0804:
ld a,(ix+0)
call doupcase ; Convert to upper case
sub '0' ; Strip off offset
jr c,l0837 ; Out of range
cp 9+1 ; Test decimal
jr c,l0820 ; Yeap
inc c ; Test hex allowed
dec c
jr nz,l0837 ; Nope
sub 'A'-'0'-10 ; Fix hex offset
cp 10 ; Verify correct range
jr c,l0837
cp 15+1
jr nc,l0837
l0820:
ld d,h ; Copy current number
ld e,l
add hl,hl ; * 2
ret c ; Overflow
add hl,hl ; * 4
ret c
inc c ; Test hex
dec c
jr nz,l082c
ld d,h ; Copy * 4
ld e,l
l082c:
add hl,de ; * 5 or * 8
ret c
add hl,hl ; * 10 or * 16
ret c
ld e,a
ld d,0
add hl,de ; Insert new digit
ret c
jr l0802
l0837:
ld a,c
or a ; Test hex
ret z ; Yeap
ld a,h
add a,a ; Get MSB into carry if decimal
ret
;
; Add two strings
; ENTRY Stack holds strings
; EXIT Stack holds combined string
;
l083d:
pop ix ; Get caller
pop hl
push hl
ld a,l ; Get length of 1st
ld h,0
inc hl
add hl,sp ; Point to 2nd
ld c,(hl)
add a,c ; Add lengthes
jr c,l0866 ; Too long
ld (hl),a ; Set new length
ex de,hl
ld hl,0
ld b,h
sbc hl,bc ; Prepare moving strings
add hl,sp
ld sp,hl
ex de,hl
push hl
inc bc
ldir ; move into right place
ex de,hl
pop hl
dec hl
dec de
ld c,a
inc bc
lddr
ex de,hl
inc hl
ld sp,hl
jp (ix)
l0866:
ld a,_StrLenErr ; Set error
jp l2029
;
; Function COPY(string,start,length):string
; ENTRY Start on stack, followed by string
; Reg HL holds length
; EXIT Substring on stack
;
l086b:
pop ix ; Get caller
call l04c8 ; Get length byte from integer
ld d,a
pop hl ; Get start
call l09dd ; Verify 1..255
ld e,a
pop hl ; Get length ( - and 1st character)
push hl
ld a,l
sub e ; Test against start
jr c,l0896 ; Out of bounds
inc d ; Test zero length
dec d
jr z,l0896 ; Yeap, done
cp d ; Compare against length
jr c,l0899 ; Nothing to move
ld c,d ; Fix a bit
ld b,0
ld h,b
add hl,sp
ld a,e
add a,d
ld d,h
ld e,l
dec a
ld l,a
ld h,b
add hl,sp
ld a,c
lddr ; Then move down
ex de,hl
jr l089f
l0896:
xor a ; Set zero length
jr l089c
l0899:
inc a ; Fix length
ld l,e
dec l ; Fix position
l089c:
ld h,0
add hl,sp ; Copy position
l089f:
ld (hl),a ; Store length
ld sp,hl ; Get stack
jp (ix) ; Exit
;
; Function LENGTH(string):integer
; ENTRY String on stack
; EXIT Reg HL holds length
;
l08a3:
pop ix ; Get caller
pop hl ; Get length ( - and 1st character)
push hl
ld a,l ; Save length
ld h,0
inc hl
add hl,sp
ld sp,hl ; Fix stack
ld l,a ; Get 16 bit length
ld h,0
jp (ix) ; Exit
;
; Function POS(substring,string):integer
; ENTRY String on stack, followed by substring
; EXIT Reg HL holds position, 0 is not found
;
l08b2:
pop ix ; Get caller
ld hl,0
ld d,h
add hl,sp ; Copy stack
ld e,(hl) ; Get length of main_string
ld c,e
inc hl
push hl
add hl,de ; Point to sub_string
ld e,(hl) ; Get length of sub_string
ld b,e
inc hl
push hl
add hl,de ; Point to end of both
push hl
pop iy ; Copy address
pop de ; Get sub_string
pop hl ; Get main_string
ld a,c
sub b ; Test range
jr c,l08dc ; Sub_string > main_string - no match
inc a ; Fix count
ld c,a
l08ce:
push bc
push de
push hl
l08d1:
ld a,(de)
cp (hl) ; Compare
jr z,l08e1 ; Maybe success
pop hl
pop de
pop bc
inc hl
dec c ; Test more to search
jr nz,l08ce ; Ok, then try next
l08dc:
ld hl,0 ; Set zero result
jr l08ef
l08e1:
inc hl
inc de
djnz l08d1 ; Loop thru sub_string
pop de
pop hl
pop bc
ld hl,0
add hl,sp ; Get pointers
ex de,hl
sbc hl,de ; Calculate resulting position
l08ef:
ld sp,iy ; Set stack
jp (ix) ; Exit
;
; Procedure DELETE(string,start,length)
; ENTRY Start on stack, followed by string
; Reg HL holds length
;
l08f3:
pop ix ; Get caller
call l04c8 ; Get length byte from integer
ld c,a
pop hl
call l09dd ; Verify length in range 1..255
ld e,a
pop hl ; Get start_string
ld a,(hl) ; Get length
sub e ; Test start > length
jr c,l091e ; Exit if so
inc c
dec c ; Test any length
jr z,l091e ; Nope, exit
sub c ; Test remaining count
jr c,l091c ; Nope, done
push af
ld a,(hl)
sub c
ld (hl),a
ld b,0
ld d,b
add hl,de ; Point to destination
ld d,h
ld e,l
add hl,bc ; Point to source
pop af
inc a
ld c,a
ldir ; Unpack
jr l091e
l091c:
dec e ; Adjust length
ld (hl),e ; Store it
l091e:
jp (ix) ; Exit
;
; Procedure INSERT(string,substring,start)
; ENTRY Pointer of substring on stack, followed by string
; Reg HL holds start
; Reg B holds max length of string
;
l0920:
pop ix ; Get caller
call l09dd ; Verify start in range 1..255
ld c,a
pop de ; Get sub_string
ld (l00e8),de
ld hl,0
add hl,sp ; Get string pointer
ld a,(de)
push af
add a,(hl) ; Get combined length
jr c,l0937 ; Truncate on overflow
cp b ; Compare against max
jr c,l0938 ; Ok
l0937:
ld a,b ; Set max defualt
l0938:
ld (de),a ; Save combined length
pop af ; Get length of substring
ld d,a
ld e,(hl)
sub c ; Get remainder
jr c,l096e ; Skip
inc a
ld l,a
ld a,d
add a,e
jr c,l0949
cp b
ld a,l
jr c,l0951
l0949:
ld a,b
sub e
jr c,l0973
sub c
jr c,l0973
inc a
l0951:
or a
jr z,l0973
push bc
push de
ld hl,(l00e8) ; Get back sub_string pointer
ld e,a
dec e
ld d,0
ld b,d
add hl,de
add hl,bc
pop de
push de
push hl
ld d,b
add hl,de
ex de,hl
pop hl
ld c,a
lddr ; move down
pop de
pop bc
jr l0973
l096e:
ld a,d
inc a
jr z,l098b
ld c,a
l0973:
ld a,b
sub c
inc a
cp e
jr c,l097a
ld a,e
l097a:
or a
jr z,l098b
ld hl,(l00e8) ; Get sub_string pointer
ld b,0
add hl,bc
ex de,hl
ld hl,1
add hl,sp
ld c,a
ldir ; move
l098b:
ld hl,0
ld d,h
add hl,sp ; Fix stack
ld e,(hl)
inc de
add hl,de
ld sp,hl ; Set stack
jp (ix) ; Exit
;
; Check assignment of string to character
; EXIT Reg L holds character
;
l0996:
pop ix ; Get caller
pop hl ; Get length and character
dec l ; Verify character only
jp nz,l0866 ; Error if not
ld l,h ; Unpack character
ld h,0
jp (ix) ; Exit
;
; Set character into string
;
l09a2:
ld hl,2
ld d,h
add hl,sp ; Point to string
ld e,(hl) ; Get length
inc de
add hl,de ; Point to top
ld a,(hl) ; Get character
ld (hl),1 ; Set length
inc hl
ld (hl),a ; Store character
ret
;
; Compare two strings
; ENTRY 1st stack 1st pushed, 2nd stack 2nd pushed
; EXIT Carry flag set if 1st<2nd
; Zero flag set if 1st=2nd
;
l09b0:
ld hl,2*2 ; Note 2nd level call
ld d,h
add hl,sp ; Point to 2nd string
ld e,(hl) ; Get length
ld c,e
inc hl
push hl
add hl,de ; Point to first string
ld e,(hl) ; Get length
ld b,e
inc hl
push hl
add hl,de ; Set return stack
push hl
pop iy ; Copy into reg IY
pop de ; Get 1st string
pop hl ; Get 2nd string
l09c4:
xor a ; Try zero length
cp b
jr z,l09cc
cp c ; Test on both
jr nz,l09d3
ld a,b
l09cc:
cp c
l09cd:
pop hl ; Get back callers
pop de
ld sp,iy ; Set new stack
push de ; Set 2nd kevel caller
jp (hl) ; Exit
l09d3:
ld a,(de)
cp (hl) ; Compare
jr nz,l09cd ; No match
inc hl
inc de
dec b
dec c
jr l09c4
;
; Verify value in reg HL in range 1..255
;
l09dd:
ld a,h ; Verify < 256
or a
jr nz,l09e4
ld a,l
or a ; Verify <> 0
ret nz
l09e4:
ld a,_StrIdx
jp l2029
;
; Function ADD:real
; ENTRY Regs (HL,DE,BC) hold 1st number
; Regs (HL,DE,BC)' hold 2nd number
; EXIT Regs (HL,DE,BC) hold sum
;
l09e9:
call l0a0d ; Add
l09ec:
ret nc ; Check result
ld a,_FLPovfl
jp l2027 ; Set error and abort
;
; Function SUBTRACT:real
; ENTRY Regs (HL,DE,BC) hold 1st number
; Regs (HL,DE,BC)' hold 2nd number
; EXIT Regs (HL,DE,BC) hold difference
;
l09f2:
call l0a81 ; Subtract
jr l09ec ; Check result
;
; Function SQR(real):real
; ENTRY Regs (HL,DE,BC) hold number
; EXIT Regs (HL,DE,BC) hold square
;
l09f7:
call l0fac ; Copy number, then multiply
;
; Function MULTIPLY:real
; ENTRY Regs (HL,DE,BC) hold multiplicand
; Regs (HL,DE,BC)' hold multiplier
; EXIT Regs (HL,DE,BC) hold product
;
l09fa:
call l0a97 ; Multiply
jr l09ec ; Check result
;
; Function DIVIDE:real
; ENTRY Regs (HL,DE,BC) hold 1st dividend
; Regs (HL,DE,BC)' hold 2nd divisor
; EXIT Regs (HL,DE,BC) hold quotient
;
l09ff:
exx ; Get divisor
ld a,l
or a ; Verify not zero
exx
l0a03:
ld a,_DivZero
jp z,l2027 ; Error if division by zero
call l0af5 ; Divide
jr l09ec ; Check result
;
; Add reals
; ENTRY Regs (HL,DE,BC) hold 1st number
; Regs (HL,DE,BC)' hold 2nd number
; EXIT Regs (HL,DE,BC) hold sum
; Carry set on overflow
;
l0a0d:
exx
bit sgn.bit,b ; Test sign of 2nd number
exx
jp nz,l0a88 ; Subtract if less 0
l0a14:
exx
ld a,l ; Test 2nd number zero
or a
exx
ret z ; Ok, result is the 1st number
exx
push bc ; Save 1st number
push de
push hl
exx
ld a,l
or a ; Test 1st number zero
jr nz,l0a27 ; Nope
exx
res sgn.bit,b ; Clear sign
jr l0a7b ; Get 2nd number as result
l0a27:
push bc
set sgn.bit,b ; Force bit set
xor a
ex af,af'
exx
set sgn.bit,b
ld a,l
exx
sub l ; Test same exponents
jr z,l0a47 ; Yeap
jr nc,l0a3c
neg
ex af,af'
dec a
ex af,af'
exx
l0a3c:
call l0b7a ; Shift mantissa right
inc l ; Bump exponent
dec a
jr nz,l0a3c
ex af,af'
jr z,l0a47
exx
l0a47:
pop af ; Get back mantissa MSB
and sign.bit ; Test sign
jr nz,l0a5b ; It's negative
call l0b92 ; Add mantissas
jr nc,l0a76 ; Test bit out
call l0b7b ; Rotate mantissa right
or a
inc l ; Fix exponent
jr nz,l0a76 ; Test underflow
scf
jr l0a7b
l0a5b:
call l0bc6 ; Compare mantissas
ccf
push af
jr z,l0a72 ; It's same
jr c,l0a65 ; It's less
exx
l0a65:
call l0bac ; Subtract mantissas
l0a68:
bit sgn.bit,b ; Test normalized
jr nz,l0a75 ; Yeap
call l0b86 ; Shift left
dec l
jr nz,l0a68
l0a72:
call l0b72 ; Zero result
l0a75:
pop af
l0a76:
jr c,l0a7a ; Test sign
res sgn.bit,b ; Reset if positive
l0a7a:
or a
l0a7b:
exx
pop hl
pop de
pop bc
exx
ret
;
; Subtract reals
; ENTRY Regs (HL,DE,BC) hold 1st number
; Regs (HL,DE,BC)' hold 2nd number
; EXIT Regs (HL,DE,BC) hold difference
; Carry set on overflow
;
l0a81:
exx
bit sgn.bit,b ; Test sign of 2nd number
exx
jp nz,l0a14 ; Add if less 0
l0a88:
call l0a8f ; Negate
call l0a14 ; Then add
ret c
;
; Negate real
; ENTRY Regs HL,DE,BC hold real number
; EXIT Sign changed if real > 0
;
l0a8f:
inc l ; Test exponent zero
dec l
ret z ; Exit if so
ld a,b
xor sign.bit ; Change sign bit
ld b,a
ret
;
; Multiply reals
; ENTRY Regs (HL,DE,BC) hold multiplicand
; Regs (HL,DE,BC)' hold multiplier
; EXIT Regs (HL,DE,BC) hold product
; Carry set on overflow
;
l0a97:
exx
ld a,l
or a ; Test zero multiplier
exx
jp z,l0b72 ; Return 0.0 if so
ld a,l
or a
ret z ; Return if multiplicand zero
exx
add a,l ; Add exponents
exx
call l0b4d ; Fix exponent
push bc ; Save number
push de
push hl
add ix,sp
call l0b72 ; Prepare result
exx
ld l,mant.len ; Set mantissa count
exx
l0ab3:
ld a,bit.len ; Set bit count
inc ix
ld l,(ix+0)
l0aba:
ex af,af'
rr l ; Shift bit
jr nc,l0ac2
call l0b92 ; Add mantissa if bit out
l0ac2:
call l0b7b ; Rotate mantissa right
ex af,af'
dec a ; Go thru all bits
jr nz,l0aba
exx
dec l
exx
jr nz,l0ab3
ld l,(ix-mant.len) ; Get byte back
bit sgn.bit,b ; Test sign
jr nz,l0ade
ex af,af'
call l0b87 ; Get bit
inc l
dec l
jr z,l0ade
dec l
l0ade:
pop af ; Clean stack
pop af
pop af
l0ae1:
or a
l0ae2:
ex af,af'
pop af
exx
pop bc
pop hl
exx
pop ix
res sgn.bit,b ; Reset hi bit
or b
ld b,a ; Insert sign
inc l
dec l
call z,l0b72 ; Clear if underflow
ex af,af'
ret
;
; Divide reals
; ENTRY Regs (HL,DE,BC) hold 1st dividend
; Regs (HL,DE,BC)' hold 2nd divisor
; EXIT Regs (HL,DE,BC) hold quotient
; Carry set on overflow
;
l0af5:
ld a,l
or a ; Test zero divisor
ret z
exx
sub l ; Get resulting exponent
exx
ccf
call l0b4d ; Fix it
push hl
push hl
push hl
add ix,sp
exx
ld l,mant.len ; Get complete count
exx
ld a,bit.len ; Set bit count
l0b0a:
ex af,af'
call l0bc6 ; Compare mantissas
jr c,l0b13
call l0bac ; Subtract mantissas
l0b13:
ccf
rl l
ex af,af'
dec a ; Go thru the bits
jr nz,l0b26
ld (ix+mant.len),l ; Set result
dec ix
exx
dec l ; Go thru the mantissa
exx
jr z,l0b32 ; Total end
ld a,bit.len ; Reset bit count
l0b26:
call l0b86 ; Shift left
jr nc,l0b0a
ex af,af'
call l0bac ; Subtract mantissas
or a
jr l0b13
l0b32:
call l0b86 ; Shift left
jr c,l0b3b
call l0bc6 ; Compare mantissas
ccf
l0b3b:
pop hl
pop de
pop bc
bit sgn.bit,b ; Test bit
jr nz,l0b47
call l0b87 ; Shift in
jr l0ae1
l0b47:
inc l ; Test ok
jr nz,l0ae1
scf
jr l0ae2
;
; Fix exponent
; ENTRY Accu and Carry reflect state of addition or
; subtraction of exponents
;
l0b4d:
jr c,l0b55 ; Test bit out
add a,exp.offset ; Add offset
jr c,l0b59 ; Test bit
jr l0b70
l0b55:
add a,exp.offset
jr c,l0b70
l0b59:
ld l,a ; Set new exponent
ex (sp),ix ; Get caller
exx
push hl
push bc
ld a,b
set sgn.bit,b ; Set bit
exx
xor b
and sign.bit ; Get result
push af
set sgn.bit,b ; Second, too
push ix ; Bring back caller
ld ix,0 ; Return IX=0
ret
l0b70:
pop hl
ret c
;
; Clear real number
; EXIT Regs (HL,DE,BC) hold zero
;
l0b72:
xor a
ld l,a ; Clear all involved bytes
ld b,a
ld c,a
ld d,a
ld e,a
ld h,a
ret
;
; Shift mantissa right
;
l0b7a:
or a ; Clear carry
;
; Rotate mantissa right
;
l0b7b:
rr b ; Shift 5 bytes right
rr c
rr d
rr e
rr h
ret
;
; Shift mantissa left
;
l0b86:
or a ; Clear carry
;
; Rotate mantissa left
;
l0b87:
rl h ; Shift 5 bytes left
rl e
rl d
rl c
rl b
ret
;
; Add mantissas
;
l0b92:
ld a,h ; Get 1st
exx ; Then second
add a,h ; Add
exx
ld h,a ; Into 1st
ld a,e
exx
adc a,e
exx
ld e,a
ld a,d
exx
adc a,d
exx
ld d,a
ld a,c
exx
adc a,c
exx
ld c,a
ld a,b
exx
adc a,b
exx
ld b,a
ret
;
; Subtract mantissas
;
l0bac:
ld a,h ; Get 1st
exx ; Then second
sub h ; Subtract
exx
ld h,a ; Into 1st
ld a,e
exx
sbc a,e
exx
ld e,a
ld a,d
exx
sbc a,d
exx
ld d,a
ld a,c
exx
sbc a,c
exx
ld c,a
ld a,b
exx
sbc a,b
exx
ld b,a
ret
;
; Compare mantissas
;
l0bc6:
ld a,b ; Get 1st
exx ; Then second
cp b ; Compare
exx
ret nz ; Exit if .NE. zero
ld a,c
exx
cp c
exx
ret nz
ld a,d
exx
cp d
exx
ret nz
ld a,e
exx
cp e
exx
ret nz
ld a,h
exx
cp h
exx
ret
;
; Compare two reals
; ENTRY 1st real in register set
; 2nd real in alternative set
; EXIT Carry flag set if 1st<2nd
; Zero flag set if 1st=2nd
;
l0bdf:
exx
ld a,b ; Get sign
exx
xor b ; Test same signs
jp p,l0be9 ; Yeap
ld a,b ; Get 1st sign
rla ; Calculate result
ret
l0be9:
bit sgn.bit,b ; Test 1st > 0
jr z,l0bf3 ; Yeap
call l0bf3 ; Compare
ret z
ccf
ret
l0bf3:
ld a,l ; Get exponent
exx
cp l ; Compare
exx
ret nz ; Not same
or a ; Test zero
ret z
jp l0bc6 ; Compare mantissas
;
; Function INT(real):real
;
l0bfd:
ld a,l
sub Exp.One ; Test >= 1
jp c,l0b72 ; Nope, return 0.0
inc a ; Fix count
cp mant.bits ; Test fraction
ret nc ; No, that's it
exx
push bc ; save 2nd
push de
push hl
ex af,af'
call l0b72 ; Init result
ex af,af'
l0c10:
scf
call l0b7b ; Rotate mantissa right
dec a
jr nz,l0c10
exx
ld a,h ; Mask result
exx
and h
exx
ld h,a
ld a,e
exx
and e
exx
ld e,a
ld a,d
exx
and d
exx
ld d,a
ld a,c
exx
and c
exx
ld c,a
ld a,b
exx
and b
exx
ld b,a
l0c31:
jp l0a7b
;
; Function FRAC(real):real
;
l0c34:
exx
push bc
push de
push hl
exx
call l0fac ; Copy number
exx
call l0bfd ; Get integer part
exx
call l0a81 ; Subtract from original number
jr l0c31
;
; Function SQRT(real):real
;
l0c46:
ld a,l ; Test zero operand
or a
ret z ; Ok, that's it
bit sgn.bit,b ; Verify operand >= 0
ld a,_NegSqrt
jp nz,l2027 ; Should be
call l0fac ; Copy number
ld a,l
add a,exp.offset
sra a ; Fix resulting exponent
add a,exp.offset
ld l,a
sub sqr.exp ; Fix exponent
push af
exx
l0c5f:
push bc
push de
push hl
call l0af5 ; Divide reals
call l0a0d ; Add reals
dec l ; Exponent - 1
push bc
push de
push hl
call l0a81 ; Subtract reals
ld a,l
pop hl
pop de
pop bc
exx
pop hl
pop de
pop bc
ex (sp),hl
cp h ; Test ready
ex (sp),hl
jr nc,l0c5f ; Loop on
pop af
exx
ret
;
; Function COS(real):real
;
l0c7f:
exx
call l0f8e ; Load constant PI
dec l ; Make 90 degrees
call l0a81 ; Subtract reals
;
; Function SIN(real):real
;
l0c87:
exx
call l0f8e ; Load constant PI
inc l ; Make 360 degrees
exx
ld a,l
cp sin.min ; Test underflow
ret c
push bc
res sgn.bit,b ; Clear sign
call l0bdf ; Compare against period
pop bc
jr c,l0ca3
call l0af5 ; Divide reals
call l0c34 ; Get fraction
call l0a97 ; Multiply reals
l0ca3:
bit sgn.bit,b ; Test sign
jr z,l0caa
call l0a0d ; Add reals
l0caa:
exx
dec l ; Make 180 degrees
exx
call l0bdf ; Test within 180 degrees
push af
jr c,l0cb6
call l0a81 ; Subtract reals
l0cb6:
exx
dec l ; Make 90 degrees
exx
call l0bdf ; Test within 90 degrees
jr c,l0cc3
exx
inc l ; Make 180 degrees
call l0a81 ; Subtract reals
l0cc3:
ld a,l
cp sin.min ; Test underflow
jr c,l0d03
exx
ld bc,02aaah ; Set 1/3
ld de,0aaaah
ld hl,0aa7fh
call l0a97 ; Multiply reals (Divide by 3)
push ix
ld ix,l0d0d-Real.Len
ld a,Trg.Len
call l0f34 ; Do the TAYLOR loop
pop ix
call l0fac ; Copy number
call l0a97 ; Multiply reals
call l0a97 ; Multiply reals
push bc
push de
push hl
exx
call l0fac ; Copy number
dec l ; Divide by 4
dec l
exx
dec l ; Divide by 2
call l0a0d ; Add reals
exx
pop hl
pop de
pop bc
exx
call l0a81 ; Subtract reals
inc l ; Multiply by 4
inc l
l0d03:
pop af
inc l ; Test zero
dec l
ret z
ret c ; Check sign
ld a,b
xor sign.bit ; Toggle it
ld b,a
ret
;
; Taylor series for SINE and COSINE
;
l0d0d:
db 067h,0aah,03fh,02bh,032h,0d7h ; -1/11!
db 06eh,0b6h,02ah,01dh,0efh,038h ; 1/9!
db 074h,00dh,0d0h,000h,00dh,0d0h ; -1/7!
db 07ah,088h,088h,088h,088h,008h ; 1/5!
db 07eh,0abh,0aah,0aah,0aah,0aah ; -1/3!
Trg.Len equ ($-l0d0d)/Real.Len
;
; Function LN(real):real
;
l0d2b:
inc l
dec l ; Check zero
ld a,_LNerr
jp z,l2027 ; Error if so
bit sgn.bit,b
jp nz,l2027 ; If negative, too
exx
call l0f98 ; Load constant SQRT(2)
exx
ld a,l
ld l,Exp.One ; Fix exponent
sub l
push af
call l0af5 ; Divide reals
exx
call l0f86 ; Load constant 1.0
exx
call l0a81 ; Subtract reals
push bc
push de
push hl
exx
inc l ; Number times 2
call l0a0d ; Add reals
exx
pop hl
pop de
pop bc
call l0af5 ; Divide reals
push ix
ld ix,l0d92-Real.Len
ld a,LN.len
call l0f34 ; Do the TAYLOR loop
pop ix
inc l ; Number times 2
exx
call l0fa2 ; Load constant LN(2)
dec l ; Halve it
exx
call l0a0d ; Add reals
pop af
push bc
push de
push hl
ld l,a
ld h,0
jr nc,l0d7c
dec h ; Set -1
l0d7c:
call l1008 ; Convert to real
exx
inc l ; Number times 2
call l0a97 ; Multiply reals
exx
pop hl
pop de
pop bc
call l0a0d ; Add reals
ld a,l
cp ln.min ; Test underflow
jp c,l0b72 ; Return 0.0 if so
ret
;
; Taylor series for Natural Logarithm
;
l0d92:
db 07dh,08ah,09dh,0d8h,089h,01dh ; 1/13
db 07dh,0e9h,0a2h,08bh,02eh,03ah ; 1/11
db 07dh,08eh,0e3h,038h,08eh,063h ; 1/9
db 07eh,049h,092h,024h,049h,012h ; 1/7
db 07eh,0cdh,0cch,0cch,0cch,04ch ; 1/5
db 07fh,0abh,0aah,0aah,0aah,02ah ; 1/3
LN.len equ ($-l0d92)/Real.Len
;
; Function EXP(real):real
;
l0db6:
exx
call l0fa2 ; Load constant LN(2)
exx
or a
bit sgn.bit,b
push af ; Save sign
res sgn.bit,b ; Clear it
call l0af5 ; Divide reals
ld a,l
cp exp.max ; Test overflow
jr nc,l0e10
push bc
push de
push hl
inc l ; Times 2
call l0fd0 ; Get integer
push hl
srl h ; Divide by 2
rr l
ld a,l
pop hl
push af
call l1008 ; Back to real
inc l ; Test zero
dec l
jr z,l0de0
dec l ; Fix if not
l0de0:
exx
pop af
pop hl
pop de
pop bc
push af
call l0a81 ; Subtract reals
push ix
ld ix,l0e16-Real.Len
ld a,EXP.Len
call l0f49 ; Do the TAYLOR loop
pop ix
pop af
jr nc,l0e03
push af
exx
call l0f98 ; Load constant SQRT(2)
exx
call l0a97 ; Multiply reals
pop af
l0e03:
add a,l ; Build resulting exponent
ld l,a
jr c,l0e10 ; Overflow
pop af ; Test sign
ret z
exx
call l0f86 ; Load constant 1.0
jp l0af5 ; Divide reals (1/number)
l0e10:
pop hl
ld a,_FLPovfl ; Error
jp l2027
;
; Taylor series for natural EXPonetiation
;
l0e16:
db 06dh,02eh,01dh,011h,060h,031h ; 1.3215 E-6
db 070h,046h,02ch,0feh,0e5h,07fh ; 1.5252 E-5
db 074h,036h,07ch,089h,084h,021h ; 1.5403 E-4
db 077h,053h,03ch,0ffh,0c3h,02eh ; 1.3333 E-3
db 07ah,0d2h,07dh,05bh,095h,01dh ; 9.6181 E-3
db 07ch,025h,0b8h,046h,058h,063h ; 5.5504 E-2
db 07eh,016h,0fch,0efh,0fdh,075h ; 2.4022 E-1
db 080h,0d2h,0f7h,017h,072h,031h ; 6.9314 E-1
EXP.Len equ ($-l0e16)/Real.Len
;
; Function ARCTAN(real):real
;
l0e46:
ld a,l
or a ; Test zero
ret z
push ix
exx
call l0f86 ; Load constant 1.0
exx
xor a
bit sgn.bit,b ; Test sign
jr z,l0e58
inc a
res sgn.bit,b ; Make absolute
l0e58:
push af
call l0bdf ; Compare against 1.0
jr c,l0e66
exx
call l0af5 ; Divide reals (1/number)
pop af
set sgn.bit,a ; Indicate reverse
push af
l0e66:
exx
ld bc,006cfh ; Load 0.13165
ld de,0e98eh
ld hl,04a7eh
exx
call l0bdf ; Compare reals
jr nc,l0e7b
call l0f2e ; Build TAYLOR series
jr l0eca
l0e7b:
ld ix,l0ee0-3*Real.Len
ld a,2 ; Set loop
l0e81:
ex af,af'
exx
ld de,3*Real.Len
add ix,de
call l0f73 ; Get value from table
exx
call l0bdf ; Compare reals
jr c,l0e9c
ex af,af'
dec a ; Go thru the loop
jr nz,l0e81
exx
ld de,2*Real.Len
add ix,de ; Fix table
exx
l0e9c:
exx
call l0f6e ; Get next from table
set sgn.bit,b ; Make negative
call l0a0d ; Add reals
push bc
push de
push hl
call l0f73 ; Get value back
call l0a97 ; Multiply reals
exx
call l0f86 ; Load constant 1.0
call l0a0d ; Add reals
exx
pop hl
pop de
pop bc
call l0af5 ; Divide reals
push ix
call l0f2e ; Do TAYLOR
pop ix
exx
call l0f6e ; Get from table
call l0a0d ; Add reals
l0eca:
pop af
rla ; Get sign bit
jr nc,l0ed8
push af
exx
call l0f8e ; Load constant PI
dec l ; Make 90 degrees
call l0a81 ; Subtract reals
pop af
l0ed8:
pop ix
bit 1,a ; Test operand sign
ret z
set sgn.bit,b ; Set negative
ret
;
; 2nd Taylor series for ARCTangent
;
l0ee0:
db 07fh,0e7h,0cfh,0cch,013h,054h ; 4.1421 E-1
db 07fh,0f6h,0f4h,0a2h,030h,009h ; 2.6794 E-1
db 07fh,06ah,0c1h,091h,00ah,006h ; 2.6179 E-1
db 080h,0b5h,09eh,08ah,06fh,044h ; 7.6732 E-1
db 080h,082h,02ch,03ah,0cdh,013h ; 5.7735 E-1
db 080h,06ah,0c1h,091h,00ah,006h ; 5.2359 E-1
db 081h,000h,000h,000h,000h,000h ; 1.0000
db 080h,021h,0a2h,0dah,00fh,049h ; 7.8539 E-1
;
; Taylor series for ARCTangent
;
l0f10:
db 07dh,0e8h,0a2h,08bh,02eh,0bah ; -1/11
db 07dh,08eh,0e3h,038h,08eh,063h ; 1/9
db 07eh,049h,092h,024h,049h,092h ; -1/7
db 07eh,0cdh,0cch,0cch,0cch,04ch ; 1/5
db 07fh,0abh,0aah,0aah,0aah,0aah ; -1/3
AT.Len equ ($-l0f10)/Real.Len
;
; Perform TAYLOR series
; Calculate SERIES(x^2)*x
;
l0f2e:
ld ix,l0f10-Real.Len
ld a,AT.Len
l0f34:
push bc
push de
push hl
push af
call l0fac ; Copy number
call l0a97 ; Multiply reals [^2]
pop af
call l0f49 ; Do the TAYLOR loop
exx
pop hl
pop de
pop bc
jp l0a97 ; Multiply reals
;
; The TAYLOR series loop
; ENTRY Reg IX points to table
; Accu holds loop count
; Calculate : 1-(1/3!)x+..+/-..-(1/11!)x^8
;
l0f49:
push af
exx
call l0f6e ; Load from table
jr l0f60 ; Skip addition this time
l0f50:
push af
exx
push bc
push de
push hl
call l0f6e ; Get next value from table
call l0a0d ; Add reals
exx
pop hl
pop de
pop bc
exx
l0f60:
call l0a97 ; Multiply reals
pop af
dec a ; Test done
jr nz,l0f50 ; Nope
exx
call l0f86 ; Load constant 1.0
jp l0a0d ; Add reals
;
; Load next real from table
; ENTRY Reg IX points to table
; EXIT Regs (HL,DE,BC) hold real
;
l0f6e:
ld de,Real.Len
add ix,de ; Point to nexr
;
; Load real from table
; ENTRY Reg IX points to table
; EXIT Regs (HL,DE,BC) hold real
;
l0f73:
ld l,(ix+0) ; Get exponent
ld h,(ix+1) ; Mantissa LSB
ld e,(ix+2)
ld d,(ix+3)
ld c,(ix+4)
ld b,(ix+5) ; Mantissa MSB
ret
;
; Load constant 1.0
;
l0f86:
ld hl,Exp.One ; Load 6 bytes 2^0
ld b,h
ld c,h
ld d,h
ld e,h
ret
;
; Load constant PI=3.141592654
;
l0f8e:
ld bc,0490fh ; Load 6 bytes
ld de,0daa2h
ld hl,02182h
ret
;
; Load constant SQRT (2)=1.414213562
;
l0f98:
ld bc,03504h ; Load 6 bytes
ld de,0f333h
ld hl,0fa81h
ret
;
; Load constant LN (2)=0.693147181
;
l0fa2:
ld bc,03172h ; Load 6 bytes
ld de,017f7h
ld hl,0d280h
ret
;
; Copy real number
; ENTRY Regs (HL,DE,BC) hold number
; EXIT Number copied to alternating regs (HL,DE,BC)'
;
l0fac:
push bc ; Push onto stack
push de
push hl
exx ; Copy into alternate registers
pop hl ; Pop back
pop de
pop bc
ret
;
; Function RANDOM:real;
; EXIT Regs (HL,DE,BC) hold number
;
l0fb4:
call l0792 ; Get random value
ld hl,exp.offset ; Init exponent and count
ld a,mant.bits-bit.len
l0fbc:
bit sgn.bit,b ; Test MSB set
jr nz,l0fcd
sla e ; Shift left if not
rl d
rl c
rl b
dec l ; Count down exponent
dec a
jr nz,l0fbc
ld l,a
l0fcd:
res sgn.bit,b ; .. make 1.0> x >=0.0
ret
;
; Function ROUND(real):integer
;
l0fd0:
bit sgn.bit,b ; Attache sign
exx
call l0f86 ; Load constant 1.0
jr z,l0fda ; Test < 0
set sgn.bit,b ; make constant -1.0
l0fda:
dec l ; Set +-0.5
call l0a0d ; Add reals
;
; Function TRUNC(real):integer
;
l0fde:
or a
bit sgn.bit,l ; Test exponent < 0
jr z,l0fff ; Return zero if so
bit sgn.bit,b ; Mark sign
ex af,af'
set sgn.bit,b ; Set bit
l0fe8:
ld a,int.max
cp l
jr c,l1003 ; Test overflow
jr z,l0ff5 ; Or end of conversion
call l0b7a ; Shift mantissa right
inc l ; Bump exponent
jr l0fe8
l0ff5:
call l0b7a ; Shift mantissa right
ex af,af'
ld h,b ; Get result
ld l,c
ret z ; End if > 0
jp l0783 ; Negate
l0fff:
ld hl,0 ; Return 0
ret
l1003:
ld a,_TruncOvl
jp l2027 ; Set error
;
; Convert integer to floating point
; ENTRY Reg HL holds signed integer
; EXIT Regs (HL,DE,BC) hold real
;
; NOTE: ON INTEGER 8000H AND ONLY ON THIS NUMBER
; THIS ROUTINE WILL LOOP FOREVER !!!!!!!!
;
l1008:
ld a,h ; Test Zero
or l
jp z,l0b72 ; Set 0.0 if so
bit sgn.bit,h ; Test sign
ex af,af'
call l0780 ; Make number positive
ld a,int.max+1 ; Init exponent
l1015:
add hl,hl ; Shift mantissa
dec a ; Fix exponent
bit sgn.bit,h ; Test ready
jr z,l1015 ; Nope, wait for bit
ld b,h ; Get into hi part of mantissa
ld c,l
ld de,0 ; Clear lo part
ld h,d
ld l,a
ex af,af' ; Test sign
ret nz
res sgn.bit,b ; Set > 0
ret
;
; Convert real to formatted ASCII string
; ENTRY Reg HL holds fix comma places (-1 on none)
; Reg DE holds decimal places
; Regs (HL,BC,DE)' hold real number
; Reg IX points to ASCII buffer
;
l1027:
call l04c8 ; Get fix comma places
ex de,hl
ld e,0
jr c,l1033 ; Integer was < 0, no places
cp real.dig+1 ; Test max digits
jr c,l104b
l1033:
dec e
call l04c8 ; Get decimal places
exx
bit sgn.bit,b ; Test sign
exx
ld d,real.field ; Init field size
jr z,l1040
inc d ; Fix for sign < 0.0
l1040:
sub d ; Test against field length
jr nc,l1044
xor a
l1044:
cp real.field+2 ; Test max
jr c,l104a
ld a,real.field+2
l104a:
inc a
l104b:
ld d,a
push de
exx
ld iy,Number ;number ;???
push ix
call l10eb ; Prepare conversion
pop ix
pop de
ld c,a ; Save result exponent
ld a,d
inc a
bit sgn.bit,e ; Test sign
jr nz,l1071 ; < 0
add a,c ; Fix exponent
jp p,l106b
ld (iy),0 ; Clear entry
jr l1076
l106b:
cp real.ASCII ; Test decimal places
jr c,l1071
ld a,real.ASCII-1 ; Truncate it
l1071:
push de
call l1180 ; Normalize ASCII
pop de
l1076:
bit sgn.bit,b ; Test sign
jr z,l107f
ld a,'-'
call l10e5 ; Set sign
l107f:
bit sgn.bit,e ; Test sign
jr z,l1086
ld h,c ; Unpack
ld c,0
l1086:
bit sgn.bit,c ; Test sign
jr z,l108f
call l10e3 ; Set 0
jr l1096
l108f:
call l10d9 ; Copy ASCII
dec c ; Bump down
jp p,l108f
l1096:
ld a,d ; Test mantissa
or a
jr z,l10b1 ; None
ld a,'.'
call l10e5 ; Set decimal dot
l109f:
inc c ; Fix exponent
jr z,l10a8
call l10e3 ; Set 0
dec d
jr nz,l109f
l10a8:
dec d
jp m,l10b1
call l10d9 ; Copy ASCII
jr l10a8
l10b1:
bit sgn.bit,e ; Test exponent
ret z ; Nope
ld a,'E'
call l10e5 ; Set 'E'xponent
ld a,'+'
bit sgn.bit,h ; Test bit
jr z,l10c5
ld a,h
neg ; Make exponent > 0
ld h,a
ld a,'-'
l10c5:
call l10e5 ; Store sign of exponent
ld a,h ; Get exponent
ld b,'0'-1 ; Init HI
l10cb:
inc b ; Fix result
sub 10 ; Divide by 10
jr nc,l10cb
add a,'9'+1 ; Make remainder ASCII
ld (ix),b ; save HI
inc ix
jr l10e5 ; Store LO
;
; Copy from buffer, set 0 if end
;
l10d9:
ld a,(iy) ; Get number
inc iy
or a ; Test end
jr nz,l10e5 ; Nope
dec iy ; Fix for zero storage
;
; Store ASCII zero into number
;
l10e3:
ld a,'0' ; Set zero
;
; Store ASCII into number
;
l10e5:
ld (ix),a ; Store number
inc ix ; Update pointer
ret
;
; Prepare ASCII for real to formatted ASCII conversion
; ENTRY Reg IY points to ASXII buffer
; Regs (HL,BC,DE) hold real number
; EXIT Buffer pre-filled
; Accu holds exponent equivalent
;
l10eb:
push iy ; save buffer
inc l ; Test zero number
dec l
jr nz,l10ff
ld b,real.ASCII ; Set length
l10f3:
ld (iy),'0' ; Clear ASCII number
inc iy
djnz l10f3
xor a
jp l117d
l10ff:
push bc ; Save sign
res sgn.bit,b ; Reset sign
ld a,l
exx
sub exp.offset ; Strip off offset
ld l,a
sbc a,a ; Expand to signed 16 bit
ld h,a
ld de,ExpFix
call l06f5 ; HL:=HL*DE
ld de,10 / 2
add hl,de ; Gix exponent
ld a,h
cp ExpRange ; Test range
jr nz,l1119
inc a ; Fix result
l1119:
ld (iy),a ; Store into buffer
neg
call l1240
ld a,l
cp Exp.One ; Test exponent
jr nc,l112c
call l12b3 ; Fix mantissa
dec (iy) ; Fix exponent
l112c:
set sgn.bit,b ; Set bit
ld a,exp.offset+4
sub l ; Test exponent
ld l,0
jr z,l113d
l1135:
call l0b7a ; Shift mantissa right
rr l
dec a
jr nz,l1135
l113d:
ld a,(iy) ; Get exponent
push af
ld a,real.ASCII ; Set count
l1143:
ex af,af'
ld a,b ; Get MSB
rra ; Isolate hi
rra
rra
rra
and LoMask ; Mask bits
add a,'0' ; Make ASCII
ld (iy),a
inc iy
ld a,b
and LoMask
ld b,a
push bc
push de
push hl
sla l
call l0b87 ; Rotate mantissa left *2
sla l
call l0b87 ; * 4
ex de,hl
ex (sp),hl
add hl,de ; * 5
pop de
ex (sp),hl
adc hl,de
ex de,hl
pop hl
ex (sp),hl
adc hl,bc
ld b,h
ld c,l
pop hl
sla l
call l0b87 ; *10
ex af,af'
dec a
jr nz,l1143
pop af
pop bc
l117d:
pop iy
ret
;
; Normalize ASCII number
; ENTRY Accu holds length of number
;
l1180:
push iy
pop hl ; Copy buffer
ld e,a
ld d,0
add hl,de
ld a,(hl) ; Get last digit
ld (hl),0
cp '5' ; Test to be normalized
ret c ; Nope
l118d:
dec e ; Count down
jp m,l119c
dec hl ; Get previous
ld a,(hl)
inc a ; Advance digit
ld (hl),a
cp '9'+1 ; Test in range
ret c ; Yeap
ld (hl),0 ; Clear this one
jr l118d
l119c:
ld (hl),'1' ; Set carry
inc hl
ld (hl),0 ; Clear next
inc c
ret
;
; Convert ASCII string to Floating Point number
; ENTRY Reg IX points to ASCII number
; EXIT Regs HL,DE,BC hold real
; Carry set indicates conversion error
;
cnv_flp:
exx
ld bc,0 ; Reset flags
exx
call l0b72 ; Init 0.0
l11ab:
ld a,(ix) ; Get character
call doupcase ; Convert to upper case
cp '.' ; Test decimal point
jr nz,l11c1
exx
bit dot.bit,b ; Test already selected
scf
ret nz ; Error if so
set dot.bit,b ; Indicate dot
exx
l11bd:
inc ix ; Skip character
jr l11ab ; Get next
l11c1:
cp 'E' ; Test exponent
jr z,l11e6 ; Yeap, process it
call l1239 ; Test digit
jr nc,l121e ; Nope
ex af,af'
call l12b3 ; Convert mantissa
ret c ; Error
ex af,af'
exx
push bc
ld l,a ; Build integer
ld h,0
call l1008 ; Convert to floating point
call l09e9 ; Add reals
exx
pop bc
ret c ; End if overflow
bit dot.bit,b ; Test decimal point
jr z,l11e3
dec c ; Fix length if so
l11e3:
exx
jr l11bd
;
; Found 'E'xponent
;
l11e6:
call l121e ; Fix mantissa
ret c ; Overflow
exx
set exp.bit,b ; Set bit
inc ix
ld a,(ix)
cp '+' ; Test any sign
jr z,l11fc ; Skip plus
cp '-'
jr nz,l11fe
set exps.bit,b ; Indicate negative exponent
l11fc:
inc ix
l11fe:
call l1236 ; Get 1st digit
ccf
ret c ; Invalid
ld c,a
inc ix
call l1236 ; Get 2nd digit
jr nc,l1215 ; Only one
inc ix
ld d,a
ld a,c ; Get first one - it's tens
add a,a ; * 2
add a,a ; * 4
add a,c ; * 5
add a,a ; *10
add a,d ; Insert 2nd
ld c,a
l1215:
bit exps.bit,b ; Test exponent < 0
jr z,l121d ; Nope
ld a,c
neg ; Change it if so
ld c,a
l121d:
exx
l121e:
exx
ld a,c ; Get exponent
add a,exp.offset ; Set offset
cp 05ah ; Check range
ret c ; Underflow
cp 0a6h
ccf
ret c ; Overflow
push bc
push ix
ld a,c
call l1240 ; Fix exponent
pop ix
exx
pop bc ; Fix stack
exx
ret
;
; Get character and test if digit
; ENTRY Reg IX points to character
; EXIT Accu holds character
; Carry reset if in range
;
l1236:
ld a,(ix) ; Get character
;
; Test character a digit - C set if so
; ENTRY Accu holds character
; EXIT Carry reset if in range
;
l1239:
sub '0' ; Strip off offset
ccf
ret nc ; Out of range
cp 9+1
ret
;
; Fix exponent for real to ASCII conversion
; ENTRY Accu holds exponent equivalent
; EXIT Real fixed
;
l1240:
push af ; Save exponent
or a ; Test sign
jp p,l1247
neg ; Make >0
l1247:
push af
srl a ; Shift
srl a
inc a ; Then fix
ld hl,-Real.Len ; Init index
ld de,Real.Len
l1253:
add hl,de ; Fix index
dec a
jr nz,l1253
ex de,hl
ld ix,l1277 ; Point to table
add ix,de
call l0f73 ; Get number from table
pop af
and 11b ; Get MOD 4
jr z,l126e
l1266:
push af
call l12b3 ; Fix mantissa
pop af
dec a
jr nz,l1266
l126e:
pop af ; Get back exponent
or a
jp p,l0a97 ; Multiply reals if > 0
exx
jp l0af5 ; Divide reals if < 0
;
; Fix up table
;
l1277:
db 081h,000h,000h,000h,000h,000h ; 1 E 0
db 08eh,000h,000h,000h,040h,01ch ; 1 E 4
db 09bh,000h,000h,020h,0bch,03eh ; 1 E 8
db 0a8h,000h,010h,0a5h,0d4h,068h ; 1 E12
db 0b6h,004h,0bfh,0c9h,01bh,00eh ; 1 E16
db 0c3h,0ach,0c5h,0ebh,078h,02dh ; 1 E20
db 0d0h,0cdh,0ceh,01bh,0c2h,053h ; 1 E24
db 0deh,0f9h,078h,039h,03fh,001h ; 1 E28
db 0ebh,02bh,0a8h,0adh,0c5h,01dh ; 1 E32
db 0f8h,0c9h,07bh,0ceh,097h,040h ; 1 E36
;
; Fix mantissa for real to ASCII conversion
; ENTRY Regs (BC,DE,HL) hold real
; EXIT Real fixed
;
l12b3:
ld a,l ; Test exponent
or a
ret z ; Zero
set _MB,b ; Set bit
push bc
push de
ld a,h
call l0b7a ; Shift mantissa right
call l0b7a ; Two places
add a,h ; Add LSB
ld h,a
ex (sp),hl ; Get middle part
adc hl,de ; Add it
ex de,hl
pop hl
ex (sp),hl
adc hl,bc ; Same for hi part
ld b,h ; Copy to high
ld c,l
pop hl ; Get back old hi
jr nc,l12d6
call l0b7b ; Rotate mantissa right
inc l ; Fix exponent
scf
ret z
l12d6:
ld a,l
add a,3 ; Fix exponent
ld l,a
res _MB,b ; Clear bit
ret
;
; Test sets not equal (<>)
; ENTRY Both sets on stack
; EXIT Reg HL holds boolean result
;
l12dd:
ld c,_TRUE ; Set flag
jr l12e3 ; Compare
;
; Test sets equal (=)
; ENTRY Both sets on stack
; EXIT Reg HL holds boolean result
;
l12e1:
ld c,FALSE
l12e3:
call l133f ; Get sets
l12e6:
ld a,(de)
cp (hl) ; Compare
jr nz,l12f2 ; Not equal
inc hl
inc de
djnz l12e6
ld a,c
xor _TRUE ; Zoggle flag if equal
ld c,a
l12f2:
ld hl,2*set.len
add hl,sp ; Fix stack
ld sp,hl
ld l,c ; Get state
ld h,0
jp (ix) ; Exit
;
; Test two sets included (1st in 2nd, <=)
; ENTRY Both sets on stack
; EXIT Reg HL holds boolean result
;
l12fc:
ld c,_TRUE ; Set flag
jr l1302
;
; Test two sets included (2nd in 1st, >=)
; ENTRY Both sets on stack
; EXIT Reg HL holds boolean result
;
l1300:
ld c,FALSE
l1302:
call l133f ; Get sets
dec c ; Test comparision mode
jr nz,l1309
ex de,hl
l1309:
ld c,FALSE
l130b:
ld a,(de)
or (hl) ; Combine
cp (hl) ; Compare
jr nz,l12f2
inc hl
inc de
djnz l130b
ld c,_TRUE ; Return TRUE
jr l12f2
;
; Combine two sets (add, +)
; ENTRY Both sets on stack
; EXIT Combined set on stack
;
l1318:
call l133f ; Get sets
l131b:
ld a,(de)
or (hl) ; Combine sets
ld (hl),a
inc hl
inc de
djnz l131b
l1322:
ex de,hl
ld sp,hl
jp (ix)
;
; Combine two sets (subtract, -)
; ENTRY Both sets on stack
; EXIT Combined set on stack
;
l1326:
call l133f ; Get sets
l1329:
ld a,(de)
cpl ; Complement
and (hl) ; Mask bits
ld (hl),a
inc hl
inc de
djnz l1329
jr l1322
;
; Combine two sets (intersection, *)
; ENTRY Both sets on stack
; EXIT Combined set on stack
;
l1333:
call l133f ; Get sets
l1336:
ld a,(de)
and (hl) ; Mask
ld (hl),a
inc hl
inc de
djnz l1336
jr l1322
;
; Get addresses of sets
; ENTRY Both sets on stack
; EXIT Regs HL and DE point to sets
; Reg IX holds caller address
; Reg B holds set length
;
l133f:
pop iy ; Get last caller
pop ix ; Get caller before last one
ld hl,0
add hl,sp
ex de,hl ; Get 1st set
ld hl,set.len
ld b,l ; Get length
add hl,sp ; Get 2nd set
jp (iy) ; Return
;
; Test element in set (IN)
; ENTRY Both sets on stack
; EXIT Reg HL holds boolean result
;
l134f:
pop ix ; Get caller
ld hl,set.len+1
add hl,sp ; Get pointer to set
ld a,(hl)
or a ; Test any set
jr z,l135c
xor a
jr l1362 ; Force FALSE
l135c:
dec hl
ld b,(hl)
call l05ba ; Get bit state
and (hl)
l1362:
ld hl,set.len+2
add hl,sp
ld sp,hl ; Set return stack
ld hl,FALSE ; Init FALSE
jr z,l136d ; Test result
inc hl ; Set TRUE
l136d:
jp (ix)
;
; Procedure ASSIGN(file,filename)
; ENTRY Filenname as string on stack
; FIB followed string
;
; Assign text file
;
l136f:
db skip ; Set non zero
;
; Assign (un)typed file
;
l1370:
xor a ; Set zero
ld (l00e8),a ; Put into mode
pop iy ; Get back caller
ld hl,(l00d2) ; Get top of memory
ld b,16 ; And max length
call l05e2 ; Assign string from stack
xor a
ld (de),a ; Close it
pop hl ; Fetch FIB
ld (l00e2),hl ; Put into device
push iy ; Bring back caller
ld a,h ; Verify not standard but file
or a
jr nz,l1390
ld a,_StdAssErr ; Set illegal FIB
ld (l00d0),a
ret
l1390:
ld a,(l00e8) ; Get back mode
or a ; Test text file
jr z,l13a0 ; Nope
call l13b6 ; Find standard device
jr nz,l13a0 ; Nope
ld hl,(l00e2) ; Get back FIB
ld (hl),a ; Set flag
ret
l13a0:
call l03f2 ; Parse file
ld hl,(l00e2)
ld (hl),0
ld de,FIB.FCB
add hl,de ; Point to FCB part
ex de,hl
ld hl,l005c
ld bc,FCBlen
ldir ; move FCB to FIB
ret
;
; Find standard IO device
; ENTRY TOPRAM filled with device string
; EXIT Zero flag set if device found
; Accu holds FIB flag if so
;
l13b6:
ld b,Std.Len ; Init length
ld hl,l13e6 ; Get table address
l13bb:
push bc
push hl
ld b,Std.Itm-1 ; Set length of one item
ld de,(l00d2) ; Get top of memory
l13c3:
inc de
ld a,(de)
cp ' ' ; Skip leading blanks
jr z,l13c3
l13c9:
ld a,(de) ; Get character
call doupcase ; Convert to upper case
sub (hl) ; Compare
jr z,l13da ; Maybe a hit
pop hl
pop bc
ld de,Std.Itm
add hl,de ; Point to next entry
djnz l13bb ; Try more
or a
ret
l13da:
inc hl
inc de
djnz l13c9 ; Loop until all found
pop bc
pop bc
ld a,(de)
cp ':' ; Verify standard device
ret nz
ld a,(hl) ; Get flag if so
ret
;
; Standard character I/O devices
;
l13e6:
db 'CON'
db 11000001b ; Input output for CON
Std.Itm equ $-l13e6
db 'TRM'
db 11000001b ; Input output for TRM
db 'KBD'
db 10000010b ; Input for KBD
db 'LST'
db 01000011b ; Output for LST
db 'AUX'
db 11000100b ; Input output for AUX
db 'USR'
db 11000101b ; Input output for USR
Std.Len equ ($-l13e6) / Std.Itm
;
; Prepare files
; ENTRY Reg HL points to FIB
;
; Procedure REWRITE(text_file)
;
l13fe:
db skip
;
; Procedure RESET(text_file)
;
l13ff:
xor a
ld (l00e8),a ; Set mode (0=RESET)
call l1469 ; Close open file
ld a,(l00d0)
or a ; Test error
ret nz ; End if so
ld hl,(l00e2) ; Get FIB
res wr.bit,(hl) ; Reset write flag
ld a,(hl)
and FIBtype ; Get type
ret nz ; Exit on standard device
call l1430 ; Prepare file operation
ld a,(l00d0)
or a ; Test error
ret nz ; Exit if so
ld hl,(l00e2) ; Get back FIB
ld a,(l00e8) ; Get file mode
or a ; Test RESET
ld bc,RecLng*256+_.in
jr z,l142b ; Yeap
ld bc,0*256+_.out
l142b:
ld (hl),c ; Set flag
inc hl
inc hl
ld (hl),b ; Set buffer pointer
ret
;
; Prepare file operation for current FIB
;
l1430:
call l145a ; Clear FCB of this FIB
ld hl,(l00e2) ; Get FIB
ld de,FIB.FCB
add hl,de ; Point to FCB
ex de,hl
ld a,(l00e8) ; Get file mode
or a ; Test RESET
ld bc,_NoFile*256+_open
jr z,l144e ; Yeap, go open file
push de
ld c,_delete
call BDOS ; Delete file before rewrite
pop de
ld bc,_DirFull*256+_make
l144e:
push bc
call BDOS ; Now open or make file
pop bc
;inc a ; Test success
;ret nz ; Yeap
or a
ret z
ld a,b
ld (l00d0),a ; Set error if not
ret
;
; Clear FCB of current FIB
;
l145a:
ld hl,(l00e2) ; Get FIB
ld de,FIB.FCB+_ex
add hl,de ; Point to EX filed
ld b,FCBlen-_ex ; Set length
l1463:
ld (hl),0 ; Clear it
inc hl
djnz l1463
ret
;
; Close text file
;
; Procedure CLOSE(text_file)
;
; ENTRY Reg HL holds FIB
;
l1469:
ld (l00e2),hl ; Save FIB for current device
ld a,(hl)
and FIBtype ; Get type
ret nz ; Exit if not a file
bit out.bit,(hl) ; Test output
jr z,l147e ; Skip if not
ld a,eof
call l16c6 ; Close file by EOF
call l170c ; Then flash buffer
jr l1481
l147e:
bit in.bit,(hl) ; Test input
ret z ; Nope, end
l1481:
ld hl,(l00e2) ; Get FIB
push hl
ld de,FIB.FCB
add hl,de ; Point to FCB
ex de,hl
ld c,_close
call BDOS ; Close file
pop hl
inc a ; Test success
jr nz,l1498 ; Yeap
ld a,_NoClose
ld (l00d0),a ; Set error
l1498:
ld (hl),0 ; Reset FIB flag
ret
;
; Set standard device
;
l149b:
ex (sp),hl
ld (l00e4),hl ; Save caller
ex (sp),hl
push hl
ld hl,l00c2
ld (l00e2),hl ; Set standard as FIB
pop hl
ret
;
; Check file before read
; ENTRY Reg HL points to FIB
;
l14a9:
ex (sp),hl
ld (l00e4),hl ; Save caller for error
ex (sp),hl
ld (l00e2),hl ; Save FIB
bit in.bit,(hl) ; Test read allowed
ret nz ; Yeap
ld a,_NoRead
ld (l00d0),a ; Set error
ret
;
; Check file before write
; ENTRY Reg HL points to FIB
;
l14ba:
ex (sp),hl
ld (l00e4),hl ; Save caller for error
ex (sp),hl
ld (l00e2),hl ; Save FIB
bit out.bit,(hl) ; Test write allowed
ret nz ; Yeap
ld a,_NoWrite
ld (l00d0),a ; Set error
ret
;
; Function READLN(var)
; ENTRY Reg HL points to variable
;
l14cb:
db skip
;
; Function READ(var)
; ENTRY Reg HL points to variable
; EXIT Reg HL points to variable
;
l14cc:
xor a
ex (sp),hl ; Get caller
ld (l00e4),hl ; Save it
ex (sp),hl
push hl
ld hl,l00c2
ld (l00e2),hl ; Set standard device
res wr.bit,(hl) ; Reset write bit
push af ; Save mode
call l14e8 ; Read a line
pop af
or a ; Test READLN
jr z,l14e6
call l01e1 ; Give new line if so
l14e6:
pop hl
ret
;
; Read a line from keyboard
;
l14e8:
ld b,0 ; Reset flag
l14ea:
ld hl,l00d1 ; Point to buffer length
ld a,(hl) ; Get buffer length
cp _MaxBuf+1 ; Verify in range
jr c,l14f4
ld a,_MaxBuf ; Truncate if not
l14f4:
ld c,a
ld (hl),_MaxBuf ; Set default length
ld hl,(l00d2) ; Get top of memory
ld (l00d4),hl ; Unpack it
l14fd:
ld d,0 ; Reset character count
l14ff:
call readfromkbd ; Read character
ld (hl),a ; Unpack it
ld e,1 ; Init flag
cp bs ; Test backspace
jr z,l153f
;cp DEL ; Test delete
;jr z,l153f
dec e
cp CtrlX ; Test ^X
jr z,l153f
cp esc ; Test escape
jr z,l153f
cp eof ; Test end of file
jr z,l1550
cp cr ; Test end of line
jr z,l1556
cp ' ' ; Test printable
jr nc,l1533
cp CtrlC ; Test ^C
jr nz,l14ff
ld a,(l00dd) ; Get $C mode
or a ; Test abort
jr z,l14ff ; $C- - so ignore
ld ix,(l00e4)
jp l2016 ; Abort
;
; Found printable character
;
l1533:
ld a,c ; Get max
cp d ; Test against count
jr z,l14ff ; Yeap, ignore
ld a,(hl) ; Get character
inc d ; Advance counter
inc hl ; Point to next storage location
call puttoconsole_a ; Put to console
jr l14ff
;
; Special control detected: Backspace, DELete, ^X, ESCape
;
l153f:
dec d ; Fix count
jp m,l14fd ; Ignore if at 1st position
dec hl
call l0200 ; Position cursor left
db bs,' ',bs
db null
dec e ; Test backspace or delete
jr z,l14ff ; Yeap
jr l153f ; Else delete two characters on screen
;
; Found EOF
;
l1550:
inc b ; Test flag
dec b
jr z,l14ff ; Ignore input
jr l155a ; Close input line
;
; Found CR
;
l1556:
inc b ; Test flag
dec b
jr nz,l155e ; Ignore EOF
l155a:
ld (hl),eof ; Close line
jr l1566
l155e:
call l01e1 ; Give new line
ld (hl),cr ; Close line
inc hl
ld (hl),lf
l1566:
inc hl
ld (l00d6),hl ; Set top pointer
ret
;
; Get character from file or console buffer
;
l156b:
ld hl,(l00e2) ; Get FIB
ld a,(l00d0)
or a ; Test error
jp nz,l15ed ; Force EOF if so
ld a,(hl)
bit wr.bit,a ; Test preread char
jp nz,l15e9 ; Fetch if so
and FIBtype ; Test device
jr nz,l15ab ; Yeap, standard I/O
inc hl ; Point to sector buffer
inc hl
ld a,(hl)
or a ; Test filled
jp p,l1597 ; Not yet
push hl
ex de,hl
ld c,_setdma
call l19ba ; set DTA
pop hl
ld c,_rdseq
push hl
call l19ba ; Read sector
pop hl
;jr z,l1595 ; Read was successfull
cp 128 ;EOF in NedoOS
jr nz,l1595 ; Read was successfull
;jr $ ;lister.pas
;CP/M has eofs in the end of last sector?
;do this by hand:
or a
jr z,read_load_noaddeofs ;full sector
;a=128+bytes loaded
neg
;a=128-bytes loaded
ld b,a
ld a,l
add a,127
ld e,a
adc a,h
sub e
ld d,a
;ld de,TmpBuff+127 ;de= Point to buffer end
ld a,eof;-1
ld (de),a
dec de
djnz $-2
read_load_noaddeofs
push hl
ld de,FIB.buff-2
add hl,de ; Point to buffer
ld (hl),eof ; Set EOF
pop hl
l1595:
xor a
ld (hl),a ; Reset buffer pointer
l1597:
inc (hl) ; Bump pointer
add a,FIB.buff-2
ld e,a
ld d,0
add hl,de ; Calculate current buffer
ld a,(hl)
cp eof ; Test EOF
jr nz,l15e0 ; Nope
ld hl,(l00e2)
inc hl
inc hl
dec (hl) ; Fix pointer if eof found
;push hl
; ld c,_close
; call BDOS_with_FCB1 ;с этим виснет lister в конце!!!
;pop hl
jr l15e0
l15ab:
dec a ; Test CON:
jr nz,l15c9
ld hl,(l00d4) ; Get current pointer
ld de,(l00d6) ; Get top pointer
or a
sbc hl,de ; Test more in buffer
jr c,l15bf ; Ok
ld b,-1
call l14ea ; Else get more
l15bf:
ld hl,(l00d4) ; Get current pointer
ld a,(hl)
inc hl ; Bump
ld (l00d4),hl
jr l15e0
l15c9:
dec a ; Test KBD:
jr nz,l15d2
call l00a3 ; Read KBD
ld a,l
jr l15e0
l15d2:
dec a ; Test AUX:
dec a
jr nz,l15dc
call l00af ; Get from auxiliary
ld a,l
jr l15e0
l15dc:
call l00b5 ; Read USR
ld a,l
l15e0:
ld hl,(l00e2) ; Get back FIB
set wr.bit,(hl) ; Set preread flag
inc hl
ld (hl),a ; Save character
dec hl
ret
l15e9:
inc hl ; Point to character buffer
ld a,(hl) ; Get character
dec hl
ret
l15ed:
ld a,eof ; Return EOF
ret
;
; Get character from current device
; Fix up controls
;
l15f0:
push hl
ld hl,(l00e2) ; Get FIB
ld a,(hl)
and FIBtype ; Get device
cp RAMdevice ; Test RAM
jr z,l1622
l15fb:
call l156b ; Get character from device
cp ' '+1 ; Test control
jr nc,l160a ; Nope
cp eof ; Test EOF
jr z,l160a ; Yeap
res wr.bit,(hl) ; Reset preread
jr l15fb ; Then synchronize
l160a:
ld de,Number ; Set buffer
ld b,_MaxSamp ; Set max
l160f:
push bc
push de
call l156b ; Get character from device
pop de
pop bc
cp ' '+1 ; Test control
jr c,l1620 ; Yeap, end if so
res wr.bit,(hl) ; No preread
ld (de),a ; save character
inc de
djnz l160f
l1620:
xor a
ld (de),a ; Close buffer
l1622:
pop hl
ret
;
; Check negative sign of ASCII number
; ENTRY Location NUMBER filled
; EXIT Reg IX points to number buffer
; Reg B holds 0 on no negative sign
; and 1 on negative sign found
; Zero flag indicates empty buffer
;
l1624:
ld ix,Number ; Init pointer
ld a,(ix) ; Get character
or a
ret z ; Exit if zero
ld b,0
cp '-' ; Test negative sign
ret nz ; Nope
inc b ; Fix result
inc ix ; Skip pointer
ret
;
; Fix number conversion for error
; ENTRY Reg IX points behind number
; Carry set reflects overflow
; EXIT Carry set indicates error
; IORESULT set to error 010H
;
l1636:
jr c,l163d ; Fall into error
ld a,(ix) ; Test correct end
or a
ret z ; Yeap
l163d:
ld a,_IllNum
ld (l00d0),a ; Set error
scf
ret
;
; Get character from input READ(char)
; ENTRY Reg HL points to character variable
;
l1644:
push hl ; Save pointer
call l156b ; Get character
res wr.bit,(hl) ; Reset preread
pop hl ; Get back pointer
ld (hl),a ; Save character
ret
;
; Get byte from input READ(byte)
; ENTRY Reg HL points to byte variable
;
l164d:
db skip ; Set byte flag
;
; Get integer from input READ(integer)
; ENTRY Reg HL points to integer variable
;
l164e:
xor a ; Reset byte flag
ld c,a
push bc
call l15f0 ; Get number input
pop bc
call l1624 ; Test sign
ret z ; Empty number, exit
push bc
push hl
call cnv_int ; Convert ASCII to integer
pop de
pop bc
call l1636 ; Test error
ret c ; Yeap, exit
dec b ; Test negative sign
call z,l0783 ; Negate if so
ex de,hl
ld (hl),e ; Save low or byte
inc c
dec c ; Test byte
jr nz,l1670 ; Skip if so
inc hl
ld (hl),d ; Save high on integer
l1670:
ex de,hl
ret
;
; Get real from input READ(real)
; ENTRY Reg HL points to real variable
;
l1672:
call l15f0 ; Get ASCII number
call l1624 ; Test sign
ret z ; Empty number, exit
push bc
push hl
call cnv_flp ; Convert to real
exx
pop hl
pop bc
call l1636 ; Test error
ret c ; Yeap, exit
dec b ; Test negative sign
exx
call z,l0a8f ; Negate if so
exx
jp l05d1 ; Save real number
;
; Get string from input READ(string[max])
; ENTRY Reg HL points to string variable
; Reg B holds max characters in string
;
l168e:
push hl ; Save pointer
ex de,hl
ld c,0 ; Clear character count
l1692:
push bc
push de
call l156b ; Get character
pop de
pop bc
cp cr ; Test end of line
jr z,l16a8
cp eof ; Test end of file
jr z,l16a8
res wr.bit,(hl) ; Reset preread
inc c ; Advance count
inc de ; Advance pointer
ld (de),a
djnz l1692
l16a8:
pop hl ; Get back pointer
ld (hl),c ; Set length
ret
;
; Handle end of line after READLN from file
;
l16ab:
call l156b ; Get character
cp eof ; Test end of file
jr z,l16c5
res wr.bit,(hl) ; Reset preread
cp lf ; Test new line
jr z,l16c5
cp cr ; Wait for end of line
jr nz,l16ab
call l156b
cp lf ; Maybe new line
jr nz,l16c5
res wr.bit,(hl) ; Reset preread if so
l16c5:
ret
;
; Output character to device
; ENTRY Accu holds character
;
l16c6:
ld hl,(l00e2) ; Get FIB
ld c,a ; Save character
ld a,(l00d0)
or a ; Test I/O error
ret nz ; Exit if so
ld a,(hl) ; Get type
and FIBtype ; Test device
jr nz,l16e4 ; Yeap
inc hl ; Point to sector buffer
inc hl
push hl
ld a,(hl) ; Get pointer
add a,FIB.buff-2
ld e,a
ld d,0
add hl,de ; Make pointer absolute
ld (hl),c ; Save character
pop hl
inc (hl) ; Advance count
ret p ; Still in range
jr l170c ; Write record
l16e4:
cp RAMdevice ; Test store to RAM
jr z,l16fd ; Yeap
pop hl
ld b,0
push bc
push hl
dec a ; 1=CON:
jp z,l00a6 ; Put to console
dec a ; 3=LST:
dec a
jp z,l00a9 ; Put to printer
dec a ; 4=AUX:
jp z,l00ac ; Put to auxiliary
; 5=USR:
jp l00b2 ; Put to console
l16fd:
ld hl,(l00e8) ; Get string pointer
ld a,(l00ea) ; Get max length
cp (hl) ; Test in range
ret z ; Nope, exit
inc (hl) ; Bump count
ld e,(hl)
ld d,0
add hl,de ; Build address
ld (hl),c ; Store character
ret
;
; Write sector to file if any item in buffer
;
l170c:
ld hl,(l00e2) ; Get FIB
inc hl
inc hl
ld a,(hl) ; Get record pointer
or a ; Test any in buffer
ret z ; Nope, exit
ld (hl),0 ; Clear pointer
ld c,_wrseq
call l19ba ; Write record
ret z ; Ok, no errr
ld a,_WrErr
ld (l00d0),a ; Set error
ret
;
; Write character to device
; WRITE(char)
; ENTRY Reg L holds character
;
l1722:
ld a,l ; Get character
jp l16c6 ; Put it
;
; Write integer to device
; WRITE(int)
; WRITE(int:m)
; ENTRY Integer on stack
; Reg HL holds digit count (zero without count)
;
l1726:
pop bc
pop de
push bc
ld ix,(l00d2) ; Get top of memory for buffer
bit sgn.bit,h ; Test sign of count
jr z,l1737 ; >= 0
call l0783 ; Negate
ex de,hl ; Swap values
jr l1745
l1737:
ex de,hl
bit sgn.bit,h ; Test sign of number
jr z,l1745 ; >= 0
call l0783 ; Negate
ld (ix),'-' ; Init sign
inc ix
l1745:
push de
call l07c6 ; Convert integer to ASCII
l1749:
pop hl
call l04c8 ; Get byte from integer
ld de,(l00d2) ; Get back top of memory
push ix
pop hl
or a
sbc hl,de ; Calculate length of string
ld c,l
ex de,hl
l1759:
sub c ; Test against count
jr c,l176a ; Ignore if out of range
jr z,l176a
ld b,a ; Save count
push hl
l1760:
ld a,' '
push bc
call l16c6 ; Blank leading places
pop bc
djnz l1760
pop hl
l176a:
ld b,c ; Get back length
inc b
l176c:
dec b
ret z
ld a,(hl)
push bc
push hl
call l16c6 ; Type digits
pop hl
pop bc
inc hl
jr l176c
;
; Formatted write
; WRITE(real)
; WRITE(real:n)
; WRITE(real:n:m)
; ENTRY Reg HL holds fix comma places (-1 on none)
; Stack holds decimal places and real
; (Without decimal places defaults to 24)
;
l1779:
pop bc
pop de ; Get places
exx
pop hl ; Get number
pop de
pop bc
exx
push bc
ld ix,(l00d2) ; Get top of memory for buffer
push de
call l1027 ; Convert real to ASCII
jr l1749
;
; Boolean write
; WRITE(bool)
; WRITE(bool:m)
; ENTRY Reg HL holds places (0 on none)
; Stack holds boolean
;
l178b:
pop bc
pop de ; Get boolean
push bc
call l04c8 ; Get byte from integer
bit _LB,e ; Test bit
ld hl,l17a1
ld c,l17a1.l
jr nz,l1759 ; It is TRUE
ld hl,l17a5
ld c,l17a5.l
jr l1759 ; Tell FALSE
;
l17a1:
db 'TRUE'
l17a1.l equ $-l17a1
l17a5:
db 'FALSE'
l17a5.l equ $-l17a5
;
; String and formatted character write
; WRITE(string)
; WRITE(string:m)
; WRITE(char:m)
; ENTRY Reg HL holds places (0 on none)
; Stack holds string (chracter=string with length=1)
;
l17aa:
call l04c8 ; Get byte from integer for places
ld hl,2
add hl,sp ; Fix stack
ld c,(hl) ; Get length
inc hl
call l1759 ; Print right justified
pop de ; Get back caller
ld sp,hl ; Reset stack
push de
ret
;
; Immediate string write
; WRITE('string')
; ENTRY Stack holds string starting with length
;
l17ba:
pop hl ; Get pointer to string
ld a,(hl) ; Get length
inc hl
or a ; Test any
jr z,l17cc
ld b,a ; save length if so
l17c1:
ld a,(hl) ; Get character
push bc
push hl
call l16c6 ; Write it
pop hl
pop bc
inc hl
djnz l17c1
l17cc:
jp (hl)
;
; Give new line
; WRITELN{...}
;
l17cd:
ld a,cr
call l16c6 ; Give return
ld a,lf
jp l16c6 ; Followed by line feed
;
; The logical delimiter functions
; Function SEEKEOLN(device):boolean
; ENTRY Reg HL points to FIB
; EXIT Reg HL holds TRUE or FALSE
;
l17d7:
ld de,1*256+cr ; Set CR
jr l17e9
;
; Function EOLN(device):boolean
;
l17dc:
ld de,cr
jr l17e9
;
; Function SEEKEOF(device):boolean
;
l17e1:
ld de,1*256+eof ; Set EOF
jr l17e9
;
; Function EOF(device):boolean
;
l17e6: ;???
ld de,eof
l17e9:
ld (l00e2),hl ; Set device
bit in.bit,(hl) ; Test input possible
jr z,l180c ; Nope
l17f0:
push de
call l156b ; Get character
pop de
cp e ; Test end found
jr z,l1808 ; Yeap
cp eof ; Test end of file
jr z,l1808 ; Force TRUE if so
cp ' '+1 ; Test control
jr nc,l180c ; Nope
inc d ; Test control to be checked
dec d
jr z,l180c ; Yeap
res wr.bit,(hl) ; Reset preread
jr l17f0
l1808:
ld hl,_TRUE ; Return TRUE
ret
l180c:
ld hl,FALSE ; Return FALSE
ret
;
; Prepare typed files
; Procedure REWRITE(typed_file)
; ENTRY Reg HL points to FIB
; Reg DE holds length of record
;
l1810:
db skip
;
; Procedure RESET(typed_file)
;
l1811:
xor a
ld (l00e8),a ; Set mode (0=RESET)
ld (l00e6),de ; Save record length
call l187a ; Close file
ld a,(l00d0) ; Test error
or a
ret nz ; End if so
call l1430 ; Set up FIB ;opens/creates file!!!
ld a,(l00d0) ; Test error
or a
ret nz ; End if so
ld hl,(l00e2) ; Init FIB flag
ld (hl),_.in+_.out+_.read
inc hl
inc hl
ld (hl),a ; Init record pointer
ld de,FIB.cur-2
add hl,de ; Point to current record
ld (hl),a ; Clear it
inc hl
ld (hl),a
ld de,FIB.FCB+_rrn-FIB.cur-1
add hl,de ; Point to random record
ld (hl),a ; Clear it
inc hl
ld (hl),a
ld de,FIB.rec-FIB.FCB-_rrn-1
add hl,de ; Point to FIB record
ld a,(l00e8)
or a ; Test mode
jr nz,l1864 ; Skip RESET
;
; Perform RESET
;
push hl
ld bc,FixRecLen ; Set four bytes
xor a
call l1909 ; Prepare read
pop hl
inc hl
inc hl
ld c,(hl) ; Point to max records
inc hl
ld b,(hl)
ld hl,(l00e6)
or a
sbc hl,bc ; Test agianst tem in file
ret z ; Correct value
ld a,_InvRec
ld (l00d0),a ; Set error
ret
;
; Perform REWRITE
;
l1864:
push hl
xor a
ld (hl),a ; Clear record
inc hl
ld (hl),a
inc hl
ld de,(l00e6) ; Fetch length
ld (hl),e ; Store into FIB
inc hl
ld (hl),d
pop hl
ld bc,FixRecLen
ld a,Rec.New+Rec.Wr
jp l1909 ; Prepare write
;
; Procedure CLOSE(typed_file)
; ENTRY Reg HL points to FIB
;
l187a:
ld (l00e2),hl ; Save FIB
ld a,(hl) ; Get state
and _.in+_.out ; Test any action
ret z ; Nope
call l19ae ; Write record if requested
ld hl,(l00e2) ; Get FIB
ld de,FIB.FCB+_rrn
add hl,de ; Point to random recird
xor a
ld (hl),a ; Clear it
inc hl
ld (hl),a
ld de,-FIB.FCB-_rrn+1
add hl,de ; Point to record
ld (hl),a ; Clear it
inc hl
inc hl
ld bc,FixRecLen
ld a,Rec.Wr
call l1909 ; Prepare write
call l19ae ; Write if requested
jp l1481 ; Close file
;
; Prepare write to record file
; ENTRY Reg HL points to FIB
;
l18a4:
ex (sp),hl
ld (l00e4),hl ; Save caller
ex (sp),hl
ld (l00e2),hl ; Save FIB
ld a,(hl)
and _.in+_.out ; Test I/O allowed
ret nz ; Yeap
l18b0:
ld a,_BlkErr
ld (l00d0),a ; Set error
ret
;
; Get structure from input READ(type)
; ENTRY Reg HL points to FIB
;
l18b6:
ld a,(l00d0) ; Get error
or a ; Test previous
ret nz ; Yeap
push hl
call l1a5a ; Get record data
ex de,hl
or a
sbc hl,de ; Test against last record
pop hl
jr nc,l18d6 ; Error
xor a
call l1909 ; Read
l18ca:
ld hl,(l00e2) ; Get back FIB
ld de,FIB.cur
add hl,de
inc (hl) ; Bump record
ret nz
inc hl
inc (hl)
ret
l18d6:
ld a,_IllEOF
ld (l00d0),a ; Set error
ret
;
; Put structure to output WRITE(type)
; ENTRY Reg HL points to FIB
;
l18dc:
ld a,(l00d0) ; Get error
or a ; Test previous
ret nz ; Yeap
push hl
call l1a5a ; Get record data
or a
sbc hl,de ; Test same size
ld a,Rec.Wr
jr nz,l18fc
ld hl,(l00e2)
ld de,FIB.rec
add hl,de ; Point to record
inc (hl) ; Bump it
jr nz,l18fa
inc hl
inc (hl)
jr z,l1902 ; Overflow error
l18fa:
ld a,Rec.New+Rec.Wr
l18fc:
pop hl
call l1909 ; Execute write
jr l18ca
l1902:
pop hl
ld a,_OvflErr
ld (l00d0),a ; Set error
ret
;
; Perform record IO
; ENTRY Reg HL points to FIB record field
; Reg BC holds record length
; (Four on CLOSE, RESET and REWRITE)
; Accu holds code :
; 0 : On RESET and READ
; 1 : On CLOSE and WRITE
; 3 : On WRITE and REWRITE
;
l1909:
ld (l00e9),a ; Save code
ex de,hl
l190d:
ld hl,(l00e2) ; Get FIB
bit rd.bit,(hl) ; Test known buffer
jr z,l1943 ; Nope
res rd.bit,(hl) ; Reset bit
ld a,(l00e9) ; Get mode
bit Rec.Wr.bit,a ; Test write
jr z,l1935 ; Nope, so read
inc hl
inc hl
ld a,(hl) ; Get record pointer
dec hl
dec hl
or a
jr nz,l1935 ; Not empty, so read
ld a,(l00e9) ; Get code
bit Rec.New.bit,a ; Test new
jr nz,l1943 ; Yeap
ld a,b ; Get counter
or a
jr nz,l1943
ld a,c ; Test new
or a
jp m,l1943
l1935:
push bc
push de
ld c,_rndrd
call l19ba ; Read record
pop de
pop bc
;jr nz,$
jr nz,l1991 ; Error return
ld hl,(l00e2) ; Get back FIB
l1943:
ld a,(l00e9) ; Get mode
bit Rec.Wr.bit,a ; Test write allowed
jr z,l194c ; Nope
set wr.bit,(hl) ; Set bit
l194c:
inc hl
inc hl
ld a,(hl) ; Get pointer to buffer
add a,FIB.buff-2
push de
ld e,a
ld d,0
add hl,de ; Get address of buffer
pop de
sub FIB.buff-2 ; Reset pointer
call l199a ; Swap pointer
l195c:
ldi ; move bytes
jp po,l1966 ; Test done
inc a ; Bump pointer
jp p,l195c ; Test done
dec a
l1966:
inc a
call l199a ; Swap back
ld hl,(l00e2) ; Get FIB
inc hl
inc hl
and NOMSB ; Test remainder in buffer
ld (hl),a
jr nz,l198a ; Yeap
push bc
push de
push hl
call l19ae ; Write record
pop hl
pop de
pop bc
jr nz,l1994 ; Error return
push de
ld de,FIB.FCB+_rrn-2
add hl,de ; Point to record
pop de
inc (hl) ; Advance it
jr nz,l198a
inc hl
inc (hl)
l198a:
ld a,b ; Test all done
or c
jp nz,l190d ; Nope
ex de,hl
ret
l1991:
ld a,_IllEOF
db skip.2
l1994:
ld a,_WrErr
ld (l00d0),a ; Set error
ret
;
; Swap record pointers on request
; ENTRY Reg HL and DE hold pointer
; EXIT Register swapped on write selected
;
l199a:
push af
ld a,(l00e9) ; Get mode
bit Rec.Wr.bit,a ; Test selection
jr z,l19a3
ex de,hl ; Swap
l19a3:
pop af
ret
;
; Force record write
; Procedure FLUSH(type)
; ENTRY Reg HL holds FIB
;
l19a5:
ld (l00e2),hl ; Save FIB
call l19ae ; Write if possible
ret z
jr l1994 ; Set error
;
; Write random record if select, set read
;
l19ae:
ld c,_rndwr ; Set OS function
ld hl,(l00e2) ; Get FIB
set rd.bit,(hl) ; Set read bit
bit wr.bit,(hl) ; Test write
ret z ; Nope
res wr.bit,(hl) ; Reset and write
;
; Execute file function
; ENTRY Reg C holds file function
; EXIT Zero flag reflects state of function
; Accu holds BDOS code
;
l19ba:
ld hl,(l00e2) ; Load FIB
push hl
push bc
ld de,FIB.buff
add hl,de ; Point to buffer
ex de,hl
ld c,_setdma
call BDOS ; Set disk buffer
pop bc
pop hl
ld de,FIB.FCB
add hl,de ; Point to FCB
ex de,hl
call BDOS ; Execute OS function
or a ; Build result
ret
;
; Procedure SEEK(file,record)
; ENTRY Reg HL holds record seeked for
; FIB pushed onto stack
;
l19d5:
pop bc
pop de
ld (l00e2),de ; Save FIB
push bc
push hl
call l1a5a ; Get FIB data
pop de
or a
sbc hl,de ; Test record less size
jr c,l1a26 ; Error if so
ld hl,(l00e2) ; Get FIB
ld bc,FIB.reclen ; Point to length of record
add hl,bc
ld c,(hl) ; Get record
inc hl
ld b,(hl)
inc hl
ld (hl),e ; Save record number
inc hl
ld (hl),d
call l1a2c ; Multiply it
ld bc,FixRecLen
add hl,bc ; Adjust for header
jr nc,l19fe
inc de
l19fe:
ld a,l
and NOMSB ; Get record pointer
add hl,hl ; * 2
ex de,hl
adc hl,hl
ex de,hl
ld d,e ; / 256
ld e,h
ld hl,(l00e2) ; Get FIB
inc hl
inc hl
ld (hl),a ; Store record pointer
ld bc,FIB.FCB+_rrn-2
add hl,bc ; Point to random record
ld c,(hl) ; Get it
inc hl
ld b,(hl)
ex de,hl
or a
sbc hl,bc ; Test record already set
add hl,bc
ret z ; Yeap
push de
push hl
call l19ae ; Write record
pop de
pop hl
ld (hl),d ; Set current record
dec hl
ld (hl),e
ret
l1a26:
ld a,_SeekEOF
ld (l00d0),a ; Set error
ret
;
; Multiply record number by record length
; ENTRY Reg BC holds length of record
; Reg DE holds number of record
; EXIT Reg HL holds the product of both
;
l1a2c:
push de ; Copy number
exx
pop hl ; Get copy
exx
ld hl,0 ; Init result
ld d,h
ld e,l
ld a,16 ; Set bit length
l1a37:
add hl,hl ; Shift result
ex de,hl
adc hl,hl ; Treat as 32 bit number
ex de,hl
exx
add hl,hl ; Shift number
exx
jr nc,l1a45
add hl,bc ; Fix for carry
jr nc,l1a45
inc de
l1a45:
dec a
jr nz,l1a37 ; Loop on
ret
;
; Function EOF(device):boolean (untyped)
;
l1a49::
call l1a5d ; Get size of file
or a
sbc hl,de ; Test end
ld hl,FALSE
ret nz ; Return FALSE if not
inc hl ; Fix for TRUE
ret
;
; Get record position of file
; Function FILEPOS(file):integer
; ENTRY Reg HL holds FIB
; EXIT Reg HL holds current record
;
l1a55:
call l1a5d ; Get size of file
ex de,hl ; Into integer result
ret
;
; Get record data of file
; EXIT Reg HL holds size of file
; Reg DE holds current record
; Reg BC holds record length
;
l1a5a:
ld hl,(l00e2) ; Load FIB
;
; Get size of file
; Function FILESIZE(file):integer
; ENTRY Reg HL holds FIB
; EXIT Reg HL holds size of file in terms of records
; Reg DE holds current record
; Reg BC holds length of record
;
l1a5d:
ld de,FIB.rec
add hl,de ; Point to records
ld e,(hl) ; Get number of records
inc hl
ld d,(hl)
inc hl
push de
ld c,(hl) ; Get record length
inc hl
ld b,(hl)
inc hl
ld e,(hl) ; Get current record
inc hl
ld d,(hl)
pop hl
ret
;
; Prepare untyped files
; Procedure REWRITE(un_typed_file)
; ENTRY Reg HL points to FIB
;
l1a6f:
db skip
;
; Procedure RESET(un_typed_file)
;
l1a70:
xor a
ld (l00e8),a ; Save mode (0=RESET)
call l1ab0 ; Close open file
ld a,(l00d0)
or a ; Test error
ret nz ; Exit if so
call l1430 ; Fix FIB
ld a,(l00d0)
or a ; Test error
ret nz ; Exit if so
ld hl,(l00e2) ; Get FIB
ld (hl),_.in+_.out ; Set flag
push hl
ld de,FIB.FCB
add hl,de ; Point to FCB
ex de,hl
ld c,_filsiz
call BDOS ; Get size of file
pop hl
ld de,FIB.FCB+_rrn
add hl,de ; Point to size
xor a
ld c,(hl) ; Get size
ld (hl),a ; Reset size
inc hl
ld b,(hl)
ld (hl),a
ld de,FIB.rec-FIB.FCB-_rrn-1
add hl,de ; Point to recird number
ld (hl),c ; Set it
inc hl
ld (hl),b
inc hl
ld (hl),RecLng ; Set standard record
inc hl
ld (hl),a
inc hl
ld (hl),a ; Init current record
inc hl
ld (hl),a
ret
;
; Close untyped file
; ENTRY Reg HL holds FIB
;
; Procedure CLOSE(un_typed_file)
;
l1ab0:
ld (l00e2),hl ; Save FIB
ld a,(hl) ; Get mode
and _.in+_.out ; Test access
ret z ; Nope
jp l1481 ; Close it
;
; Write block to untyped file
; Procedure BLOCKWRITE(file,buffer,count)
; ENTRY Reg HL holds number of records to be written
; On stack FIB and buffer
;
l1aba:
ld a,_rndwr ; Set function code
jr l1ac0
;
; Read block from untyped file
; Procedure BLOCKREAD(file,buffer,count)
; ENTRY Reg HL holds number of records to be read
; On stack FIB and buffer
;
l1abe:
ld a,_rndrd ; Set function code
l1ac0:
ld b,h ; Copy count
ld c,l
ld hl,l00f0 ; Point to scratch
ld (l00e6),hl ; Set for record
pop ix
pop de ; Get buffer
pop hl ; Get FIB
push ix
push bc
call l1afd ; Execute block I/O
pop bc
ld a,(l00d0)
or a ; Test error
ret nz ; Exit if so
ld hl,(l00f0)
sbc hl,bc ; Test all records processed
ret z ; Yeap
ld a,(l00e9) ; Get file function
cp _rndrd ; Test read
ld a,_IllEOF
jr z,l1ae9
ld a,_WrErr
l1ae9:
ld (l00d0),a ; Set error code accordingly
ret
;
; Write block to untyped file
; Procedure BLOCKWRITE(file,buffer,count,result)
; ENTRY Reg HL points to result
; On stack FIB, buffer and number of records
;
l1aed:
ld a,_rndwr ; Set function
jr l1af3
;
; Read block from untyped file
; Procedure BLOCKREAD(file,buffer,count,result)
; ENTRY Reg HL points to result
; On stack FIB, buffer and number of records
;
l1af1:
ld a,_rndrd ; Set function
l1af3:
ld (l00e6),hl ; Save result pointer
pop ix
pop bc ; Get count
pop de ; Get buffer
pop hl ; Get FIB
push ix
;
; Perform block IO
; ENTRY Accu holds file function
; Reg HL holds FIB
; Reg DE holds buffer
;
l1afd:
ld (l00e9),a ; Save function
ld (l00e2),hl ; Save FIB
ld a,(hl) ; Get mode
and _.in+_.out ; Test IO allowed
jp z,l18b0 ; Nope
ld hl,(l00e6) ; Get record address
xor a
ld (hl),a ; Clear record
inc hl
ld (hl),a
l1b10:
ld a,b
or c ; Test all done
jr z,l1b4d ; Yeap
push bc
push de
ld c,_setdma
call BDOS ; Set disk buffer
ld hl,(l00e2) ; Get back FIB
ld de,FIB.FCB
add hl,de ; Point to FCB
ex de,hl
ld a,(l00e9) ; Get file function
ld c,a
call BDOS ; Execute I/O
pop de
pop bc
or a ; Test result
jr nz,l1b4d ; Not good
push de
ld hl,(l00e2) ; Get FIB again
ld de,FIB.FCB+_rrn
add hl,de ; Point to record
inc (hl) ; Advance record
jr nz,l1b3c
inc hl
inc (hl)
l1b3c:
pop de
ld hl,RecLng
add hl,de ; Advance buffer
ex de,hl
ld hl,(l00e6)
inc (hl) ; Advance record count
jr nz,l1b4a
inc hl
inc (hl)
l1b4a:
dec bc ; Count down requested length
jr l1b10
l1b4d:
ld hl,(l00e2) ; Get FIB
ld de,FIB.FCB+_rrn
add hl,de ; Point to last record
ld c,(hl)
inc hl
ld b,(hl)
ld de,FIB.cur-FIB.FCB-_rrn-1
add hl,de ; Point to FIB record
ld (hl),c ; Save record number
inc hl
ld (hl),b
ld de,-FIB.rec
add hl,de ; Point to record
ld d,(hl)
dec hl
ld e,(hl)
ex de,hl
or a
sbc hl,bc ; Test against last record
ret nc
ex de,hl
ld (hl),c ; Save new max record
inc hl
ld (hl),b
ret
;
; Procedure SEEK(file,record)
; ENTRY Reg HL holds record seeked for
; FIB pushed onto stack
;
l1b6f:
pop bc
pop de
ld (l00e2),de ; Save FIB
push bc
push hl
call l1a5a ; Get record data
pop de
or a
sbc hl,de ; Test position
jp c,l1a26 ; Error if overflow
ld hl,(l00e2) ; Get FIB
ld bc,FIB.cur
add hl,bc
ld (hl),e ; Save new position
inc hl
ld (hl),d
ld bc,FIB.FCB+_rrn-FIB.cur-1
add hl,bc
ld (hl),e ; Save in FCB, too
inc hl
ld (hl),d
ret
;
; Delete file
; Procedure ERASE(file)
; ENTRY Reg HL holds FIB
;
l1b93:
call l1c4c ; Check legal FIB
ret nz ; Nope
ld de,FIB.FCB
add hl,de ; Point to FCB
ex de,hl
ld c,_delete
call BDOS ; Delete file
inc a
ret nz
jr l1be4 ; Set error if unknown
;
; Rename file
; Procedure RENAME(file,newname)
; ENTRY FIB and name on stack
;
l1ba5:
pop iy
ld hl,(l00d2) ; Get top of memory for buffer
ld b,16 ; Set max
call l05e2 ; Assign string from stack
xor a
ld (de),a
pop hl ; Load FIB
push iy
call l1c4c ; Check legal FIB
ret nz ; Nope
push hl
call l03f2 ; Parse file
pop hl
push hl
ld de,FIB.FCB+DIRlen
add hl,de ; Point to 2nd FCB
ex de,hl
ld hl,l005c
ld bc,Fdrv+Fname+Fext
ldir ; move new name
pop hl
ld de,FIB.FCB
add hl,de ; Point to FCB
push hl
ex de,hl
ld c,_rename
call BDOS ; Rename
pop de
inc a ; Test success
jr z,l1be4 ; Nope
ld hl,l005c
ld bc,FCBlen
ldir ; Unpack new file
ret
l1be4:
ld a,_NoFile ; Set error
l1be6:
ld (l00d0),a
ret
;
; Perform executing new programs
; Procedure EXECUTE(File)
; ENTRY Reg HL points to FIB
;
l1bea:
db skip
;
; Procedure CHAIN(File)
;
l1beb:
xor a
ld (l00e8),a ; Set mode (0=CHAIN)
call l1c4c ; Test device ok
ret nz ; Nope
ld a,(l00d8) ; Test run mode
or a
ld a,_DirErr
jr z,l1be6 ; Must *NOT* be direct mode
ld hl,(l00e2) ; Get FIB
ld de,FIB.FCB
add hl,de ; Point to FCB
ld de,l005c
ld bc,FCBlen
ldir ; move to standard FCB
ld de,l005c
ld c,_open
call BDOS ; Open file ;WHERE IS CLOSE???
inc a
jr z,l1be4 ; File not found
ld hl,l1c33 ; Point to loader
ld de,l00b0
ld bc,l0019
ldir ; move loader to temporry location
ld de,0x0100;TPA ; Init loader address
ld a,(l00e8) ; Test mode
or a
jr nz,l1c2d
ld de,(progstartaddr);(TPA+1) ; Change address for CHAIN
l1c2d:
ld sp,0x0100;TPA ; Get local stack
jp l00b0 ; Go load
;
; ############### Start of loader ###############
;
; Loader will be moved into 00B0H temporary location
;
l1c33:
disp l00b0
_l1c33:
push de
ld c,_setdma
call BDOS ; Set disk buffer
ld de,l005c
ld c,_rdseq
call BDOS ; Read a code record
pop de
ld hl,RecLng
add hl,de ; Bump address
ex de,hl
;or a ; Test more
;jr z,_l1c33
cp 128 ;EOF in NedoOS
jr nz,_l1c33 ; Read was successfull
;jr $
jr 0x0100;TPA ; Start after loading
l0019 equ $-_l1c33
ent
;
; ################ End of loader ################
;
; Check legal device for file operation
; ENTRY Reg HL points to FIB
; EXIT Zero flag set if legal device
; If illegal, IOerror 20H will be set
;
l1c4c:
ld (l00e2),hl ; Save FIB
ld a,(hl) ; Get flag
and FIBtype ; Mask it
ret z ; 0000 menas file
ld a,_IllIO
ld (l00d0),a ; Set error
ret
;
; Load overlay file
; ENTRY Reg HL holds record procedure starts with
; Reg DE holds number of records to be read
;
; Overlay call follows:
; 2 Bytes hold last sector read
; 11 Bytes NAME.EXT of file
; n*128 Bytes record(s)
;
l1c59:
ld (l00e6),hl ; Save record
ld (l00e8),de ; Save record count
ex de,hl
pop hl
ld (l00e2),hl ; Save caller
ld c,(hl) ; Fetch last sector
ld (hl),e ; Set new one
inc hl
ld b,(hl)
ld (hl),d
ex de,hl ; Compare bew:old
or a
sbc hl,bc
jr z,l1cca ; Overlay already in memory
ex de,hl
inc hl
ld de,l005c
ld a,(l00dc) ; Get overlay drive
ld (de),a ; Store into standard FCB
inc de
ld bc,Fname+Fext
ldir ; move name to standard FCB
ld b,FCBlen-_ex
xor a
l1c82:
ld (de),a ; Clear remainder of FCB
inc de
djnz l1c82
push hl ; Save address of buffer
ld de,l005c
ld c,_open
call BDOS ; Open file
pop de ; Get back buffer address
inc a ; Test success
jr z,l1cd2 ; Nope
ld hl,(l00e6) ; Get start record
ld (l005c+_rrn),hl ; Set for random record
ld bc,(l00e8) ; Get record count
l1c9d:
push bc
push de
ld c,_setdma
call BDOS ; Set disk buffer
ld de,l005c
ld c,_rndrd
call BDOS ; Read from file
pop de
pop bc
or a ; Verify no error
jr nz,l1cd2 ; Error
ld hl,(l005c+_rrn)
inc hl ; Bump record
ld (l005c+_rrn),hl
ld hl,RecLng
add hl,de ; Get next address
ex de,hl
dec bc
ld a,b ; Test done
or c
jr nz,l1c9d ; Nope
ld de,l005c
ld c,_close
call BDOS ; Close file
l1cca:
ld hl,(l00e2) ; Get caller
ld de,2+Fname+Fext
add hl,de ; Skip header
jp (hl) ; Enter overlay
l1cd2:
ld ix,(l00e2) ; Get caller's PC
ld a,_OVLerr
jp l2029 ; Abort
;
; Procedure OVRDRIVE(drive)
; ENTRY Reg HL holds drive (1=A, 2=B, etc)
;
l1cdb:
call l04c8 ; Get byte from integer
cp 'P'-'@'+1 ; Test max
ret nc ; Exit on range error
ld (l00dc),a ; Set overlay drive
ret
;
; Procedure NEW(pointer)
; Procedure GETMEM(pointer,space)
; ENTRY Reg HL holds space required
; Variable pointer on stack
;
l1ce5:
ld (l00f0),hl ; Save space required
ex de,hl
pop hl
ex (sp),hl
ld (l00f2),hl ; Save address of variable
inc de
inc de
inc de
ld a,e
and -HeapLen ; Get modulo 4
ld e,a
ld hl,l00de
ld (l00f8),hl ; Init pointer
ld ix,(l00de) ; Get pointer to 1st free address
l1cff:
ld l,(ix+HeapLOlen)
ld h,(ix+HeapHIlen)
ld a,l ; Test assignment
or h
jr z,l1d51 ; Maybe free
sbc hl,de ; Test gap
jr nc,l1d1c
ld l,(ix+HeapLOadr); Get next address
ld h,(ix+HeapHIadr)
push hl
ld (l00f8),ix ; Save last address
pop ix ; Copy chain
jr l1cff
l1d1c:
jr nz,l1d28 ; Not same gap length
ld e,(ix+HeapLOadr); Get address if so
ld d,(ix+HeapHIadr)
push ix
jr l1d43 ; Save state
l1d28:
ld c,l ; Copy length
ld b,h
ld l,(ix+HeapLOadr); Get address
ld h,(ix+HeapHIadr)
l1d30:
push ix ; Save pointer
add ix,de ; Advance
ld (ix+HeapLOadr),l; Set start values
ld (ix+HeapHIadr),h
ld (ix+HeapLOlen),c
ld (ix+HeapHIlen),b
push ix
pop de ; Copy pointer
l1d43:
ld hl,(l00f8) ; Get pointer
ld (hl),e ; Set new link
inc hl
ld (hl),d
pop de
ld hl,(l00f2)
ld (hl),e ; Set into vriable
inc hl
ld (hl),d
ret
l1d51:
push ix
pop hl
add hl,de
ld (l00c4),hl ; Set new heap pointer
ld hl,(l00f0) ; Get space
ld bc,HeapLen
add hl,bc ; Get complete length
push ix
pop bc
add hl,bc
jp c,l1d75 ; Error if overlapping
ld bc,(l00c6) ; Get recursion pointer
sbc hl,bc ; Test against it
ld bc,0
ld hl,0
jp c,l1d30
;
; Heap error
;
l1d75:
ld a,_HeapErr
jp l2027 ; Set error
;
; Procedure DISPOSE(pointer)
; Procedure FREEMEM(pointer,space)
; ENTRY Reg HL holds space
; Variable pointer on stack
;
l1d7a:
ex de,hl ; Save space
pop hl
ex (sp),hl ; Get variable pointer
ld a,(hl) ; Get dynamic pointer
inc hl
ld h,(hl)
ld l,a
inc de ; Fix space
inc de
inc de
ld a,e
and -HeapLen ; Get modulo 4
ld e,a
ex de,hl
ld (l00f0),hl ; Save length
ld hl,(l00de) ; Load pointer to free heap
push hl
pop ix
or a
sbc hl,de ; Check pointer addresses
jr nc,l1de9
l1d97:
ld l,(ix+HeapLOadr); Get address
ld h,(ix+HeapHIadr)
push hl
or a
sbc hl,de ; Compare
jr nc,l1da7
pop ix
jr l1d97
l1da7:
pop hl
push de
pop iy
ld bc,(l00f0) ; Get length
ld (iy+HeapLOlen),c; Store it
ld (iy+HeapHIlen),b
ld (iy+HeapLOadr),l; Store address, too
ld (iy+HeapHIadr),h
ld (ix+HeapLOadr),e
ld (ix+HeapHIadr),d
push ix
pop hl
ld c,(ix+HeapLOlen); Get old length
ld b,(ix+HeapHIlen)
call l1e04 ; Compare
jr z,l1dd8 ; Match
ld e,(ix+HeapLOadr); Get address
ld d,(ix+HeapHIadr)
push de
pop ix
l1dd8:
push ix
pop hl
ld c,(ix+HeapLOlen)
ld b,(ix+HeapHIlen)
ld e,(ix+HeapLOadr)
ld d,(ix+HeapHIadr)
jr l1e04
l1de9:
ld hl,(l00de) ; Get pointer to free heap
ld (l00de),de ; Set new address
push de
pop ix
ld (ix+HeapLOadr),l; Set chain
ld (ix+HeapHIadr),h
ld bc,(l00f0) ; Get length
ld (ix+HeapLOlen),c
ld (ix+HeapHIlen),b
ex de,hl
l1e04:
add hl,bc ; Bump next
or a
sbc hl,de ; Test same
ret nz
push de
pop iy ; Copy pointer
ld hl,(l00c4) ; Get heap pointer
or a
sbc hl,de ; Test top found
jr z,l1e2f
ld a,(iy+HeapLOadr); Unpack address
ld (ix+HeapLOadr),a
ld a,(iy+HeapHIadr)
ld (ix+HeapHIadr),a
ld l,(iy+HeapLOlen)
ld h,(iy+HeapHIlen)
add hl,bc
ld (ix+HeapLOlen),l; Unpack new length
ld (ix+HeapHIlen),h
xor a
ret
l1e2f:
push ix
pop hl
ld (l00c4),hl ; Set new top heap pointer
ld b,HeapLen
l1e37:
ld (hl),0 ; Clear top
inc hl
djnz l1e37
ret
;
; Get free memory
; Function MEMAVAIL:integer
; EXIT Reg HL holds free memory in bytes
;
l1e3d:
call l1e4b ; Get memory
ld hl,(l00f4) ; Get available memory
ret
;
; Get max free memory
; Function MAXAVAIL:integer
; EXIT Reg HL holds free memory in bytes
;
l1e44:
call l1e4b ; Get memory
ld hl,(l00f6) ; Get max memory
ret
;
; Get free memory
;
l1e4b:
ld hl,0
ld (l00f4),hl ; Init available memory
ld (l00f6),hl
ld ix,(l00de) ; Get pointer to free heap
l1e58:
ld c,(ix+HeapLOlen)
ld b,(ix+HeapHIlen)
ld a,c
or b ; Test end of chain
jr z,l1e80
ld hl,(l00f4) ; Get old available memory
add hl,bc ; Add length
ld (l00f4),hl
ld hl,(l00f6) ; Get max
or a
sbc hl,bc ; Check it
jr nc,l1e75
ld (l00f6),bc ; Set new max
l1e75:
ld l,(ix+HeapLOadr); Get chain
ld h,(ix+HeapHIadr)
push hl
pop ix
jr l1e58 ; Loop
l1e80:
ld hl,(l00c6) ; Get recursion pointer
ld bc,-5
add hl,bc ; Build free address
ld de,(l00c4) ; Get heap pointer
or a
sbc hl,de ; Test any free
ret c
ex de,hl
ld hl,(l00f4) ; Get available memory
add hl,de ; Add gap
ld (l00f4),hl
ld hl,(l00f6) ; Get max
or a
sbc hl,de ; Subtract
ret nc
ld (l00f6),de ; Set new
ret
;
; Mark heap
; Procedure MARK(pointer)
; ENTRY Reg HL holds pointer
;
l1ea3:
ld de,(l00c4) ; Get heap pointer
ld (hl),e ; Store into variable
inc hl
ld (hl),d
ret
;
; Release heap
; Procedure RELEASE(pointer)
; ENTRY Reg HL holds pointer
;
l1eab:
ld e,(hl) ; Load heap from variable
inc hl
ld d,(hl)
ex de,hl
;
; Init heap
; ENTRY Reg HL points to 1st free location
;
l1eaf:
ld (l00c4),hl ; Set heap pointer
ld (l00de),hl
ld b,HeapLen
l1eb7:
ld (hl),0 ; Clear 4 bytes
inc hl
djnz l1eb7
ret
;
; Convert number to string
; Procedure STR(real,string)
; ENTRY Real pushed onto stack with formatting data
; Reg HL points to string
; Reg B holds length of string
;
l1ebd:
db skip
;
; Procedure STR(integer,string)
; ENTRY Integer pushed onto stack with digit count
; Reg HL points to string
; Reg B holds length of string
;
l1ebe:
xor a
ld c,a ; Save mode
ld (l00e8),hl ; Save string
xor a
ld (hl),a ; Init to empty string
ld (l00d0),a ; Clear error
ld a,b
ld (l00ea),a ; Save max length
ld hl,(l00e2)
ld (l00ed),hl ; Save current FIB
ld hl,l1f46
ld (l00e2),hl ; Set RAM device
pop hl ; Get caller
ld (l00e4),hl
pop hl ; Get digit count/comma places
inc c ; Test mode
dec c
jr nz,l1ee6
call l1726 ; Get integer string
jr l1ee9
l1ee6:
call l1779 ; Get real string
l1ee9:
ld hl,(l00ed)
ld (l00e2),hl ; Restore FIB
ld hl,(l00e4) ; Get caller
jp (hl)
;
; Convert string to number
; Procedure VAL(string,real,result)
; ENTRY String and address of real pushed onto stack
; Reg HL points to result
;
l1ef3:
db skip
;
; Procedure VAL(string,integer,result)
; ENTRY String and address of integer pushed onto stack
; Reg HL points to result
;
l1ef4:
xor a
ld (l00ec),a ; Save mode
ld (l00e8),hl ; Save result
ld hl,(l00e2)
ld (l00ed),hl ; Save current FIB
ld hl,l1f46
ld (l00e2),hl ; Set RAM FIB
pop hl
ld (l00e4),hl ; Save caller
pop hl
ld (l00ea),hl ; Save integer/real address
ld hl,l005c
ld b,1eh
call l05e2 ; Assign string from stack
xor a
ld (de),a
ld hl,(l00ea) ; Get back variable pointer
ld a,(l00ec) ; Test mode
or a
jr nz,l1f27
call l164e ; Convert to integer
jr l1f2a
l1f27:
call l1672 ; Convert to real
l1f2a:
ld hl,l00d0
ld a,(hl) ; Get IOResult
ld (hl),0 ; Clear
or a
ld h,a
ld l,a
jr z,l1f3d ; Test error
push ix
pop hl ; Get last address
ld de,l005c
sbc hl,de ; Get relative string error
l1f3d:
ex de,hl
ld hl,(l00e8) ; Point to result
ld (hl),e ; Save error or success
inc hl
ld (hl),d
jr l1ee9 ; Exit
;
; FIB for RAM storage
;
l1f46:
db _.in+_.out+RAMdevice
db 0
;
; Procedure RANDOMIZE
;
l1f48:
ld a,r ; Get refresh counter
ld (l00c8+3),a ; Set for random
ret
;
; Fill variable with constant value
; Procedure FILLCHAR(var,num,val)
; ENTRY Reg HL holds value
; Count and variable address pushed onto stack
;
l1f4e:
ex de,hl
pop ix
pop bc ; Get count
pop hl ; Get address
ld a,b
or c ; Test count zero
jr z,l1f62 ; Skip if so
ld (hl),e ; Store value
dec bc ; Fix count
ld a,b
or c ; Test count one
jr z,l1f62 ; Skip if so
ld d,h ; Copy address
ld e,l
inc de
l1f60:
ldir ; move value for fill
l1f62:
jp (ix)
;
; move variable to another
; Procedure MOVE(var1,var2,len)
; ENTRY Reg HL holds count
; Variables pushed onto stack
;
l1f64:
ld b,h ; Copy count
ld c,l
pop ix
pop de ; Get 2nd var
pop hl ; Get 1st one
ld a,b
or c
jr z,l1f62 ; Test zero length
sbc hl,de
add hl,de ; Test overlapping
jr nc,l1f60 ; move up if so
dec bc
add hl,bc ; Point to top
ex de,hl
add hl,bc
ex de,hl
inc bc
lddr ; move down
jp (ix)
;
; Get string from OS command line
; Function PARAMSTR(num):any_string
; ENTRY Reg HL holds number of substring
; EXIT Selected string on stack
;
l1f7d:
ld d,l ; Get number
inc d
dec d
jr z,l1f85 ; Skip if none
call l1f9d
l1f85:
pop ix ; Free stack
ld c,a ; Get length of string
ld b,0
cpl
ld l,a
ld h,-1
add hl,sp ; Build address on stack
ld sp,hl
ld (hl),c ; Store length
inc hl
ex de,hl
inc c ; Test any selected
dec c
jr z,l1f99 ; Nope
ldir ; Unpack it
l1f99:
jp (ix)
;
; Get number of parameters in OS command line
; Function PARAMCOUNT:integer;
;
l1f9b:
ld d,0 ; Set dummy selection
;
; Get parameters of OS command line
; ENTRY Reg D holds number of substring selected
; EXIT Reg DE points to selected substring
; Accu holds length of substring
; Reg HL holds index of substring
;
l1f9d:
ld hl,l0080 ; Init pointer
;ld a,MaxParams ; Test parameter count
;ld b,(hl)
;cp b
;jr nc,l1fa8
ld b,MaxParams ; Truncate to max
;l1fa8:
;inc hl
ld c,0 ; Init count
l1fab:
inc b
dec b ; Test end
jr z,l1fbc ; Yeap
ld a,(hl)
cp ' '
jr z,l1fb8 ; Skip white spaces
cp tab
jr nz,l1fbc
l1fb8:
inc hl
dec b
jr l1fab
l1fbc:
ld e,l ; Save pointer
l1fbd:
inc b
dec b ; Test done
jr z,l1fce ; Yeap
ld a,(hl)
cp ' '
jr z,l1fce ; Find white space
cp tab
jr z,l1fce
inc hl
dec b
jr l1fbd
l1fce:
ld a,l
sub e ; Test same position
jr z,l1fd6
inc c ; Count up index
dec d ; Test found
jr nz,l1fab
l1fd6:
ld l,c ; Get selected or last index
ld h,0 ; Make pointer relative
ld d,h
ret
;
; Procedure GOTOXY(x_val,y_val)
; ENTRY Reg HL holds y_val
; x_val on stack
;
l1fdb:
pop de
pop bc
push de
dec l ; Fix row
ld h,c
dec h ; Fix column
jp l02a2 ; Position cursor
;
; Function UPCASE(char):char
; ENTRY Reg HL holds character
; EXIT Reg HL holds UPPER case character
;
l1fe4:
ld a,l ; Get into accu
call doupcase ; Convert to upper case
ld l,a ; Bring it back
ret
;
; Execute BIOS function
; Procedures BIOS(func)
; BIOS(func,param)
; Functions BIOS(func):integer
; BIOS(func,param):integer
; BIOSHL(func,param):integer
; ENTRY Reg DE holds BIOS function
; Reg BC holds optional parameter
; EXIT Accu and reg HL hold result
;
l1fea:
ld hl,(OS+1) ; Get base address
add hl,de ; Make executable
add hl,de
add hl,de
jp (hl) ; Execute
;
; Get IO result
; Function IORESULT:integer
; EXIT Reg HL holds result
;
l1ff1:
ld hl,l00d0 ; Point to result
ld a,(hl) ; Get it
ld (hl),0 ; Clear after request
ld l,a
ld h,0
ret
;
; Control C entry - entered via RST after each statement
;
l1ffb:
call l0316 ; Test key pressed
ld a,h
or l
ret z ; Nope
ld a,(l00dd) ; Get $C mode
push af
xor a
ld (l00dd),a ; Set $C-
call l0320 ; Read from keyboard
pop af
ld (l00dd),a ; Reset $C mode
ld a,l
cp CtrlC ; Test Control-C
ret nz ; Nope
pop ix ; Fetch PC
l2016:
ld de,_CBRK ; Set CtrlC error
jr l202c ; Enter error routine
;
; Check IOResult after IO operation
; (May be turned off by {$I-})
;
l201b:
ld a,(l00d0) ; Test any error
or a
ret z ; Nope
pop ix ; Get caller
ld e,a ; Save code
ld d,_IO ; Set mode
jr l202c
l2027:
pop ix ; Get caller
l2029:
ld e,a ; Save code
ld d,_RT ; Set mode
;
; Common error handler
; ENTRY Reg D holds error mode
; Reg E holds error code
; Reg IX holds callers address
;
l202c:
;jr $
push de
call l037a ; Reset some things
pop de
xor a
ld (l00dd),a ; Set $C- mode
ld hl,(l00ce) ; Get current PC
ld a,h ; Check zero
or l
push ix
pop hl
ld bc,(l00cc) ; Get base PC
sbc hl,bc ; Subtract for base
ld bc,TPhead
add hl,bc ; Fix for 0100h start
ld (l00ce),hl ; Set current PC
or a ; Look for previous zero
jr nz,l2054 ; Nope
push de
push de
push hl
call l00d9 ; Do restart
pop de
l2054:
ld a,d
or a ; Test user break
jr nz,l206c
call l0200 ; Tell control C
db '^C'
db cr,lf
db 'User break'
db null
jr l2097
l206c:
dec a ; Test I/O error
jr nz,l207a
call l0200 ; Tell I/O error
db cr,lf
db 'I/O'
db null
jr l2088
l207a:
call l0200 ; Tell run time error
db cr,lf
db 'Run-time'
db null
l2088:
call l0200
db ' error '
db null
ld a,e
call l04b4 ; Print error byte
l2097:
call l0200 ; Tell current PC
db ', PC='
db null
ld hl,(l00ce) ; Get current PC
call l04af ; Print hex
jr l20bd ; Abort
;
; Process memory error
;
l20a8:
call l0200 ; Tell error
db 'Not enough memory'
db null
;
; Error detected, tell abort and break
;
l20bd:
call l0200 ; Tell it
db cr,lf
db 'Program aborted'
db cr,lf,null
;
; Halt program
;
l20d4:
ld a,(l00d8) ; Test run mode
or a
jp z,l278e ; Enter TP menue
if TERM == 0
YIELDGETKEYLOOP
endif
jp OS ; Exit .COM file
;
; Restart after error
;
l20de:
pop hl ; Get PC
pop de ; Clean stack
pop de
jp (hl) ; Restart
;
;end of runtime library
; %%%%%%%%%%%%%%%%%%%
; %%% MENUE ENTRY %%%
; %%%%%%%%%%%%%%%%%%%
;
; Enter here thru cold start
;
l20e2:
jp l215e ; Go to initializer
;
; Set up environment
;
l20e5:
ld hl,NEDOOSMEMTOP;ld hl,(TPAtop) ; Get top of memory
pop bc
ld sp,hl
push bc
ld de,-StkSpc
add hl,de ; Allow some space
ld (l4548),hl ; Set top of memory
ld hl,l7ad7 ; Get top of used memory
ld bc,256*0+0 ; No break, no interrupt
call l0364 ; Init pointers
call l030a ; Give lead in sequence
call setlowvideo ; Set low video
jp setnormvideo ; Set normal video
;
; Init session and load work file if defined
;
l2104:
call l20e5 ; Set up environment
ld a,(l4542) ; Get compile flag
push af
ld a,(l4541) ; Test error message file read
or a
call nz,l2da4 ; Yeap, read it
call l2d8f ; Init session
call l2d4b ; Test work file defined
call nz,l2506 ; Yeap, load file
ld a,(l44f3) ; Get compiler mode
dec a
jr z,l2125 ; Compile to memory
pop af
ld (l4542),a ; Reset compile flag
l2125:
jp l223b ; Enter menue
;
; Give delimiter line
;
l2128:
call l0200
db '---------------------------------------'
db cr,lf,null
ret
;
; Give B blanks
;
l2156:
call l0200 ; Just do it
db ' ',null
djnz l2156
ret
;
; Come here after cold start
;
l215e:
;OS_HIDEFROMPARENT
;ld e,6 ;textmode
;OS_SETGFX
ld hl,NEDOOSMEMTOP;ld hl,(TPAtop) ; Fetch top of memory
ld bc,-MEMGAP
add hl,bc
ld (l44f6),hl ; Set for available memory
ld c,_retdsk
call BDOS ; Get logged disk (return L=A=current drive)
inc a
ld (l44f8),a ; Save it
call l20e5 ; Set up environment
call l023e ; Clear screen
call l2128 ; Give delimiter
call l0200 ; Tell what we are
l217d:
db 'TURBO'
db ' Pascal system',null
call setlowvideo ; Set low video
ld b,7
call l2156 ; Give blanks
call l0200 ; Tell version
;
db 'Version 3.00A'
db cr,lf,null
ld b,27
call l2156 ; Give blanks
call l0200 ; Tell type and copyright
;
db 'CP/M-80, Z80'
db cr,lf,cr,lf
db 'Copyright (C) 1983,84,85 '
db null
call setnormvideo ; Set normal video
call l0200
;
db 'BORLAND Inc.'
db cr,lf,null
call l2128 ; Give delimiter
call l0200 ; Tell type of terminal
;
db lf
db 'Terminal: '
db null
ld hl,l0153
call l01d0 ; Give string
call l0200 ; Ask for error messages to be included
;
db cr,lf,lf,lf,lf
db 'Include error messages'
db null
call l2d21 ; Ask for YES or NO
ld (l4541),a ; Save result
call nz,l2da4 ; YES, read it
call l2d8f ; Init session
call l227a ; Display menue
;
; %%%%%%%%%%%%%%%%%%%&&&&&
; %%% TURBO WARM START %%%
; %%%%%%%%%%%%%%%%%%%&&&&&
;
l223b:
nop:ld sp,NEDOOSMEMTOP;ld sp,(TPAtop) ; Get top of stack
ld hl,l223b
push hl ; Set return address
call l01fa ; Indicate input requested
;
db cr+MSB,lf+MSB,'>'+MSB
db null
call readfromkbd ; Read character
call doupcase ; Convert to upper case
call l01e1 ; Give new line
ld hl,l2460
ld de,l2472
ld b,MainLen
call l2450 ; Find command
jr c,l227a ; Display menue if not found
jp (hl) ; Execute command
;
; Input option string
; On exit ^DE points to first non blank
;
l2261:
call l0200 ; Tell what we want
;
db ': '
db null
call l14e8 ; Get line
call l01e1 ; Give new line
ld de,l7ad7 ; Point to start of line
l2270:
ld a,(de) ; Get character
cp eof ; End on end of line
ret z
cp ' ' ; Skip blanks
ret nz
inc de
jr l2270
;
; Display menue
;
l227a:
call l023e ; Clear screen
call l01fa ; Give some info
;
db 'L'+MSB,'ogged drive:',' '+MSB
db null
ld c,_retdsk
call BDOS ; Fetch disk (return L=A=current drive)
add a,'A' ; Make ASCII
call puttoconsole_a ; Put to console
call l01fa ; Tell work file
;
db cr+MSB,lf+MSB,lf+MSB
db 'W'+MSB,'ork file:',' '+MSB
db null
call l3135 ; Type it
call l01fa ; Tell main file
;
db cr+MSB,lf+MSB
db 'M'+MSB,'ain file:',' '+MSB
db null
ld de,l44f9
call l2df8 ; Tell name of file
call l01fa ; Give selection
;
db cr+MSB,lf+MSB,lf+MSB
db 'E'+MSB,'dit '
db 'C'+MSB,'ompile '
db 'R'+MSB,'un '
db 'S'+MSB,'ave'
db cr,lf,lf
db 'e','X'+MSB,'ecute '
db 'D'+MSB,'ir '
db 'Q'+MSB,'uit compiler '
db 'O'+MSB,'ptions'
db cr,lf,lf
db 'Text: '
db null
ld de,(l4544) ; Get start of text
ld hl,(l4546) ; Get end of text
dec hl
call l2338 ; Tell free bytes
ld de,(l4546) ; Get end of text
ld hl,(l4548) ; Get top of available memory
;
; Tell free memory
; ENTRY Reg HL holds end address
; Reg DE holds start address
;
l232e:
call l0200 ; Tell free memory
;
db 'Free: '
db null
;
; Print decimal free bytes and hex addresses
; ENTRY Reg HL holds end address
; Reg DE holds start address
;
l2338:
push hl
push de
or a
sbc hl,de ; Calculate difference
call l2e5c ; Print it
call l0200 ; Tell bytes
;
db ' bytes ('
db null
pop hl ; Get start address
call l04af ; Print hex
ld a,'-'
call puttoconsole_a ; Give delimiter
pop hl ; Get end address
call l04af ; Print hex
ld a,')'
call puttoconsole_a ; Give closure
jp l01e1 ; Give new line
;
; Display arrow if compile selected
;
l2361:
dec a ; Test compile selected
jr nz,l2374 ; Nope, erase display
call l01fa
a2361:
db 'compile -> '
la2361 equ $-a2361
db null
ret
l2374:
ld b,la2361
jp l2156 ; Give blanks
;
; ##############################
; ### MAIN MENUE O - Options ###
; ##############################
;
l2379:
ld hl,l2379
push hl ; Set return address
call l023e ; Clear screen
ld a,(l44f3) ; Get compile mode
call l2361 ; Display arrow
call l01fa
db 'M'+MSB,'emory'
db cr,lf,null
call l2361 ; Display arrow
call l01fa
db 'C'+MSB,'om-file'
db cr,lf,null
call l2361 ; Display arrow
call l01fa
db 'c','H'+MSB,'n-file'
db cr,lf,lf,null
ld a,(l44f3) ; Get compile mode
cp 1 ; Test compile to memory
jr z,l2419 ; Yeap
call l01fa
db 'S'+MSB,'tart address:',' '+MSB
db null
ld hl,(l44f4) ; Get start address
call l04af ; Print hex
call l01fa
db ' (min '
db null
ld hl,l20e2 ; Get start address
call l04af ; Print hex
call l01fa
db ')'
db cr,lf
db 'E'+MSB,'nd address:',' '+MSB
db null
ld hl,(l44f6) ; Get top of available memory
call l04af ; Print hex
call l01fa
db ' (max '
db null
ld hl,NEDOOSMEMTOP;ld hl,(TPAtop)
call l04af ; Print hex
call l01fa
db ')'
db cr,lf,lf,null
l2419:
call l01fa
db 'F'+MSB,'ind run-time error '
db 'Q'+MSB,'uit'
db cr,lf,lf
db '>'+MSB
db null
call readfromkbd ; Read character
call doupcase ; Convert to upper case
call l01e1 ; Give new line
ld hl,l246b
ld de,l2488
ld b,SubLen
call l2450 ; Find command
ret c ; Not found
jp (hl) ; Execute
;
; Find character in list ^HL of length in reg B
; Return address from table ^DE on success
; Set C if not found
;
l2450:
cp (hl) ; Compare
jr z,l245a ; Match
inc hl ; Skip character
inc de ; Skip address
inc de
djnz l2450 ; Go thru table
scf ; Indicate no match
ret
l245a:
ex de,hl
ld e,(hl) ; Fetch address
inc hl
ld d,(hl)
ex de,hl
ret
;
l2460:
db 'LWMECRSXDQO'
MainLen equ $-l2460
l246b:
db 'MCHSEFQ'
SubLen equ $-l246b
l2472:
dw l2cce ; L - Log drive
dw l24c9 ; W - Work file
dw l249a ; M - Main file
dw l2af8 ; E - Edit
dw l2827 ; C - Compile
dw l2a97 ; R - Run
dw l2639 ; S - Save
dw l2b2d ; X - eXecute
dw l2b93 ; D - Directory
dw l2b24 ; Q - Quit
dw l2379 ; O - Options
l2488:
dw l2740 ; M - Compile Memory
dw l2744 ; C - Compile Com-file
dw l2748 ; H - Compile cHn-file
dw l2750 ; S - Start address
dw l276e ; E - End address
dw l279b ; F - Find run-time error
dw l2496 ; Q - Quit
;
; ##########################
; ### SUB MENUE Q - Quit ###
; ##########################
;
l2496:
pop hl
jp l227a ; Display menue
;
; ################################
; ### MAIN MENUE M - Main file ###
; ################################
;
l249a:
call l0200
db cr,lf
db 'Main file name'
db null
call l2d9f ; Init a bit
call l2261 ; Input string
ld a,0
ld (l44f9+Fdrv),a ; Set default drive
ret z
call l2d2a ; Prepare .PAS file
ld de,l44f9 ; Point to main file
ld hl,l005c
ld bc,FCBlen
ldir ; Unpack FCB
ret
;
; ################################
; ### MAIN MENUE W - Work file ###
; ################################
;
l24c9:
ld hl,l25bc
ld (l259d+1),hl ; Redirect error
call l2601 ; Save work file
call l0200
db cr,lf
db 'Work file name'
db null
call l2261 ; Input string
ld a,0
ld (l451d+Fdrv),a ; Set no work file
jr nz,l24f6 ; Got input
call l2d8f ; Init session
jp l223b ; Enter menue
l24f6:
call l2d2a ; Prepare .PAS file
ld de,l451d
ld hl,l005c
ld bc,FCBlen
ldir ; Unpack work file
jr l250c ; Init and load text file
;
; Init a bit and load wirk file into memory
;
l2506:
ld hl,l25b7
ld (l259d+1),hl ; Redirect error
l250c:
ld hl,l25eb
ld (l257c+1),hl ; Set vector for file too big
call l2d8f ; Init session
ld de,l451d
;
; Load text file
; ENTRY Reg DE points to FCB
; EXIT Reg HL points to end of memory
;
l2518:
ld hl,(l4544) ; Get start of text
ld (l4460),hl ; Set block start pointer
ld (l4462),hl ; Set block end pointer
ld (l4450),hl ; Set current memory pointer
ld (l4454),hl ; Set block pointer
ld (l4458),hl ; Set edit pointer
ld (curstartofpage),hl ; Set start of screen
ld bc,(l4548) ; Get top of available memory
call l253b ; Load file
ld (hl),cr ; Close last line
inc hl
ld (l4546),hl ; Set end of text
push hl
ld c,_close
call BDOS_with_FCB1 ;WHY DOESN'T HELP???
pop hl
ret
;
; Load a file
; ENTRY Reg BC holds last available address
; Reg DE holds FCB
; Reg HL holds start address
; EXIT Reg HL holds end address
;
l253b: ;once
push hl
push bc
push de
call l0200 ; Tell action
db cr,lf
db 'Loading '
db null
call l2df8 ; Tell name of file
ld de,l005c
call l26dc ; Clear FCB
pop hl
ld bc,l0024
ldir
ld c,_open
call BDOS_with_FCB1 ; Open file
l2560:
;push af
;ld de,TmpBuff
;ld c,_setdma
;call _BDOS ; Set disk buffer
;pop af
pop bc
pop hl
inc a ; Test file found
jr z,l259d ; Nope
ld (l7b6d),bc ; Set last memory address
l2573:
ld bc,(l7b6d) ; Get last memory address
dec b
or a
sbc hl,bc ; Test room in memory
add hl,bc
l257c:
jp nc,a_DUMMY ; Nope
push hl
ld de,TmpBuff
ld c,_setdma
call _BDOS ; Set disk buffer
ld c,_rdseq
call BDOS_with_FCB1 ; Read record from file
pop hl
;or a ; Test end of file
;ret nz ; Yeap
cp 128
ret z ;EOF in NedoOS
if 1==1
;CP/M has eofs in the end of last sector?
;do this by hand:
or a
jr z,load_noaddeofs ;full sector
;a=128+bytes loaded
neg
;a=128-bytes loaded
ld b,a
ld de,TmpBuff+127 ; Point to buffer end
ld a,eof;-1
ld (de),a
dec de
djnz $-2
load_noaddeofs
endif
ld de,TmpBuff ; Point to buffer
ld b,RecLng
l258d:
;ld (hl),eof ;why there was not?
;inc hl
ld a,(de) ; Scan for EOF
cp -1
;jr z,$
ret z
and NOMSB ;why???
cp eof
;jr z,$
ret z
;dec hl
ld (hl),a ; Unpack data
inc hl
inc de
djnz l258d
jr l2573
l259d:
jp a_DUMMY ; *** REDIRECTED ***
;
; Tell file not found
;
l25a0:
call l0200
db cr,lf
db 'File not found'
db null
l25b4:
jp l2e76 ; Get ESCape
;
; Redirected error if work file read error
;
l25b7:
call l25a0 ; Tell file not found
jr l25ee
;
; Redirected error if work file not found
;
l25bc:
call l0200
db cr,lf
db 'New File'
db null
inc hl
push hl
ld hl,1000
call l021d ; Delay one second
pop hl
ret
;
; Tell file too big
;
l25d4:
ld hl,(l4546) ; Get end of text
call l0200
db cr,lf
db 'File too big'
db null
jr l25b4
;
; Process file too big error
;
l25eb:
call l25d4 ; Tell file too big
l25ee:
xor a
ld (l451d+Fdrv),a ; Indicate no file
jp l223b ; Enter menue
;
; Set extension .BAK
;
l25f5:
ld hl,l005c+Fdrv+Fname
ld (hl),'B'
inc hl
ld (hl),'A'
inc hl
ld (hl),'K'
ret
;
; Save work file on request
;
l2601:
db skip
;
; Save work file on request
;
l2602:
xor a
ex af,af'
ld a,(l447f) ; Test text changed
or a
ret z ; Nope
ex af,af'
or a ; Test request
jr z,l2639 ; Save file if not
call l0200
db 'Workfile '
db null
call l3135 ; Type name of file
call l0200
db ' not saved. Save'
db null
xor a
ld (l447f),a ; Set no text changed
call l2d21 ; Ask for YES or NO
ret z ; NO
;
; ###########################
; ### MAIN MENUE S - Save ###
; ###########################
;
l2639:
call l2d50 ; Get file
ld hl,l451d
push hl
ld de,l005c
ld bc,FCBlen
ldir ; Unpack file
call l0200 ; Tell action
db cr,lf
db 'Saving '
db null
ld de,l005c
call l2df8 ; Tell name of file
ld hl,(l4546) ; Get end of text
dec hl
ld (hl),eof ; Close text
call l25f5 ; Set extension .BAK
call l26d9 ; Clear FCB
ld c,_delete
call _BDOS ; Delete file
ld hl,l005c+Fdrv
ld de,l005c+DIRlen
xor a
ld (l447f),a ; Set no text changed
ld (de),a
inc a
ld (l44f2),a ; Set rename flag
inc de
ld bc,DIRlen-1
ldir ; Unpack name
pop hl
ld de,l005c
ld bc,DIRlen
ldir ; Get new file
ld c,_rename
call BDOS_with_FCB1 ; Rename it
ld hl,(l4544) ; Get start of text
l2692:
push hl
call l26d9 ; Clear FCB
ld c,_make
call _BDOS ; Create new file
pop hl
inc a
jr z,l26ed ; Error creating file
push hl
ld de,TmpBuff
push de
ld c,_setdma
call _BDOS ; Set disk buffer
pop de
pop hl
ld b,RecLng ; Set length of buffer
l26ad:
ld a,(hl) ; Get from memory
inc hl
l26af:
ld (de),a ; Put to buffer
inc de
djnz l26c6
ld b,a ; Save last character
push bc
push hl
ld c,_wrseq
call BDOS_with_FCB1 ; Write record to file
pop hl
pop bc
or a ; Test success
jr nz,l26fe ; Nope, write error
ld de,TmpBuff ; Reset pointer
ld a,b ; Get back last character
ld b,RecLng ; Reset buffer length
l26c6:
cp eof ; Test end of file
jr nz,l26ad ; Nope, go on
ld a,b
sub RecLng ; Test record boundary
ld a,eof
jr nz,l26af ; Nope, write end
ld c,_close ; Close file
;
; Do OS call with standard FCB
;
BDOS_with_FCB1:
ld de,l005c
jp _BDOS ; Do file call
;
; Clear FCB
;
l26d9:
ld de,l005c
;
; Clear FCB ^DE
;
l26dc:
push de
ld hl,_ex
add hl,de ; Point to extent
ld (hl),0 ; Clear it
ld d,h
ld e,l
inc de
ld bc,FCBlen-_ex-1
ldir ; Clear remainder
pop de
ret
;
; Create file error
;
l26ed:
call l0200 ; Tell error
db ' Directory'
db null
jr l2708
;
; Write file error
;
l26fe:
call l0200 ; Tell error
db ' Disk'
db null
l2708:
call l0200
db ' full'
db null
call l2e76 ; Get ESCape
call l26d9 ; Clear FCB
ld c,_delete
call BDOS_with_FCB1 ; Delete file
ld a,(l44f2) ; Test to be renamed
or a
ret z ; Nope
ld (l447f),a ; Set text changed
ld hl,l005c+Fdrv
ld de,l005c+DIRlen
xor a
ld (l44f2),a ; Clear rename flag
ld (de),a ; Clear name entry
inc de
ld bc,DIRlen-1
ldir ; Unpack FCB
call l25f5 ; Set extension .BAK
ld c,_rename
call BDOS_with_FCB1 ; Rename file
jp l223b ; Enter menue
;
; ####################################
; ### SUB MENUE M - Compile Memory ###
; ####################################
;
l2740:
ld a,1 ; Set memory
jr l274a
;
; ######################################
; ### SUB MENUE C - Compile Com-file ###
; ######################################
;
l2744:
ld a,2 ; Set .COM file
jr l274a
;
; ######################################
; ### SUB MENUE H - Compile cHn-file ###
; ######################################
;
l2748:
ld a,3 ; Set .CHN file
l274a:
ld (l44f3),a ; Set compile mode
jp l2d9f ; Force compile
;
; ###################################
; ### SUB MENUE S - Start address ###
; ###################################
;
l2750:
call l0200 ; Tell what we want
db 'Start address'
db null
call l2261 ; Input string
ld hl,l20e2 ; Set default
call nz,l2dd9 ; Get new hex value
ld (l44f4),hl ; Save new start address
ret
;
; #################################
; ### SUB MENUE E - End address ###
; #################################
;
l276e:
call l0200 ; Tell what we want
db 'End address'
db null
call l2261 ; Input string
ld hl,NEDOOSMEMTOP;ld hl,(TPAtop)
ld bc,-MEMGAP
add hl,bc ; Calculate default
call nz,l2dd9 ; Get new hex value
ld (l44f6),hl ; Set top of available memory
ret
;
; Exit memory resident program
;
l278e:
call l20e5 ; Set up environment
ld hl,(l00ce) ; Get current PC
ld a,h
or l
jr nz,l27b1 ; Process error
jp l223b ; Enter menue
;
; #########################################
; ### SUB MENUE F - Find run-time error ###
; #########################################
;
l279b:
call l0200 ; Tell what we want
db 'Enter PC'
db null
call l2261 ; Input string
ret z ; Empty
call l2dd9 ; Get hex PC
ld (l00ce),hl ; Set current PC
l27b1:
call l01e1 ; Give new line
call l27d7 ; Load file into memory
ld hl,0
ld (l7904),hl ; Clear address
ld a,2
ld (CmpTyp),a ; Set searching
call l0200 ; Tell searching
db cr,lf
db 'Searching'
db null
call l2d9f ; Force compile
jp l28d0 ; Go compile
;
; Load file into memory
;
l27d7:
call l2d4b ; Test work file defined
call z,l2d50 ; Get file if not
call l2d7a ; Test main file here
l27e0:
ld hl,l451d
jr nz,l27ea ; Got any file
call l2d50 ; Get file
jr l2808
l27ea:
call l2d7f ; Test same files
jr z,l27e0 ; Yeap, get another one
call l2602 ; Save work file
ld hl,l25eb
ld (l257c+1),hl ; Set vector for file too big
ld hl,l25b7
ld (l259d+1),hl ; Set vector for read error
ld de,l44f9 ; Point to main file
push de
call l2518 ; Load text file ;closes automatically
ld a,1
pop hl
l2808:
ld (l44f1),a ; Re/Set file flag
ld de,FFCB
ld bc,FCBlen
ldir ; Unpack file
xor a
ld (CmpTyp),a ; Set compile to memory
ld hl,NEDOOSMEMTOP;ld hl,(TPAtop)
ld (l790a),hl ; Set end of code
l281d:
ld hl,(l4546) ; Get end of text
ld (hl),eof ; Set end of file
inc hl
ld (l7904),hl ; Set for code start address
ret
;
; ##############################
; ### MAIN MENUE C - Compile ###
; ##############################
;
l2827:
call l27d7 ; Load file into memory
ld a,(l44f3) ; Get compile mode
dec a ; Test compile to memory
jp z,l28aa ; Yeap
dec a ; Test compile to .COM file
push af
jr nz,l283c ; Nope
ld a,'C' ; Load .COM
ld hl,'O'+'M'*256
jr l2841
l283c:
ld a,'C' ; Load .CHN
ld hl,'H'+'N'*256
l2841:
ld (FFCB+Fdrv+Fname),a
ld (FFCB+Fdrv+Fname+1),hl
ld a,1
ld (CmpTyp),a ; Set compile to file
ld hl,(l44f4) ; Get start address of compiler
ld (l7904),hl ; Save
ld hl,(l44f6) ; Get top of available memory
ld (l790a),hl ; Save also
ld de,FFCB
push de
call l26dc ; Clear FCB
ld c,_delete
call _BDOS ; Delete file
pop de
ld c,_make
call _BDOS ; Create new file
inc a ; Test success
jp z,l2a5a ; Nope, error
pop af ; Get back .COM or .CHN
ld hl,0x0100;TPA
jr z,l2877 ; Got .COM
ld hl,(l7904) ; Get code start address
l2877:
ld (CodePC),hl ; Save for current PC
ex de,hl
l287b:
ld hl,(l7904) ; Get code start address
scf
sbc hl,de ; Test end reached
jr c,l28a9 ; Yeap
ld hl,(l7904) ; Get code start address
ld (progstartaddr),hl;(TPA+1),hl ; Set as start address
push de
ld c,_setdma
call _BDOS ; Set disk buffer
ld c,_wrseq
ld de,FFCB
call _BDOS ; Write record to file
pop de
ld hl,l20e2
ld (progstartaddr),hl;(TPA+1),hl ; Reset start address
;or a ; Test I/O success
;jp nz,l2a5a ; Error, disk full
ld hl,RecLng
add hl,de ; Advance buffer
ex de,hl
jr l287b
l28a9:
db skip
l28aa:
xor a
call l0200 ; Tell compiling
;
db cr,lf
db 'Compiling '
db null
ld de,FFCB
or a ; Test compile to memory
jr z,l28cd ; Yeap
call l0200 ; Indicate file
;
db ' --> '
db null
call l2df8 ; Tell name of file
l28cd:
call l2d9f ; Force compile
l28d0:
call l01e1 ; Give new line
call COMPILE ; Compile ;must close output file!!!
ld a,(l7901) ; Get error code
cp _ABORT ; Test abort
jr nz,l28fa ; Nope
call l0200 ; Tell abortion
;
db cr,lf,lf
db 'Compilation aborted'
db null
jp l223b ; Enter menue
l28fa:
call l0200 ; Tell lines
db ' lines'
db cr,lf,lf,null
ld a,(l7901) ; Get error code
or a ; Test any error
jp nz,l2970 ; Yeap
ld a,(CmpTyp) ; Get compile flag
cp 2 ; Test searching
jr nz,l292a ; Nope
call l2a7a ; Tell error position
call l0200
db 'not found'
db cr,lf,null
jp l223b ; Re-enter menue
l292a:
or a ; Test compile to memory
jr z,l293a ; Yeap
ld hl,(l7904) ; Get code start address
ld de,l20e2 ; Get start of application
or a
sbc hl,de
add hl,de
call nz,l232e ; Tell free
l293a:
call l0200
db 'Code: '
db null
ld de,(l7904) ; Get code start address
ld hl,(l7906) ; Get code end address
push hl
dec hl
call l2338 ; Tell free bytes
pop de
ld hl,(DataBeg) ; Get start of data
push hl
call l232e ; Tell free
pop de
inc de
ld hl,(l790a) ; Get end of code
call l0200
db 'Data: '
db null
call l2338 ; Tell free bytes
ld a,-1
ld (l4542),a ; Set no compile
ret
;
; Process compiler error
;
l2970:
cp _DskFull ; Test disk error
jp nc,l2a5a ; Error, disk full
cp _FndRTerr ; Test run-time error found
jr nc,l29ec ; Yeap
ld b,a ; Save error number
call l0200 ; Tell error
db 'Error '
db null
ld h,0
ld l,b ; Build 16 bit number
push bc
call l2e61 ; Print it
pop bc
ld a,(l4541) ; Test error message file read
or a
jr z,l29f8 ; No message file
ld hl,(l429e) ; Get base of message file
l2995:
ld a,(hl) ; Get character
cp eof ; Test end of message
jr z,l29f8 ; Yeap
cp ' ' ; Test control
jr c,l29ad ; Yeap, skip it
sub '0' ; Build number - always two digits
ld c,a
add a,a
add a,a
add a,c
add a,a
inc hl
add a,(hl) ; Combine number
sub '0' ; Fix it
inc hl
cp b ; Test message found
jr z,l29b6 ; Got it
l29ad:
ld a,(hl)
inc hl
cp cr ; Skip to end of line
jr nz,l29ad
inc hl
jr l2995 ; Try next line
l29b6:
call l0200 ; Tell result
;
db ': '
db null
l29bc:
ld a,(hl) ; Get character
cp cr ; Test end of text
jr z,l29f8 ; That's all
cp ' ' ; Test combined message
jr nc,l29e6 ; Nope
ld de,(l429e) ; Get base of message file
l29c9:
ld a,(de) ; Get character
inc de
cp ' ' ; Test printable
jr nc,l29dd ; Yeap, skip it
cp (hl) ; Test extension found
jr nz,l29dd ; Nope
l29d2:
ld a,(de) ; Get from extended part
cp cr ; Test end of line
jr z,l29e9 ; Yeap
call puttoconsole_a ; Put substring to console
inc de
jr l29d2
l29dd:
ld a,(de)
inc de
cp cr ; Skip this line
jr nz,l29dd
inc de
jr l29c9
l29e6:
call puttoconsole_a ; Put to console
l29e9:
inc hl
jr l29bc ; Loop on
;
; Got position of run-time error
;
l29ec:
call l2a7a ; Tell error position
call l0200
db 'found'
db null
l29f8:
xor a
ld (l44f1),a ; Clear file flag
ld a,(IncFlg) ; Test read from memory
or a
jr z,l2a41 ; Nope
ld a,'.'
call puttoconsole_a ; Put to console
call l2602 ; Save work file
ld de,l451d
ld hl,l790f
ld bc,Fdrv+Fname+Fext
ldir ; Copy include file
call l2506 ; Load it
call l0200
db cr,lf
db 'Error found in above include file'
db null
jr l2a51
l2a41:
call l2d7a ; Test main file here
jr z,l2a51 ; Nope
ld de,l451d
ld hl,l44f9 ; Point to main file
ld bc,Fdrv+Fname+Fext
ldir ; Copy file
l2a51:
call l2e76 ; Get ESCape
ld hl,(l790c) ; Fetch current editor address
jp l2afe ; And fall into edit
;
; Process disk full
;
l2a5a:
call l0200 ; Tell error
;
db 'Disk or directory full'
db null
call l2e76 ; Get ESCape
jp l223b ; Enter menue
;
; Tell error position message
;
l2a7a:
call l0200
db 'Run-time error position '
db null
ret
;
; ##########################
; ### MAIN MENUE R - Run ###
; ##########################
;
l2a97:
ld a,(l4542) ; Get compile flag
or a
call z,l2827 ; Compile before run
ld a,(l44f3) ; Get compile flag
dec a
jr z,l2adf ; Got to memory
dec a
ret nz ; Skip chain
call l2b33 ; Load overlay file
ret z ; Not found
call l2d7a ; Test main file here
ld hl,l451d
jr z,l2ab5 ; Nope
ld hl,l44f9 ; Point to main file
l2ab5:
ld de,FFCB
ld bc,Fdrv+Fname+Fext
ldir ; Unpack FCB
ld a,'C' ; Set .COM
ld hl,'O'+'M'*256
ld (FFCB+Fdrv+Fname),a
ld (FFCB+Fdrv+Fname+1),hl
ld de,FFCB
call l26dc ; Clear FCB
push de
ld c,_open
call _BDOS ; Open file ;WHERE IS CLOSE???
pop hl
inc a ; Test file here
jp z,l2104 ; Nope, init session
ld de,l42a0 ; Set dummy parameter
jp l2b7a ; Prepare overlay
l2adf:
ld (l0080),a ; Clear parameter
call l281d ; Set text and code pointer
call l0200 ; Tell running
db cr,lf
db 'Running'
db cr,lf,null
ld hl,(l7904) ; Get code start address
jp (hl) ; And go
;
; ###########################
; ### MAIN MENUE E - Edit ###
; ###########################
;
l2af8:
call l2d50 ; Get file
ld hl,-1 ; Set zero offset
l2afe:
push hl
ld hl,(l00a6+1)
ld (l421e),hl ; Change I/O
ld hl,l4214
ld (l00a6+1),hl
pop hl
jp l2e91 ; Go edit
;
; Control: EXIT EDITOR
;
l2b0f:
call l3e40 ; Sample character
ld hl,(l0169) ; Get screen lines
dec l ; Fix row
ld h,0 ; Set column
call l02a2 ; Position cursor
ld hl,(l421e)
ld (l00a6+1),hl ; Reset I/O
jp l223b
;
; ###########################
; ### MAIN MENUE Q - Quit ###
; ###########################
;
l2b24:
call l2601 ; Save work file
call l0310 ; Give lead out sequence
jp OS ; Exit to OS
;
; ##############################
; ### MAIN MENUE X - eXecute ###
; ##############################
;
l2b2d:
call l2b33 ; Load overlay file
ret z ; Not found
jr l2b5a ; Go
;
; Load overlay file
; Z set says not found
;
l2b33:
call l2601 ; Save work file
ld de,l217d ; Set name
ld a,'O'
ld hl,'V'+'R'*256
call l2e20 ; Prepare .OVR file
ret z
ld de,a_OVLADR-RecLng
l2b45:
ld hl,RecLng
add hl,de ; Build disk buffer address
push hl
ex de,hl
ld c,_setdma
call BDOS ; Set disk buffer
ld c,_rdseq
call BDOS_with_FCB1 ; Read record
pop de
;or a ; Test end of file
;jr z,l2b45 ; Nope, loop on
cp 128 ;EOF in NedoOS
jr nz,l2b45 ; Read was successfull
ret
;
; Execute file
;
l2b5a:
call l0200 ; Tell program
db cr,lf
db 'Program'
db null
call l2261 ; Input string
jp z,l2104 ; No input
ld a,'C'
ld hl,'O'+'M'*256
call l2e20 ; Prepare .COM file
jr z,l2b5a ; Not there, retry
ld hl,l005c
l2b7a:
push de ; Set argument pointer
push hl ; Set FCB
ld a,(l44f8)
push af ; Set logged disk
ld hl,l03ee
push hl ; Set parse file routine
ld hl,l00f4
push hl ; Set available memory
ld hl,l4450
push hl ; Set current memory pointer
ld hl,l2104
push hl ; Set return address
jp a_OVLADR ; Execute overlay
;
; ################################
; ### MAIN MENUE D - Directory ###
; ################################
fcbmask
db 0
db "???????????"
ds FCB_sz-11-1
fcbmask_filename=fcbmask+FCB_FNAME
;
l2b93:
call l0200
db 'Dir mask'
db null
call l2261 ; Input string
call l03ee ; Parse file
ld c,_retdsk
call _BDOS ; Return current disk (return L=A=current drive)
push af
push af
ld a,(l005c) ; Get disk
or a ; Test default
jr z,l2bbb ; Yeap
pop hl ; Clean stack
dec a
ld e,a
push af ; Set new disk
;ld c,_seldsk
;call _BDOS ; Select disk
l2bbb:
pop af
add a,'A' ; Make disk ASCII
ld (l2c8d),a ; Save disk
;ld de,TmpBuff
;ld c,_setdma
;call _BDOS ; Set disk buffer
ld de,0 ; Clear flag and count
ld c,_srcfrs
l2bce:
push de
push bc
ld de,TmpBuff
ld c,_setdma
call _BDOS ; Set disk buffer
pop bc
ld de,fcbmask
call BDOS_with_FCB1 ; Search for file
pop de
ld c,a
inc a ; Test valid one
jr z,l2c29 ; Nope
ld a,c
add a,a ; Result *32
add a,a
add a,a
add a,a
add a,a
ld c,a
ld b,0
ld hl,TmpBuff+_SYS
add hl,bc ; Point to SYS bit
bit 7,(hl) ; Test set
jr nz,l2c25 ; Yeap, skip display
ld d,-1 ; Set any found flag
ld hl,TmpBuff
add hl,bc ; Point to entry
inc e ; Test first file
dec e
jr nz,l2bff ; Nope
ld a,(l0168) ; Get screen columns
dec a
ld e,-1
l2bf8:
inc e
sub Dirlng ; Calculate files per line
jr nc,l2bf8
jr l2c05
l2bff:
call l0200
;
db ': '
db null
l2c05:
ld b,Fname+Fext ; Set length
l2c07:
inc hl
ld a,(hl)
and NOMSB ; Strip off offset
call puttoconsole_a ; Put to console
ld a,b
cp Fext+1 ; Test extension
ld a,' '
call z,puttoconsole_a ; Put blank to console if so
djnz l2c07
dec e ; Test remainder in line
jr z,l2c22 ; Nope
ld a,' '
call puttoconsole_a ; Put to console
jr l2c25
l2c22:
call l01e1 ; Give new line
l2c25:
ld c,_srcnxt ; Search next
jr l2bce
l2c29:
inc e ; Test any file left
dec e
call nz,l01e1 ; Give new line if so
inc d ; Test any file found
jr z,l2c3e ; Yeap
call l0200 ; Else tell it
;
db 'No file'
db cr,lf,null
l2c3e:
call l01e1 ; Give new line
;
; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
; !!! FOLLOWING IS ERRONEOUS ON CP/M 3.x !!!
; !!! USES BDOS FUNCTION 46 ON CP/M 3.x !!!
; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
;
ld c,_getdpb
call BDOS ; Fetch disk parameter block
push hl
pop ix ; Copy it
ld a,(ix+3) ; Get block mask
inc a ; Fix
rra ; DIV 8 (1-> 1k, 2->2k etc.)
rra
rra
and DPBMASK ; Mask it
ld (l7b71),a ; Save block size
ld l,(ix+5) ; Fetch block count
ld h,(ix+6)
ld (l7b6f),hl ; Save it
inc hl ; Fix
call l2cc6 ; Build size in bytes
push hl ; Save it
;
; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
; !!! THE ALLOCATION VECTOR MAY BE FOUND IN ANOTHER !!!
; !!! MEMORY BANK RUNNING CP/M 3.X. !!!
; !!! THE NEXT CALCULATION MAY BE WRONG THEREFORE !!!
; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
;
ld c,_getalv
call BDOS ; Get allocation vector
ex de,hl
ld hl,(l7b6f) ; Get block count
ld bc,0
call l2ca5 ; Get free blocks
ld h,b
ld l,c
call l2cc6 ; Build size in bytes
call l0200 ; Tell size
;
db 'Bytes Remaining On '
l2c8d:
db 'X: '
db null
ex de,hl
pop hl ; Get back total size
or a
sbc hl,de ; Calculate free bytes
call l2e61 ; Print number
ld a,'k'
call puttoconsole_a ; Put to console
pop af ; Get back selected disk
ld e,a
ret
;ld c,_seldsk
;jp _BDOS ; Select disk
;
; BC holds resulting block count
; DE holds allocation vector
; HL holds block count
;
; BC holds free blocks
;
l2ca5:
push bc
ld bc,-8
add hl,bc ; Fix block count
pop bc
ld a,h ; Get hi
or a
ld a,(de)
jp p,l2cb8
l2cb1:
inc l
jr z,l2cbd ; Done, calculate free blocks
or a
rra
jr l2cb1
l2cb8:
call l2cbd ; Calculate free blocks from bits
jr l2ca5
;
; Calculate free blocks in reg BC from vector in Accu
;
l2cbd:
inc de ; Advance allocation vector
l2cbe:
or a ; Test end of bit stream
ret z ; Yeap
rra ; Get resulting bit
jr nc,l2cbe ; Not set
inc bc ; Advance block count
jr l2cbe
;
; Build bytes in blocks
;
l2cc6:
ld a,(l7b71) ; Get block size
l2cc9:
rra ; Get bit
ret c ; Got it
add hl,hl ; Double byte count
jr l2cc9
;
; ################################
; ### MAIN MENUE L - Log drive ###
; ################################
;
l2cce:
call l0200 ; Tell what we expect
;
db 'New drive'
db null
call l2261 ; Input string
ld a,(de)
cp eof ; Test empty input
jr nz,l2ce8 ; Nope
ld a,(DU) ; Get from caller
jr l2cf1
l2ce8:
call doupcase ; Convert to upper case
sub 'A' ; Verify in range
ret c
cp 'P'-'A'+1
ret nc
l2cf1:
if 1==1
ret
else
push af
ld c,_resdsk
call _BDOS ; Reset disk system
pop af
ld (DU),a ; Set new disk
ld e,a
ld c,_seldsk
jp _BDOS ; Select disk
endif
;
; Ask for YES or NO - Z set is NO
;
l2d01:
call l0200 ; Tell what we does expect
;
db ' (Y/N)? '
db null
l2d0d:
call readfromkbd ; Read character
call doupcase ; Convert to upper case
cp 'Y' ; Test YES
jr z,l2d1b
cp 'N' ; Test NO
jr nz,l2d0d
l2d1b:
call puttoconsole_a ; Put to console
sub 'N'
ret
;
; Get response Y or N - Z set is NO
;
l2d21:
call l2d01 ; Ask for YES or NO
push af
call l01e1 ; Give new line
pop af
ret
;
; Build file <name>.PAS
;
l2d2a:
ld a,'P' ; Set .PAS
ld hl,'A'+'S'*256
l2d2f:
ld (l005c+Fdrv+Fname),a
ld (l005c+Fdrv+Fname+1),hl
ld c,0 ; Set no wild card
call l0406 ; Parse file
ld a,(l005c) ; Test drive given
or a
ret nz ; Yeap
push de
ld c,_retdsk
call _BDOS ; Return current disk (return L=A=current drive)
inc a
ld (l005c),a ; Set disk
pop de
ret
;
; Test work file defined - Z set says no
;
l2d4b:
ld a,(l451d+Fdrv) ; Fetch name
or a
ret
;
; Get file
;
l2d50:
call l2d4b ; Test work file defined
jr nz,l2d6f ; Yeap
call l2d7a ; Test main file defined
jr nz,l2d5f ; Yeap
call l24c9 ; Get work file
jr l2d6f
l2d5f:
ld de,l451d
ld hl,l44f9 ; Point to main file
ld bc,l0024
ldir
ld a,1
ld (l44f1),a ; Set file flag
l2d6f:
ld a,(l44f1) ; Test file flag
or a
ret z ; No file
call l2602 ; Save work file
jp l2506
;
; Test main file defined - Z set says no
;
l2d7a:
ld a,(l44f9+Fdrv) ; Fetch name
or a
ret
;
; Compare main and work file - Z says same
;
l2d7f:
ld de,l451d ; Point to work file
ld hl,l44f9 ; Point to main file
ld b,Fdrv+Fname+Fext
l2d87:
ld a,(de)
sub (hl) ; Compare
ret nz ; Not same
inc de
inc hl
djnz l2d87
ret
;
; Init session
;
l2d8f:
ld hl,(l4544) ; Get start of text
ld (hl),' ' ; Clear it
inc hl
ld (l4546),hl ; Save pointer
xor a
ld (l447f),a ; Clear text change flag
ld (l44f1),a ; Clear file flag
l2d9f:
xor a
ld (l4542),a ; Force compile
ret
;
; Read error message file
;
l2da4:
ld hl,(l429e) ; Get base of message file
ld (l4544),hl ; Set as start of text
ld de,l217d ; Point to filename
ld a,'M'
ld hl,'S'+'G'*256
call l2e20 ; Prepare .MSG file
ld (l4541),a ; Set error message file read
call z,l2e76 ; Get ESCape
jr z,l2dcf
ld hl,l25a0
ld (l259d+1),hl ; Set vector for file not found
ld hl,l25d4
ld (l257c+1),hl ; Set vector for file too big
ld de,l005c
call l2518 ; Load text file ;closes automatically
l2dcf:
ld hl,(l4546) ; Get end of text
ld (hl),eof
inc hl
ld (l4544),hl ; Set start of text
ret
;
; Convert string ^DE to hex number in reg HL
;
l2dd9:
ld hl,0 ; Init result
l2ddc:
ld a,(de) ; Get character
call doupcase ; Convert to upper case
sub '0' ; Strip off offset
ret c ; Out of range
cp 9+1 ; Test decimal
jr c,l2def ; Yeap
sub 'A'-'0'-10 ; Fix for hex
cp 10 ; Verify correct range
ret c
cp 15+1
ret nc
l2def:
add hl,hl ; Old * 16
add hl,hl
add hl,hl
add hl,hl
or l
ld l,a ; Insert digit
inc de
jr l2ddc
;
; Tell name of file ^DE
;
l2df8:
inc de
ld a,(de) ; Get name
dec de
or a ; Test defined
ret z ; Nope
ld a,(de) ; Get drive
add a,'A'-1
cp 'A'-1 ; Test default drive
call nz,puttoconsole_a ; Put to console if not
ld a,':'
call nz,puttoconsole_a ; Give delimiter
ld b,Fname+Fext ; Set length
l2e0c:
inc de
ld a,(de) ; Get character
and NOMSB ; Strip off attribute
cp ' ' ; Test blank
call nz,puttoconsole_a ; Put to console if not
ld a,b
cp Fext+1 ; Test extension follows
ld a,'.'
call z,puttoconsole_a ; Put delimiter to console if so
djnz l2e0c
ret
;
; Prepare file ^DE with extensin in A,L,H
; Z set if file not found
;
l2e20:
call l2d2f ; Parse file and build extension
ld hl,l005c
call l2e51 ; Open file
ret nz ; Got it
ld a,(l44f8) ; Get logged disk
cp (hl) ; Test same drive
ld (hl),a ; Set logged one
call nz,l2e51 ; Open file if different drives
ret nz
ld a,'A'-'@'
cp (hl) ; Test base drive
ld (hl),a ; Force it
call nz,l2e51 ; Open file if not base
ret nz ; Got it
ld (hl),0 ; Set default drive
ex de,hl ; And tell error
;
; Tell file ^DE not found
;
l2e3e:
call l2df8 ; Tell name of file
call l0200 ; Tell not found
;
db ' not found'
db null
xor a
ret
;
; Open standard file - Z set says not found
;
l2e51:
push de
push hl
ld c,_open
call BDOS_with_FCB1 ; Open file
pop hl
pop de
inc a ; Fix result
ret
;
; Print integer in reg HL fixed sized
;
l2e5c:
ld de,-5 ; Set size
jr l2e64
;
; Print integer number in reg HL
;
l2e61:
ld de,-1 ; Set no size
l2e64:
push ix
push iy
push hl
push de
call l149b ; Set standard device
pop hl
call l1726 ; Write integer
pop iy
pop ix
ret
;
; Get ESCape character
;
l2e76:
push af
call l0200 ; Tell it
;
db '. Press <ESC>'
db null
l2e88:
call readfromkbd ; Read character
jp l0128 ; &PATCH&: Test special keys
nop
l2e8f:
pop af
ret
;
; %%%%%%%%%%%%%%%%%%%%
; %%% EDITOR PART %%%%
; %%%%%%%%%%%%%%%%%%%%
;
l2e91:
push hl
ld de,256*lf+cr
ld hl,(l4546) ; Get end of text
ld (hl),d ; Close line
dec hl
ld (hl),e
ld (l7b74+_LinLen),de
xor a
ld (l4474),a ; Clear change flag
inc a
ld (l4475),a ; Init row
ld hl,l43de
ld (l7b72),hl ; Init pointer to all delimiters
ld iy,l446c
call l023e ; Clear screen
pop de ; Get offset
inc de ; Fix it
ld hl,(l4544) ; Get start of text
add hl,de ; Add to offset
call l33a9 ;status line?
l2ebd:
ld a,(l4482) ; Get control character count
dec a
jr z,l2ed5 ; Got one
ld hl,256*0+0
call l02a2 ; Set cursor to control position
ld a,(l4482) ; Get control character count
add a,a ; Double it
ld b,a ; For count
ld a,' ' ;TODO speedup spaces
l2ed0:
call puttoconsole_a ; Blank control characters
djnz l2ed0
l2ed5:
call l3b96 ;set edit cursor?
call l2ff7 ; Give status
call l2f3a ; Get character
jr nc,l2f0e ; No control
jr z,l2ebd
ld hl,l2ebd
ld a,d
cp (HIGH MMSB)-1 ; Test special address
jr c,l2ef4 ; Nope
ld (l447f),a ; Set text changed
and NOMSB
ld d,a
xor a
ld (l4542),a ; Force compile
l2ef4:
push hl ; Set return address
push de ; Save control address
ld hl,l4456+1
ld de,l445a+1
ld bc,l0008
lddr ; Save a bit
ret
;
; Control: CONTROL PREFIX
;
l2f02::
call l2f8a ; Get character
ld (iy+22),3
call l4271 ; Get character
jr l2f16
l2f0e:
ld (l447f),a ; Re/Set text changed
ld hl,l4542
ld (hl),0 ; Force compile
l2f16:
ld hl,(l4452) ; Get current edit pointer
ld de,l7b74+_LinLen-2
call cmp_hl_de ; Compare HL:DE
jr nc,l2ebd ; Line too long
bit 0,(iy+6) ; Test insert
push af
call z,l41eb ; Yeap, so make room
pop af
ld (hl),a ; Store character
inc hl ; Bump buffer
push hl
call l4197
pop hl
ld (l4452),hl ; Set current edit pointer
call l3fe7 ;set column?
jp l2ebd
;
; Get character
; C set indicates control
;
l2f3a:
call l4271 ; Get character
cp '~'+1 ; Test printable range
jr nc,l2f44 ; Nope
cp ' ' ; Test once again
ret nc
l2f44:
ld hl,l4482 ; Point to control character count
ld (hl),1 ; Init count
inc hl
ld (hl),a ; Save control
l2f4b:
;push hl
;ld hl,l4482 ; Point to control character count
;ld de,l42a1
;ld b,11111111b
;call l2fc1 ; Find control
;pop hl
;or a ; Test found
;jr nz,l2f6b ; Yeap
push hl
ld hl,l4482 ; Point to control character count
ld de,l4369
;ld b,00011111b
ld b,11111111b
call l2fc1 ; Find control
pop hl
or a ; Test found
scf
ret z ; Nope
l2f6b:
dec a ; Test all found
jr z,l2f78 ; Nope
ld hl,l43f4
add hl,bc ; Go into table
add hl,bc
ld e,(hl) ; Fetch address
inc hl
ld d,(hl)
scf ; Set result
ret
l2f78:
call l2f8a ; Get character
push af
call l4271 ; Get character
inc (iy+22)
inc hl
ld (hl),a
pop af
call z,l2f8a ; Get character
jr l2f4b
;
; Get character
;
l2f8a:
call l4232 ; Poll character from input
call l428f ; Test look ahead buffer empty
ret nz ; Nope
push hl
ld hl,256*0+0
call l02a2 ; Position cursor
ld hl,l4482 ; Point to control character count
ld a,(hl) ; Get length
l2f9c:
push af
inc hl
ld a,(hl) ; Get character
call l2fa8 ; Dispaly as control
pop af
dec a
jr nz,l2f9c
pop hl
ret
;
; Display character in Accu
;
l2fa8:
push af
call l3cec ; Make normal video
pop af
cp ' ' ; Test control
jp nc,puttoconsole_a ; Put to console if not
push af
push af
ld a,'^'
call puttoconsole_a ; Indicate control
pop af
add a,'@'
call puttoconsole_a ; Put to console as ASCII
pop af
ret
;
; ^HL points to key sequence searched for in list ^DE with mask in reg B
; Accu= 0 says not found
; Accu= 1 says part found
; Accu=-1 says found
;
l2fc1:
ld c,-1 ; Init index
push bc
push hl
l2fc5:
pop hl
pop bc
ld a,(de) ; Get length from list
inc de
or a ; Test end
ret z ; Yeap
inc c ; Advance index
push bc
push hl
ld c,(hl) ; Get length from input
sub c ; Get difference
inc hl
jr nc,l2fd7 ; In range
add a,c ; Else fix it
ld c,a
jr l2ff0 ; Go adjust
l2fd7:
push af
l2fd8:
ld a,(de) ; Get from list
sub (hl) ; Compare
and b ; Set mask
jr nz,l2fed ; No match
inc de
inc hl
dec c
jr nz,l2fd8
pop af
pop hl
pop bc
ld b,0
ld a,-1
ret z ; Got exact length
ld a,1 ; Fix for partial success
ret
l2fed:
pop af
add a,c
ld c,a
l2ff0:
ld b,0
ex de,hl
add hl,bc
ex de,hl
jr l2fc5
;
; Give editor status
;
l2ff7:
call l4232 ; Poll character from input
call l428f ; Test look ahead buffer empty
ret nz ; Nope
ld hl,l4474
ld a,(hl) ; Test status changed
or a
jr nz,l3078 ; No change
ld (hl),-1 ; Reset it
ld hl,256*0+0
ld (l4476),hl
xor a
ld (l4478),a
call l02a2 ; Position cursor
call l3c12 ; Clear line
call l3cdf ; Set low video
ld a,(l0168) ; Get screen columns
cp MINWID ; Test room for filename
jr c,l302a ; Nope
ld hl,256*42+0
call l02a2 ; Position cursor
call l3135 ; Type work file
l302a:
ld hl,256*6+0
call l420e ; Position cursor and tell line
db 'Line '
db null
ld hl,256*16+0
call l420e ; Position cursor and tell column
db 'Col '
db null
ld hl,256*24+0
ld a,(l4472) ; Get insert mode
or a
jr nz,l305a ; Overwrite
call l420e ; Position cursor and tell insert
db 'Insert '
db null
jr l3068
l305a:
call l420e ; Position cursor and tell overwrite
db 'Overwrite '
db null
l3068:
ld a,(l4479) ; Get tabulate state
or a
jr nz,l3078
call l4211
db 'Indent'
db null
l3078:
ld a,(l446c) ;xscroll???
add a,(iy+4) ; Add column
inc a
ld hl,(l4478)
cp l
jr z,l309b
ld (l4478),a
push af
ld hl,256*20+0
call l02a2 ; Position cursor
call l3cdf ; Set low video
pop af
ld l,a
ld h,0
ld a,3 ; Set number of digits
call l30ec ; Give count
l309b:
ld de,(l4476)
ld hl,(l4450) ; Get current memory pointer
call cmp_hl_de ; Compare HL:DE
jp z,l37a4 ; Same, set edit cursor
call l37a4 ; Set edit cursor
ld de,(l4544) ; Get start of text
ld hl,(l4450) ; Get current memory pointer
or a
sbc hl,de ; Get relative position
ld c,l
ld b,h
ex de,hl
ld de,1
ld a,c
or b ; Test any
jr z,l30d3 ; Nope
l30bf:
ld a,lf
inc de
cpir ; Find new line
jp po,l30d3 ; Got it
dec e
inc e
call z,l4232 ; Poll character from input
call l428f ; Test look ahead buffer empty
jr nz,l30e9 ; Nope
jr l30bf
l30d3:
ld hl,256*11+0
push de
call l02a2 ; Position cursor
call l3cdf ; Set low video
pop hl
ld a,5 ; Set number of digits
call l30ec ; Give count
ld hl,(l4450) ; Get current memory pointer
ld (l4476),hl
l30e9:
jp l37a4 ; Set edit cursor
;
; Print fixed format integer
; ENTRY Reg HL holds number to be printed
; Accu holds decimal places
;
l30ec:
push af
ld b,0 ; Clear count
call l30fe ; Print number
pop af
add a,b ; Test all digits typed
ret z ; Yeap
ld b,a
ld a,' '
l30f8:
call puttoconsole_a ; Fill remainder with blanks
djnz l30f8
ret
;
; Print decimal number
; ENTRY Reg HL holds number
; Reg B holds places
;
l30fe:
ld a,h
or l ; Test zero output
ld a,'0'
jr z,l3131 ; Yeap, print it
ld de,10000
call l311f ; Get ten thousands
ld de,1000
call l311f ; Get thousands
ld de,100
call l311f ; Get hundreds
ld de,10
call l311f ; Get tens
ld de,1 ; Finally units
;
; Print modulo
; ENTRY Reg HL holds number
; Reg DE holds divisor
; Reg B holds places
; EXIT Reg HL fixed
; Reg B decremented if digit is printed
;
l311f:
xor a ; Clear digit
l3120:
sbc hl,de ; Divide
jr c,l3127
inc a ; Bump digit
jr l3120
l3127:
add hl,de ; Make remainder positive
add a,'0' ; Make ASCII
cp '0' ; Test zero
jr nz,l3131
inc b ; Test leading zero
dec b
ret z ; Suppress it
l3131:
dec b ; Fix count
jp puttoconsole_a ; Put to console
;
; Type work file
;
l3135:
ld de,l451d
jp l2df8 ; Tell name of file
;
; Get string for search and file function
; ENTRY Reg DE points to line buffer
; Byte 0 holds max characters
; Byte 1 holds resulting length
;
l313b:
call l0200 ; Indicate input
;
db ': '
db null
ex de,hl
push hl
pop ix ; Copy buffer
inc hl
ld d,(hl)
ld (hl),0
inc hl
l314a:
res _LB,(iy+_Video) ; Disable video
push de
push hl
call l2f3a ; Get character
pop hl
pop de
set _LB,(iy+_Video) ; Allow video
jr nc,l31b9 ; No control
jr nz,l3165
ld a,(l4483) ; Get character
call l3ef6 ; Test function cancelled
jr l314a
l3165:
ld a,c
cp 0
jr nz,l316d
ld (hl),1ah
ret
l316d:
cp 3
jr nz,l317c
ld a,(ix+1)
cp d
jr nc,l314a
inc (ix+1)
jr l31c6
l317c:
cp 5
jr nz,l3190
l3180:
ld a,(ix+1)
cp d
jr z,l314a
ld a,(hl) ; Get character
call l2fa8 ; Display as control
inc hl
inc (ix+1)
jr l3180
l3190:
cp 4
jr nz,l319b
l3194:
call l31d7
jr nz,l3194
jr l314a
l319b:
cp '-'
jr nz,l31a4
call l4271 ; Get character
jr l31b9
l31a4:
cp 1bh
jr z,l31b4
cp 1ch
jr z,l31b4
cp 1
jr z,l31b4
cp 2
jr nz,l314a
l31b4:
call l31d7
l31b7:
jr l314a
l31b9:
ld e,a
ld a,(ix+1)
cp (ix+0)
jr nc,l314a
inc (ix+1)
ld (hl),e
l31c6:
ld a,(hl) ; Get character
inc hl
call l2fa8 ; Display as control
ld a,(ix+1)
cp d
jr c,l31b7
ld d,(ix+1)
jp l31b7
l31d7:
ld a,(ix+1)
or a
ret z
dec (ix+1)
dec hl
ld a,(hl)
cp ' '
call c,l31e6
l31e6:
call l4211
db bs+MSB,' '+MSB,bs+MSB
db null
ld a,0ffh
or a
ret
;
; Control: FIND STRING
;
l31f1:
xor a
ld (l447e),a ; Set find flag
call l31fd ; Get string searched for
call l3220 ; Get options
jr l3252 ; Enter process
;
; Get string searched for
;
l31fd:
call l3e04 ; Tell what we want
db 'Find'
db null
ld de,l4490 ; Point to buffer
l3208:
jp l313b ; Get search string
;
; Get string to be replaced
;
l320b:
call l3e07 ; Tell what we want
db 'Replace with'
db null
ld de,l44b1 ; Point to buffer
jr l3208 ; Get replace string
;
; Get options
;
l3220:
call l3e07 ; Tell what we want
db 'Options'
db null
ld de,l44d2 ; Get buffer
call l313b ; Get search string
ld a,(l0168) ; Get screen columns
ld h,a
dec h ; Fix column
ld l,0 ; Set row
jp l02a2 ; Position cursor
;
; Control: FIND AND REPLACE STRING
;
l323b:
ld a,-1
ld (l447e),a ; Set replace flag
call l31fd ; Get string searched for
call l320b ; Get replace string
call l3220 ; Get options
jr l3252 ; Enter process
;
; Control: REPEAT LAST SEARCH
;
l324b:
call l2f8a ; Get character
ld (iy+22),3 ; Init count
l3252:
call l3e40 ; Sample character
call l3e23 ; Find last non blank
inc hl
ld de,(l4452) ; Get current edit pointer
call l4191 ; Find min
ld de,l7b74
or a
sbc hl,de ; Subtract base
ld de,(l4450) ; Get current memory pointer
add hl,de ; Add for real address
ld (l4488),hl ; Set end
ld de,0 ; Clear counter
ld hl,l44d2+1 ; Init buffer
ld b,(hl) ; Fetch length
ld (iy+17),0 ; Clear flag
inc b ; Test any in buffer
dec b
jr z,l32c0 ; Nope
l327d:
inc hl
ld a,(hl) ; Get character
cp '0' ; Test possible count
jr c,l3293 ; Nope
cp '9'+1
jr nc,l3293
call l3426
sub '0'
add a,e ; Add digit to count
ld e,a
jr nc,l32be
inc d ; Remember carry
jr l32be
l3293:
call doupcase ; Convert to upper case
cp 'W' ; Test whole word search
jr nz,l329e
set _W,(iy+17)
l329e:
cp 'U' ; Test ignore case
jr nz,l32a6
set _U,(iy+17)
l32a6:
cp 'N' ; Test no request
jr nz,l32ae
set _N,(iy+17)
l32ae:
cp 'G' ; Test global
jr nz,l32b6
set _G,(iy+17)
l32b6:
cp 'B' ; Test backwards
jr nz,l32be
set _B,(iy+17)
l32be:
djnz l327d
l32c0:
ld a,e ; Test loop count
or d
jr nz,l32c7 ; Yeap
ld de,1 ; Set default
l32c7:
ld (l448a),de ; Save loop count
ld hl,(l4544) ; Get start of text
ld a,(l447d) ; Get option flags
bit _B,a ; Test backwards
jr z,l32d8 ; Nope
ld hl,(l4546) ; Get end of text
l32d8:
bit _G,a ; Test global search
jr nz,l32df ; Yeap
ld hl,(l4488) ; Get end of search pointer
l32df:
ld (l4488),hl ; Set end of search pointer
bit _B,(iy+17) ; Test backwards
jr nz,l32f5 ; Yeap
ld de,(l4546) ; Get end of text
dec de
call cmp_hl_de ; Compare HL:DE
jp nc,l3380
jr l32fb
l32f5:
call l3bee ; Fix to start of line
jp c,l3380
l32fb:
ld de,l4492
ld a,(l4491)
ld b,a
bit _B,(iy+17) ; Test backwards
jr z,l330e ; Nope
dec a
add a,e
ld e,a
jr nc,l330e
inc d
l330e:
bit _W,(iy+17) ; Test whole word search
jr z,l3323 ; Nope
push de
push hl
call l33fb
ld a,(hl)
pop hl
pop de
jr c,l3323
call l33e4
jr c,l3377
l3323:
dec b
inc b
jr z,l332e
l3327:
call l340f
jr nz,l3377
djnz l3364
l332e:
bit _W,(iy+17) ; Test whole word search
jr z,l3341 ; Nope
push hl
call l3406
ld a,(hl)
pop hl
jr c,l3341
call l33e4
jr c,l3377
l3341:
bit _B,(iy+17) ; Test backwards
call z,l3bdd ; Nope
ld a,(l447e) ; Get find flag
or a
call nz,l3430 ; Replace selected
bit _G,(iy+17) ; Test global search
l3353:
jr nz,l32df
ld bc,(l448a) ; Get loop count
dec bc ; Decrement
ld (l448a),bc
ld a,b
or c
jr nz,l3353
jr l33a9
l3364:
push de
call l3406
pop de
jr c,l3380
bit _B,(iy+17) ; Test backwards
jr z,l3374 ; Nope
dec de
jr l3327
l3374:
inc de
jr l3327
l3377:
ld hl,(l4488) ; Get end of search pointer
call l3406
jp nc,l32df
l3380:
call l33d6
call l33a9
bit _G,(iy+17) ; Test global search
ret nz
call l3e04
db 'Search string not found'
db null
jp l3f12
;status line???
l33a9:
call l33af
jp l3d2c ; Restore line
l33af:
ld de,(l4546) ; Get end of text
dec de
call cmp_hl_de ; Compare HL:DE
jr c,l33ba ;hl<de
ex de,hl
l33ba:
push hl
push hl
call l3bf5 ; Get previous EOL
ld (l4450),hl ; Set current memory pointer
or a
ex de,hl
pop hl
sbc hl,de
ld de,l7b74
add hl,de
ld (l4452),hl ; Set current edit pointer
call l3fe7 ;set column?
call l401f
pop hl
ret
l33d6:
ld de,(l4544) ; Get start of text
call l4191 ; Find min
ld hl,(l4546) ; Get end of text
dec hl
jp l4191 ; Find min
l33e4:
cp '0'
jr c,l33f9
cp ':'
ret c
cp 'A'
jr c,l33f9
cp 5bh
ret c
cp 61h
jr c,l33f9
cp 7bh
ret c
l33f9:
or a
ret
l33fb:
bit _B,(iy+17) ; Test backwards
jr z,l340c ; Nope
l3401:
call l3bdd
ccf
ret
l3406:
bit _B,(iy+17) ; Test backwards
jr z,l3401 ; Nope
l340c:
jp l3bee ; Fix to start of line
l340f:
ld a,(de)
cp 1
ret z
cp (hl)
ret z
bit _U,(iy+17) ; Test ignore case
jr z,l3424 ; Yeap
call l33e4
jr nc,l3424
xor (hl)
and 0dfh
ret
l3424:
cp (hl)
ret
l3426:
push hl
ld l,e
ld h,d
add hl,hl
add hl,hl
add hl,de
add hl,hl
ex de,hl
pop hl
ret
l3430:
push hl
call l428f ; Test look ahead buffer empty
jr z,l343c ; Yeap
bit _N,(iy+17) ; Test no request
jr nz,l349d ; Yeap
l343c:
call l33a9
call l3b96
bit _N,(iy+17) ; Test no request
jr nz,l349d ; Yeap
call l3e07
db 'Replace (','Y'+MSB,'/','N'+MSB,'): '
db null
l345b:
ld l,(iy+5) ; Get row
ld h,(iy+4) ; Get column
call l02a2 ; Position cursor
ld bc,l07d0
l3467:
call l4232 ; Poll character from input
call l428f ; Test look ahead buffer empty
jr nz,l348c ; Nope
dec bc
ld a,c
or b
jr nz,l3467
ld hl,256*15+0
call l02a2 ; Position cursor
ld bc,l07d0
l347d:
call l4232 ; Poll character from input
call l428f ; Test look ahead buffer empty
jr nz,l348c ; Nope
dec bc
ld a,c
or b
jr nz,l347d
jr l345b
l348c:
call l4271 ; Get character
call l3ef6 ; Test function cancelled
call doupcase ; Convert to upper case
cp 'Y'
jr z,l349d
cp 19h
jr nz,l34eb
l349d:
set 0,(iy+19)
xor a
ld (l4542),a ; Force compile
ld a,(l44b2)
ld c,a
ld b,0
pop hl
push hl
push bc
ld a,(l4491)
sub c
ld c,a
push af
jr nc,l34b7
dec b
l34b7:
bit _B,(iy+17) ; Test backwards
jr nz,l34c0 ; Yeap
ld hl,(l4488) ; Get end of search pointer
l34c0:
pop af
push hl
call nz,l3f18
pop de
pop bc
ld a,b
or c
jr z,l34d0
ld hl,l44b3
ldir
l34d0:
call l428f ; Test look ahead buffer empty
push af
call nz,l4147 ; Nope, so reset row
pop af
jr nz,l34e2 ; Eas not empty
push de
call l3d2c ; Restore line
call l4139
pop de
l34e2:
bit _B,(iy+17) ; Test backwards
jr nz,l34eb ; Yeap
pop hl
ex de,hl
ret
l34eb:
pop hl
ret
;
; Control: WRITE BLOCK TO FILE
;
l34ed:
bit 0,(iy+20) ; Test block set
ret nz ; Nope
call l3e40 ; Sample character
call l3d2c ; Restore line
ld hl,(l4460) ; Get block start pointer
ld de,(l4462) ; Get block end pointer
call cmp_hl_de ; Compare HL:DE
ret nc ; Start >= end
call l363c
call l3d2c ; Restore line
l3509:
call l3e04 ; Tell what we want
db 'Write block to file'
db null
call l3566 ; Get name of file
ret z
call l2d2a ; Prepare .PAS file
ld c,_open
call BDOS_with_FCB1 ; Open file ;WHERE IS CLOSE???
inc a ; Test file already exist
jr z,l3551 ; Nope
call l3e07
db 'Overwrite old '
db null
ld de,l005c
call l2df8 ; Tell name of file
call l2d01 ; Ask for YES or NO
jr z,l3509 ; No
ld c,_delete
call BDOS_with_FCB1 ; Delete file
l3551:
ld hl,(l4462) ; Get block end pointer
ld a,(hl) ; Save character
push af
push hl
ld (hl),eof ; Set end of file
call l3e0d ; Set cursor
ld hl,(l4460) ; Get block start pointer
call l2692 ; Save block to file
ld c,_close
call BDOS_with_FCB1
pop hl
pop af
ld (hl),a ; Restore character
ret
;
; Get name of file
;
l3566:
ld de,l44df
call l313b ; Get filename
ld de,l44df+2
ld a,(de)
cp eof ; Test empty name
ret
;
; Control: READ BLOCK FROM FILE
;
l3573:
call l3e04 ; Tell what we want
db 'Read block from file'
db null
call l3566 ; Get name of file
ret z
call l2d2a ; Prepare .PAS file
ld c,_open
call BDOS_with_FCB1 ; Open file ;WHERE IS CLOSE???
inc a ; Test success
jr nz,l35a8 ; Yeap
call l3e0d ; Set cursor
ld de,l005c
call l2e3e ; Tell not found
call l3f12
jr l3573
l35a8:
res 0,(iy+20) ; Mark block
call l363c
ld hl,(l4546) ; Get end of text
ld de,(l4548) ; Get top of available memory
ld bc,l00fe
add hl,bc ; Build top
or a
sbc hl,de ; Calculate size
push hl
ld b,h
ld c,l
ld hl,(l448c)
scf
call l3f18
ld c,_close
call BDOS_with_FCB1
pop de
ld hl,l35dd ; Set return address
push hl
ld hl,(l448c)
push hl
xor a
sbc hl,de
push hl
ld hl,l35f1
ld (l257c+1),hl ; Redirect load error
jp l2560 ; Load the block
;
; Process end of read
;
l35dd:
ld (l4462),hl ; Set block end pointer
ex de,hl
ld hl,(l448c)
ld (l4460),hl ; Set block start pointer
l35e7:
ld hl,(l7b6d) ; Get last memory address
or a
sbc hl,de ; Build difference
ld b,h
ld c,l
jr l3612
;
; Redirected load error
;
l35f1:
ld de,(l448c)
call l35e7
jp l3ed9
;
; Control: MOVE BLOCK
;
l35fb:
call l363c
jp nc,l3d2c ; Restore line
call l3687
ld hl,(l448c)
ld de,(l4460) ; Get block start pointer
ld (l4460),hl ; Set block start pointer
add hl,bc
ld (l4462),hl ; Set block end pointer
l3612:
ex de,hl
or a
call l3f18
ld hl,(l4460) ; Get block start pointer
call l33a9
jp l3762
;
; Control: COPY BLOCK
;
l3620:
call l363c
jp nc,l3d2c ; Restore line
call l3687
ld hl,(l448c)
ld (l4460),hl ; Set block start pointer
add hl,bc
ld (l4462),hl ; Set block end pointer
call l401f
call l3d2c ; Restore line
jp l3762
;
;
;
l363c:
bit 0,(iy+20) ; Test block set
jr z,l3644 ; Yeap
xor a
ret
l3644:
call l3e23 ; Find last non blank
inc hl
ld de,(l4452) ; Get current edit pointer
push de
call l4191 ; Find min
ex de,hl
call l3e44 ; Sample character
pop hl
ld de,l7b74
or a
sbc hl,de ; Subtract base
ld de,(l4450) ; Get current memory pointer
add hl,de ; Build real pointer
ld (l448c),hl
push hl
ld de,(l4460) ; Get block start pointer
inc de
call cmp_hl_de ; Compare HL:DE
ld de,(l4462) ; Get block end pointer
jr c,l367a ; HL < Start_Of_Block
call cmp_hl_de ; Compare HL:DE
jr nc,l367a ; HL >= End_Of_Block
or a
jr l3685
l367a:
ld hl,(l4460) ; Get block start pointer
or a
sbc hl,de
ld (l448e),hl
ld c,l
ld b,h
l3685:
pop hl
ret
;
;
;
l3687:
call l3f18
ld bc,(l448e)
ld a,c ; Negate value
cpl
ld c,a
ld a,b
cpl
ld b,a
inc bc
ld de,(l448c)
ld hl,(l4460) ; Get block start pointer
push bc
ldir
pop bc
ret
;
; Control: DELETE BLOCK
;
l36a1:
bit 0,(iy+20) ; Test block set
ret nz ; Nope
call l3e40 ; Sample character
ld hl,(l4460) ; Get block start pointer
call l3bf5 ; Get previous EOL
ld (l4450),hl ; Set current memory pointer
ld hl,(l4454) ; Get block pointer
ld de,(l4460) ; Get block start pointer
inc de
call cmp_hl_de ; Compare HL:DE
jr c,l36ce ; HL < Start_Of_Block
ld de,(l4462) ; Get block end pointer
call cmp_hl_de ; Compare HL:DE
jr nc,l36ce ; HL >= End_Of_Block
ld hl,(l4450) ; Get current memory pointer
ld (l4454),hl ; Set block pointer
l36ce:
ld hl,(l4462) ; Get block end pointer
ld de,(l4460) ; Get block start pointer
or a
sbc hl,de
jp c,l3d2c ; Restore line if End < Start
ld c,l
ld b,h
ex de,hl
push hl
push bc
push af
call l401f
pop af
pop bc
pop hl
call l3f18
ld hl,(l4450) ; Get current memory pointer
ld (l4460),hl ; Set block start pointer
ld (l4462),hl ; Set block end pointer
call l3d2c ; Restore line
jp l3762
;
; Control: TOGGLE BLOCK DISPLAY
;
l36f9:
ld hl,l4480 ; Point to block mark
call l3796 ; Toggle block bit
jp l3762
;
; Control: MARK END OF BLOCK
;
l3702:
ld hl,(l4452) ; Get current edit pointer
ld (l4466),hl ; Set for end of block
ld hl,(l4450) ; Get current memory pointer
ld (l4462),hl ; Set block end pointer
bit 1,(iy+1) ; Test end block
set 1,(iy+1)
l3716:
ex af,af'
bit 0,(iy+20) ; Test previous block set
res 0,(iy+20) ; Set now
jr nz,l3762 ; Was not set
ex af,af'
jr z,l3762 ; Prevous was also not set
jr l374e
;
; Control: MARK BEGIN OF BLOCK
;
l3726:
ld hl,(l4452) ; Get current edit pointer
ld (l4464),hl ; Save address
ld hl,(l4450) ; Get current memory pointer
ld (l4460),hl ; Set block start pointer
bit 0,(iy+1) ; Test start block
set 0,(iy+1)
jr l3716
;
; Control: BEGIN OF BLOCK
;
l373c:
call l3e40 ; Sample character
ld hl,(l4460) ; Get block start pointer
jp l33a9
;
; Control: END OF BLOCK
;
l3745:
call l3e40 ; Sample character
ld hl,(l4462) ; Get block end pointer
jp l33a9
;
;
;
l374e:
ld h,0 ; Set left column
call l37a7 ; Set editor cursor
ld hl,l7b74 ; Load base address
set 0,(iy+16)
call l3c1a
res 0,(iy+16)
ret
;
;
;
l3762:
call l374e
jp l4147 ; Reset row
;
; Control: END OF TEXT
;
l3768:
call l3e40 ; Sample character
ld hl,(l4546) ; Get end of text
jp l33a9
;
; Control: LINE LEFT
;
l3771:
ld hl,l7b74 ; Set start of line
ld (l4452),hl ; Set current edit pointer
jp l3fe7 ;set column?
;
; Control: LINE RIGHT
;
l377a:
call l3e23 ; Find last non blank
inc hl
ld de,l7b74+_LinLen
call cmp_hl_de ; Compare HL:DE
jr c,l3789
ld hl,l7b74+_LinLen-1
l3789:
ld (l4452),hl ; Set current edit pointer
jp l3fe7 ;set column?
;
; Control: TOGGLE INSERT/OVERWRITE
;
l378f:
ld (iy+8),0 ; Set no change
ld hl,l4472 ; Point to insert mode
;
; Toggle status bit ^HL
;
l3796:
ld a,(hl) ; Get value
xor 1 ; Toggle bit
ld (hl),a
ret
;
; Control: TOGGLE TABULATE
;
l379b:
ld (iy+8),0 ; Set no change
ld hl,l4479
jr l3796 ; Toggle tabulate bit
;
; Set current edit cursor
;
l37a4:
ld h,(iy+4) ; Get column
;
; Set editor cursor to current row
; ENTRY Reg H holds column position
;
l37a7:
ld l,(iy+5) ; Get row
jp l02a2 ; Position cursor
;
; Control: LINE DOWN
;
l37ad:
ld hl,(l4450) ; Get current memory pointer
call findnexteol ; Find next end of line
ret c ; Out of text
call l3e40 ; Sample character
ld hl,(l4450) ; Get current memory pointer
call findnexteol ; Find next end of line
l37bd:
ld (l4450),hl ; Set current memory pointer
res 0,(iy+14)
set 0,(iy+21)
call l401f
res 0,(iy+21)
jp l3d2c ; Restore line
;
; Control: LINE UP
;
l37d2:
ld hl,(l4450) ; Get current memory pointer
call findprevline ; Find previous line
ret c ; Below start of text
push hl
call l3e40 ; Sample character
pop hl
jr l37bd
;
; Control: SCROLL UP
;
l37e0:
ld hl,(curstartofpage) ; Get start of screen
ld de,(l4544) ; Get start of text
call cmp_hl_de ; Compare HL:DE
ret z
call l3e40 ; Sample character
ld b,0
ld hl,(l4450) ; Get current memory pointer
l37f3:
ld de,(curstartofpage) ; Get start of screen
call cmp_hl_de ; Compare HL:DE
jr z,l3802 ; Match
call findprevline ; Find previous line
inc b
jr l37f3
l3802:
ld de,(l4450) ; Get current memory pointer
ld (l4450),hl ; Set current memory pointer
ex de,hl
ld a,(l0169) ; Get screen lines
sub 3 ; Less status
cp b
jr nz,l3815
call findprevline ; Find previous line
l3815:
push hl
ld hl,(l4450) ; Get current memory pointer
call findprevline ; Find previous line
call l37bd
pop hl
l3820:
jr l37bd
;
; Control: SCROLL DOWN
;
l3822:
call l3e40 ; Sample character
ld hl,(l4450) ; Get current memory pointer
push hl
ld hl,(curstartofpage) ; Get start of screen
ld a,(l0169) ; Get screen lines
sub 2 ; Less status
ld b,a
l3832:
call findnexteol ; Find next end of line
djnz l3832
push af
call l37bd
pop af
pop hl
jr c,l3820
ld de,(curstartofpage) ; Get start of screen
call cmp_hl_de ; Compare HL:DE
jr nc,l3820 ; HL >= Start_Of_Screen
call findnexteol ; Find next end of line
jr l3820
;
; Control: BOTTOM OF SCREEN
;
l384d:
ld hl,(curstartofpage) ; Get start of screen
ld de,(l4450) ; Get current memory pointer
call cmp_hl_de ; Compare HL:DE
ret z ; Same
push hl
call l3e40 ; Sample character
pop hl
jr l3820
;
; Control: TOP OF SCREEN
;
l385f:
call l3e40 ; Sample character
ld hl,(curstartofpage) ; Get start of screen
ld a,(l0169) ; Get screen lines
sub 3 ; Less status
ld b,a
l386b:
call findnexteol ; Find next end of line
djnz l386b
jr l3820
;
; Control: PAGE DOWN
;
l3872:
call l3e40 ; Sample character
ld a,(l0169) ; Get screen lines
sub 2 ; Less status
ld c,a
ld b,a
ld hl,(curstartofpage) ; Get start of screen
l387f:
call findnexteol ; Find next end of line
djnz l387f
ld (curstartofpage),hl ; Set start of screen
ld b,c
ld hl,(l4450) ; Get current memory pointer
l388b:
call findnexteol ; Find next end of line
djnz l388b
l3890:
ld (l4450),hl ; Set current memory pointer
call l401f
call l4147 ; Reset row
jp l3d2c ; Restore line
;
; Control: PAGE UP
;
l389c:
call l3e40 ; Sample character
ld a,(l0169) ; Get screen lines
sub 2 ; Less status
ld b,a
ld c,a
ld hl,(curstartofpage) ; Get start of screen
l38a9:
call findprevline ; Find previous line
djnz l38a9
ld (curstartofpage),hl ; Set start of screen
ld b,c
ld hl,(l4450) ; Get current memory pointer
l38b5:
call findprevline ; Find previous line n-times
djnz l38b5
jr l3890
;
; Control: BEGIN OF TEXT
;
l38bc:
ld hl,(curstartofpage) ; Get start of screen
ld de,(l4544) ; Get start of text
call cmp_hl_de ; Compare HL:DE
jr z,l38cb ; Same
call l4147 ; Reset row
l38cb:
call l3e40 ; Sample character
ld hl,(l4544) ; Get start of text
ld (l4450),hl ; Set current memory pointer
ld (curstartofpage),hl ; Set start of screen
call l401f
call l3d2c ; Restore line
ld hl,l7b74
ld (l4452),hl ; Init edit pointer
jp l3fe7 ;set column?
;
; Control: NEW LINE
;
l38e6:
bit 0,(iy+6) ; Test insert
jr z,l38f2 ; New line
call l37ad ; Line down
jp l3771 ; Goto start of line
l38f2:
set 0,(iy+19)
xor a
ld (l4542),a ; Force compile
ld a,lf
call puttoconsole_a ; Put new line to console
call l3918
call l37a4 ; Set edit cursor
bit 0,(iy+13) ; Test auto tab
ret nz ; Yeap
call l3a6b ; Position to previous line
ret c ; Below start of text
ld de,l43f2
call l412e ; Find blank
jp c,l3a72 ; Yeap, insert tab
ret
;
;
;
l3918:
call l3950
ld hl,(l4450) ; Get current memory pointer
push hl
call l3d2c ; Restore line
call l3e40 ; Sample character
pop hl
call findnexteol ; Find next end of line
ld (l4450),hl ; Set current memory pointer
ld hl,l7b74
l392f:
ld (l4452),hl ; Set current edit pointer
call l3fe7 ;set column?
call l401f
jp l3d2c ; Restore line
;
; Control: INSERT LINE
;
l393b::
call l3950
call l0200
db cr,lf,null
ld hl,(l4450) ; Get current memory pointer
call findnexteol ; Find next end of line
call l3c1a
jp l3d2c ; Restore line
;
;
;
l3950:
call l3e40 ; Sample character
ld a,(l01ae) ; Test insert line implemented
or a
push af
call nz,l0262 ; Yeap: insert line
pop af
call z,l4139 ; Nope
call l3e23 ; Find last non blank
inc hl ; Skip
ld de,(l4452) ; Get current edit pointer
call l4191 ; Find min
ld de,l7b74
or a
sbc hl,de ; Subtract base
l3970:
ex de,hl
ld hl,(l4450) ; Get current memory pointer
add hl,de ; Add offset
push hl
scf
ld bc,-2
call l3f18
pop hl
ld (hl),cr ; Close line
inc hl
ld (hl),lf
ret
;
; Control: CURSOR LEFT
;
l3984:
ld hl,(l4452) ; Get current edit pointer
call l3c02 ; move character left
ret c ; Not possible
l398b:
ld (l4452),hl ; Set current edit pointer
jp l3fe7 ;set column?
;
; Control: CURSOR RIGHT
;
l3991:
ld hl,(l4452) ; Get current edit pointer
call l3be8 ; move character right
ret nc ; Out off limit
jr l398b ; Save new position
;
; Control: LAST CURSOR POSITION
;
l399a:
call l3e40 ; Sample character
ld hl,(l4458) ; Get edit pointer
call l3bf5 ; Get previous EOL
ld (l4450),hl ; Set current memory pointer
ld hl,(l445a)
jp l392f
;
; Control: MARK SINGLE WORD
;
l39ac:
call l3a0b ; Word right
call l39ea ; Word left
ld hl,(l4452) ; Get current edit pointer
l39b5:
call l412a ; Find delimiter
jr c,l39bf ; Yeap
call l3be8 ; move character right
jr c,l39b5 ; Still in limit
l39bf:
ld (l4452),hl ; Set current edit pointer
call l3702 ; Mark end
call l39ea ; Word left
jp l3726 ; Mark start
;
;
;
l39cb:
ld hl,(l4450) ; Get current memory pointer
call findprevline ; Find previous line
jr c,l3a05 ; Below start
push hl
call l3e40 ; Sample character
pop hl
ld (l4450),hl ; Set current memory pointer
res 0,(iy+14)
call l401f
call l3d2c ; Restore line
call l3e23 ; Find last non blank
jr l3a01
;
; Control: WORD LEFT
;
l39ea:
ld hl,(l4452) ; Get current edit pointer
l39ed:
call l3c02 ; move character left
jr c,l39cb ; At beginning of line
call l412a ; Find delimiter
jr c,l39ed ; Yeap
l39f7:
call l3c02 ; move character left
jr c,l3a01 ; At beginning of line
call l412a ; Find delimiter
jr nc,l39f7 ; Nope
l3a01:
inc hl
l3a02:
ld (l4452),hl ; Set current edit pointer
l3a05:
ld hl,(l4452) ; Get current edit pointer
jp l3fe7 ;set column?
;
; Control: WORD RIGHT
;
l3a0b:
call l3e23 ; Find last non blank
ld de,(l4452) ; Get current edit pointer
push de
xor a
sbc hl,de
jr nc,l3a19
inc a
l3a19:
ld (l7b71),a ; Set direction flag
pop hl
l3a1d:
dec hl
l3a1e:
call l3be8 ; move character right
jr c,l3a4e ; Still in limit
l3a23:
ld hl,(l4450) ; Get current memory pointer
call findnexteol ; Find next end of line
ret c ; Out of text
call l3e40 ; Sample character
ld hl,(l4450) ; Get current memory pointer
call findnexteol ; Find next end of line
ld (l4450),hl ; Set current memory pointer
res 0,(iy+14)
call l401f
call l3d2c ; Restore line
ld hl,l7b74
ld (l4452),hl ; Init current edit pointer
call l412a ; Find delimiter
jr c,l3a1d ; Yeap
jp l3fe7 ;set column?
l3a4e:
call l412a ; Find delimiter
jr nc,l3a1e ; Nope
l3a53:
call l3be8 ; move character right
jr c,l3a64 ; Still in limit
ld a,(l7b71) ; Get direction
or a
jr nz,l3a23
call l3e23 ; Find last non blank
inc hl ; Skip
jr l3a02
l3a64:
call l412a ; Find delimiter
jr c,l3a53 ; Yeap
jr l3a02
;
; Position to previous line
; EXIT Reg HL points to line
; Carry set if below start of text
;
l3a6b:
ld hl,(l4450) ; Get current memory pointer
call findprevline ; Find previous line
ret
;
; Control: TABULATE
;
l3a72:
call l3a6b ; Position to previous line
ret c ; Below start of text
ld a,(l4471) ; Get row
push af ; Save it
ld hl,(l4452) ; Get current edit pointer
ld (l4468),hl ; Save it
res 0,(iy+7) ; Disable video
call l3e40 ; Sample character
ld hl,(l4450) ; Get current memory pointer
push hl
call findprevline ; Find previous line
ld (l4450),hl ; Set current memory pointer
call l3d2c ; Restore line
ld hl,l43f2
ld (l7b72),hl ; Set pointer to reduced delimiters
call l3a0b ; Word right
ld hl,l43de
ld (l7b72),hl ; Reset pointer to delimiters
pop hl
pop af
ld (l4471),a ; Reset row
ld (l4450),hl ; Reset current memory pointer
call l3d2c ; Restore line
set 0,(iy+7) ; Enable video
bit 0,(iy+6) ; Test insert
jp nz,l374e ; Nope
ld hl,(l4452) ; Get current edit pointer
ld de,(l4468) ; Get back previous pointer
sbc hl,de ; Get difference
ret c ; Nothing to clear
ret z
ex de,hl ; Get length
l3ac5:
push de
call l41eb ; Make room
ld (hl),' ' ; Insert blank
pop de
dec e
jr nz,l3ac5
jp l374e
;
; Control: DELETE TO END OF LINE
;
l3ad2:
ld hl,(l4452) ; Get current edit pointer
push hl
call l3fc5
pop hl
push hl
ld de,l7b74+_LinLen-1
l3ade:
ld (hl),' ' ; Clear character
call cmp_hl_de ; Compare HL:DE
jr z,l3ae8 ; Match
inc hl ; Advance
jr l3ade
l3ae8:
pop hl
jp l4197
;
; Control: DELETE LINE
;
l3aec::
ld hl,l7b74
ld (l4452),hl ; Set current edit pointer
call l3fe7 ;set column?
call l3ad2 ; Delete to end of line
call l3e40 ; Sample character
ld hl,(l4450) ; Get current memory pointer
push hl
push hl
call findnexteol ; Find next end of line
pop de
jr c,l3b10 ; Out of text
or a
sbc hl,de ; Fet length
ld c,l
ld b,h
pop hl
jp nz,l3b26
ret
l3b10:
pop hl
jp l3d2c ; Restore line
l3b14:
call l3e44 ; Sample character
ld hl,(l4450) ; Get current memory pointer
call findnexteol ; Find next end of line
jp c,l3d2c ; Restore line if out of text
dec hl
dec hl
ld bc,2
or a
l3b26:
call l3f18
ld a,(l01b4) ; Test delete line implemented
or a
jr z,l3b3c ; Nope
call l0259 ; Delete line
ld a,(l0169) ; Get screen lines
dec a
call l3bbc
jp l3d2c ; Restore line
l3b3c:
call l4139
jp l3d2c ; Restore line
;
; Control: DELETE RIGHT WORD
;
l3b42:
call l3e23 ; Find last non blank
ld de,(l4452) ; Get current edit pointer
call cmp_hl_de ; Compare HL:DE
ex de,hl
jr c,l3b14 ; HL<DE
ld a,(hl)
cp ' ' ; Test blank
jr z,l3b8c
call l412a ; Find delimiter
jr c,l3b83 ; Yeap
l3b59:
call l4173
call l412a ; Find delimiter
jr c,l3b86 ; Yeap
jr l3b59
;
;
;
l3b63:
ld hl,(l4450) ; Get current memory pointer
call findprevline ; Find previous line
ret c ; Below start of text
call l37d2 ; Line up
call l377a ; Line right
jp l3b42 ; Delete right word
;
; Control: DELETE RIGHT CHARACTER
;
l3b73:
ld hl,(l4452) ; Get current edit pointer
jr l3b83 ; Go delete
;
; Control: DELETE LEFT CHARACTER
;
l3b78:
ld hl,(l4452) ; Get current edit pointer
call l3c02 ; move character left
jr c,l3b63 ; Beginning of line
ld (l4452),hl ; Set current edit pointer
l3b83:
call l4173
l3b86:
call l3fe7 ;set column?
jp l4197
l3b8c:
call l4173
ld a,(hl)
cp ' ' ; Test blank
jr z,l3b8c ; Skip them
jr l3b86
;
;
;
l3b96:
call l428f ; Test look ahead buffer empty
jp nz,l37a4 ; Nope, set edit cursor
call l3bac
jr nc,l3b96
jp l37a4 ; Set edit cursor
;
;
;
l3ba4:
call l3bac
jr nc,l3ba4
jp l37a4 ; Set edit cursor
;
; ????????????????????????????????????????????
; EXIT Carry set if row same as screen height
;
l3bac:
ld a,(l4475) ; Get current row
ld hl,l0169 ; Get screen lines
cp (hl) ; Compare
scf
ret z ; Same, so exit
inc (iy+9) ; Bump row
cp (iy+5) ; Test aginst row
ret z
;
;
;
l3bbc:
ld h,0 ; Set column
ld l,a ; Get row
push af
call l02a2 ; Position cursor
pop af
ld hl,(curstartofpage) ; Get start of screen
ld b,a
l3bc8:
dec b
jr z,l3bd8
call findnexteol ; Find next end of line
jr nc,l3bc8
call l3cec ; Make normal video
call l3c12 ; Clear line
xor a
ret
l3bd8:
call l3c1a
xor a
ret
;
;
;
l3bdd:
;gotonextchar,check eof
inc hl
ld de,(l4546) ; Get end of text
;
; Compare addresses
; ENTRY Regs HL and DE hold addresses
; EXIT Zero set if HL=DE
; Carry set if HL<DE
;
cmp_hl_de:
push hl
or a
sbc hl,de ; Compare
pop hl
ret
;
; move pointer right
; ENTRY Reg HL holds pointer
; EXIT Carry reset if pointer ou of limit
;
l3be8:
inc hl ; Point to next
ld de,l7b74+_LinLen-2
jr cmp_hl_de ; Compare HL:DE
;
; Fix to start of line
; ENTRY Reg HL holds text pointer
; EXIT Reg HL decremented by 1
; Carry set if HL < Start_of_Text
;
l3bee:
dec hl
ld de,(l4544) ; Get start of text
jr cmp_hl_de ; Compare HL:DE
;
; Find EOL of previous line
; ENTRY Reg HL holds current pointer
; EXIT Reg HL points to previous end
;
l3bf5:
ld a,lf
l3bf7:
call l3bee ; Fix to start of line
ret z ; Got it
jr c,l3c00 ; Here before start
cp (hl) ; Find new line
jr nz,l3bf7 ; Nope
l3c00:
inc hl ; Adjust pointer
ret
;
; move pointer left
; ENTRY Reg HL holds pointer
; EXIT Carry set if pointer out of limit
;
l3c02:
dec hl ; Get previous
ld de,l7b74 ; Init pointer
jr cmp_hl_de ; Compare HL:DE
;
;
;
l3c08:
;nextline
cp cr ; Test return
ret nz ; Nope
ld a,(hl)
call l3bdd ;gotonextchar,check eof
ret nc ;eof
jr l3c08
;
; Clear line
;
l3c12:
ld a,(l0168) ; Get screen columns
dec a
ld b,a
l3c17:
jp l3cf9 ; Clear to end of line
;
;
;
l3c1a:
call l3ca1
call l3cc0
ld a,(l446c) ;xscroll???
ld b,a
or a
jr z,l3c36
l3c27:
ld a,(hl)
call l3bdd
jr nc,l3c12 ; Clear line
call l3c08 ;nextline (hl after cr)
cp lf ; Test new line
jr z,l3c12 ; Clear line if so
djnz l3c27 ;skip xscroll chars???
l3c36:
ld a,(l0168) ; Get screen columns
dec a
ld b,a
bit 0,(iy+16)
jr z,l3c5e
l3c41:
call l3ca1
call l3cc0
push hl
call l3e23 ; Find last non blank
ld de,(l4452) ; Get current edit pointer
call l4191 ; Find min
ex de,hl ; Change to max
inc hl
ld (l4486),hl
ex de,hl
pop hl
call cmp_hl_de ; Compare HL:DE
jr nc,l3c89 ; Clear if HL>=DE
l3c5e:
call l3ca1
call l3cc0
ld de,(l4486)
call cmp_hl_de ; Compare HL:DE
jr z,l3c89 ; Clear if same
ld a,(hl)
call l3bdd ;gotonextchar,check eof
jr nc,l3c17 ; Clear line
call l3c08 ;nextline (hl after cr)
cp lf ; Test end of line
jr z,l3c17 ; Clear on new line
call l3c8b ; Process control character
djnz l3c5e
l3c7f:
ld a,(hl)
call l3bdd
jr nc,l3c89 ; Clear line
cp lf ; Test new line
jr nz,l3c7f
l3c89:
jr l3c17 ; Clear line
;
; Process control character
;
l3c8b:
cp ' ' ; Test control character
jr nc,l3c96 ; Nope
add a,'@' ; Make ASCII
push af
call l3c99 ; Select video
pop af
l3c96:
jp puttoconsole_a ; Put to console ;TODO speedup
;
; Select video
;
l3c99:
ld a,(l00e0) ; Get video mode
or a
jr z,l3cec ; Make normal video
jr l3cdf ; Set low video
;
;
;
l3ca1:
bit 0,(iy+16)
ret z
bit 0,(iy+20) ; Test block set
jr nz,l3cec ; Nope, make normal video
ld de,(l4464) ; Get block start address
call cmp_hl_de ; Compare HL:DE
jr c,l3cec ; Make normal video
ld de,(l4466) ; Get end of block pointer
call cmp_hl_de ; Compare HL:DE
jr c,l3cdf ; Set low video
jr l3cec ; Make normal video
;
;
;
l3cc0:
bit 0,(iy+16)
ret nz
bit 0,(iy+20) ; Test block set
jr nz,l3cec ; Nope, make normal video
ld de,(l4460) ; Get block start pointer
call cmp_hl_de ; Compare HL:DE
jr c,l3cec ; Make normal video
ld de,(l4462) ; Get block end pointer
call cmp_hl_de ; Compare HL:DE
jr z,l3cec ; Make normal video
jr nc,l3cec ; Make normal video
;
; Set low video
;
l3cdf:
ld a,(l00e0) ; Get video mode
or a ; Test enabled
ret z ; Nope
bit 0,(iy+7) ; Test selected
ret z ; Nope
jp setlowvideo ; Set low video
;
; Set normal video
;
l3cec:
ld a,(l00e0) ; Get video mode
or a ; Test enabled
ret nz ; Yeap
bit 0,(iy+7) ; Test selected
ret z ; Nope
jp setnormvideo ; Set normal video
;
; Clear to end of line
; ENTRY Reg B holds column position
;
l3cf9:
inc b ; Test position
dec b
ret z ; Ignore left margin
ld a,(l01bc) ; Test clear to end of line implemented
or a
jp nz,l0299 ; Yeap
l3d03:
ld a,' '
call puttoconsole_a ; Put blanks to console
djnz l3d03
ret
;
; Delete current line
;
l3d0b:
ld a,(l01b4) ; Test delete line implemented
or a
jr nz,l3d23 ; Yeap
ld (l4474),a ; Set no change
ld a,(l0169) ; Get screen lines
dec a
ld l,a ; Set row
ld h,0 ; Set column
call l02a2 ; Position cursor
ld a,lf
jp puttoconsole_a ; Put new line to console
l3d23:
ld hl,256*0+1
call l02a2 ; Position cursor
jp l0259 ; Delete line
;
; Control: RESTORE DELETED LINE
;
l3d2c:
ld hl,(l4450) ; Get current memory pointer
ld de,0
ld (l4464),de ; Reset start of block pointer
ld (l4466),de ; Reset end of block pointer
ld b,_LinLen ; Set max length
ld ix,l7b74 ; Set base address
ld (iy+1),0 ; Clear block state
l3d44: ;;;;;;
ld a,(hl)
ld de,(l4460) ; Get block start pointer
call cmp_hl_de ; Compare HL:DE
jr nz,l3d56 ; Not same addresses
ld (l4464),ix ; Set start of block pointer
set 0,(iy+1) ; Set start block
l3d56:
ld de,(l4462) ; Get block end pointer
call cmp_hl_de ; Compare HL:DE
jr nz,l3d67 ; Not same addresses
ld (l4466),ix ; Set end of block pointer
set 1,(iy+1) ; Set end block
l3d67:
cp cr ; Test end of line
jr nz,l3dc3 ; Nope
ld (ix+0),' ' ; Fill with blank
inc ix
dec b
jr z,l3dd9
call l3bdd
jr nc,l3d44
l3d79:
ld de,(l4462) ; Get block end pointer
call cmp_hl_de ; Compare HL:DE
jr nc,l3d8a ; HL>= Start_Of_Block
push hl
ld hl,-1
ld (l4466),hl ; Set end of block pointer
pop hl
l3d8a:
ld de,(l4460) ; Get block start pointer
call cmp_hl_de ; Compare HL:DE
jr nc,l3d99 ; HL>= End_Of_Block
ld hl,-1
ld (l4464),hl ; Set start of block pointer
l3d99: ;;;;;
ld a,_LinLen
sub b ; Calculate remaining length
ld (l446f),a ; Save relative column
l3d9f:
ld (ix+0),' ' ; Fill with blanks
inc ix
djnz l3d9f
ld hl,(l4452) ; Get current edit pointer
call l3fe7 ;set column?
bit 0,(iy+14)
set 0,(iy+14)
jp nz,l374e
ld a,(l4475) ; Get current row
dec a
cp (iy+5) ; Test against row
ret nc
jp l374e
l3dc3:
cp lf ; Test end of line
jr z,l3d79 ; Yeap
ld (ix+0),a ; Store character
inc ix
dec b ; Test still room
jr nz,l3dd1 ; Yeap
jr l3dd9 ; Line too long
l3dd1:
call l3bdd
jr nc,l3d79
jp l3d44
l3dd9:
call l3e04 ; Tell error
db 'Line too long - CR inserted'
db null
call l3f12
ld hl,_LinLen-2
call l3970
jp l3d2c ; Restore line
;
;
;
l3e04:
call l3ba4
l3e07:
call l3e0d ; Set cursor
jp l4211
;
; Set cursor home
;
l3e0d:
ld (iy+8),0 ; Set no change
ld hl,256*0+0
call l02a2 ; Position cursor
call l3c12 ; Clear line
ld hl,256*0+0
call l02a2 ; Position cursor
jp l3cdf ; Set low video
;
; Find last non blank in current line
; EXIT Reg HL holds pointer to non blank
;
l3e23:
ld a,' ' ; Set what we are looking for
ld hl,l7b74+_LinLen-1
ld de,l7b74-1 ; Init pointers
l3e2b:
cp (hl) ; Test match
ret nz ; Nope, got it
dec hl
call cmp_hl_de ; Test beginning
jr nz,l3e2b ; Nope
ret
;
; Get pointer within limits
; ENTRY Reg HL holds 1st pointer
; Reg BC holds 2nd pointer
; EXIT Reg HL unchanged if out of line
; Reg HL holds MIN(HL,BC) else
;
l3e34:
ld de,l7b74+_LinLen
call cmp_hl_de ; Compare HL:DE
ret nc ; End found
ld d,b
ld e,c
jp l4191 ; Find min
;
; Poll character, insert at end of line
;
l3e40:
call l3e23 ; Find last non blank
inc hl ; Skip over
;
; Poll character, insert at current position
; ENTRY Reg HL holds current text address
;
l3e44:
ld c,l ; Copy pointer
ld b,h
ld hl,(l4464) ; Get start of block pointer
call l3e34 ; Fix it
ld (l4464),hl ; Set start of block pointer
ld hl,(l4466) ; Get end of block pointer
call l3e34 ; Fix it
ld (l4466),hl ; Set end of block pointer
ld l,c
ld h,b
inc hl
ld de,l7b74
or a
sbc hl,de ; Get relative position
push hl
ld a,(l446f) ; Get relative column
sub l ; Subtract it
ld c,a
ld b,0 ; Expand for 16 bits
jr nc,l3e6d
ld b,-1 ; Signed expansion
l3e6d:
ld hl,(l4450) ; Get current memory pointer
call nz,l3f18
pop bc
ld ix,(l4450) ; Get current memory pointer
ld hl,l7b74 ; Load base
ld b,c ; Copy position
dec b ; Test any
inc b
jr z,l3ea5 ; Nope
l3e80:
ld a,(hl) ; Get character
ld de,(l4464) ; Get start of block pointer
call cmp_hl_de ; Compare HL:DE
jr nz,l3e8e ; Not the same
ld (l4460),ix ; Set block start pointer
l3e8e:
ld de,(l4466) ; Get end of block pointer
call cmp_hl_de ; Compare HL:DE
jr nz,l3e9b ; Not the same
ld (l4462),ix ; Set block end pointer
l3e9b:
ld (ix+0),a ; Unpack character
inc hl
inc ix
djnz l3e80
dec ix
l3ea5:
ld a,cr
ld (ix+0),a ; Set end of line
ret
;
; Display characters left and check enough memory
;
l3eab:
ld hl,(l4548) ; Get top of available memory
or a
sbc hl,de ; Test remainder
jr c,l3ed9 ; Nope
ld bc,l00fe
sbc hl,bc ; Test min
ret nc ; Yeap
add hl,bc
push hl
call l3e0d ; Set cursor
pop hl
ld b,0
call l30fe ; Tell bytes left
call l4211
db ' byte(s) left'
db null
call l3f12 ; Wait for quit
ret
l3ed9:
call l3e04
db 'ERROR: Out of space'
db null
call l3f12 ; Wait for quit
jp l2ebd
;
; Test editor function cancelled
;
l3ef6:
cp a_CAN ; Test cancel
ret nz ; Nope
call l3e04
db '*** INTERRUPTED'
db null
call l3f12 ; Wait for quit
jp l2ebd
;
; Clear ahaed buffer and wait for user quit
;
l3f12:
call l422b ; Clear look ahead buffer
jp l2e76 ; Get ESCape
;
;
;
l3f18:
push hl
push bc
jr nc,l3f96
ld de,(l4546) ; Get end of text
push de
push de
ex de,hl
or a
sbc hl,de
ex (sp),hl
or a
sbc hl,bc
jp nc,l3ed9
ld e,l
ld d,h
push de
call l3eab ; Test enough room
pop de
pop bc
inc bc
pop hl
ld (l4546),de ; Set end of text
ld a,b
l3f3c:
sub HIGH _SavLen
jr c,l3f4d
ld b,a
push bc
ld bc,_SavLen
lddr ; move down
pop bc
call l4232 ; Poll character from input
jr l3f3c
l3f4d:
ld a,c
or b
jr z,l3f53
lddr
l3f53:
pop bc
pop hl
ex de,hl
inc de
ld hl,(l4460) ; Get block start pointer
call l3f8e
ld (l4460),hl ; Set block start pointer
ld hl,(l4462) ; Get block end pointer
call l3f8e
ld (l4462),hl ; Set block end pointer
ld hl,(curstartofpage) ; Get start of screen
call l3f8e
ld (curstartofpage),hl ; Set start of screen
ld hl,(l4450) ; Get current memory pointer
call l3f8e
ld (l4450),hl ; Set current memory pointer
ld hl,(l4454) ; Get block pointer
call l3f8e
ld (l4454),hl ; Set block pointer
ld hl,(l4458) ; Get edit pointer
call l3f8e
ld (l4458),hl ; Set edit pointer
ret
;
;
;
l3f8e:
call cmp_hl_de ; Compare HL:DE
ret c
or a
sbc hl,bc
ret
;
;
;
l3f96:
push hl
add hl,bc
push hl
ld de,(l4546) ; Get end of text
inc de
ex de,hl
or a
sbc hl,de
ld c,l
ld b,h
pop hl
pop de
ld a,b
l3fa7:
sub HIGH _SavLen
jr c,l3fb8
ld b,a
push bc
ld bc,_SavLen
ldir ; move up
pop bc
call l4232 ; Poll character from input
jr l3fa7
l3fb8:
ld a,c
or b
jr z,l3fbf
ldir
dec de
l3fbf:
ld (l4546),de ; Set end of text
jr l3f53
;
;
;
l3fc5:
push hl
ld de,(l4464) ; Get start of block pointer
call l4191 ; Find min
bit 0,(iy+1) ; Test start block
jr z,l3fd6 ; Nope
ld (l4464),hl ; Set start of block pointer
l3fd6:
pop hl
bit 1,(iy+1) ; Test end block
ret z ; Nope
ld de,(l4466) ; Get end of block pointer
call l4191 ; Find min
ld (l4466),hl ; Set end of block pointer
ret
;
;
;set column?
l3fe7:
ld de,l7b74 ; Get base address
ld a,(l0168) ; Get screen columns
dec a
ld c,a
or a
sbc hl,de
ld a,l
sub (iy+0)
jr c,l4012
cp c
jr c,l400e
sub c
inc a
add a,(iy+0)
ld (l446c),a ;xscroll???
ld a,(l0168) ; Get screen columns
dec a
dec a
ld (l4470),a ; Set column to end
jp l3762
l400e:
ld (l4470),a ; Set column
ret
l4012:
add a,(iy+0)
ld (l446c),a ;xscroll???
ld (iy+4),0 ; Clear column
jp l3762
;
;
;
l401f:
bit 0,(iy+7)
ret z
ld hl,(curstartofpage) ; Get start of screen
ld de,(l4544) ; Get start of text
call l4191 ; Find min
ex de,hl
ld (curstartofpage),hl ; Set max for start of screen
ld bc,1
ld de,(l4450) ; Get current memory pointer
call cmp_hl_de ; Compare HL:DE
jp z,l40da ; Same
jr c,l4086 ; HL < Current_Pointer
l4041:
ld de,(l4450) ; Get current memory pointer
call cmp_hl_de ; Compare HL:DE
jr z,l4055 ; Same
call findprevline ; Find previous line
inc bc
ld a,c
or a
call z,l4232 ; Poll character from input
jr l4041
l4055:
ld (curstartofpage),hl ; Set start of screen
ld (iy+5),1 ; Init row
set 0,(iy+14)
ld a,b
or a
jr nz,l4083 ; Test row
ld a,(l01ae) ; Test insert line implemented
or a
jr z,l4083 ; Nope
ld a,(l0169) ; Get screen lines
dec a
cp c
jr c,l4083
dec c
ld hl,256*0+1
call l02a2 ; Position cursor
dec c
push af
inc c
l407b:
call l0262 ; Insert line
dec c
jr nz,l407b
pop af
ret z
l4083:
jp l4147 ; Reset row
l4086:
ld de,(l4450) ; Get current memory pointer
call cmp_hl_de ; Compare HL:DE
jr z,l409a ; Same
call findnexteol ; Find next end of line
inc bc
ld a,c
or a
call z,l4232 ; Poll character from input
jr l4086
l409a:
ld a,b
or a
jr nz,l40de
ld a,(l0169) ; Get screen lines
dec a
ld e,a
ld a,c
sub e
ld d,a
inc d
jr c,l40da
dec d
jr nz,l40b3
bit 0,(iy+21)
jp nz,l4103
l40b3:
inc d
sub e
jr nc,l40de
ld a,(l4475) ; Get current row
sub d ; Test row
jr c,l40de
jr z,l40de
ld (l4475),a ; Set row
ld hl,(curstartofpage) ; Get start of screen
ld b,d
push de
l40c7:
call findnexteol ; Find next end of line
push hl
call l3d0b ; Delete current line
pop hl
djnz l40c7
ld (curstartofpage),hl ; Set start of screen
pop de
l40d5:
dec e
ld (iy+5),e ; Set row
ret
l40da:
ld (iy+5),c ; Set row
ret
l40de:
ld hl,(curstartofpage) ; Get start of screen
dec bc
ld a,(l0169) ; Get screen lines
sub 3
ld e,a
ld a,c
sub e
ld c,a
jr nc,l40ee
dec b
l40ee:
call findnexteol ; Find next end of line
dec bc
ld a,c
or b
jr nz,l40ee
ld (curstartofpage),hl ; Set start of screen
call l4147 ; Reset row
set 0,(iy+14)
jp l401f
l4103:
call l40d5
ld a,(l4475) ; Get current row
ld l,a
ld a,(l0169) ; Get screen lines
cp l
ld a,l
jr z,l4117
dec a
jr z,l4117
ld (l4475),a ; Set row
l4117:
ld hl,(curstartofpage) ; Get start of screen
call findnexteol ; Find next end of line
ld (curstartofpage),hl ; Set start of screen
call l3d0b ; Delete current line
ld a,(l0169) ; Get screen lines
dec a
jp l3bbc
;
; Find delimiter
; ENTRY Reg HL points to current text
; EXIT Carry set if delimiter found
;
l412a:
ld de,(l7b72) ; Get pointer to delimiters
l412e:
ld a,(de) ; Test end of list
or a
ret z ; Yeap
cp (hl) ; Compare
jr z,l4137 ; Got it
inc de
jr l412e
l4137:
scf
ret
;
; Delete line if no ESC sequence present
;
l4139:
push af
ld a,(l4471) ; Get row
cp (iy+9) ; Compare
jr nc,l4145
ld (l4475),a ; Set row
l4145:
pop af
ret
;
; Reset row
;
l4147:
ld (iy+9),1 ; Init row
ret
;
; Adjust pointer for inserting characters
; ENTRY Reg BC holds number of characters to be inserted
;
l414c:
ex de,hl
bit 0,(iy+1) ; Test start block
jr z,l415f ; Nope
ld hl,(l4464) ; Get start of block pointer
call cmp_hl_de ; Compare HL:DE
jr c,l415f ; Start_of_block < DE
add hl,bc ; Add offset
ld (l4464),hl ; Set start of block pointer
l415f:
bit 1,(iy+1) ; Test end block
jr z,l4171 ; Nope
ld hl,(l4466) ; Get end of block pointer
call cmp_hl_de ; Compare HL:DE
jr c,l4171 ; End_of_block < DE
add hl,bc ; Add offset
ld (l4466),hl ; Set end of block pointer
l4171:
ex de,hl
ret
;
;
;
l4173:
push hl
ld bc,-1
call l414c ; Delete one character
ex de,hl
ld hl,l7b74+_LinLen-1
or a
sbc hl,de
jr z,l418a ; Same
ld c,l
ld b,h
ld l,e
ld h,d
inc hl
ldir ; Unpack
l418a:
ld hl,l7b74+_LinLen-1
ld (hl),' ' ; Clear last entry
pop hl
ret
;
; Get minimum of two addresses
; ENTRY Reg HL holds 1st address
; Reg DE holds 2nd address
; EXIT Regs swapped if 1st >= 2nd
;
l4191:
call cmp_hl_de ; Compare HL:DE
ret c ; HL < DE
ex de,hl ; Swap
ret
;
;
;
l4197:
call l37a4 ; Set edit cursor
ld a,(l0168) ; Get screen columns
dec a
sub (iy+4) ; Subtract from column
ld hl,(l4452) ; Get current edit pointer
ld b,a
set 0,(iy+16)
call l3c41
res 0,(iy+16)
ret
;
; Adjust for next end of line
; ENTRY Reg HL holds current pointer
; EXIT Reg HL holds pointer to next line
; Carry set if pointer behind end address
;
findnexteol:
push bc
ex de,hl
ld hl,(l4546) ; Get end of text
dec hl
or a
sbc hl,de ; Build difference
ld b,h
ld c,l
inc bc
ex de,hl
ld d,h
ld e,l
jr c,l41cc ; Out of text
ld a,lf
cpir ; Find new line
jp po,l41cc
or a
pop bc
ret
l41cc:
scf ; Set out of text
ex de,hl
pop bc
ret
;
; Adjust for previous end of line
; ENTRY Reg HL holds current pointer
; EXIT Reg HL holds pointer to previous line
; Carry set if pointer below start address
;
findprevline:
push bc
ld c,l ; Save pointer
ld b,h
ld a,lf
call l3bee ; Fix to start of line
jr c,l41e7 ; Below
l41da:
call l3bee ; Fix to start of line
jr z,l41e5 ; Got start
jr c,l41e7 ; It's below start
cp (hl) ; Find line feed
jr nz,l41da ; Nope
inc hl
l41e5:
pop bc
ret
l41e7:
ld h,b ; Restore pointer
ld l,c
pop bc
ret
;
; Adjust pointer for inserting one character
;
l41eb:
push hl
ld bc,1
call l414c ; Adjust pointer for inserting one character
ld de,l7b74+_LinLen-1
ex de,hl
or a
sbc hl,de ; Get difference
dec hl
ld c,l
ld b,h
ld de,l7b74+_LinLen-2
ld l,e
ld h,d
dec hl
ld a,c
or b ; Test any
jr z,l420c ; Nope
push de
lddr ; move characters
pop hl
ld (hl),' ' ; Clear character
l420c:
pop hl
ret
;
; Position cursor and give immediate string
; ENTRY Reg H holds column
; Reg L holds row
;
l420e:
call l02a2 ; Position cursor
l4211:
jp l01fa ; Give string
;
; #####################################################
; >>> Redirected console output during edit session <<<
; #####################################################
;
l4214:
pop hl
ex (sp),hl
bit 0,(iy+7)
jr z,l4220
push hl
l421e equ $+1
call a_DUMMY ; *** REDIRECTED ***
l4220:
ld a,(l4543)
sub 2
ld (l4543),a
ret nz
jr l423e ; Poll character from input
;
; Clear look ahead buffer
;
l422b:
ld hl,(l445c) ; Get input queue pointer
ld (l445e),hl ; Set for output queue pointer
ret
;
; Poll character from input
;
l4232:
push af
push bc
push de
push hl
call l423e ; Poll character from input
pop hl
pop de
pop bc
pop af
ret
;
; Poll character from input without register preserving
;
l423e:
ld hl,(l445e) ; Get output queue pointer
call l4263 ; Bump it
ld de,(l445c) ; Get input queue pointer
ex de,hl
sbc hl,de ; Test room in output queue
ex de,hl
ret z ; Nope
push hl
push ix
push iy
YIELD
if TERM
GETKEY_ ;call l00a0 ; Test key pressed
else
GET_KEY ;call l00a0 ; Test key pressed
endif
pop iy
pop ix
pop hl
or a
ret z ; No character available
;call readfromkbd ; Read character
ld (hl),a ; Store it
ld (l445e),hl ; Set output queue pointer
ret
;
; Bump and check ahead pointer
; ENTRY Reg HL holds current pointer
; EXIT Reg HL holds position within the queue
;
l4263:
inc hl ; Bump pointer
ld de,l7b59+_Ahead
or a
ex de,hl
sbc hl,de ; Test end of queue
ex de,hl
ret nz ; Nope
ld hl,l7b59 ; Set start of queue
ret
;
; Get character from console or ahead buffer
;
l4271:
push hl
push de
ld de,(l445c) ; Get input queue pointer
ld hl,(l445e) ; Get output queue pointer
or a
sbc hl,de ; Test any in buffer
ex de,hl
jr z,l4289 ; Nope, buffer is empty
call l4263 ; Bump queue pointer
ld a,(hl) ; Get character
ld (l445c),hl ; Set input queue pointer
jr l428c
l4289:
call readfromkbd ; Read character
l428c:
pop de
pop hl
ret
;
; Test look ahead buffer empty - Z set says yes
;
l428f:
push hl
push de
ld de,(l445c) ; Get input queue pointer
ld hl,(l445e) ; Get output queue pointer
or a
sbc hl,de
pop de
pop hl
ret
;
l429e:
dw l7bf5 ; Base of message file
l42a0:
db eof
if 1==0
;default key codes
l42a1::
; Basic movement
db 1,0dh
db 1,1
db 1,0ffh
db 1,6
db 1,0fah
db 1,0fbh
db 1,1fh
db 1,1eh
db 1,0f5h
db 1,0f4h
db 1,0f8h
db 1,0f9h
; Extended movement
db 1,0f6h
db 1,0f7h
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
; Insert and delete commands
db 1,0e0h
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
; Block commands
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
; More commands
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
db 1,0ffh
;
db 0,0ffh
db 1,0ffh
;
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0
endif
l4369::
;
; Basic movement
;
db 1,'M'-'@'
db 1,key_left;'S'-'@'
db 1,key_left;'H'-'@'
db 1,key_right;'D'-'@'
db 1,'A'-'@'
db 1,'F'-'@'
db 1,key_up;'E'-'@'
db 1,key_down;'X'-'@'
db 1,'W'-'@'
db 1,'Z'-'@'
db 1,key_pgup;'R'-'@' ;pgup
db 1,key_pgdown;'C'-'@' ;pgdn
;
; Extended movement
;
db 1,key_home;2,'Q'-'@','S'-'@' ; LINE LEFT (home)
db 1,key_end;2,'Q'-'@','D'-'@' ; LINE RIGHT (end)
db 2,'Q'-'@','E'-'@' ; BOTTOM OF SCREEN
db 2,'Q'-'@','X'-'@' ; TOP OF SCREEN
db 2,'Q'-'@','R'-'@' ; BEGIN OF TEXT
db 2,'Q'-'@','C'-'@' ; END OF TEXT
db 2,'Q'-'@','B'-'@' ;to begin of block
db 2,'Q'-'@','K'-'@' ;to end of block
db 2,'Q'-'@','P'-'@' ;last cursor position
;
; Insert and delete commands
;
db 1,key_ins;'V'-'@' ;insert mode on/off
db 1,'N'-'@' ;insert line
db 1,'Y'-'@' ;delete line
db 2,'Q'-'@','Y'-'@' ;delete to end of line
db 1,'T'-'@' ;delete right word
db 1,key_del;'G'-'@'
db 1,key_backspace;DEL
db 1,key_backspace;0ffh
;
; Block commands
;
db 2,'K'-'@','B'-'@'
db 2,'K'-'@','K'-'@'
db 2,'K'-'@','T'-'@'
db 2,'K'-'@','H'-'@'
db 2,'K'-'@','C'-'@'
db 2,'K'-'@','V'-'@'
db 2,'K'-'@','Y'-'@'
db 2,'K'-'@','R'-'@'
db 2,'K'-'@','W'-'@'
;
; More commands
;
db 1,key_esc;db 2,'K'-'@','D'-'@'
db 1,'I'-'@'
db 2,'Q'-'@','I'-'@'
db 2,'Q'-'@','L'-'@'
db 2,'Q'-'@','F'-'@'
db 2,'Q'-'@','A'-'@'
db 1,'L'-'@'
db 1,'P'-'@'
db 0
l43de::
db '<>,[].*+-/$:=(){}^#'''
l43f2::
db ' ',null
l43f4::
;
; Basic movement
;
dw l38e6 ; NEW LINE
dw l3984 ; CURSOR LEFT
dw l3984 ; CURSOR LEFT
dw l3991 ; CURSOR RIGHT
dw l39ea ; WORD LEFT
dw l3a0b ; WORD RIGHT
dw l37d2 ; LINE UP
dw l37ad ; LINE DOWN
dw l37e0 ; SCROLL UP
dw l3822 ; SCROLL DOWN
dw l389c ; PAGE UP
dw l3872 ; PAGE DOWN
;
; Extended movement
;
dw l3771 ; LINE LEFT (home)
dw l377a ; LINE RIGHT (end)
dw l384d ; BOTTOM OF SCREEN
dw l385f ; TOP OF SCREEN
dw l38bc ; BEGIN OF TEXT
dw l3768 ; END OF TEXT
dw l373c ; BEGIN OF BLOCK
dw l3745 ; END OF BLOCK
dw l399a ; LAST CURSOR POSITION
;
; Insert and delete commands
;
dw l378f ; TOGGLE INSERT/OVERWRITE
dw MMSB+l393b ; INSERT LINE
dw MMSB+l3aec ; DELETE LINE
dw MMSB+l3ad2 ; DELETE TO END OF LINE
dw MMSB+l3b42 ; DELETE RIGHT WORD
dw MMSB+l3b73 ; DELETE RIGHT CHARACTER
dw MMSB+l3b78 ; DELETE LEFT CHARACTER
dw MMSB+l3b78 ; DELETE LEFT CHARACTER
;
; Block commands
;
dw l3726 ; MARK BEGIN OF BLOCK
dw l3702 ; MARK END OF BLOCK
dw l39ac ; MARK SINGLE WORD
dw l36f9 ; TOGGLE BLOCK DISPLAY
dw MMSB+l3620 ; COPY BLOCK
dw MMSB+l35fb ; MOVE BLOCK
dw MMSB+l36a1 ; DELETE BLOCK
dw MMSB+l3573 ; READ BLOCK FROM FILE
dw l34ed ; WRITE BLOCK TO FILE
;
; More commands
;
dw l2b0f ; EXIT EDITOR
dw MMSB+l3a72 ; TABULATE
dw l379b ; TOGGLE TABULATE
dw MMSB+l3d2c ; RESTORE DELETED LINE
dw l31f1 ; FIND STRING
dw l323b ; FIND AND REPLACE STRING
dw l324b ; REPEAT LAST SEARCH
dw MMSB+l2f02 ; CONTROL PREFIX
l4450::
dw 0 ; Current memory pointer
l4452:
dw l7b74 ; Current edit pointer
l4454:
dw 0 ; Block pointer
l4456:
dw l7b74
l4458:
dw 0 ; Edit pointer
l445a:
dw l7b74
l445c:
dw l7b59 ; Input queue pointer
l445e:
dw l7b59 ; Output queue pointer
l4460:
dw 0 ; Block start pointer
l4462:
dw 0 ; Block end pointer
l4464:
dw 2 ; Block start pointer
l4466:
dw 2 ; Block end pointer
l4468:
dw 0 ; Temporry edit pointer
curstartofpage:
dw 0 ; Start of screen
;
; The editor status block
;
l446c:
db 0 ; + 0 xscroll???
db 0 ; + 1: Block state
; xxxxxxx1: Start set)
; xxxxxx1x: End set)
db 1 ; + 2
l446f:
db 1 ; + 3: Relative column
l4470:
db 0 ; + 4: Editor column
l4471:
db 1 ; + 5: Editor row
l4472:
db 0 ; + 6: Insert flag (Bit 0=0)
db 1 ; + 7: Video flag (1 is reverse)
l4474:
db 0 ; + 8: Change flag
l4475:
db 1 ; + 9: Editor row
l4476:
db 0 ; +10
db 0 ; +11
l4478:
db 0 ; +12
l4479:
db 0 ; +13: Auto tabulate flag
db 1 ; +14
db 1 ; +15
db 0 ; +16
l447d:
db 0 ; +17: Option flags for search/replace
; 00000001: W: Whole word search
; 00000010: N: No request
; 00000100: U: Ignore case
; 00001000: G: Global search
; 00010000: B: Backwards
l447e:
db 0 ; +18: Find (0) or replace (-1) flag
l447f:
db 0 ; +19: Text change flag
l4480:
db 0 ; +20: Block marker (1: Not set)
db 0 ; +21
l4482:
db 3 ; +22
l4483:
db 0,0,0
l4486:
db 0,0
l4488:
dw 0 ; End of search pointer
l448a:
dw 0 ; Search loop count
l448c:
dw 0
l448e:
dw 0
;
; Search buffer
;
l4490:
db 1eh
l4491:
db 0
l4492:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0
;
; Replace buffer
;
l44b1:
db 1eh
l44b2:
db 0
l44b3:
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0
;
; Option buffer
;
l44d2:
db 0ah
db 0,0,0,0,0,0,0,0,0,0,0,0
;
; Block file name
;
l44df:
db 0fh
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
l44f1:
db 0 ; File flag
l44f2:
db 0 ; Rename flag (1 is rename)
l44f3:
db 1 ; Compile flag:
; 1: Compile to memory
; 2: Compile to COM-file
; 3: Compile to CHN-file
l44f4:
dw l20e2 ; Start address of compiler
l44f6:
dw 0 ; Top of available memory
l44f8:
db 0 ; Logged disk
l44f9:
ds FCBlen ; Main file
l451d:
ds FCBlen
l4541:
db 0 ; Error message file flag (0 is not read)
l4542:
db 0 ; Compile flag
l4543:
db 0
l4544:
dw l7bf5 ; Start of text
l4546:
dw l7bf5 ; End of text
l4548:
dw 0 ; Top of available memory
;
; %%%%%%%%%%%%%%%%%%%%%%
; %%% COMPILER ENTRY %%%
; %%%%%%%%%%%%%%%%%%%%%%
;
COMPILE:
ld (l7b71),sp ; Save stack
ld hl,(l4546) ; Get end of text
inc hl
ld (MemsTop),hl ; Save for memory top
inc h ; Allow a gap of 1024 bytes
inc h
inc h
inc h
ld (COMsTop),hl ; Save for top of .COM file
ld hl,(l790a) ; Get end of code
ld (DataBeg),hl ; Save for start of data
xor a
ld h,a
ld l,a
ld (l7b91),a ; Clear ????
ld (l7b92),a ; Clear ????
ld (l7b94),a ; Clear ????
ld (l7ba2),a ; Clear end of file
ld (l7ba0),a ; Clear end on break [option U+]
ld (BackLevel),a ; Clear back fix level
ld (IncFlg),a ; Enable memory read
ld (l7b96),a ; Clear OVERLAY number
ld (RRN_stat ),a ; Clear file access
ld (RRN_off),hl ; Clear record base
ld (l7bef),hl ; Clear line count
call l718f ; Test abort
dec hl
ld (FFCB+_rrn),hl ; Set highest record
ld a,_Char+1 ;13=element of a set???
ld (curtype_l7b93),a ; Set special type
ld a,0xff-(__Ropt+__Uopt)
ld (l7b9d),a ; Set default options
ld a,2*DefWITH
ld (l7bc7),a ; Set depth for WITH
ld hl,(l4544) ; Get start of text
ld (l7bd7),hl ; Init source pointer
ld (l7bd9),hl
ld ix,l79d7 ; Init start of line
ld (ix+0),null ; Set line empty
ld hl,(l7904) ; Get code start address
call ChkChn ; Check chaining
ld hl,(l4548) ; Get top of available memory
dec hl
ld (l7b77),hl ; Save
ld d,h
ld e,l
ld bc,LenLab ; Get length of internal table
or a
sbc hl,bc
ld (LabPtr),hl ; Init label pointers
ld (PrevLabPtr),hl
ld (CurLab),hl
call ChkOvfl ; Check enough memory
ld hl,l731f+LenLab-1
lddr ; Unpack symbol table
call l45ea ; Go compile
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to file
jr nz,l45e2 ; Nope
call FixBack ; Fix back level
call writerecord_TmpBuff ; Write record
ld c,_close
ld de,FFCB
call _BDOS ; must close output file!!!
l45e2:
ld (l7906),iy ; Save new top of code
xor a
jp l72e3 ; Set special zero error
;
; Do the compiler task
;
l45ea:
call GetLine ; Process line
call FindStr ; Find PROGRAM
dw l7529
jr nz,l460a ; Nope
call l4692 ; Build dummy label
call l6f1b ; Test (
jr nz,l4607 ; Nope
l45fc:
call l4692 ; Build dummy label
call l6f13 ; Test ,
jr z,l45fc ; Yeap, get next dummy
call l6f6e ; Verify )
l4607:
call l6f48 ; Verify ;
l460a:
ld a,_LD.SP
ld hl,0x0100;TPA
call StCode ; Set LD SP,TPA
ld hl,l79d7 ; Get start of source line
ld a,(CmpTyp) ; Get compile flag
or a ; Test compile to memory
jr z,l4621 ; Yeap
ld de,l0080
call VarAlloc ; Allow space for loader
l4621:
call StLD.HL ; Set LD HL,L79D7
ld a,(l7b9d) ; Get options
bit _Copt,a ; Test $C+
ld d,0
jr z,l462e ; Nope
dec d
l462e:
push de ; Save flag
ld a,_LD.BC
call writebyte_a_addriy ; Set LD BC,FLAG
push iy ; Save PC
call writeword_hl_addriy ; Set dummy word
ld hl,l0364
call StCALL_ ; Set CALL INIPRG
ld a,_LD.HL
call writebyte_a_addriy ; Set LD HL,1STFREE
push iy ; Save PC
call writeword_hl_addriy ; Set dummy word
ld a,_LD.DE
call writebyte_a_addriy ; Set LD DE,LASTFREE
push iy ; Save PC
call writeword_hl_addriy ; Set dummy word
ld hl,(l790a) ; Get end of code
call StLD.BC ; Set LD BC,TOPRAM
ld a,(CmpTyp) ; Get compile flag
ld h,a
ld l,_LD.A
call writeword_hl_addriy ; Set LD A,FLAG
ld hl,l04d4
call StCALL_ ; Set CALL RANGCHK
call l469e ; Do a block
call l52fc
ld a,(ix+0)
cp '.' ; Verify closing .
call ErrNZ
db _DotExp
ld hl,l20d4
call StJP_ ; Set JP HALT
pop hl ; Get back PC for LASTFREE
ld de,(DataBeg) ; Get start of data
call storeback_de_to_addrhl ; Store back
pop hl ; Get back PC for 1STFREE
call storeback_iy_to_addrhl ; Store back current PC
pop hl ; Get back PC for FLAG
pop de ; Get FLAG
ld a,(l7ba0) ; Get end on break flag [option U+]
ld e,a
jp storeback_de_to_addrhl ; Store it back
;
; Build dummy label
;
l4692:
ld hl,(LabPtr) ; Get label pointer
push hl ; Save it
call GetLabel ; Get label
pop hl
ld (LabPtr),hl ; Restore label pointer
ret
;
; Perform a block
;
l469e:
ld a,(l7bc7) ; Get depth for WITH
push af
add a,a ; Double it
ld e,a
ld d,0
call VarAlloc ; Allocate space for it
push hl
call StJP ; Set JP
push iy ; Save PC
push hl
call writeword_hl_addriy ; Set dummy word
l46b3:
call FndTabStr ; Find statement
db _Byte
dw l7584
call ErrNZ ; Must be
db _BEGINexp
ld a,(hl) ; Get type
l46be:
cp _Label ; Test LABEL
jr nz,l46c7 ; Nope
call l488e ; Process it
jr l46b3
l46c7:
cp _Const ; Test CONST
jr nz,l46d0 ; Nope
call l48b7 ; Process it
jr l46be
l46d0:
cp _Type ; Test TYPE
jr nz,l46d9 ; Nope
call l4aeb ; Process it
jr l46be
l46d9:
cp _Var ; Test VAR
jr nz,l46e6 ; Nope
call l4b2a ; Process it
ld hl,(DataBeg) ; Get start of data
ex (sp),hl
jr l46be
l46e6:
cp _Overly ; Test OVERLAY
jp nz,l485e
ld a,(CmpTyp) ; Get compile flag
or a
call ErrZ ; Must not be compiled to memory
db _OvlDirErr
ld hl,FFCB+Fdrv
ld de,l7bb2
ld bc,Fname
ldir ; Copy name of file
ld hl,l7b96 ; Point to OVERLAY number
ld a,(hl) ; Get current number
inc (hl) ; Advance it
ex de,hl ; Get pointer to extension
ld (hl),'0' ; Init extension
inc hl
ld b,'0'-1 ; Init tens
l4709:
inc b ; Divide by ten
sub 10
jr nc,l4709
ld (hl),b ; Save tens
inc hl
add a,'9'+1 ; Calculate units
ld (hl),a ; Save it
ld hl,l1c59
call StCALL_ ; Set CALL OVERLAY
ld hl,-1
call writeword_hl_addriy ; Save word
ld hl,l7bb2 ; Point to name
ld b,Fname+Fext
l4724:
ld a,(hl)
call writebyte_a_addriy ; Store name and extension
inc hl
djnz l4724
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to file
jr nz,l473b ; Nope
call FixBack ; Fix back level
xor a
ld (BackLevel),a ; Set back fix level
call writerecord_TmpBuff ; Write record
l473b:
ld hl,(RRN_off) ; Get record base
push hl
ld hl,(CodePC) ; Get code pointer
push hl
ld hl,(l7bb0) ; Get length of overlay
push hl
ld (CodePC),iy ; Set code pointer
ld hl,0
ld (l7bb0),hl ; Clear length of overlay
ld hl,-FCBlen
add hl,sp ; Let some space on stack for FCB
ld sp,hl
ex de,hl
ld hl,FFCB
ld bc,FCBlen
ldir ; Unpack current FCB
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to file
jr nz,l478c ; Nope
ld hl,l7bb2
ld de,FFCB+Fdrv
ld bc,Fname+Fext
ldir ; Copy overlay FCB to .COM FCB
ex de,hl
ld b,FCBlen-Fdrv-Fname-Fext
l4773:
ld (hl),0 ; Clear remainder of FCB
inc hl
djnz l4773
ld de,FFCB
push de
ld c,_delete
call _BDOS ; Delete file
pop de
ld c,_make
call _BDOS ; Create new one
inc a
call ErrZ ; Must be success
db _NoOvl
l478c:
xor a
ld (RRN_stat ),a ; Clear file access
ld (RecPtr),a ; Clear record pointer
ld hl,(DataBeg) ; Get start of data
ld (l7bab),hl ; Set for overlay
l4799:
call FndTabStr ; Find PROCEDURE or FUNCTION
db 1
dw l75a7
call ErrNZ ; Must be either
db _SUBexp
ld a,(hl) ; Get type
push iy
ld hl,(FFCB+_rrn) ; Get current record
ld (RRN_off),hl ; Set record base
ld hl,(DataBeg) ; Get start of data
push hl
ld hl,(l7bab) ; Get address of overlay data
push hl
ld e,-1
call l4b3a ; Perform PROCEDURE/FUNCTION
ld b,h
ld c,l
pop de ; Get back overlay data
ld hl,(DataBeg) ; Get start of data
or a
sbc hl,de ; Test min
add hl,de
jr c,l47c6
ex de,hl ; Swap addresses
l47c6:
ld (l7bab),hl ; Set address of overlay data
pop hl
ld (DataBeg),hl ; Set start of data
pop de
push bc
push de
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to file
call z,FixBack ; Yeap, fix back level
xor a
ld (BackLevel),a ; Reset back fix level
pop de
push de
l47dd:
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to memory
call z,flushunfinished ;nope
push iy ; Copy code pointer
pop hl
or a
sbc hl,de ; Get difference
ld a,l
and RecLng-1 ; Test record boundary
jr z,l47ee ; Yeap
xor a
call writebyte_a_addriy ; Fill remainder with zeroes
jr l47dd
l47ee:
add hl,hl ; Calculate lenght in bytes
ld e,h
ld d,0
rl d
ld hl,(l7bb0) ; Get length of overlay
sbc hl,de ; Test max
jr nc,l47ff
ld (l7bb0),de ; Set new length
l47ff:
pop iy ; Get back PC
pop hl
inc hl
ld (hl),e ; Save record
inc hl
ld (hl),d
call FindStr ; Find more OVERLAY
dw l759f
jr z,l4799 ; Yeap
ld hl,(l7bab) ; Get address of overlay data
ld (DataBeg),hl ; Set start of data
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to file
jr nz,l4821 ; Nope
ld de,FFCB
ld c,_close
call _BDOS ; Close file
l4821:
ld hl,0
add hl,sp ; Copy stack
ld de,FFCB
ld bc,FCBlen
ldir ; Get back original .COM FCB
ld sp,hl
ld de,(l7bb0) ; Get length of overlay
pop hl
ld (l7bb0),hl ; Set new length
pop hl
ld (CodePC),hl ; Set code pointer
pop hl
ld (RRN_off),hl ; Set record base
xor a
ld (RRN_stat ),a ; Clear file access
ld hl,-1
ld (FFCB+_rrn),hl ; Set highest record number
push iy
pop hl
call ChkChn ; Check chaining
l484e:
ld b,RecLng
l4850:
xor a
call writebyte_a_addriy ; Clear record
djnz l4850
dec de
ld a,d ; Test all done
or e
jr nz,l484e
jp l46b3
l485e:
cp _Begin ; Test BEGIN
jr z,l486a ; Yeap
ld e,0
call l4b3a ; Perform PROCEDURE/FUNCTION
jp l46b3
l486a:
call l4e8a ; Process it
pop de
pop hl
push de
push iy ; Copy PC
pop de
dec de ; Fix it
dec de
or a
sbc hl,de ; Calculate size
add hl,de
jr z,l4880
call storeback_iy_to_addrhl ; Store back PC
jr l4884
l4880:
dec hl
call ChkChn ; Check chaining
l4884:
pop de
pop hl
ld (l7bca),hl
pop af
ld (l7bc6),a
ret
;
; Process LABEL
;
l488e:
ld de,256*1+0
call puttolabel_d_e ; Put to table
ld a,(ix+0)
call IsItValid ; Test valid character
call SampLabel ; Build label
ld a,(l7b94) ; Get ???
call puttolabel ; Put to label
ld b,3
l48a5:
ld a,-1
call puttolabel ; Set end
djnz l48a5
call SetLabPtr ; Set label pointer
call l6f13 ; Test ,
jr z,l488e ; Yeap
jp l6f48 ; Verify ;
;
; Process CONST
;
l48b7:
ld hl,(LabPtr) ; Get label pointer
push hl
ld de,256*0+0
call puttolabel_d_e ; Put to table
call GetLabel ; Get label
call l6f23 ; Test =
jr nz,l4901 ; Nope, must be : then
call GetConst ; Get constant
ld a,b ; Get type
call puttolabel ; Store into table
ld a,b ; Get back type
cp _Real ; Test real
jr nz,l48e3 ; Nope
exx
push hl ; Save reals
push de
push bc
ld b,3 ; Set word count
l48db:
pop de ; Get part of real
call puttolabel_d_e ; Put to table
djnz l48db
jr l48fa
l48e3:
cp _String ; Test string
jr nz,l48f6 ; Nope, must be integer
ld hl,l7a57 ; Get buffer
ld a,c ; Get length
inc c ; Fix it
l48ec:
call puttolabel ; Put to table
ld a,(hl)
inc hl
dec c
jr nz,l48ec
jr l48fa
l48f6:
ex de,hl ; Get integer
call puttolabel_d_e ; Put to table
l48fa:
call SetLabPtr ; Set label pointer
ld d,2
jr l4928
l4901:
call l6f40 ; Verify :
xor a
call puttolabel ; Store zero in table
call puttolabel_i_y ; Store PC to table
ld hl,(LabPtr) ; Get label pointer
push hl
call puttolabel_d_e ; Put to table
call SetLabPtr ; Set label pointer
call l4f9b ; Get type
pop hl ; Get back label pointer
ld de,(l7b5a) ; Get type table
ld (hl),d ; Store into
dec hl
ld (hl),e
call l6f76 ; Verify =
call l4937 ; Assign constant
ld d,4
l4928:
pop hl ; Get back label pointer
ld (hl),d ; Put into
call l6f48 ; Verify ;
call FndTabStr ; Find statement
db 1
dw l7584
jr nz,l48b7 ; Nope
ld a,(hl) ; Get type
ret
;
; Process presetted constant
;
l4937:
ld a,(l7b5c) ; Get type
cp _Ptr ; Test valid
jr c,l4946 ; May not be a file
cp _String
jr nc,l4946
call ERROR
db _InvFilPtr
l4946:
cp _Array ; Test ARRAY constant
jr nz,l49a1 ; Nope
call l6d2a ; Save environment
ld hl,(l7b60) ; Get hi set limit
call l5271 ; Load name
ld hl,(l7b6d) ; Get last memory address
ld de,(l7b6b)
or a
sbc hl,de
inc hl
push hl
ld hl,(l7b5e) ; Get lo set limit
call l5287 ; Get name
pop de
ld a,(l7b5c) ; Get type
cp _Char ; Test character
jr nz,l4978
ld a,d ; Test byte
or a
jr nz,l4978 ; Nope
call l6f1b ; Test (
jr nz,l498a ; Nope
jr l497b
l4978:
call l6f66 ; Verify (
l497b:
push de
call l4937 ; Recursive assign constant
pop de
dec de
ld a,d
or e
jr z,l499a
call l6f5e ; Verify ,
jr l497b
l498a:
push de
call _GetStrC ; Get string constant
pop de
ld a,c ; Get length
cp e
call ErrNZ ; Verify valid length
db _StrConst
call StConst ; Store string
jr l499d
l499a:
call l6f6e ; Verify )
l499d:
call RestEnv1 ; Get back environment
ret
l49a1:
cp _Record ; Test RECORD constant
jr nz,l49fa ; Nope
call l6d2a ; Save environment
call l6f66 ; Verify (
ld a,(l7b5d)
ld c,a
ld hl,(l7b62) ; Get length of type
push hl
ld hl,0
l49b6:
push bc
push hl
ld b,_Ptr
call FndLABEL ; Get pointer label
call ErrNZ ; Should be found
db _Undef
call l5276 ; Get values and name
pop de
ld hl,(l7b58) ; Get value
or a
sbc hl,de
add hl,de
call ErrNZ ; Verify valid size
db _InvSetOrder
ld de,(l7b62) ; Get length of type
add hl,de
push hl
call l6f40 ; Verify :
call l4937 ; Assign constant recursively
pop hl
pop bc
call l6f0f ; Test ;
jr z,l49b6 ; Yeap
call l6f6e ; Verify )
pop de
ex de,hl
or a
sbc hl,de
l49eb:
ld a,h ; Test zero
or l
jr z,l49f6 ; Yeap
xor a
call writebyte_a_addriy ; Fill zeroes
dec hl
jr l49eb
l49f6:
call RestEnv1 ; Get back environment
ret
l49fa:
cp _Set ; Test SET constant
jr nz,l4a7a ; Nope
call l6d2a ; Save environment
ld hl,(l7b62) ; Get length of type
ld (l7b6f),hl
ld hl,(l7b5e) ; Get lo set limit
call l5287 ; Get name
call l6f30 ; Verify [
ld (l7ba9),ix ; Save line pointer
call l0581 ; Initialize a set on stack
ld ix,(l7ba9) ; Get back line pointer
call l6ef7 ; Test ]
jr z,l4a4b ; Yeap
l4a20:
call l4aca
push hl
call FindStr ; Find ..
dw l7580
jr nz,l4a37 ; Nope
call l4aca
ld (l7ba9),ix ; Save source pointer
call l059b ; Init a contiguous set value
jr l4a3f
l4a37:
pop hl
ld (l7ba9),ix ; Save source pointer
call l0591 ; Init one set element
l4a3f:
ld ix,(l7ba9) ; Get back source pointer
call l6f13 ; Test ,
jr z,l4a20 ; Yeap
call l6f38 ; Verify ]
l4a4b:
ld hl,l7a57
ld bc,set.len
ld (l7ba9),ix ; Save source pointer
call l0612 ; Assign set variable
ld ix,(l7ba9) ; Get back source pointer
ld hl,l7a57
ld a,(l7b5e) ; Get lo set limit
rra ; Divide by 8
rra
rra
and set.len-1 ; Get modulo
ld e,a
ld d,0
add hl,de ; Build pointer
ld a,(l7b6f) ; Get length
ld b,a
l4a6f:
ld a,(hl) ; Get bytes
call writebyte_a_addriy ; Store them
inc hl
djnz l4a6f
call RestEnv1 ; Get back environment
ret
l4a7a:
cp _String ; Test STRING constant
jr nz,l4a99 ; Nope
call _GetStrC ; Get string constant
ld a,(l7b62) ; Get length of string
dec a
sub c
ld b,a
jr nc,l4a8d
add a,c
ld c,a ; Set length
ld b,0
l4a8d:
call StLen ; Put string
inc b
l4a91:
dec b
ret z
xor a
call writebyte_a_addriy ; Fill zeroes
jr l4a91
l4a99:
cp _Real ; Test REAL constant
jr nz,l4abc ; Nope
call _GetConst ; Get constant
ld a,b ; Get type
cp _Real ; Test real
jr z,l4aaf ; Yeap
cp _Integ ; Test integer
call ErrNZ ; Should be
db _IntRealCexp
call l1008 ; Convert to real
exx
l4aaf:
exx
push bc
push de
push hl
ld b,Real.Len/2 ; Set word count
l4ab5:
pop hl
call writeword_hl_addriy ; Save real number
djnz l4ab5
ret
l4abc:
call l4aca
ld a,(l7b62) ; Get length of type
dec a
ld a,l
jp z,writebyte_a_addriy ; Set byte
jp writeword_hl_addriy ; Or set word
;
;
;
l4aca:
call _GetConst ; Get constant
ld a,(l7b5c) ; Get type
cp b ; Verify same types
call ErrNZ
db _InvType
ld de,(l7b5e) ; Get lo set limit
call l728d ; Compare
jr c,l4ae7 ; Out of range
ld de,(l7b60) ; Get hi set limit
call l728d ; Compare
ret c
ret z
l4ae7:
call ERROR
db _ConstRange
;
; Process TYPE
;
l4aeb:
ld hl,(LabPtr) ; Get label pointer
push hl
l4aef:
ld hl,(LabPtr) ; Get label pointer
push hl
ld de,0
call puttolabel_d_e ; Put to table
call GetLabel ; Get label
ld hl,(LabPtr) ; Get label pointer
push hl
call puttolabel_d_e ; Put to table
call SetLabPtr ; Set label pointer
call l6f76 ; Verify =
call l4f9b ; Get type
pop hl
ld de,(l7b5a) ; Get type table
ld (hl),d ; Store into
dec hl
ld (hl),e
pop hl
ld (hl),3
call l6f48 ; Verify ;
call FndTabStr ; Find statement
db _Byte
dw l7584
jr nz,l4aef ; Nope
ld a,(hl) ; Fetch type
pop hl
push af
call l5295
pop af
ret
;
; Process VAR
;
l4b2a:
call l4f35
call l6f48 ; Verify ;
call FndTabStr ; Find statement
db _Byte
dw l7584
jr nz,l4b2a ; Nope
ld a,(hl) ; Fetch type
ret
;
; Perform PROCEDURE/FUNCTION
;
; Accu holds PROCEDURE or FUNCTION
; Reg E holds overlay flag (-1)
;
l4b3a:
ld b,a
ld c,0
sub _Proc ; Get type
ld (l7b97),a ; 0 is PROCEDURE
ld a,e ; Get overlay
ld (l7b99),a ; 0 is normal
ld a,(l7b9d) ; Get options
ld (l7b9e),a ; Set local options
push bc
call l6ddb
jp z,l4c61
pop de
call puttolabel_d_e ; Put to table
call GetLabel ; Get label
ld hl,(CurLab) ; Get current label pointer
push hl
ld hl,(PrevLabPtr) ; Get previous label pointer
ld (CurLab),hl
ld hl,(LabPtr) ; Get label pointer
push hl
call puttolabel_d_e ; Put to table
call puttolabel_d_e ; Multiple
call puttolabel_d_e
call puttolabel_d_e
ld de,(RRN_off) ; Get record base
call puttolabel_d_e ; Put to table
ld de,0
call puttolabel_d_e ; Put to table
call l6f1b ; Test (
ld b,0 ; Clear parameter count
jr nz,l4bda ; Nope
l4b88:
push bc
ld hl,(LabPtr) ; Get label pointer
push hl
call puttolabel_d_e ; Put to table
call puttolabel_d_e ; Twice
call FindStr ; Find VAR
dw l7595
ld bc,0
jr nz,l4b9e ; Nope
dec c ; Indicate VAR
l4b9e:
push bc
call GetLabel ; Get label
pop bc
inc b ; Count parameters
call l6f13 ; Test ,
jr z,l4b9e ; Yeap
push bc
call l6f0b ; Test :
jr nz,l4bb8 ; Nope
ld a,c
ld (l7b8f),a ; Save state
call l4f18 ; Get variable
jr l4bc3
l4bb8:
inc c ; Verify not VAR
call ErrNZ
db _SemiExp
ld hl,l750b+7
ld (l7b5a),hl ; Init type table
l4bc3:
pop bc
pop hl
ld (hl),b
dec hl
ld (hl),c
ld de,(l7b5a) ; Get type table
dec hl
ld (hl),d ; Store into
dec hl
ld (hl),e
pop bc
inc b
call l6f0f ; Test ;
jr z,l4b88 ; Yeap
call l6f6e ; Verify )
l4bda:
push bc
ld a,(l7b97)
or a ; Test PROCEDURE
jr z,l4c07 ; Yeap
call l6f40 ; Verify :
xor a
ld (l7b8f),a
call l4f18 ; Get variable
ld a,(l7b5c) ; Get type
cp _String ; Test range
jr nc,l4bf8
cp _Ptr ; Should be pointer
call ErrNZ
db _InvResult
l4bf8:
pop bc
pop hl
push hl
push bc
ld de,-4
add hl,de ; Fix pointer
ld de,(l7b5a) ; Get type table
ld (hl),d ; Store into
dec hl
ld (hl),e
l4c07:
pop bc
pop de
pop hl
ld (CurLab),hl ; Restore current label pointer
push de
push bc
call SetLabPtr ; Set label pointer
call l6f48 ; Verify ;
ld a,(l7b99)
or a ; Test overlay
jr nz,l4c44 ; Yeap
call FindStr ; Find FORWARD
dw l7533
jr nz,l4c2c ; Nope
push iy ; Copy PC
pop de
call StJP_ ; Set JP <addr>
ld a,-1
jr l4c38
l4c2c:
call FindStr ; Find EXTERNAL
dw l753a
jr nz,l4c44 ; Nope
call _GetIntC ; Get integer constant
ex de,hl
xor a
l4c38:
pop bc
pop hl
ld (hl),a ; Store values
dec hl
ld (hl),b
dec hl
ld (hl),d ; Set address
dec hl
ld (hl),e
jp l6f48 ; Verify ;
l4c44:
pop bc
pop hl
push hl
ld (hl),0 ; Set values
dec hl
ld (hl),b
dec hl
push iy ; Copy PC
pop de
ld a,(l7b99)
or a ; Test overlay
jr z,l4c5b ; Nope
ex de,hl
ld bc,-16
add hl,bc ; Fix value
ex de,hl
l4c5b:
ld (hl),d ; Save address
dec hl
ld (hl),e
pop hl
jr l4c76
l4c61:
ld a,(hl)
or a
call ErrZ ; Verify label not found
db _DoubleLab
ld a,(l7b99)
or a ; Test overlay (0 is not)
call ErrNZ ; Verify not FORWARD overlay
db _OvlFORW
call SetLine ; Set new pointer
pop de
call l6f48 ; Verify ;
l4c76:
ex de,hl
ld a,(l7b9d) ; Get option
ld hl,(DataBeg) ; Get start of data
bit _Aopt,a ; Test $A+ - absolute code for recursion
jr z,l4c84 ; Yeap
ld hl,0
l4c84:
ld (l7b83),hl
ld hl,(CurLab) ; Get current label pointer
push hl
ld hl,(LabPtr) ; Get label pointer
ld (CurLab),hl ; Into current
push hl
ex de,hl
ld a,(hl)
ld (hl),0
dec hl
ld b,(hl)
dec hl
ld d,(hl)
dec hl
ld e,(hl)
dec hl
or a
jr z,l4ca7
push hl
ex de,hl
inc hl
call storeback_iy_to_addrhl ; Store back PC
pop hl
l4ca7:
ld a,(l7b97)
or a ; Test PROCEDURE
jr z,l4cd2 ; Yeap
ld d,(hl)
dec hl
ld e,(hl)
dec hl
push hl
ex de,hl
call l5287 ; Get name
ld a,(l7b5c) ; Get type
ld (l7b87),a
ld hl,(l7b62) ; Get length of type
ld a,l
ld (l7b88),a ; save lo
ex de,hl
call VarAlloc ; Allocate space
ld (l7b89),hl
ex de,hl
pop hl
ld (hl),d
dec hl
ld (hl),e
dec hl
jr l4cd6
l4cd2:
ld de,-4
add hl,de
l4cd6:
ld de,-4
add hl,de
push hl
ld c,0
ld a,b
or a
jr z,l4d2b
l4ce1:
ld a,(hl)
add a,c
ld c,a
push bc
ld b,(hl)
dec hl
ld a,(hl)
ld (l7b8f),a
dec hl
ld d,(hl) ; Get type table
dec hl
ld e,(hl)
dec hl
push hl
ex de,hl
ld (l7b5a),hl ; Save type table
call l5287 ; Get name
ld hl,(LabPtr) ; Get label pointer
ex (sp),hl
push bc
l4cfd:
push bc
ld de,4*256+0
call puttolabel_d_e ; Put to table
l4d04:
ld a,(hl)
call puttolabel ; Store into table
bit _MB,(hl) ; Test end of table
dec hl
jr z,l4d04 ; Nope
push hl
call puttolabel ; Store last byte into table
call puttolabel_d_e ; Put to table
call puttolabel_d_e
call SetLabPtr ; Set label pointer
pop hl
pop bc
djnz l4cfd
pop bc
ex (sp),hl
xor a
ld (l7b90),a
call l4f52
pop hl
pop bc
djnz l4ce1
l4d2b:
ld b,c
push bc
ld hl,(LabPtr) ; Get label pointer
push hl
ld hl,(l7b83)
push hl
ld hl,(l7b89)
push hl
ld a,(l7b87)
push af
ld a,(l7b88)
push af
ld a,(l7b97) ; Get PROCEDURE/FUNCTION flag
push af ; Save it
ld hl,l7b94 ; Point to ???
inc (hl)
call l469e ; Perform a block
pop af
ld (l7b97),a ; Reset flag
pop af
ld (l7b88),a
pop af
ld (l7b87),a
pop hl
ld (l7b89),hl
pop hl
ld (l7b83),hl
ld (l7b85),de
ld a,h
or l
jr z,l4d79
sbc hl,de
jr z,l4d79
call StLD.BC ; Set LD BC,val16
ex de,hl
call StLD.HL ; Set LD HL,val16
ld hl,l0508 ; Set recursion routine
call StCALL_ ; Set CALL RECUR
l4d79:
pop hl
pop bc
inc b
dec b
jp z,l4df3
call StImm ; Set POP IY
db a_L1
s_I1:
POP IY
a_L1 equ $-s_I1
l4d86:
push bc
inc hl
ld e,(hl)
inc hl
ld d,(hl)
add hl,de
push hl
dec hl
dec hl
l4d8f:
bit _MB,(hl) ; Test end of string
dec hl
jr z,l4d8f ; Nope
call l5276 ; Get values and name
ld a,(Envir1)
or a
jr nz,l4dd4
ld a,(l7b5c) ; Get type
cp _Set
jr c,l4dbd
jr z,l4de6
cp _Ptr
jr z,l4de3
cp _String
jr c,l4dbd
jr z,l4de6
cp _Integ
jr nc,l4de3
call StImm ; Set POP sequence
db a_L2
s_I2:
POP HL
POP DE
POP BC
a_L2 equ $-s_I2
jr l4de6
l4dbd:
call StPOP ; Set POP HL
ld hl,(l7b58) ; Get value
call StLD.DE ; Set LD DE,val16
ld hl,(l7b62) ; Get length of type
call StLD.BC ; Set LD BC,val16
call StImm ; Set LDIR
db a_L3
s_I3:
LDIR
a_L3 equ $-s_I3
jr l4de9
l4dd4:
xor a
ld (Envir1),a
ld a,_Ptr
ld (l7b5c),a ; Set POINTER
ld hl,2
ld (l7b62),hl ; Set length of pointer type
l4de3:
call StPOP ; Set POP HL
l4de6:
call l661b
l4de9:
pop hl
pop bc
djnz l4d86
call StImm ; Set PUSH IY
db a_L4
s_I4:
PUSH IY
a_L4 equ $-s_I4
l4df3:
call l52fc
ld hl,l7b94 ; Point to ???
dec (hl)
ld a,(l7b97)
or a ; Test PROCEDURE
jr z,l4e46 ; Yeap
ld hl,(l7b89)
ld a,(l7b87)
cp _String
jr nz,l4e24
ld b,a
call StImm ; Set POP IY
db a_L5
s_I5:
POP IY
a_L5 equ $-s_I5
ld a,_LD.HL
call StCode ; Set LD HL,val16
ld hl,l053a
call StCALL_ ; move string to stack
call StImm
db a_L6
s_I6:
PUSH IY
a_L6 equ $-s_I6
jr l4e46
l4e24:
cp _Real
jr nz,l4e35
ld a,_LD.HL
call StCode ; Set LD HL,val16
ld hl,l052c
call StCALL_ ; Set load real
jr l4e46
l4e35:
ld a,_LD_a_HL
call StCode ; Set LD HL,(adr16)
ld a,(l7b88)
dec a
jr nz,l4e46
call StImm ; Set LD H,0
db a_L7
s_I7:
LD H,0
a_L7 equ $-s_I7
l4e46:
ld hl,(l7b83)
ld a,h
or l
jr z,l4e74
ld de,(l7b85)
sbc hl,de
jr z,l4e74
ld a,(l7b97)
or a ; Test PROCEDURE
jr z,l4e65 ; Yeap
ld a,(l7b87)
cp _String
ld a,_EXX
call nz,writebyte_a_addriy ; Set EXX
l4e65:
call StLD.BC ; Set LD BC,val16
ex de,hl
call StLD.DE ; Set LD DE,val16
ld hl,l0522
call StJP_ ; Set end of recursive routine
jr l4e79
l4e74:
call StImm ; Set RET
db a_L8
s_I8:
RET
a_L8 equ $-s_I8
l4e79:
call l6f48 ; Verify ;
pop de
pop hl
ld (LabPtr),hl ; Set label pointers
ld (PrevLabPtr),hl
pop hl
ld (CurLab),hl ; Restore current label pointer
ex de,hl
ret
;
; Process BEGIN
;
l4e8a:
ld hl,(LabPtr) ; Get label pointer
l4e8d:
ld de,(CurLab) ; Get current label pointer
or a
sbc hl,de
add hl,de
ret z ; End on level 0
inc hl
ld e,(hl)
inc hl
ld d,(hl)
add hl,de
ld a,(hl)
cp 6 ;_TxtF???
jr z,l4ea4
cp 5 ;_RecF???
jr nz,l4e8d
l4ea4:
push hl
dec hl
dec hl
l4ea7:
bit _MB,(hl) ; Find end of string
dec hl
jr z,l4ea7
ld a,(hl) ; Get type
or a
call ErrNZ ; Maybe undefined FORWARD
db _UndefFORW
pop hl
jr l4e8d
;
;
;
l4eb5:
ld hl,(LabPtr) ; Get label pointer
push hl
ld b,0
l4ebb:
push bc
ld d,_Ptr ; Set type
ld a,(l7b91) ; Get ???
ld e,a
call puttolabel_d_e ; Put to table
call GetLabel ; Get label
call puttolabel ; Store into table
call puttolabel_d_e ; Put to table
call puttolabel_d_e ; Twice
call SetLabPtr ; Set label pointer
pop bc
inc b
call l6f13 ; Test ,
jr z,l4ebb ; Yeap
pop hl
ret
;
;
;
l4edd:
ld hl,(LabPtr) ; Get label pointer
push hl
call l4f9b ; Get type
pop hl
call l5295
call FindStr ; Test ABSOLUTE
dw l7562
ld a,0
jr nz,l4f14 ; Nope
ld a,(l7b91) ; Get ???
or a
call ErrNZ
db _InvalABS
ld bc,256*_Ptr+0
call FndLABEL ; Find label
jr nz,l4f0c ; Nope
ld a,(hl)
ld (l7b8f),a
dec hl
ld d,(hl)
dec hl
ld e,(hl)
ex de,hl
jr l4f0f
l4f0c:
call _GetIntC ; Get integer constant
l4f0f:
ld (l7b7f),hl ; Store value
ld a,-1
l4f14:
ld (l7b90),a
ret
;
; Process variable on PROCEDURE and FUNCTION
;
l4f18:
call l4fc8 ; Get simple type
call ErrNZ ; Verify ok
db _TypeExp
xor a
ld (l7b90),a
ld a,(l7b8f)
or a
ret nz
ld a,(l7b5c) ; Get type
cp _RecF
ret c
cp _String
ret nc
call ERROR ; Files must be VAR
db _VarFile
;
;
;
l4f35:
call l4eb5
push hl
push bc
call l6f40 ; Verify :
xor a
ld (l7b8f),a
call l4edd
pop bc
ld a,(l7b90)
or a
jr z,l4f51
ld a,b
dec a
call ErrNZ ; Invalid ABSOLUTE
db _InvalABS
l4f51:
pop hl
l4f52:
push bc
push hl
ld a,(l7b8f)
ld hl,2
or a
jr nz,l4f60
ld hl,(l7b62) ; Get length of type
l4f60:
ex de,hl
ld a,(l7b91) ; Get ???
or a
jr nz,l4f72
ld a,(l7b90)
or a
jr nz,l4f72
call VarAlloc ; Allocate space
jr l4f7b
l4f72:
ld hl,(l7b7f)
push hl
add hl,de
ld (l7b7f),hl
pop hl
l4f7b:
ex de,hl
pop hl
dec hl
l4f7e:
dec hl
bit _MB,(hl)
jr z,l4f7e
dec hl
ld a,(l7b8f)
ld (hl),a
dec hl
ld (hl),d
dec hl
ld (hl),e
dec hl
ld de,(l7b5a) ; Get type table
ld (hl),d ; Store into
dec hl
ld (hl),e
dec hl
dec hl
dec hl
pop bc
djnz l4f52
ret
;
; Get a TYPE
;
l4f9b:
call l4fc8 ; Test simple type
ret z
call FindStr ; Skip possible PACKED
dw l7542
call l4fdb ; Check ARRAY
ret z
call l5039 ; Check RECORD
ret z
call l5106 ; Check SET
ret z
call l5140 ; Check ^
ret z
call l516b ; Check FILE
ret z
call l51a5 ; Check STRING
ret z
call l51c5 ; Test SCALAR ()
ret z
call l5210 ; Test RANGE ..
ret z
call ERROR ; Type declaration expected
db _TypeExp
;
; Get SIMPLE TYPE
; EXIT Zero set if found
;
l4fc8:
ld bc,256*3+0
call FndLABEL ; Get from table
ret nz ; Not found
ld d,(hl) ; Fetch type table
dec hl
ld e,(hl)
ex de,hl
ld (l7b5a),hl ; Save type
call l5287 ; Get name
xor a ; Set success
ret
;
; Look for ARRAY
;
l4fdb:
call FindStr ; Test ARRAY
dw l7548
ret nz ; Nope
call l6f30 ; Verify [
ld b,0
l4fe6:
push bc
call l523b
pop bc
ld hl,(l7b5a) ; Get type table
push hl
ld hl,(l7b60) ; Get hi limit
ld de,(l7b5e) ; Get lo limit
or a
sbc hl,de
inc hl
ld a,h
or l
call ErrZ ; Verify not same
db _MemOvfl
push hl
inc b
call l6f13 ; Test ,
jr z,l4fe6 ; Yeap
push bc
call l6f38 ; Verify ]
call l6f88
call l4f9b ; Get type
pop bc
l5012:
ld hl,(l7b5a) ; Get type table
ld (l7b5e),hl ; Set as lo limit
ld hl,(l7b62) ; Get length of type
pop de
push bc
call l729a ; Multiply numbers
call ErrCY ; Check compiler overflow
db _MemOvfl
pop bc
ld (l7b62),hl ; Set length of type
pop hl
ld (l7b60),hl ; Set hi limit
ld a,_Array
ld (l7b5c),a ; Set ARRAY
push bc
call l5254 ; Put to table
pop bc
djnz l5012
ret
;
; Look for RECORD
;
l5039:
call FindStr ; Test RECORD
dw l7554
ret nz ; Nope
ld a,(l7b9a)
push af
ld a,(l7b91) ; Get ???
push af
ld hl,l7b92 ; Point to ???
inc (hl)
ld a,(hl)
ld (l7b91),a ; Set ???
ld hl,(l7b7f)
push hl
ld hl,(l7b81)
push hl
ld hl,l0000
ld (l7b7f),hl
ld (l7b81),hl
xor a
ld (l7b9a),a
call l508b
ld hl,(l7b81)
ld (l7b62),hl ; Set length of type
pop hl
ld (l7b81),hl
pop hl
ld (l7b7f),hl
ld a,(l7b91) ; Get ???
ld (l7b5d),a
pop af
ld (l7b91),a ; Set ???
pop af
ld (l7b9a),a
ld a,_Record
ld (l7b5c),a ; Set RECORD
jp l5254
;
;
;
l508b:
call l50f9
ret z
call FindStr ; Test CASE
dw l75da
jr z,l50b0 ; Yeap
call l4f35
ld hl,(l7b7f)
ld de,(l7b81)
or a
sbc hl,de
jr c,l50a9
add hl,de
ld (l7b81),hl
l50a9:
call l6f0f ; Test ;
jr z,l508b ; Yeap
jr l50e8
l50b0:
call l4fc8
call nz,l4f35
call l6f88
l50b9:
call l50f9
ret z
ld hl,(l7b7f)
push hl
l50c1:
call _GetConst ; Get constant
call l6f13 ; Test ,
jr z,l50c1 ; Yeap
call l6f40 ; Verify :
call l6f66 ; Verify (
ld a,(l7b9a)
push af
ld a,0ffh
ld (l7b9a),a
call l508b
pop af
ld (l7b9a),a
pop hl
ld (l7b7f),hl
call l6f0f ; Test ;
jr z,l50b9 ; Yeap
l50e8:
ld a,(l7b9a)
or a
jp nz,l6f6e ; Verify )
call FindStr ; Find END
dw l7530
ret z ; Yeap
call ERROR
db _End
l50f9:
ld a,(l7b9a)
or a
jp nz,l6f1f
call FindStr ; Find END
dw l7530
ret
;
; Check SET
;
l5106:
call FindStr ; Test SET
dw l7551
ret nz ; Nope
call l6f88
call l523b
ld hl,(l7b60) ; Get hi set limit
ld de,(l7b5e) ; Get lo set limit
ld a,h
or d
call ErrNZ
db _IllSetRange
srl l
srl l
srl l
srl e
srl e
srl e
ld a,l
inc a
sub e
ld l,a
ld (l7b62),hl ; Set length of type
ld hl,(l7b5a) ; Get type table
ld (l7b5e),hl ; Set lo set limit
ld a,_Set
ld (l7b5c),a ; Set SET
jp l5254
;
; Check ^
;
l5140:
call l6f27
ret nz
ld de,l0000
call puttolabel_d_e ; Put to table
ld hl,(LabPtr) ; Get label pointer
push hl
call l6dba
call SetLabPtr ; Set label pointer
pop hl
ld (l7b5e),hl ; Set lo set limit
ld a,_Ptr
ld (l7b5c),a ; Set POINTER
ld a,0ffh
ld (l7b5d),a
ld hl,l0002
ld (l7b62),hl ; Set length of type
jp l5254
;
; Check FILE
;
l516b:
call FindStr ; Find FILE
dw l754d
ret nz ; Nope
call FindStr ; Find OF
dw l7560
jr nz,l5197 ; Nope
call l4f9b ; Get type
ld a,(l7b5c) ; Get type
cp _RecF
jr c,l518a
cp _String
jr nc,l518a
call ERROR
db _FileF
l518a:
ld hl,(l7b5a) ; Get type table
ld (l7b5e),hl ; Set lo set limit
ld a,_RecF
ld hl,l00b0
jr l519c
l5197:
ld a,_UntF
ld hl,l0030
l519c:
ld (l7b5c),a ; Set type
ld (l7b62),hl ; Set length of type
jp l5254
;
; Check STRING
;
l51a5:
call FindStr ; Find STRING
dw l755a
ret nz ; Nope
call l6f30 ; Verify [
call _GetIntC ; Get integer constant
inc h
dec h
call ErrNZ
db _IllStrgLen
inc l
dec l
call ErrZ
db _IllStrgLen
call l6f38 ; Verify ]
inc hl
ld a,_String
jr l519c
;
; Test SCALAR ()
;
l51c5:
call l6f1b ; Test (
ret nz ; Nope
ld hl,lffff
l51cc:
push hl
ld de,2*256+0 ;l0200
call puttolabel_d_e ; Put to table
call GetLabel ; Get label
ld a,(curtype_l7b93) ; Get type
call puttolabel
pop de
inc de
push de
call puttolabel_d_e ; Put to table
call SetLabPtr ; Set label pointer
pop hl
call l6f13 ; Test ,
jr z,l51cc ; Yeap
call l6f6e ; Verify )
push hl
ld hl,curtype_l7b93 ; Point to type
ld a,(hl)
inc (hl)
pop hl
ld de,l0000
l51f8:
ld (l7b5c),a ; Set type
ld (l7b5e),de ; Set lo set limit
ld (l7b60),hl ; Set hi set limit
ld a,d
or h
ld hl,l0001
jr z,l520a
inc hl
l520a:
ld (l7b62),hl ; Set length of type
jp l5254
;
; Test RANGE ..
;
l5210:
call GetConst ; Get constant
ret nz
ld a,b
push af
cp 0ah ;_Integ
call ErrCY
db _IllSkalar
push hl
call FindStr ; Find ..
dw l7580
call ErrNZ
db _TwoDots
call _GetConst ; Get constant
pop de
pop af
push af
cp b
call ErrNZ
db _InvType
call l728d ; Compare
call ErrCY ; Verify upper > lower
db _IllLimit
pop af
jr l51f8
;
;
;
l523b:
call l5210
ret z
call l51c5
ret z
call l4fc8
call ErrNZ
db _SimTyp
ld a,(l7b5c) ; Get type
cp _Integ
ret nc
call ERROR
db _SimTyp
l5254:
ld de,8*256+0 ;l0800
call puttolabel_d_e ; Put to table
ld hl,(LabPtr) ; Get label pointer
ld (l7b5a),hl ; Save into type table
ld hl,l7b5c ; Point to type
ld b,8
l5265:
ld a,(hl)
call puttolabel
inc hl
djnz l5265
call SetLabPtr ; Set label pointer
xor a
ret
;
;
;
l5271:
ld de,l7b69
jr l528a
;
; Get values and name
;
l5276:
ld a,(hl)
dec hl
ld (Envir1),a
ld d,(hl)
dec hl
ld e,(hl)
dec hl
ld (l7b58),de ; Set value
ld d,(hl)
dec hl
ld e,(hl)
ex de,hl
;
; Get name
;
l5287:
ld de,l7b5c ; Point to type
l528a:
push bc
ld b,8
l528d:
ld a,(hl)
ld (de),a
dec hl
inc de
djnz l528d
pop bc
ret
;
;
;
l5295:
ld (l7b79),hl
ld hl,(LabPtr) ; Get label pointer
l529b:
ld bc,(l7b79)
or a
sbc hl,bc
add hl,bc
ret z
inc hl
ld c,(hl)
inc hl
ld b,(hl)
add hl,bc
ld a,(hl)
cp 8 ;???
jr nz,l529b
ld (hl),0
push hl
dec hl
dec hl
ld a,(hl)
cp 4 ;???
jr nz,l52f8
dec hl
ld a,(hl)
or a
jr z,l52f8
ld (hl),0
dec hl
push hl
ld e,(hl)
dec hl
ld d,(hl)
ld hl,(LabPtr) ; Get label pointer
l52c7:
ld bc,(l7b77) ; Get top of available memory
or a
sbc hl,bc
add hl,bc
call ErrZ
db _InkPointer
inc hl
ld c,(hl)
inc hl
ld b,(hl)
add hl,bc
ld a,(hl)
cp 3 ;???
jr nz,l52c7
push hl
push de
dec hl
dec hl
l52e1:
ld a,(de)
cp (hl)
jr z,l52e9
pop de
pop hl
jr l52c7
l52e9:
bit 7,(hl)
dec hl
dec de
jr z,l52e1
pop bc
pop bc
ld b,(hl)
dec hl
ld c,(hl)
pop hl
ld (hl),c
dec hl
ld (hl),b
l52f8:
pop hl
jp l529b
;
;
;
l52fc:
xor a
ld (l7b95),a
ld (l7bc9),a
call l5377
ld (l7ba4),iy
call StJP_
ld hl,(LabPtr) ; Get label pointer
l5310:
ld de,(PrevLabPtr) ; Get previous label pointer
or a
sbc hl,de
add hl,de
jr nc,l5363
inc hl
ld c,(hl)
inc hl
ld b,(hl)
inc hl
ld a,(hl)
inc hl
ld e,(hl)
inc hl
ld d,(hl)
push hl
push bc
ld b,a
ld a,d
or e
jr z,l533a
ex de,hl
dec hl
ld a,(hl)
ld c,a
inc a
call ErrZ
db _UnkLabel
dec hl
ld d,(hl)
dec hl
ld e,(hl)
jr l5340
l533a:
ld de,(l7ba4)
ld c,0
l5340:
pop hl
ld a,b
sub c
jr nz,l534a
call storeback_de_to_addrhl
jr l5360
l534a:
call ErrCY
db _IllGOTO
push de
push af
call storeback_iy_to_addrhl ; Store back PC
pop af
ld b,a
l5355:
call StPOP ; Set POP HL
djnz l5355
ld a,_JP
pop hl
call StCode
l5360:
pop hl
jr l5310
l5363:
ld hl,(l7ba4)
inc hl
push iy
pop de
dec de
dec de
or a
sbc hl,de
add hl,de
jp nz,storeback_iy_to_addrhl ; Store back PC
dec hl
jp ChkChn ; Check chaining
;
; Statement BEGIN
;
l5377:
call l5385 ; Process a statement
call FindStr ; Find END
dw l7530
ret z
call l6f50
jr l5377
;
; Process a statement
;
l5385:
ld a,0ffh
ld (l7b98),a
ld a,(l7b9d) ; Get options
ld (l7b9e),a ; Set local options
bit _Uopt,a ; Test $U+
jr z,l539c ; Nope
ld a,RST
ld (l7ba0),a ; Set end on break flag [option U+]
call writebyte_a_addriy ; Insert RST
l539c:
call FndTabStr ; Find statement
db 2
dw l75bb
jr z,l53cb ; Yeap
call l67b2
jp z,l57ea
ld bc,256*5+0
call FndLABEL
jp z,l573d
ld bc,256*1+0
call FndLABEL
jr z,l53d0
ld bc,256*6+0
call FndLABEL
jp z,l591f
call FndTabStr ; Find procedure
db 2
dw l7638
ret nz ; Nope
l53cb:
ld e,(hl) ; Fetch address
inc hl
ld d,(hl)
ex de,hl
jp (hl) ; Go
l53d0:
call l6f40 ; Verify :
ld a,(l7b94) ; Get ???
cp (hl)
call ErrNZ
db _IllLabel
dec hl
ld a,(hl)
inc a
call ErrNZ
db _DoubleLab
ld a,(l7b95)
ld (hl),a
push iy
pop de
dec hl
ld (hl),d
dec hl
ld (hl),e
jr l5385
;
; Statement IF
;
l53ef:
call l5eb0
call StImm ; Set BIT 0,L ! JP Z,addr
db a_L9
s_I9:
BIT _LB,L
db _JPZ
a_L9 equ $-s_I9
push iy
call writeword_hl_addriy
call FindStr ; Find THEN
dw l756a
call ErrNZ
db _StrIdx
call l5385 ; Process a statement
call FindStr ; Find ELSE
dw l756e
jr nz,l5420 ; Nope
call StJP ; Set JP
pop hl
push iy
call writeword_hl_addriy
call storeback_iy_to_addrhl ; Store back PC
call l5385 ; Process a statement
l5420:
pop hl
jp storeback_iy_to_addrhl ; Store back PC
;
; Statement WHILE
;
l5424:
push iy
call l5eb0
call FindStr ; Find DO
dw l7572
call ErrNZ
db _NoDO
call StImm ; Set BIT 0,L ! JP Z,addr
db a_L10
s_I10:
BIT _LB,L
db _JPZ
a_L10 equ $-s_I10
push iy
call writeword_hl_addriy
call l5385 ; Process a statement
pop de
pop hl
ld a,_JP
call StCode
ex de,hl
jp storeback_iy_to_addrhl ; Store back PC
;
; Statement REPEAT
;
l544c:
push iy
l544e:
call l5385 ; Process a statement
call FindStr ; Find UNTIL
dw l7574
jr z,l545d ; Yeap
call l6f50
jr l544e
l545d:
call l5eb0
call StImm
db a_L11
s_I11:
BIT _LB,L
db _JPZ
a_L11 equ $-s_I11
pop hl
jp writeword_hl_addriy
;
; Statement FOR
;
l546b:
ld bc,256*4+0
call FndLABEL
call ErrNZ
db _Undef
call l5276
ld a,(Envir1)
or a
jr nz,l5485
ld a,(l7b5c) ; Get type
cp _Integ
jr nc,l5489
l5485:
call ERROR
db _SimTyp
l5489:
call l6d2a ; Save environment
ld a,(l7b5c) ; Get type
push af
call l6f7e
call l5ee8
call StPUSH ; Set PUSH HL
pop af
push af
cp b
call ErrNZ
db _InvType
call FndTabStr ; Find TO or DOWNTO
db 1
dw l75f5
call ErrNZ
db _NoDOWN_TO
ld e,(hl) ; Get instruction
push de
call l5ee8
pop de
pop af
push de
cp b
call ErrNZ
db _InvType
call FindStr ; Find DO
dw l7572
call ErrNZ
db _NoDO
call StImm ; Set POP DE
db a_L12
s_I12:
POP DE
a_L12 equ $-s_I12
pop de
call l6d63
push de
ld a,e
ld hl,l0666 ; Set up FOR .. TO loop
cp '#'
jr z,l54d5
ld hl,l0676 ; Set up FOR .. DOWNTO loop
l54d5:
call StCALL_ ; Set CALL <loop>
push iy
;jr $
call StImm ; Set code sequence
db a_L13
s_I13:
LD A,D
OR E
JP Z,$-$ ;for future patching???
PUSH DE
a_L13 equ $-s_I13
call l661b
ld hl,l7b95
inc (hl)
call l5385 ; Process a statement
ld hl,l7b95
dec (hl)
pop hl
pop de
call RestEnv1 ; Get back environment
push hl
ld hl,(l7b58) ; Get value
ld a,_LD_a_HL
call StCode
ld a,(l7b62) ; Get length of type
dec a
jr nz,l550c
call StImm ; Set LD H,0
db a_L14
s_I14:
LD H,0
a_L14 equ $-s_I14
l550c:
ld a,e ; Get byte
call writebyte_a_addriy ; Store it
call StImm ; Set code sequence
db a_L15
s_I15:
POP DE
DEC DE
db _JP
a_L15 equ $-s_I15
pop hl
call writeword_hl_addriy
inc hl
inc hl
inc hl
jp storeback_iy_to_addrhl ; Store back PC
;
; Statement CASE
;
l5521:
call l5ebb
ld (l7b9c),a
xor a
ld (l7b9b),a
call l6f88
ld b,0
push bc
l5531:
ld b,1
l5533:
push bc
ld hl,l7b9b
bit 7,(hl)
jr z,l5549
call StImm ; Set ADD HL,DE
db a_L16
s_I16:
ADD HL,DE
a_L16 equ $-s_I16
bit 4,(hl)
jr z,l5549
call StImm ; Set ADD HL,BC
db a_L17
s_I17:
ADD HL,BC
a_L17 equ $-s_I17
l5549:
call _GetConst ; Get constant
ld a,(l7b9c)
cp b
call ErrNZ
db _IllCASE
call StLD.DE ; Set LD DE,val16
push hl
call FindStr ; Find ..
dw l7580
pop hl
jr nz,l5582 ; Nope
push hl
call _GetConst ; Get constant
ld a,(l7b9c)
cp b
call ErrNZ
db _IllCASE
pop de
or a
sbc hl,de
inc hl
call StLD.BC
call StImm ; Set sequence
db a_L18
s_I18:
OR A
SBC HL,DE
OR A
SBC HL,BC
a_L18 equ $-s_I18
ld a,0dah
jr l558b
l5582:
call StImm ; Set sequence
db a_L19
s_I19:
OR A
SBC HL,DE
a_L19 equ $-s_I19
ld a,0cah
l558b:
ld (l7b9b),a
call l6f0b ; Test :
pop bc
jr z,l55a5
ld a,(l7b9b) ; Get byte
call writebyte_a_addriy ; Store it
push iy
call writeword_hl_addriy
call l6f5e ; Verify ,
inc b
jr l5533
l55a5:
push iy
pop de
inc de
inc de
inc de
l55ab:
dec b
jr z,l55b4
pop hl
call storeback_de_to_addrhl
jr l55ab
l55b4:
ld a,(l7b9b) ; Get byte
res 3,a ; Fix it
call writebyte_a_addriy ; Store
pop bc
push iy
inc b
push bc
call writeword_hl_addriy
ld a,(l7b9b)
push af
ld a,(l7b9c)
push af
call l5385 ; Process a statement
pop af
ld (l7b9c),a
pop af
ld (l7b9b),a
call l6f0f ; Test ;
ld e,1
jr z,l55df ; Yeap
dec e
l55df:
push de
call FindStr ; Find END
dw l7530
pop de
jr z,l561e
call StJP ; Set JP
pop bc
pop hl
push iy
push bc
push de
call writeword_hl_addriy
call storeback_iy_to_addrhl ; Store back PC
call FindStr ; Find ELSE
dw l756e
pop de
jr z,l560f ; Yeap
dec e
jp z,l5531
ld a,(l7b98)
or a
call ErrZ
db _End
call ERROR
db _Undef
l560f:
call l5385 ; Process a statement
call FindStr ; Find END
dw l7530
jr z,l561e ; Yeap
call l6f50
jr l560f
l561e:
pop bc
l561f:
pop hl
call storeback_iy_to_addrhl ; Store back PC
djnz l561f
ret
;
; Statement GOTO
;
l5626:
ld bc,256*1+0
call FndLABEL
call ErrNZ
db _UnkLabel
ld a,(l7b94)
cp (hl)
call ErrNZ
db _IllLabel
ex de,hl
l5639:
call puttolabel_d_e ; Put to table
ld a,(l7b95)
call puttolabel
call StJP ; Set JP
push iy
pop de
call puttolabel_d_e ; Put to table
jp writeword_hl_addriy
;
; Statement WITH
;
l564e:
ld a,(l7bc9)
push af
l5652:
ld a,(l7bc6)
ld hl,l7bc9
cp (hl)
call ErrZ
db _TooManyWITH
call l677f
ld a,(l7b5c) ; Get type
cp _Record
call ErrNZ
db _RecVarExp
ld hl,l7bc9
ld e,(hl)
ld d,0
inc (hl)
ld hl,l7bcc
add hl,de
ld a,(l7b5d)
ld (hl),a
ld hl,(l7bca)
add hl,de
add hl,de
ld a,_LDHL_a
call StCode
call l6f13 ; Test ,
jr z,l5652 ; Yeap
call FindStr ; Find DO
dw l7572
call ErrNZ
db _NoDO
call l5385 ; Process a statement
pop af
ld (l7bc9),a
ret
;
; Statement INLINE
;
l5698:
call l6f66 ; Verify (
l569b:
ld a,'>'
call l6f29
ld a,2
jr z,l56ae
ld a,'<'
call l6f29
ld a,1
jr z,l56ae
xor a
l56ae:
ld (l7ba6),a
xor a
ld h,a
ld l,a
ld b,a
l56b5:
push bc
push hl
call GetConst ; Get constant
jr nz,l56c5
ld a,b
cp 0ah
jr z,l5702
call ERROR
db _IntConst
l56c5:
ld hl,l7ba6
ld a,(hl)
or a
jr nz,l56ce
ld (hl),2
l56ce:
ld a,'*'
call l6f29
jr nz,l56da
push iy
pop hl
jr l5702
l56da:
ld bc,256*4+0
call FndLABEL
jr nz,l56ea
call l5276
ld hl,(l7b58) ; Get value
jr l5702
l56ea:
ld bc,256*5+0
call FndLABEL
jr z,l56fc
ld bc,256*6+0
call FndLABEL
call ErrNZ
db _IllINLINE
l56fc:
dec hl
dec hl
ld d,(hl)
dec hl
ld e,(hl)
ex de,hl
l5702:
pop de
pop bc
dec b
jr nz,l570a
call NegateInt
l570a:
add hl,de
ld b,0
ld a,'+'
call l6f29
jr z,l56b5
inc b
ld a,'-'
call l6f29
jr z,l56b5
ld a,(l7ba6)
cp 1
jr z,l5729
jr nc,l572f
inc h
dec h
jr nz,l572f
l5729:
ld a,l ; Get byte
call writebyte_a_addriy ; Store it
jr l5732
l572f:
call writeword_hl_addriy
l5732:
ld a,'/'
call l6f29
jp z,l569b
jp l6f6e ; Verify )
l573d:
dec hl
ld b,(hl)
dec hl
ld d,(hl)
dec hl
ld e,(hl)
dec hl
push de
ld d,(hl)
dec hl
ld e,(hl)
dec hl
push de
dec hl
dec hl
ld d,(hl)
dec hl
ld e,(hl)
dec hl
push de
ld d,(hl)
dec hl
ld e,(hl)
dec hl
push de
inc b
dec b
jp z,l57d6
call l6f66 ; Verify (
l575e:
push bc
ld b,(hl)
dec hl
ld a,(hl)
dec hl
ld (Envir1),a
ld d,(hl)
dec hl
ld e,(hl)
dec hl
ld c,b
l576b:
bit 7,(hl)
dec hl
jr z,l576b
djnz l576b
ld b,c
push hl
ex de,hl
call l5287 ; Get name
l5778:
push bc
ld a,(Envir1)
or a
jr nz,l57a9
ld a,(l7b5c) ; Get type
cp _Set
jr c,l57a1
call l5e84
call l5864
ld a,(l7b5c) ; Get type
cp _Ptr
jr z,l57bd
cp _Real
jr c,l57c0
jr nz,l57bd
call StImm ; Set sequence
db a_L20
s_I20:
PUSH BC
PUSH DE
a_L20 equ $-s_I20
jr l57bd
l57a1:
call l6d2a ; Save environment
call l6749
jr l57af
l57a9:
call l6d2a ; Save environment
call l677f
l57af:
call CpyEnv2
ld a,(l7b69)
cp 0
call nz,l58c5
call RestEnv1 ; Get back environment
l57bd:
call StPUSH ; Set PUSH HL
l57c0:
pop bc
dec b
jr z,l57c9
call l6f5e ; Verify ,
jr l5778
l57c9:
pop hl
pop bc
dec b
jr z,l57d3
call l6f5e ; Verify ,
jr l575e
l57d3:
call l6f6e ; Verify )
l57d6:
pop de
pop hl
ld a,d
or e
jr z,l57e3
call StLD.HL ; Set LD HL,val16
ex de,hl
call StLD.DE ; Set LD DE,val16
l57e3:
pop de
pop hl
ld a,_CALL
jp StCode
l57ea:
ld a,(l7b5c) ; Get type
cp 0
jr z,l57f9
cp _RecF
jr c,l57fd
cp _String
jr nc,l57fd
l57f9:
call ERROR
db _IllAss
l57fd:
ld a,(l7bbd)
bit 1,a
jr nz,l5812
bit 0,a
jr z,l580a
ld a,0ffh
l580a:
ld hl,(l7bbe)
ld (l7b58),hl ; Set value
jr l581a
l5812:
call l678b
call StPUSH ; Set PUSH HL
ld a,1
l581a:
ld (Envir1),a
call l6f7e
ld a,(l7b5c) ; Get type
cp _Set
jp nc,l593a
call l6d2a ; Save environment
call l6749
call RestEnv2
call l58c5
ld a,(Envir2)
dec a
jr z,l5852
inc a
jr z,l5845
call StImm ; Set LD DE,(adr)
db a_L21
s_I21:
dw _LD_a_DE
a_L21 equ $-s_I21
jr l584a
l5845:
call StImm
db a_L22
s_I22:
db _LD.DE ; Set LD DE,adr
a_L22 equ $-s_I22
l584a:
ld hl,(l7b65)
call writeword_hl_addriy
jr l5857
l5852:
call StImm ; Set POP DE
db a_L23
s_I23:
pop de
a_L23 equ $-s_I23
l5857:
ld hl,(l7b6f)
call StLD.BC
call StImm ; Set LDIR
db a_L24
s_I24:
LDIR
a_L24 equ $-s_I24
ret
l5864:
ld a,(l7b5c) ; Get type
cp _Real
jr nz,l5877
ld a,b
cp _Integ
jr nz,l589d
ld b,9
ld hl,l1008
jr l589a
l5877:
cp _String
jr nz,l588c
ld a,b
cp _Char
jr nz,l589d
ld b,8
call StImm ; Set sequence
db a_L25
s_I25:
LD H,L
LD L,1
PUSH HL
a_L25 equ $-s_I25
jr l589d
l588c:
cp _Char
jr nz,l589d
ld a,b
cp _String
jr nz,l589d
ld b,0ch
ld hl,l0996 ; Set check assignment
l589a:
call StCALL_ ; Set CALL <check>
l589d:
ld a,(l7b5c) ; Get type
cp b
jr nz,l58c1
cp 3
jr nz,l58b1
ld a,c
or a
ret z
ld hl,(l7b5e) ; Get lo set limit
cp (hl)
ret z
jr l58c1
l58b1:
cp 4
ret nz
ld hl,(l7b8b)
ld a,h
or l
ret z
ld de,(l7b5e) ; Get lo set limit
sbc hl,de
ret z
l58c1:
call ERROR
db _InvType
l58c5:
ld a,(l7b5c) ; Get type
cp 0
jr z,l591b
ld c,0bfh
cp _Integ
jr nc,l5906
ld c,83h
cp _String
jr nz,l58e3
ld a,(l7b9e) ; Get local options
bit _Vopt,a ; Test $V+
jr nz,l5906 ; Yeap
ld c,80h
jr l5906
l58e3:
cp _TxtF
jr nc,l5906
ld c,0b3h
cp _Set
jr nc,l5906
ld c,0c3h
cp _Record
jr nc,l5906
ld hl,(l7b60) ; Get hi set limit
ld a,h
or l
ld c,0bfh
jr nz,l5906
ld hl,(l7b6d) ; Get last memory address
ld a,(hl)
cp 0ah
jr nz,l591b
ld c,0b3h
l5906:
ld hl,l7b5c ; Point to type
ld de,l7b69
ld b,8
l590e:
rl c
jr nc,l5916
ld a,(de)
cp (hl)
jr nz,l591b
l5916:
inc hl
inc de
djnz l590e
ret
l591b:
call ERROR
db _InvType
l591f:
ld de,lfffc
add hl,de
ld d,(hl)
dec hl
ld e,(hl)
dec hl
push de
ld d,(hl)
dec hl
ld e,(hl)
ld (l7b58),de ; Set value
pop hl
call l5287 ; Get name
xor a
ld (Envir1),a
call l6f7e
l593a:
call l5e84
call l5864
jp l661b
;
; Procedure ASSIGN(FileVar,String)
;
l5943:
call l5a0c
ld hl,l1370
cp 6
jr nz,l5955
ld hl,l136f
call l5955
jr l5989
l5955:
push hl
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5ed0
pop hl
l5960:
call l6f6e ; Verify )
jp StCALL_ ; Set CALL <...>
;
; Procedure RENAME(FileVar,String)
;
l5966:
call l5a0c
ld hl,l1ba5
call l5955
jr l5989
;
; Procedure ERASE(FileVar)
;
l5971:
call l5a0c
ld hl,l1b93
jr l5960
;
; Procedure CHAIN(FileVar)
;
l5979:
ld hl,l1beb
jr l5981
;
; Procedure EXECUTE(FileVar)
;
l597e:
ld hl,l1bea
l5981:
push hl
call l5a0c
l5985:
pop hl
l5986:
call l5960
l5989:
jp l5abe
;
; Procedure SEEK(FileVar,Integer)
;
l598c:
call l5a0c
cp 6
call ErrZ
db _IllTxtFile
ld hl,l19d5
cp 5
jr z,l599f
ld hl,l1b6f
l599f:
push hl
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5e97
jr l5985
;
; Procedure FLUSH(FileVar)
;
l59ab:
call l5a0c
cp 5
call ErrNZ
db _IllFileType
ld hl,l19a5
jr l5986
;
; Procedure RESET(FileVar,String)
;
l59b9:
ld hl,l59fa
jr l59c1
;
; Procedure REWRITE(FileVar,String)
;
l59be:
ld hl,l5a00
l59c1:
push hl
call l5a0c
ld a,(l7b5c) ; Get type
cp _RecF
jr nz,l59d8
ld hl,(l7b5e) ; Get lo set limit
call l5271 ; Load name
ld hl,(l7b6f)
call StLD.DE ; Set LD DE,val16
l59d8:
pop hl
jr l59e1
;
; Procedure CLOSE(FileVar)
;
l59db:
call l5a0c
ld hl,l5a06
l59e1:
call l6f6e ; Verify )
call l59e9
jr l5989
l59e9:
ld a,(l7b5c) ; Get type
sub _RecF
add a,a
ld e,a
ld d,0
add hl,de
ld e,(hl)
inc hl
ld d,(hl)
ex de,hl
jp StCALL_ ; Set CALL <...>
l59fa: ;reset procedures
dw l1811 ; Record file
dw l13ff ; Text file
dw l1a70 ; Untyped file
l5a00: ;rewrite procedures
dw l1810
dw l13fe
dw l1a6f
l5a06: ;close procedures
dw l187a
dw l1469
dw l1ab0
l5a0c:
call l6f66 ; Verify (
call l5a17
ret z
call ERROR
db _FileVarExp
l5a17:
call l67b2
scf
ret nz
ld a,(l7b5c) ; Get type
cp _RecF
jr c,l5a2f
cp _String
jr nc,l5a2f
call l678b
xor a
ld a,(l7b5c) ; Get back type
ret
l5a2f:
xor a
dec a
ret
;
; Procedure READLN(FileVar,Variables)
;
l5a32:
db skip
;
; Procedure READ(FileVar,Variables)
;
l5a33:
xor a
ld (l7ba3),a
call l6f1b ; Test (
jr z,l5a41 ; Yeap
call l5aca
jr l5ab4
l5a41:
call l5a17 ;get type???
jr c,l5a63
jr nz,l5a5b
cp 5 ;_RecF???
jp z,l5bd8
cp 6 ;_TxtF???
call ErrNZ
db _NoUntypeFile
ld hl,l14a9
call StCALL_ ; Set CALL FILECHECK
jr l5aac
l5a5b:
call l678b
call l5aca
jr l5a69
l5a63:
call l5aca
l5a66:
call l677f
l5a69:
ld a,(l7b5c) ; Get type
cp _String
jr c,l5a78
cp _Bool
jr z,l5a78
cp _Char+1
jr c,l5a7c
l5a78:
call ERROR
db _InvIO
l5a7c:
cp _String
jr nz,l5a8f
ld a,(l7b62) ; Get length of type
dec a
ld h,a
ld l,6
call writeword_hl_addriy
ld hl,l168e
jr l5aa9
l5a8f:
ld hl,l1672
cp _Real
jr z,l5aa9
ld hl,l1644
cp _Char
jr z,l5aa9
ld hl,l164e
ld a,(l7b62) ; Get length of type
dec a
jr nz,l5aa9
ld hl,l164d
l5aa9:
call StCALL_ ; Set CALL <read>
l5aac:
call l6f13 ; Test ,
jr z,l5a66 ; Yeap
call l6f6e ; Verify )
l5ab4:
ld hl,l16ab
l5ab7:
ld a,(l7ba3)
or a
call nz,StCALL_ ; Set CALL NEWLINE
l5abe:
ld a,(l7b9e) ; Get local options
bit _Iopt,a ; Test $I+
ret z ; Nope
ld hl,l201b
jp StCALL_ ; Set CALL CHECKIO
l5aca:
ld hl,l149b
ld a,(l7b9e) ; Get local options
bit _Bopt,a ; Test $B+
jr z,l5ae4 ; Nope
ld hl,l14cc
ld a,(l7ba3)
or a
jr z,l5ae4
ld hl,l14cb
xor a
ld (l7ba3),a
l5ae4:
jp StCALL_ ; Set CALL <read>
;
; Procedure WRITELN(FileVar,Variables)
;
l5ae7:
db skip
;
; Procedure WRITE(FileVar,Variables)
;
l5ae8:
xor a
ld (l7ba3),a
call l6f1b ; Test (
jr z,l5afa ; Yeap
ld hl,l149b
call StCALL_ ; Set CALL STDIO
jp l5bd2
l5afa:
call l5a17
jr c,l5b20
jr nz,l5b15
cp 5
jp z,l5bdd
cp 6
call ErrNZ
db _NoUntypeFile
ld hl,l14ba
call StCALL_ ; Set CALL CHECKWRFILE
jp l5bc9
l5b15:
call l620f
ld hl,l149b
call StCALL_ ; Set CALL STDIO
jr l5b4f
l5b20:
ld hl,l149b
call StCALL_ ; Set CALL STDIO
l5b26:
call GetLabType
jr nz,l5b4c
ld a,b
cp 8 ;_String???
jr nz,l5b47
ld a,(ix+0)
cp ','
jr z,l5b3b
cp ')'
jr nz,l5b47
l5b3b:
ld hl,l17ba
call StCALL_ ; Set CALL IMSTRG
call StLen
jp l5bc9
l5b47:
call l6201
jr l5b4f
l5b4c:
call l5ee8
l5b4f:
ld a,b
cp 8 ;0..7: _Array,_Record,_Set,_Ptr,_RecF,_TxtF,_UntF
jr c,l5b58 ;not a scalar type???
cp 0dh ;element of a set???
jr c,l5b5c ;8..12: (_String excluded above),_Real,_Integ,_Bool,_Char
l5b58:
call ERROR
db _InvIO
l5b5c:
cp 0ch ;_Char???
jr nz,l5b6a
call l6f0b ; Test :
jr nz,l5ba6
call l5edd
jr l5b72
l5b6a:
call l6148
call l6f0b ; Test :
jr nz,l5b8b
l5b72:
push bc
call l5e97
pop bc
ld a,b
cp 9 ;_Real???
jr nz,l5ba6
call l6f0b ; Test :
jr nz,l5b9d
push bc
call StPUSH ; Set PUSH HL
call l5e97
pop bc
jr l5ba6
l5b8b:
ld hl,l0000
ld a,b
cp 9 ;_Real???
jr nz,l5b95
ld l,12h
l5b95:
call StLD.HL ; Set LD HL,val16
ld a,b
cp 9 ;_Real???
jr nz,l5ba6
l5b9d:
call StPUSH ; Set PUSH HL
ld hl,lffff
call StLD.HL ; Set LD HL,val16
l5ba6:
ld a,b
ld hl,l17aa
cp 8 ;_String???
jr z,l5bc6
ld hl,l1779
cp 9 ;_Real???
jr z,l5bc6
ld hl,l1726
cp 0ah ;_Integ???
jr z,l5bc6
ld hl,l178b
cp 0bh ;_Bool???
jr z,l5bc6
ld hl,l1722
l5bc6:
call StCALL_ ; Set CALL <wrtype>
l5bc9:
call l6f13 ; Test ,
jp z,l5b26 ; Yeap
call l6f6e ; Verify )
l5bd2:
ld hl,l17cd
jp l5ab7
l5bd8:
ld hl,l18b6
jr l5be0
l5bdd:
ld hl,l18dc
l5be0:
ld (l7ba7),hl
ld a,(l7ba3)
or a
call ErrNZ
db _MustTextFile
ld hl,l18a4
call StCALL_ ; Set CALL PREPRECWR
ld hl,(l7b5e) ; Get lo set limit
call l5271 ; Load name
l5bf7:
call l6f13 ; Test ,
jr nz,l5c10 ; Nope
call SavEnv2
call l677f
call RestEnv2
call l58c5
ld hl,(l7ba7)
call StCALL_ ; Set CALL <write>
jr l5bf7
l5c10:
call l6f6e ; Verify )
jp l5abe
;
; Procedure BLOCKREAD(FileVar,Variable,Integer[,Integer])
;
l5c16:
ld hl,l1af1
ld de,l1abe
jr l5c24
;
; Procedure BLOCKWRITE(FileVar,Variable,Integer[,Integer])
;
l5c1e:
ld hl,l1aed
ld de,l1aba
l5c24:
push hl
push de
call l5a0c
cp 7
call ErrNZ
db _UntFileExp
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l677f
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5e97
call l6f13 ; Test ,
pop de
pop hl
jr z,l5c4b ; Yeap
push de
jr l5c63
l5c4b:
push hl
call StPUSH ; Set PUSH HL
call l677f
ld a,(l7b5c) ; Get type
cp _Integ
jr nz,l5c5f
ld a,(l7b62) ; Get length of type
dec a
jr nz,l5c63
l5c5f:
call ERROR
db _IntVarExp
l5c63:
jp l5985
;
; Procedure DELETE(String,Integer,Integer)
;
l5c66:
call l6f66 ; Verify (
call l5cad
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5e97
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5e97
ld hl,l08f3 ; Set DELETE
l5c81:
call l6f6e ; Verify )
jp StCALL_ ; Set CALL <string_procedure>
;
; Procedure INSERT(String,String,Integer)
;
l5c87:
call l6f66 ; Verify (
call l5ed0
call l6f5e ; Verify ,
call l5cad
call StPUSH ; Set PUSH HL
ld a,(l7b62) ; Get length of type
dec a
ld h,a
ld l,6
push hl
call l6f5e ; Verify ,
call l5e97
pop hl
call writeword_hl_addriy
ld hl,l0920
jr l5c81 ; Set INSERT
l5cad:
call l677f
ld a,(l7b5c) ; Get type
cp _String
ret z
call ERROR
db _StrgVarExp
;
; Procedure STR(Num,String)
;
l5cba:
call l6f66 ; Verify (
call l5ea2
call l6148
call l6f0b ; Test :
jr nz,l5ce4
push bc
call l5e97
call StPUSH ; Set PUSH HL
pop bc
ld a,b
cp 0ah
jr z,l5d02
call l6f0b ; Test :
jr nz,l5cf9
push bc
call l5e97
call StPUSH ; Set PUSH HL
pop bc
jr l5d02
l5ce4:
ld hl,l0000
ld a,b
cp 0ah
jr z,l5cee
ld l,12h
l5cee:
call StLD.HL ; Set LD HL,val16
call StPUSH ; Set PUSH HL
ld a,b
cp 0ah
jr z,l5d02
l5cf9:
ld hl,lffff
call StLD.HL ; Set LD HL,val16
call StPUSH ; Set PUSH HL
l5d02:
call l6f5e ; Verify ,
push bc
call l5cad
ld a,(l7b62) ; Get length of type
dec a
ld h,a
ld l,6
call writeword_hl_addriy
pop bc
ld hl,l1ebe
ld a,b
cp 0ah
jr z,l5d1f
ld hl,l1ebd
l5d1f:
jp l5c81
;
; Procedure VAL(String,Integer,Integer)
;
l5d22:
call l6f66 ; Verify (
call l5ed0
call l6f5e ; Verify ,
call l677f
ld a,(l7b5c) ; Get type
cp _Real
jr z,l5d45
cp _Integ
jr nz,l5d41
ld a,(l7b62) ; Get length of type
dec a
ld a,0ah
jr nz,l5d45
l5d41:
call ERROR
db _NumVarExp
l5d45:
push af
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l677f
ld a,(l7b5c) ; Get type
cp _Integ
jr nz,l5d5c
ld a,(l7b62) ; Get length of type
dec a
jr nz,l5d60
l5d5c:
call ERROR
db _IntVarExp
l5d60:
pop af
ld hl,l1ef4
cp 0ah
jr z,l5d1f
ld hl,l1ef3
jr l5d1f
;
; Procedure GOTOXY(Integer,Integer)
;
l5d6d:
call l6f66 ; Verify (
call l5e97
ld hl,l1fdb
l5d76:
push hl
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5e97
pop hl
jr l5db1
;
; Procedure RANDOMIZE
;
l5d83:
ld hl,l1f48
jp StCALL_ ; Set CALL RANDOMIZE
;
; Procedure DELAY(Integer)
;
l5d89:
call l6f66 ; Verify (
call l5e97
ld hl,l021d
jr l5db1 ; Set call to delay
;
; Procedure GETMEM(Variable,Integer)
;
l5d94:
call l5de3
call l6f5e ; Verify ,
call l5e97
jr l5dae
;
; Procedure NEW(Variable)
;
l5d9f:
call l5de3
ld hl,(l7b5e) ; Get lo set limit
call l5271 ; Load name
ld hl,(l7b6f)
call StLD.HL ; Set LD HL,val16
l5dae:
ld hl,l1ce5
l5db1:
jp l5960
;
; Procedure FREEMEM(Variable,Integer)
;
l5db4:
call l5de3
call l6f5e ; Verify ,
call l5e97
jr l5dce
;
; Procedure DISPOSE(Variable)
;
l5dbf:
call l5de3
ld hl,(l7b5e) ; Get lo set limit
call l5271 ; Load name
ld hl,(l7b6f)
call StLD.HL ; Set LD HL,val16
l5dce:
ld hl,l1d7a
jp l5960
;
; Procedure MARK(Variable)
;
l5dd4:
ld hl,l1ea3
jr l5ddc
;
; Procedure RELEASE(Variable)
;
l5dd9:
ld hl,l1eab
l5ddc:
push hl
call l5de9
pop hl
jr l5db1
l5de3:
call l5de9
jp StPUSH ; Set PUSH HL
l5de9:
call l6f66 ; Verify (
call l677f
ld a,(l7b5c) ; Get type
cp _Ptr
ret z
call ERROR
db _PtrVarExp
;
; Procedure OVRDRIVE(Integer)
;
l5df9:
call l6f66 ; Verify (
call l5e97
ld hl,l1cdb
jp l5960
;
; Procedure MOVE(Integer,Integer,Integer)
;
l5e05:
call l6f66 ; Verify (
call l677f
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l677f
ld hl,l1f64
jp l5d76
;
; Procedure FILLCHAR(Integer,Integer,Byte)
;
l5e1a:
call l6f66 ; Verify (
call l677f
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5e97
call StPUSH ; Set PUSH HL
call l6f5e ; Verify ,
call l5ebb
ld hl,l1f4e
jp l5db1
;
; Procedure CRTINIT
;
l5e38:
ld hl,l030a
jr l5e45 ; Set call to lead in
;
; Procedure CRTEXIT
;
l5e3d:
ld hl,l0310
jr l5e45 ; Set call to lead out
;
; Procedure CLRSCR
;
l5e42:
ld hl,l023e ; Set call to clear screen
l5e45:
jp StCALL_ ; Set CALL <crt_procedure>
;
; Procedure CLREOL
;
l5e48:
ld hl,l0299 ; Set call to clear to end of line
jr l5e45
;
; Procedure NORMVIDEO or HIGHVIDEO
;
l5e4d:
ld hl,setnormvideo ; Set call to normal video
jr l5e45
;
; Procedure LOWVIDEO
;
l5e52:
ld hl,setlowvideo ; Set call to low video
jr l5e45
;
; Procedure INSLINE
;
l5e57:
ld hl,l0262 ; Set call to insert line
jr l5e45
;
; Procedure DELLINE
;
l5e5c:
ld hl,l0259 ; Set call to delete line
jr l5e45
;
; Procedure EXIT
;
l5e61:
ld de,OS ; Set call to exit
jp l5639
;
; Procedure HALT
;
l5e67:
ld hl,l20d4
jp StJP_ ; Set call to HALT program
;
; Procedure PORT(Integer,Integer)
;
l5e6d:
call l5e8e
call StImm ; Set sequence
db a_L26
s_I26:
POP BC
OUT (C),L
a_L26 equ $-s_I26
ret
;
; Procedure STACKPTR
;
l5e78:
call l6f7e
call l5e97
call StImm ; Set LD SP,HL
db a_L27
s_I27:
LD SP,HL
a_L27 equ $-s_I27
ret
l5e84:
call l6d2a ; Save environment
call l5ee8
call RestEnv1 ; Get back environment
ret
l5e8e:
call l65d5
call l6f7e
call StPUSH ; Set PUSH HL
l5e97:
call l5ee8
ld a,b
cp 0ah
ret z
call ERROR
db _IntExpr
l5ea2:
call l5ee8
ld a,b
cp 0ah
ret z
cp 9
ret z
call ERROR
db _NumExprExp
l5eb0:
call l5ee8
ld a,b
cp 0bh
ret z
call ERROR
db _BoolExp
l5ebb:
call l5ee8
l5ebe:
ld a,b
cp 0ah
ret nc
cp 8
call ErrNZ
db _SimpExpr
ld b,0ch
ld hl,l0996
jp StCALL_ ; Set CALL CHECKASSIGNMENT
l5ed0:
call l5ee8
ld a,b
cp 8
ret z
cp 0ch
call ErrNZ
db _StrgExpExp
l5edd:
ld b,8
call StImm ; Set sequence
db a_L28
s_I28:
LD H,L
LD L,1
PUSH HL
a_L28 equ $-s_I28
ret
l5ee8:
call l5f98
l5eeb:
push bc
call FndTabStr ; Find relation
db 1
dw l7625
pop bc
ret nz ; Nope
ld a,(hl) ; Get code
inc a ; Test IN
jr z,l5f34 ; Yeap
dec a
push af
push bc
call l6148
ld hl,(l7b8b)
push hl
call l5f98
pop hl
ld (l7b8d),hl
pop de
call l6160
pop af
ld e,a
ld d,0
ld hl,l5f68
add hl,de
ld a,b
cp 3
jr z,l5f28
inc hl
inc hl
cp 9
jr z,l5f28
inc hl
inc hl
cp 8
jr z,l5f28
inc hl
inc hl
l5f28:
ld e,(hl)
inc hl
ld d,(hl)
ld a,d
or e
call ErrZ
db _IllOps
ex de,hl
jr l5f62
l5f34:
ld a,b
cp 0ah
jr nc,l5f47
cp 8
call ErrNZ
db _IllOps
ld hl,l0996
call StCALL_ ; Set CALL CHECKASSIGNMENT
ld b,0ch
l5f47:
push bc
call StPUSH ; Set PUSH HL
call l5f98
pop de
ld a,b
cp 3
call ErrNZ
db _IllOps
ld a,c
or a
jr z,l5f5f
cp d
call ErrNZ
db _InvType
l5f5f:
ld hl,l134f
l5f62:
call StCALL_ ; Set CALL <set>
ld b,0bh
ret
l5f68:
dw l12e1
dw l0688 ; Real =
dw l068d ; String =
dw l067f ; Integer =
dw l12dd
dw l069b ; Real <>
dw l06a0 ; String <>
dw l0692 ; Integer <>
dw l1300
dw l06ae ; Real >=
dw l06b3 ; String >=
dw l06a5 ; Integer >=
dw l12fc
dw l06c2 ; Real <=
dw l06c7 ; String <=
dw l06b8 ; Integer <=
dw l0000
dw l06d6 ; Real >
dw l06db ; String >
dw l06cc ; Integer >
dw l0000
dw l06e9 ; Real <
dw l06ee ; String <
dw l06e0 ; Integer <
l5f98:
call l6054
l5f9b:
push bc
call FndTabStr ; Find operator
db 1
dw l7619
pop bc
ret nz ; Nope
ld a,b
cp 4
call ErrZ
db _IllOps
ld a,(hl) ; Get operator
push af
push bc
call l6148
call l6054
pop de
pop af ; Get back operator
push af
or a ; Test +
jr nz,l5fc9 ; Nope
ld a,b
cp 0ch
jr nz,l5fc9
call StImm ; Set sequence
db a_L29
s_I29:
LD H,L
LD L,1
PUSH HL
a_L29 equ $-s_I29
ld b,8
l5fc9:
call l6160
pop af ; Get back operator
cp 2 ; Test -
jr nc,l601b ; Nope, OR or XOR
push af
ld a,b
ld hl,l1318
ld de,l1326
cp 3
jr z,l6006
ld hl,l09e9 ; Set add reals
ld de,l09f2 ; Set subtract reals
cp 9
jr z,l6006
cp 8
jr z,l6010
cp 0ah
call ErrNZ
db _IllOps
pop af
dec a
jr z,l5ffc
call StImm ; Set ADD HL,DE
db a_L30
s_I30:
ADD HL,DE
a_L30 equ $-s_I30
jr l5f9b
l5ffc:
call StImm ; Set sequence
db a_L31
s_I31:
EX DE,HL
OR A
SBC HL,DE
a_L31 equ $-s_I31
jr l5f9b
l6006:
pop af
dec a
jr nz,l600b
ex de,hl
l600b:
call StCALL_ ; Set CALL <string>
jr l5f9b
l6010:
pop af
dec a
call ErrZ
db _IllOps
ld hl,l083d
jr l600b ; Set add two strings
l601b:
ld a,b
jr nz,l6039 ; Must be XOR
cp 0bh
jr z,l602f
cp 0ah
call ErrNZ
db _IllOps
call StImm ; Set OR
db a_L32
s_I32:
LD A,H
OR D
LD H,A
a_L32 equ $-s_I32
l602f:
call StImm ; Set OR
db a_L33
s_I33:
LD A,L
OR E
LD L,A
a_L33 equ $-s_I33
jp l5f9b
l6039:
cp 0bh
jr z,l604a
cp 0ah
call ErrNZ
db _IllOps
call StImm ; Set XOR
db a_L34
s_I34:
LD A,H
XOR D
LD H,A
a_L34 equ $-s_I34
l604a:
call StImm ; Set XOR
db a_L35
s_I35:
LD A,L
XOR E
LD L,A
a_L35 equ $-s_I35
jp l5f9b
l6054:
call l60e9
l6057:
push bc
call FndTabStr ; Find operator
db 1
dw l7600
pop bc
ret nz ; Nope
ld a,b
cp 4
call ErrZ
db _IllOps
ld a,(hl) ; Get operator
push af
push bc
call l6148
call l60e9
pop de
pop af ; Get back operator
push af
dec a ; Test /
jr nz,l6083 ; Nope
ld a,b
cp 0ah
jr nz,l6083
ld hl,l1008
call StCALL_ ; Set CALL INT_TO_FLP
ld b,9
l6083:
call l6160
pop af ; Get back operator
ld e,a
ld a,b
inc e ; Test *
dec e
jr nz,l60a9 ; Nope
ld hl,l1333
cp 3
jr z,l60a4
ld hl,l06f5 ; Set integer multiply
cp 0ah
jr z,l60a4
ld hl,l09fa ; Set real multiply
l609e:
cp 9
call ErrNZ
db _IllOps
l60a4:
call StCALL_ ; Set CALL <real>
jr l6057
l60a9:
ld hl,l09ff ; Set real division
dec e ; Test /
jr z,l609e ; Yeap
dec e ; Test AND
jr nz,l60cc ; Nope
cp 0bh
jr z,l60c3
cp 0ah
call ErrNZ
db _IllOps
call StImm ; Set AND
db a_L36
s_I36:
LD A,H
AND D
LD H,A
a_L36 equ $-s_I36
l60c3:
call StImm ; Set AND
db a_L37
s_I37:
LD A,L
AND E
LD L,A
a_L37 equ $-s_I37
jr l6057
l60cc:
cp 0ah
call ErrNZ
db _IllOps
ld hl,l070f ; Set integer DIV
dec e ; Test DIV
jr z,l60a4 ; Yeap
ld hl,l0745 ; Set integer MOD
dec e ; Test MOD
jr z,l60a4
ld hl,l074e ; Set SHL
dec e ; Test SHL
jr z,l60a4
ld hl,l0756 ; Set SHR
jr l60a4
l60e9:
call FindStr ; Find NOT
dw l7579
jr nz,l6112 ; Nope
call l6112
ld a,b
cp 0ah
jr z,l6107
cp 0bh
call ErrNZ
db _IllOps
call StImm ; Set sequence
db a_L38
s_I38:
LD A,L
XOR 1
LD L,A
a_L38 equ $-s_I38
ret
l6107:
call StImm ; Set sequence
db a_L39
s_I39:
LD A,L
CPL
LD L,A
LD A,H
CPL
LD H,A
a_L39 equ $-s_I39
ret
l6112:
ld a,(l7ba1)
push af
call GetSign
ld a,e
ld (l7ba1),a
call l621d
ld a,(l7ba1)
ld e,a
call ChkNumSign
jr z,l6143
ld a,b
cp 0ah
jr nz,l613b
call StImm ; Set sequence
db a_L40
s_I40:
LD A,L
CPL
LD L,A
LD A,H
CPL
LD H,A
INC HL
a_L40 equ $-s_I40
jr l6143
l613b:
call StImm ; Set sequence
db a_L41
s_I41:
LD A,B
XOR 80H
LD B,A
a_L41 equ $-s_I41
l6143:
pop af
ld (l7ba1),a
ret
l6148:
ld a,b
cp 0ah
jr nc,l615d
cp 4
jr z,l615d
cp 8
ret z
cp 3
ret z
call StImm ; Set sequence
db a_L42
s_I42:
PUSH BC
PUSH DE
a_L42 equ $-s_I42
l615d:
jp StPUSH ; Set PUSH HL
l6160:
ld a,d
cp 9
jr nz,l6174
ld a,b
cp 0ah
jr nz,l6187
ld hl,l1008
call StCALL_ ; Set CALL INT_TO_FLP
ld b,9
jr l6187
l6174:
cp 8
jr nz,l6187
ld a,b
cp 0ch
jr nz,l6187
call StImm ; Set sequence
db a_L43
s_I43:
LD H,L
LD L,1
PUSH HL
a_L43 equ $-s_I43
ld b,8
l6187:
ld a,b
cp 9
jr nz,l6193
call StImm ; Set EXX
db a_L44
s_I44:
EXX
a_L44 equ $-s_I44
jr l61a4
l6193:
cp 8
jr nz,l61a4
ld a,d
cp 0ch
jr nz,l61a4
ld hl,l09a2
call StCALL_ ; Set CALL CHR_TO_STRG
ld d,8
l61a4:
ld a,d
cp 0ah
jr z,l61bc
jr nc,l61ce
cp 4
jr z,l61ce
cp 9
jr c,l61d3
call StImm ; Set sequence
db a_L45
s_I45:
POP HL
POP DE
POP BC
a_L45 equ $-s_I45
jr l61d3
l61bc:
ld a,b
cp 9
jr nz,l61ce
call StPOP ; Set POP HL
ld hl,l1008
call StCALL_ ; Set CALL INT_TO_FLP
ld d,9
jr l61d3
l61ce:
call StImm ; Set POP DE
db a_L46
s_I46:
POP DE
a_L46 equ $-s_I46
l61d3:
ld a,b
cp d
call ErrNZ
db _InvType
cp 3
jr nz,l61ea
ld a,e
cp c
ret z
or a
ret z
ld a,c
ld c,e
or a
ret z
call ERROR
db _InvType
l61ea:
cp 4
ret nz
ld hl,(l7b8b)
ld a,h
or l
ret z
ld de,(l7b8d)
ld a,d
or e
ret z
sbc hl,de
ret z
call ERROR
db _InvType
l6201:
ld de,l5eeb
push de
ld de,l5f9b
push de
ld de,l6057
push de
jr l622d
l620f:
ld de,l5eeb
push de
ld de,l5f9b
push de
ld de,l6057
push de
jr l6276
l621d:
call GetLabType
jr nz,l6257
ld a,(l7ba1)
ld e,a
call NegateNum
xor a
ld (l7ba1),a
l622d:
ld a,b
cp 9
jr nz,l6249
exx
push bc
push de
push hl
ld bc,256*3+031h
l6239:
ld a,c
sub 10h
ld c,a ; Get byte
call writebyte_a_addriy ; Store it
pop hl
call writeword_hl_addriy
djnz l6239
ld b,9
ret
l6249:
cp 8
jp nz,StLD.HL ; Set LD HL,val16
ld hl,l054d
call StCALL_ ; move immediate string to stack
jp StLen
l6257:
ld bc,256*6+0
call FndLABEL
jr nz,l6271
call l573d
ex de,hl
call l5287 ; Get name
ld hl,(l7b5e) ; Get lo set limit
ld (l7b8b),hl
ld a,(l7b5c) ; Get type
ld b,a
ret
l6271:
call l67b2
jr nz,l62d2
l6276:
ld a,(l7b5c) ; Get type
cp _String
jr nc,l6285
cp _Set
jr z,l6285
cp _Ptr
jr nz,l629d
l6285:
call l66da
ld hl,(l7b5e) ; Get lo set limit
ld (l7b8b),hl
ld a,(l7b5c) ; Get type
ld b,a
cp _Set
ret nz
call l5287 ; Get name
ld a,(l7b5c) ; Get type
ld c,a
ret
l629d:
cp _Array
call ErrNZ
db _NoStruktVar
call l678b
ld hl,(l7b5e) ; Get lo set limit
ld a,(hl)
cp 0ch
call ErrNZ
db _NoStruktVar
ld hl,(l7b60) ; Get hi set limit
ld a,(hl)
cp 0ah
call ErrNZ
db _NoStruktVar
ld hl,(l7b62) ; Get length of type
ld a,h
or a
call ErrNZ
db _NoStruktVar
ld h,l
ld l,6
call writeword_hl_addriy
ld hl,l0638
call StCALL_ ; Set set to stack
ld b,8
ret
l62d2:
call l6ee0
jr nz,l631c
ld hl,l0581
call StCALL_ ; Initialize a set on stack
call l6ef7 ; Test ]
ld bc,3*256+0 ;l0300
ret z ; Yeap
l62e4:
push bc
call l5ebb
ld a,b
pop bc
inc c
dec c
jr nz,l62ef
ld c,a
l62ef:
cp c
call ErrNZ
db _InvType
push bc
call FindStr ; Find ..
dw l7580
ld hl,l0591
jr nz,l6310 ; Nope, init one set element
call StPUSH ; Set PUSH HL
call l5ebb
ld a,b
pop bc
push bc
cp c
call ErrNZ
db _InvType
ld hl,l059b ; Init a contiguous set value
l6310:
call StCALL_ ; Set CALL <set>
pop bc
call l6f13 ; Test ,
jr z,l62e4 ; Yeap
jp l6f38 ; Verify ]
l631c:
call l6f1b ; Test (
jr nz,l6327 ; Nope
call l5ee8
jp l6f6e ; Verify )
l6327:
call FndTabStr ; Find function
db 2
dw l77b1
jr nz,l6335 ; Nope
ld e,(hl)
inc hl
ld d,(hl)
ex de,hl
xor a
jp (hl)
l6335:
call FindStr ; Find NIL
dw l757c
jr nz,l6345 ; Nope
ld hl,l0000
call StLD.HL ; Set LD HL,val16
jp l642e
l6345:
;jr $
ld bc,256*3+0
call FndLABEL ; Find label with type in reg B
call ErrNZ
db _Undef ;TODO fix bb:=(Txt in [Txt]);
ld d,(hl)
dec hl
ld e,(hl)
ld a,(de)
cp 0ah
call ErrCY
db _SimTyp
push af
call l65ef
pop af
ld b,a
ret
;
; Function SQR(Num)
;
l6360:
call l65e7
ld hl,l06f3 ; Set integer SQR
ld a,b
cp 0ah
jr z,l636e
ld hl,l09f7 ; Set real SQR
l636e:
jp StCALL_ ; Set CALL <real>
;
; Function ABS(Num)
;
l6371:
call l65e7
ld a,b
cp 0ah
jr z,l6380
call StImm ; Set RES 7,B
db a_L47
s_I47:
RES 7,B
a_L47 equ $-s_I47
ret
l6380:
ld hl,l0780 ; Set integer ABS
jr l63cf
;
; Function SQRT(Num)
;
l6385:
ld hl,l0c46
jr l63ab
;
; Function SIN(Num)
;
l638a:
ld hl,l0c87
jr l63ab
;
; Function COS(Num)
;
l638f:
ld hl,l0c7f
jr l63ab
;
; Function ARCTAN(Num)
;
l6394:
ld hl,l0e46
jr l63ab
;
; Function LN(Num)
;
l6399:
ld hl,l0d2b
jr l63ab
;
; Function EXP(Num)
;
l639e:
ld hl,l0db6
jr l63ab
;
; Function INT(Num)
;
l63a3:
ld hl,l0bfd
jr l63ab
;
; Function FRAC(Num)
;
l63a8:
ld hl,l0c34
l63ab:
push hl
call l65e7
ld hl,l1008
ld a,b
cp 0ah
call z,StCALL_ ; Set CALL INT_TO_FLP
pop hl
ld b,9
jp StCALL_ ; Set CALL <real>
;
; Function TRUNC(Num)
;
l63be:
ld hl,l0fde
jr l63c6
;
; Function ROUND(Num)
;
l63c3:
ld hl,l0fd0
l63c6:
push hl
call l65e7
pop hl
ld a,b
cp 0ah
ret z
l63cf:
ld b,0ah
jp StCALL_ ; Set CALL <real>
;
; Function SUCC(Num)
;
l63d4:
ld a,_INC.HL ; INC HL
db skip.3
;
; Function PRED(Num)
;
l63d7:
ld a,_DEC.HL ; DEC HL
push af
call l65ef
pop af ; Get byte back
jp writebyte_a_addriy ; Store it
;
; Function LO(Integer)
;
l63e1:
call l65de
call StImm ; Set LD H,0
db a_L48
s_I48:
LD H,0
a_L48 equ $-s_I48
ret
;
; Function HI(Integer)
;
l63eb:
call l65de
call StImm ; Set sequence
db a_L49
s_I49:
LD L,H
LD H,0
a_L49 equ $-s_I49
ret
;
; Function SWAP(Num)
;
l63f6:
call l65de
call StImm ; Set sequence
db a_L50
s_I50:
LD A,L
LD L,H
LD H,A
a_L50 equ $-s_I50
ret
;
; Function ODD(Num)
;
l6401:
call l65de
ld hl,l078b ; Set function ODD
l6407:
ld b,0bh
l6409:
jp StCALL_ ; Set CALL ODD
;
; Function KEYPRESSED
;
l640c:
ld hl,l00a0
jr l6407
;
; Function ORD(Var)
;
l6411:
call l6f66 ; Verify (
call l5ee8
call l6f6e ; Verify )
ld a,b
cp 4
jr z,l6422
call l5ebe
l6422:
ld b,0ah
ret
;
; Function CHR(Num)
;
l6425:
call l65de
ld b,0ch
ret
;
; Function PTR(Integer)
;
l642b:
call l65de
l642e:
ld hl,l0000
ld (l7b8b),hl
ld b,4
ret
;
; Function UPCASE(Char)
;
l6437:
call l65ef
ld b,0ch
ld hl,l1fe4
jr l6409
;
; Function LENGTH(String)
;
l6441:
call l6f66 ; Verify (
ld hl,l08a3 ; Set LENGTH
l6447:
push hl
call l5ed0
call l6f6e ; Verify )
pop hl
jp l63cf
;
; Function POS(String,String)
;
l6452:
call l6f66 ; Verify (
call l5ed0
call l6f5e ; Verify ,
ld hl,l08b2
jr l6447 ; Set POS
;
; Function COPY(String,Integer,Integer)
;
l6460:
call l6f66 ; Verify (
call l5ed0
call l6f5e ; Verify ,
call l5e97
call l6f5e ; Verify ,
call StPUSH ; Set PUSH HL
call l5e97
call l6f6e ; Verify )
ld hl,l086b
call StCALL_ ; Set CALL COPY
l647e:
ld b,8
ret
;
; Function CONCAT(String,String,...)
;
l6481:
call l6f66 ; Verify (
call l5ed0
l6487:
call l6f13 ; Test ,
jr nz,l6497 ; Nope
call l5ed0
ld hl,l083d
call StCALL_ ; Set add two strings
jr l6487
l6497:
call l6f6e ; Verify )
jr l647e
;
; Function PARAMCOUNT
;
l649c:
ld hl,l1f9b
jr l64bf
;
; Function PARAMSTR(Integer)
;
l64a1:
call l65de
ld hl,l1f7d
ld b,8
jp StCALL_ ; Set CALL PARAMSTR
;
; Function RANDOM(Integer)
;
l64ac:
call l6f1b ; Test (
ld hl,l0fb4
ld b,9
jr nz,l64c1 ; Nope
call l5e97
call l6f6e ; Verify )
ld hl,l073b ; Set integer random
l64bf:
ld b,0ah
l64c1:
jp StCALL_ ; Set CALL RANDOM
;
; Function IORESULT
;
l64c4:
ld hl,l1ff1
jr l64bf
;
; Function EOF(FileVar)
;
l64c9:
call l65f7
ld hl,l6615
call l59e9
l64d2:
ld b,0bh
ret
;
; Function SEEKEOF(FileVar)
;
l64d5:
ld hl,l17e1
jr l64e2
;
; Function SEEKEOLN(FileVar)
;
l64da:
ld hl,l17d7
jr l64e2
;
; Function EOLN(TextFileVar)
;
l64df:
ld hl,l17dc
l64e2:
push hl
call l65f7
cp 6
call ErrNZ
db _MustTextFile
pop hl
call StCALL_ ; Set CALL <eoln>
jr l64d2
;
; Function FILEPOS(FileVar)
;
l64f2:
ld hl,l1a55
ld de,l1a55
jr l6500
;
; Function FILESIZE(FileVar)
;
l64fa:
ld hl,l1a5d
ld de,l1a5d
l6500:
push hl
push de
call l65f7
pop de
pop hl
cp 6
call ErrZ
db _IllTxtFile
cp 5
jr z,l64bf
ex de,hl
jr l64bf
;
; Function MEMAVAIL
;
l6514:
ld hl,l1e3d
jr l64bf
;
; Function MAXAVAIL
;
l6519:
ld hl,l1e44
jr l64bf
;
; Procedure BIOS(Integer,Integer)
; Function BIOSHL(Integer,Integer)
;
l651e:
db skip
;
; Function BIOS(Integer,Integer)
;
l651f:
xor a
push af
call l6f66 ; Verify (
call l5e97
call StPUSH ; Set PUSH HL
call l6f13 ; Test ,
jr nz,l6538 ; Nope
call l5e97
call StImm ; Set sequence
db a_L51
s_I51:
LD B,H
LD C,L
a_L51 equ $-s_I51
l6538:
call StImm ; Set POP DE
db a_L52
s_I52:
POP DE
a_L52 equ $-s_I52
ld hl,l1fea
l6540:
call l6f6e ; Verify )
call StCALL_ ; Set CALL BIOS
pop af
ld b,0ah
or a
ret nz
call StImm ; Set sequence
db a_L53
s_I53:
LD L,A
LD H,0
a_L53 equ $-s_I53
ret
;
; Procedure BDOS(Integer,Integer)
; Function BDOSHL(Integer,Integer)
;
l6553:
db skip
;
; Function BDOS(Integer,Integer)
;
l6554:
xor a
push af
call l6f66 ; Verify (
call l5e97
call StPUSH ; Set PUSH HL
call l6f13 ; Test ,
jr nz,l656c ; Nope
call l5e97
call StImm ; Set EX DE,HL
db a_L54
s_I54:
EX DE,HL
a_L54 equ $-s_I54
l656c:
call StImm ; Set POP BC
db a_L55
s_I55:
POP BC
a_L55 equ $-s_I55
ld hl,BDOS
jr l6540
;
; Function ADDR(Var)
;
l6576:
call l6f66 ; Verify (
ld bc,256*5+0
call FndLABEL
jr z,l6589
ld bc,256*6+0
call FndLABEL
jr nz,l6594
l6589:
dec hl
dec hl
ld d,(hl)
dec hl
ld e,(hl)
ex de,hl
l658f:
call StLD.HL ; Set LD HL,val16
jr l6597
l6594:
call l677f
l6597:
call l6f6e ; Verify )
ld b,0ah
ret
;
; Function SIZEOF(Var)
;
l659d:
call l6f66 ; Verify (
ld bc,256*3+0
call FndLABEL
jr nz,l65b1
ld d,(hl)
dec hl
ld e,(hl)
ex de,hl
call l5287 ; Get name
jr l65ba
l65b1:
push iy
call l677f
pop hl
call ChkChn ; Check chaining
l65ba:
ld hl,(l7b62) ; Get length of type
jr l658f
;
; Function PORT(Integer)
;
l65bf:
call l65d5
call StImm ; Set sequence
db a_L56
s_I56:
LD C,L
IN L,(C)
a_L56 equ $-s_I56
ret
;
; Function STACKPTR
;
l65ca:
call StImm ; Set sequence
db a_L57
s_I57:
LD HL,0
ADD HL,SP
a_L57 equ $-s_I57
ld b,0ah
ret
l65d5:
call l6f30 ; Verify [
call l5e97
jp l6f38 ; Verify ]
l65de:
call l6f66 ; Verify (
call l5e97
l65e4:
jp l6f6e ; Verify )
l65e7:
call l6f66 ; Verify (
call l5ea2
jr l65e4
l65ef:
call l6f66 ; Verify (
call l5ebb
jr l65e4
l65f7:
call l6f1b ; Test (
jr z,l6608 ; Yeap
ld hl,l00c2
call StLD.HL ; Set LD HL,val16
ld a,_TxtF
ld (l7b5c),a ; Set TEXT
ret
l6608:
call l5a17
call ErrNZ
db _FileVarExp
push af
call l6f6e ; Verify )
pop af
ret
l6615: ;eof procedures
dw l1a49 ; Record file
dw l17e6 ; Text file
dw l1a49 ; Untyped file
;ld c,c
;ld a,(de)
;and 17h
;ld c,c
;ld a,(de)
;
;
;
l661b:
ld a,(Envir1)
ld c,a
ld hl,(l7b58) ; Get value
ld a,(l7b5c) ; Get type
cp _Set
jr nz,l6634
call l6734
ld hl,l0623
ld de,l0612
jr l6648 ; Assign set variable
l6634:
cp _String
jr nz,l665e
ld a,(l7b62) ; Get length of type
dec a
ld h,a
ld l,6
call writeword_hl_addriy
ld hl,l0601 ; Assign string from stack
ld de,l05e2 ; Assign string from stack
l6648:
dec c
jr z,l665b
ex de,hl
l664c:
ld a,_LD.HL
inc c
jr z,l6653
ld a,_LD_a_HL
l6653:
push hl
ld hl,(l7b58) ; Get value
call StCode
pop hl
l665b:
jp StCALL_ ; Set CALL <call>
l665e:
cp _Real
jr nz,l6672
call StImm ; Set EXX
db a_L58
s_I58:
EXX
a_L58 equ $-s_I58
ld hl,l05d1 ; Save real number
dec c
jr nz,l664c
call StPOP ; Set POP HL
jr l665b
l6672:
cp _Ptr
jr z,l669d
ld a,(l7b9e) ; Get local options
bit _Ropt,a ; Test $R+
jr z,l669d ; Nope
ld hl,(l7b5e) ; Get lo set limit
ld de,(l7b60) ; Get hi set limit
inc de
or a
sbc hl,de
add hl,de
jr z,l669d
dec de
call StLD.DE ; Set LD DE,val16
ex de,hl
or a
sbc hl,de
inc hl
call StLD.BC
ld hl,l0656
call StCALL_ ; Index check on compiler directive {$R+}
l669d:
dec c
jr nz,l66b7
call StImm ; Set sequence
db a_L59
s_I59:
EX DE,HL
POP HL
a_L59 equ $-s_I59
l66a6:
call StImm ; Set LD (HL),E
db a_L60
s_I60:
LD (HL),E
a_L60 equ $-s_I60
ld a,(l7b62) ; Get length of type
dec a
ret z
call StImm ; Set sequence
db a_L61
s_I61:
INC HL
LD (HL),D
a_L61 equ $-s_I61
ret
l66b7:
ld hl,(l7b58) ; Get value
inc c
jr nz,l66cf
ld a,(l7b62) ; Get length of type
dec a
ld a,_LDHL_a
jr nz,l66cc
call StImm ; Set LD A,L
db a_L62
s_I62:
LD A,L
a_L62 equ $-s_I62
ld a,_LDA_a
l66cc:
jp StCode
l66cf:
call StImm ; Set sequence
db a_L63
s_I63:
EX DE,HL
db _LD_a_HL
a_L63 equ $-s_I63
call writeword_hl_addriy
jr l66a6
l66da:
ld a,(l7b5c) ; Get type
cp _Integ
jr nc,l6701
cp _Ptr
jr z,l6701
push af
call l678b
pop af
ld hl,l052c ; Set load real
cp _Real
jr z,l66fe
ld hl,l053a ; move string to stack
cp _String
jr z,l66fe
call l6734
ld hl,l055d ; Push set onto stack
l66fe:
jp StCALL_ ; Set CALL <set>
l6701:
ld a,(l7bbd)
or a
jr nz,l671b
ld a,_LD_a_HL
ld hl,(l7bbe)
call StCode
ld a,(l7b62) ; Get length of type
dec a
ret nz
l6714:
call StImm ; Set LD H,0
db a_L64
s_I64:
LD H,0
a_L64 equ $-s_I64
ret
l671b:
call l678b
ld a,(l7b62) ; Get length of type
dec a
jr nz,l672b
call StImm ; Set LD L,(HL)
db a_L65
s_I65:
LD L,(HL)
a_L65 equ $-s_I65
jr l6714
l672b:
call StImm ; Set sequence
db a_L66
s_I66:
LD E,(HL)
INC HL
LD D,(HL)
EX DE,HL
a_L66 equ $-s_I66
ret
l6734:
ld hl,(l7b5e) ; Get lo set limit
call l5271 ; Load name
ld hl,(l7b62) ; Get length of type
ld a,(l7b6b)
rra
rra
rra
and 1fh
ld h,a
jp StLD.BC
l6749:
call GetConst ; Get constant
jr nz,l677f
ld a,b
cp 8
call ErrNZ
db _IllConst
ld l,18h
ld h,c
call writeword_hl_addriy
ld (l7b58),iy ; Set value
ld a,_Array
ld (l7b5c),a ; Set ARRAY
ld hl,l74db+7
ld (l7b5e),hl ; Set lo set limit
ld hl,l0000
ld (l7b60),hl ; Reset hi set limit
ld l,c
ld (l7b62),hl ; Set length of type
call StConst ; Store string
ld a,_LD.HL
ld hl,(l7b58) ; Get value
jp StCode
l677f:
call l6787
ret z
call ERROR
db _Undef
l6787:
call l67b2
ret nz
l678b:
ld a,(l7bbd)
ld hl,(l7bbe)
bit 1,a
jr nz,l67a2
bit 0,a
ld a,_LD.HL
jr z,l679d
ld a,_LD_a_HL
l679d:
call StCode
jr l67b0
l67a2:
bit 0,a
jr nz,l67b0
ld a,_LD.DE
call StCode
call StImm ; Set ADD HL,DE
db a_L67
s_I67:
ADD HL,DE
a_L67 equ $-s_I67
l67b0:
xor a
ret
l67b2:
call l680c
jr z,l67d9
ld bc,256*4+0
call FndLABEL
jr nz,l67ed
call l5276
ld a,(Envir1)
or a
ld a,'!'
ld b,0
jr z,l67cf
ld a,'*'
inc b
l67cf:
ld hl,l7bbd
ld (hl),b
ld hl,(l7b58) ; Get value
ld (l7bbe),hl
l67d9:
call l683a
jr z,l67d9
call l6931
jr z,l67d9
call l6974
jr z,l67d9
call l699f
xor a
ret
l67ed:
call FindStr ; Find MEM
dw l78fa
ret nz ; Nope
call l65d5
ld a,_Integ
ld (l7b5c),a ; Set INTEGER
ld hl,l0001
ld (l7b62),hl ; Set length of type
dec l
ld (l7b5e),hl ; Set lo set limit
dec l
ld (l7b60),hl ; Set hi set limit
jp l6903
l680c:
ld a,(l7bc9)
ld b,a
l6810:
dec b
ret m
push bc
ld e,b
ld d,0
ld hl,l7bcc
add hl,de
ld a,(hl)
ld c,a
ld b,4
call FndLABEL
pop bc
jr nz,l6810
push hl
ld a,b
add a,a
ld e,a
ld d,0
ld hl,(l7bca)
add hl,de
ld (l7bbe),hl
ld hl,l7bbd
ld (hl),1
pop hl
jp l6948
l683a:
ld a,(l7b5c) ; Get type
cp _Array
ret nz
call l6ee0
ret nz
call l678b
l6847:
call StPUSH ; Set PUSH HL
call l5e84
ld hl,(l7b60) ; Get hi set limit
call l5271 ; Load name
ld a,(l7b69)
cp b
call ErrNZ
db _InvType
ld hl,(l7b6b)
ld a,h
or a
jr nz,l6874
ld a,l
cp 4
jr nc,l6888
l6867:
or a
jr z,l6893
push af
call StImm ; Set DEC HL
db a_L68
s_I68:
DEC HL
a_L68 equ $-s_I68
pop af
dec a
jr l6867
l6874:
inc a
jr nz,l6888
ld a,l
cp 0fdh
jr c,l6888
l687c:
push af
call StImm ; Set INC HL
db a_L69
s_I69:
INC HL
a_L69 equ $-s_I69
pop af
inc a
jr nz,l687c
jr l6893
l6888:
call NegateInt
call StLD.DE ; Set LD DE,val16
call StImm ; Set ADD HL,DE
db a_L70
s_I70:
ADD HL,DE
a_L70 equ $-s_I70
l6893:
ld a,(l7b9e) ; Get local options
bit _Ropt,a ; Test $R+
jr z,l68ae
ld hl,(l7b6d) ; Get last memory address
ld de,(l7b6b)
or a
sbc hl,de
inc hl
call StLD.DE ; Set LD DE,val16
ld hl,l064c
call StCALL_ ; Index check on compiler directive {$R+}
l68ae:
ld hl,(l7b5e) ; Get lo set limit
call l5287 ; Get name
ld hl,(l7b62) ; Get length of type
ld a,h
or a
jr nz,l68d8
ld a,l
dec a
jr z,l68ed
dec a
jr nz,l68c9
call StImm ; Set ADD HL,HL
db a_L71
s_I71:
ADD HL,HL
a_L71 equ $-s_I71
jr l68ed
l68c9:
cp 4
jr nz,l68d8
call StImm ; Set sequence
db a_L72
s_I72:
ADD HL,HL
LD E,L
LD D,H
ADD HL,HL
ADD HL,DE
a_L72 equ $-s_I72
jr l68ed
l68d8:
ld a,(l7b9e) ; Get local options
bit _Xopt,a ; Test $X+
jr nz,l68ea ; Yeap
call StLD.DE ; Set LD DE,val16
ld hl,l06f5 ; Set integer multiply
call StCALL_
jr l68ed
l68ea:
call l690a
l68ed:
call StImm ; Set sequence
db a_L73
s_I73:
POP DE
ADD HL,DE
a_L73 equ $-s_I73
ld a,(l7b5c) ; Get type
cp _Array
jr nz,l6900
call l6f13 ; Test ,
jp z,l6847 ; Yeap
l6900:
call l6f38 ; Verify ]
l6903:
ld a,3
ld (l7bbd),a
xor a
ret
l690a:
ld b,1
l690c:
ld a,h
or a
jr nz,l6914
ld a,l
dec a
jr z,l6927
l6914:
bit 0,l
jr z,l691c
call StPUSH ; Set PUSH HL
inc b
l691c:
call StImm ; Set ADD HL,HL
db a_L74
s_I74:
ADD HL,HL
a_L74 equ $-s_I74
srl h
rr l
jr l690c
l6927:
dec b
ret z
call StImm ; Set sequence
db a_L75
s_I75:
POP DE
ADD HL,DE
a_L75 equ $-s_I75
jr l6927
l6931:
ld a,(l7b5c) ; Get type
cp _Record
ret nz
call l6f17
ret nz
ld a,(l7b5d)
ld c,a
ld b,4
call FndLABEL
call ErrNZ
db _Undef
l6948:
call l5276
ld hl,(l7b58) ; Get value
ld a,h
or l
ret z
ld hl,l7bbd
bit 0,(hl)
jr z,l6967
push hl
call l678b
pop hl
ld (hl),2
ld hl,(l7b58) ; Get value
ld (l7bbe),hl
xor a
ret
l6967:
ld hl,(l7bbe)
ld de,(l7b58) ; Get value
add hl,de
ld (l7bbe),hl
xor a
ret
l6974:
ld a,(l7b5c) ; Get type
cp _Ptr
ret nz
call l6f27
ret nz
ld hl,l7bbd
ld a,(hl)
or a
jr nz,l6988
inc (hl)
jr l6997
l6988:
push hl
call l678b
pop hl
ld (hl),3
call StImm ; Set sequence
db a_L76
s_I76:
LD E,(HL)
INC HL
LD D,(HL)
EX DE,HL
a_L76 equ $-s_I76
l6997:
ld hl,(l7b5e) ; Get lo set limit
call l5287 ; Get name
xor a
ret
l699f:
ld a,(l7b5c) ; Get type
cp _String
ret nz
call l6ee0
ret nz
call l678b
call StPUSH ; Set PUSH HL
ld hl,(l7b62) ; Get length of type
push hl
call l5e97
pop hl
ld a,(l7b9e) ; Get local options
bit _Ropt,a ; Test $R+
jr z,l69c7 ; Nope
call StLD.DE ; Set LD DE,val16
ld hl,l064c
call StCALL_ ; Index check on compiler directive {$R+}
l69c7:
call StImm ; Set sequence
db a_L77
s_I77:
POP DE
ADD HL,DE
a_L77 equ $-s_I77
call l6f38 ; Verify ]
ld a,_Char
ld (l7b5c),a ; Set CHAR
ld hl,l0001
ld (l7b62),hl ; Set length of type
dec hl
ld (l7b5e),hl ; Set lo set limit
dec l
ld (l7b60),hl ; Set hi set limit
ld a,3
ld (l7bbd),a
xor a
ret
;
; Get constant
;
_GetConst:
call GetConst ; Get constant
ret z
call ERROR
db _Undef
;
; Get integer constant
;
_GetIntC:
call _GetConst ; Get constant
ld a,b
cp 0ah ;_Integ
ret z
call ERROR
db _IntConst
;
; Get string constant
;
_GetStrC:
call _GetConst ; Get constant
ld a,b
cp 8 ;_String
ret z
cp 0ch ;_Char
call ErrNZ
db _StrgConExp
ld b,8 ;_String
ret
;
; Get constant
;
GetConst:
call GetSign
push de
call GetLabType
pop de
jr z,NegateNum
inc e
dec e
call ErrNZ
db _IntRealCexp
dec e
ret
NegateNum:
call ChkNumSign
ret z
ld a,b
cp 9 ;_Real
jr nz,NegateInt
exx
ld a,b
xor 80h
ld b,a
exx
xor a
ret
NegateInt:
ld a,h
cpl
ld h,a
ld a,l
cpl
ld l,a
inc hl
xor a
ret
GetSign:
ld e,0ffh
ld a,(ix+0)
cp '-'
jr z,l6a47
inc e
cp '+'
ret nz
inc e
l6a47:
jp NewLine ; Process line
ChkNumSign:
inc e
dec e
ret z
ld a,b
cp 0ah ;_Integ
jr z,ChkNumSign_valid
cp 9 ;_Real
jr nz,ChkNumSign_bad
ChkNumSign_valid:
dec e
ret
ChkNumSign_bad:
call ERROR
db _IntRealCexp
GetLabType:
call GetConstType ; Sample constant
ret z ; Got one
ld bc,256*2+0
call FndLABEL
ret nz
ld b,(hl)
ld a,b
dec hl
cp 0ah ;_Integ
jr c,GetLabType_noOrd
ld d,(hl)
dec hl
ld e,(hl)
ex de,hl
xor a
ret
GetLabType_noOrd:
cp 9 ;_Real
jr nz,GetLabType_noReal
push bc
ld b,(hl)
dec hl
ld c,(hl)
dec hl
ld d,(hl)
dec hl
ld e,(hl)
dec hl
ld a,(hl)
dec hl
ld l,(hl)
ld h,a
exx
pop bc
ret
GetLabType_noReal:
ld c,(hl)
ld de,l7a57
push bc
inc c
GetLabType_cpyStr:
dec c
jr z,GetLabType_ex
dec hl
ld a,(hl)
ld (de),a
inc de
jr GetLabType_cpyStr
GetLabType_ex:
pop bc
ret
;
; Sample constant - Z set indicates constant
;
; Reg B holds type of constant
; Reg C holds length of constant
;
GetConstType:
ld a,(ix+0) ; Get character
cp '''' ; Test string
jr z,GetConstType_strg
cp '^' ; Test control character prefix
jr z,GetConstType_strg
cp '#' ; Test character prefix
jr nz,GetConstType_noStrg
GetConstType_strg:
ld hl,l7a57 ; Init parameter buffer
ld c,0 ; Init length
GetConstType_chkMore:
ld a,(ix+0)
cp '^' ; Test control character prefix
jr z,GetConstType_ctrChr
cp '#' ; Test character prefix
jr z,GetConstType_chrPrfx
cp '''' ; Test string
jr nz,GetConstType_ex
GetConstType_cpyStrg:
inc ix
ld a,(ix+0) ;Get character
or a
call ErrZ
db _StrConLong
cp ''''
jr nz,GetConstType_unp
inc ix
ld a,(ix+0) ;Get character
cp ''''
jr nz,GetConstType_chkMore
GetConstType_unp:
ld (hl),a
inc hl
inc c
jr GetConstType_cpyStrg
GetConstType_ctrChr:
inc ix
ld a,(ix+0) ;Get character
call doupcase ; Convert to upper case
or a
call ErrZ
db _StrConLong
xor '@'
inc ix
GetConstType_sav:
ld (hl),a
inc hl
inc c
jr GetConstType_chkMore
GetConstType_chrPrfx:
inc ix
push bc
push hl
call cnv_int ; Convert ASCII to integer
ld a,l
pop hl
pop bc
call ErrCY
db _IntegErr
jr GetConstType_sav
GetConstType_ex:
ld b,8 ;_String
ld a,c ; Get count
dec a ; Test character
jr nz,GetConstType_getLine ; .. nope
ld h,a ; .. clear HI
ld a,(l7a57) ; .. get LO
ld l,a
ld b,0ch ;_Char ; Change mode
GetConstType_getLine:
jp GetLine ; Process line
GetConstType_noStrg:
cp '$'
jr z,GetConstType_hex
call IsItDigit ; Test digit
jr nc,GetConstType_numb
xor a
dec a
ret
GetConstType_numb:
push ix
pop de
GetConstType_wtNoNum:
inc de
ld a,(de)
call IsItDigit ; Test digit
jr nc,GetConstType_wtNoNum
call doupcase ; Convert to upper case
cp 'E'
jr z,GetConstType_real
cp '.'
jr nz,GetConstType_hex
inc de
ld a,(de)
cp '.'
jr z,GetConstType_hex
cp ')'
jr z,GetConstType_hex
GetConstType_real:
call cnv_flp ; Convert to real
call ErrCY ; Real constant error
db _RealErr
exx ; Real into alternate set
ld b,9 ;_Real ; .. set mode
jr GetConstType_getLine
GetConstType_hex:
call cnv_int ; Convert ASCII to integer
call ErrCY
db _IntegErr
ld b,0ah
jr GetConstType_getLine
;
; Transfer immediate opcodes
; Sequence starts with length
;
StImm:
ex (sp),hl
push bc
ld b,(hl) ; Get length
inc hl
StI_loop:
ld a,(hl) ; Get byte
call writebyte_a_addriy ; Store it
inc hl
djnz StI_loop
pop bc
ex (sp),hl
ret
StLen:
ld a,c ; Get byte
call writebyte_a_addriy ; Store it
;
; Store string
;
StConst:
ld hl,l7a57
inc c
StC_loop:
dec c
ret z
ld a,(hl) ; Get character
inc hl
call writebyte_a_addriy ; Store it
jr StC_loop
;
; Set PUSH HL
;
StPUSH:
ld a,_PUSH.HL
jr writebyte_a_addriy
;
; Set POP HL
;
StPOP:
ld a,_POP.HL
jr writebyte_a_addriy
;
; Set JP
;
StJP:
ld a,_JP
jr writebyte_a_addriy
;
; Insert operand
; ENTRY Reg DE holds operand
; (Set word in reg DE)
;
writeword_de_addriy:
ld a,e
call writebyte_a_addriy
ld a,d
jr writebyte_a_addriy
;
; Set JP WORD
;
StJP_:
ld a,_JP
jr StCode
;
; Set CALL WORD
;
StCALL_:
ld a,_CALL
jr StCode
;
; Set LD BC,WORD
;
StLD.BC:
ld a,_LD.BC
jr StCode
;
; Set LD DE,WORD
;
StLD.DE:
ld a,_LD.DE
jr StCode
;
; Set LD HL,WORD
;
StLD.HL:
ld a,_LD.HL
;
; Insert opcodes in Accu, reg L and reg H
;
StCode:
call writebyte_a_addriy
;
; Insert word in reg HL
;
writeword_hl_addriy:
ld a,l
call writebyte_a_addriy
ld a,h
;
; Insert byte in Accu
;
writebyte_a_addriy:
push bc
ld b,a
ld a,(CmpTyp) ; Get compile flag
or a ; Test mode
jr nz,St__noSt ; Searching or compiling
ld (iy+0),b ; Store byte into memory
St__noSt:
inc iy ; Update PC
or a ; Test compile to memory
jr z,St__skp ; Yeap
push hl
push de
dec a ; Test search
jr z,St__St ; Nope ; .. compile to file
push iy
pop de
dec de
ld hl,(l00ce) ; Get current PC
or a
sbc hl,de
call ErrZ
db _FndRTerr
jr St__pop
St__St:
call savebyte_b ; Put byte to file
St__pop:
pop de
pop hl
St__skp:
pop bc
;
; Check enough memory
;
ChkOvfl:
push hl
push de
push iy
pop de
ld a,(CmpTyp) ; Get compile flag
or a
jr z,ChkOv.mem ; Skip if compiling to memory
ld de,(MemsTop) ; Get memory top
dec a
jr nz,ChkOv.mem
ld de,(COMsTop) ; Get top of .COM file
ld a,(IncFlg) ; Test memory read
or a
jr z,ChkOv.mem ; Yeap
ld de,(INCsTop)
ChkOv.mem:
ld hl,(LabPtr) ; Get label pointer
scf
sbc hl,de
call ErrCY
db _CompOvfl
push iy
pop de
ld hl,(DataBeg) ; Get start of data
dec h
dec h
sbc hl,de
call ErrCY
db _MemOvfl
pop de
pop hl
ret
;
; Put byte in reg B to file
;
savebyte_b:
ld hl,RRN_stat ; Point to file access
set 1,(hl) ; Set write enabled
bit 0,(hl) ; Test re-read
jr z,SkpRdRRN ; Nope
res 0,(hl) ; Clear it
push bc
call readrecord_TmpBuff ; Re-read record
pop bc
SkpRdRRN:
ld a,(RecPtr) ; Get record pointer
ld e,a
ld d,0
ld hl,TmpBuff
add hl,de ; Build buffer address
ld (hl),b ; Store byte
inc a ; Advance record pointer
jp p,StToF__ex ; Still within limits
call writerecord_TmpBuff ; Write record
ld hl,(FFCB+_rrn)
inc hl ; Advance record count
ld (FFCB+_rrn),hl
xor a
StToF__ex:
ld (RecPtr),a ; Set record pointer
ret
;
; Allocate space in reg DE
;
VarAlloc:
ld hl,(DataBeg) ; Get start of data
or a
sbc hl,de
call ErrCY
db _MemOvfl
ld (DataBeg),hl ; Set start of data
jr ChkOvfl ; Check enough memory
;
; Store back current PC to ^HL
;
storeback_iy_to_addrhl:
push iy ; Get PC
pop de
;
; Store back reg DE to ^HL
;
storeback_de_to_addrhl:
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to memory
jr z,StBackMem ; nope
push iy
push hl
pop iy
call writeword_de_addriy ; Set word
pop iy
ret
flushunfinished
ld a,(RecPtr) ; Get record pointer
or a
ret z
push bc
push de
push hl
;ld a,h
;and l
;inc a ;-1=fake record number
;jr z,flushunfinished_skip
call flushunfinishedpp
;flushunfinished_skip
;close, open to force flush???
;ld de,FFCB
;ld c,_close
;call _BDOS ; BDOS with keep ix,iy
;ld de,FFCB
;ld c,_open
;call _BDOS ; BDOS with keep ix,iy
pop hl
pop de
pop bc
ret
StBackMem:
call flushunfinished
push bc
push de
push hl
ld hl,(MemsTop) ; Get memory top
ld a,(BackLevel) ; Get back fix level
ld b,a
inc b
l6c5e:
dec b
jr z,l6c84
ld e,(hl)
inc hl
ld d,(hl)
ex (sp),hl
or a
sbc hl,de
add hl,de
ex (sp),hl
jr c,l6c71
inc hl
inc hl
inc hl
jr l6c5e
l6c71:
dec hl
ex de,hl
ld l,b
ld h,0
add hl,hl
add hl,hl
ld b,h
ld c,l
add hl,de
ld d,h
ld e,l
dec hl
inc de
inc de
inc de
lddr
inc hl
l6c84:
pop de
ld (hl),e
inc hl
ld (hl),d
inc hl
pop de
ld (hl),e
inc hl
ld (hl),d
pop bc
ld hl,BackLevel ; Point to back fix level
inc (hl)
ret nz
xor a
jr ForceBack
;
; Fix back level
;
FixBack:
ld a,(BackLevel) ; Get back fix level
or a
ret z
ForceBack:
push bc
push de
push iy
ld b,a
ld hl,(MemsTop) ; Get memory top
Back_Loop:
push bc
ld e,(hl)
inc hl
ld d,(hl)
inc hl
push hl
ex de,hl
call ChkChn ; Check chaining
pop hl
ld b,(hl)
inc hl
push hl
call savebyte_b ; Put byte to file
pop hl
ld b,(hl)
inc hl
push hl
call savebyte_b ; Put byte to file
pop hl
pop bc
djnz Back_Loop
pop hl
pop de
pop bc
;
; Check chaining
;
ChkChn:
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to memory
call z,flushunfinished ;nope
push hl
pop iy
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to memory
ret nz ; yes
push de
push bc
ld de,(CodePC) ; Get code pointer
or a
sbc hl,de
ld a,l
and 7fh
ld (RecPtr),a ; Set record pointer
add hl,hl
ld l,h
rla
and 1
ld h,a
ld de,(RRN_off) ; Get record base
add hl,de ; Calculate new record
ld de,(FFCB+_rrn)
or a
sbc hl,de
add hl,de
jr z,Chk_sameRRN
push hl
call writerecord_TmpBuff ; Write record
pop hl
ld (FFCB+_rrn),hl ; Reset record
Chk_sameRRN:
pop bc
pop de
ret
;
; Read random record from file
; Read a record
;
readrecord_TmpBuff:
;ld hl,(FFCB+_rrn)
;jr $
ld c,_rndrd ; .. load read function
jr l6d09 ; .. fall in read
;
; Write a record
;
writerecord_TmpBuff:
ld hl,RRN_stat ; Point to file access
set 0,(hl) ; Set re-read enabled
bit 1,(hl) ; Test record to be written
ret z ; Nope
res 1,(hl) ; Reset it
flushunfinishedpp
;write unfinished last sector???
ld c,_rndwr
l6d09:
push bc ; Save function
ld de,TmpBuff
ld c,_setdma
call _BDOS ; Set disk buffer
pop bc
ld de,FFCB
call _BDOS ; Read or write record
ret ;КОСТЫЛЬ!!! иначе lister не компилируется на диск (читает сектор за границей файла перед патчем и записью?)
or a
ret z
;dec a
;ret z
;cp 3
;ret z
cp 128 ;fail
ret nz ;not fail
call ERROR
db _DskFull
;
; Save environment to stack
;
SavEnv2:
exx
ld de,Envir2
jr SavEnv7
;
; Save environment to stack
;
l6d2a:
exx
ld de,Envir1
SavEnv7:
pop hl
ld (Env_PC),hl
ld hl,-l000d;lfff3
add hl,sp
ld sp,hl
ex de,hl
ld bc,l000d
ldir
BackEnv_PC:
ld hl,(Env_PC)
push hl
exx
ret
RestEnv2:
exx
ld de,Envir2
jr RestEnv7
;
; Get back environment
;
RestEnv1:
exx
ld de,Envir1
RestEnv7:
pop hl
ld (Env_PC),hl
ld hl,0;l0000
add hl,sp
ld bc,l000d
ldir
ld sp,hl
jr BackEnv_PC
;
; Restore environment from stack, leave stack intact
;
CpyEnv2:
exx
ld de,Envir2
jr CpyEnv7
l6d63:
exx
ld de,Envir1
CpyEnv7:
ld hl,2;l0002
add hl,sp
ld bc,l000d
ldir
exx
ret
;
; Store current PC into label table
;
puttolabel_i_y:
push iy
pop de
puttolabel_d_e:
ld a,d
call puttolabel
ld a,e
puttolabel:
push hl
ld hl,(LabPtr) ; Get label pointer
ld (hl),a
dec hl
ld (LabPtr),hl ; Set label pointer
pop hl
jp ChkOvfl ; Check enough memory
;
; Get label
;
GetLabel:
ld a,(ix+0) ; Get 1st character
call IsItLab ; Test label character
;
; Build label
;
SampLabel:
call ErrCY
db _IllChar
call DoubleLabel ; Verify no double label
l6d94:
call Reserved ; Verify no reserved word
ld a,(ix+0)
l6d9a:
cp 'a'
jr c,l6da4
cp 'z'+1
jr nc,l6da4
sub 'a'-'A'
l6da4:
call puttolabel
inc ix
ld a,(ix+0)
call IsItValid ; Test valid character
jr nc,l6d9a ; Yeap
ld hl,(LabPtr) ; Get label pointer
inc hl
set 7,(hl)
jp GetLine ; Process line
l6dba:
ld a,(ix+0)
call IsItLab ; Test label character
call ErrCY
db _IllChar
jr l6d94
;
; Set label pointer
;
SetLabPtr:
ld hl,(PrevLabPtr) ; Get previous label pointer
ld de,(LabPtr) ; Get label pointer
or a
sbc hl,de
ex de,hl
call puttolabel_d_e ; Put to table
ld hl,(LabPtr) ; Get label pointer
ld (PrevLabPtr),hl ; Unpack into previous
ret
l6ddb:
ld hl,(CurLab) ; Get current label pointer
jr l6de3
;
;
; Find label from table
; ENTRY Reg B holds selected TYPE
; Reg C holds item flag
; 0 if 1st item in line
; -1 if not 1st one
; EXIT Zero set if label found
;;
;; l7bc1 = 00, A = -1, NZ ---->>> Not found
;; l7bc1 = type, NZ ---->>> Not same type as B
;; Z ---->>> Same type
;; HL, DE hold pointers
;
FndItem:
ld hl,(l7b77) ; Get top of available memory
l6de3:
ld (l7b7d),hl
ld a,(FirstVAR)
cp c
jr z,l6e48
ld a,c
ld (FirstVAR),a
ld hl,(PrevLabPtr) ; Get previous label pointer
l6df3:
ld de,(l7b7d)
xor a
sbc hl,de ; Test pointer reached
add hl,de
jr nz,l6e03
xor a
ld (l7bc1),a
dec a
ret
l6e03:
inc hl
ld e,(hl) ; Get length of entry ?????????
inc hl
ld d,(hl)
add hl,de ; Point to end
ld a,(hl) ; Test more
or a
jr z,l6df3 ; .. end of table ??????????????
dec hl
ld a,(hl) ; Get type
inc hl
cp c
jr nz,l6df3 ; .. not what we expect
push ix
pop de ; Copy pointer
push bc
push hl
dec hl ; Fix to lable
dec hl
l6e19:
ld b,(hl) ; Get characters
ld a,(de)
dec hl
inc de
ld c,b ; Save label
res 7,b ; Clear MSB
cp 'a' ; Check a..z
jr c,l6e2a
cp 'z'+1
jr nc,l6e2a
sub 'a'-'A' ; .. map to a..z
l6e2a:
cp b ; Compare
jr nz,l6e37
bit 7,c ; Test last character
jr z,l6e19 ; .. nope
ld a,(de) ; Verify end of label
call IsItValid ; Test valid character
jr c,l6e3b ; Nope
l6e37:
pop hl
pop bc
jr l6df3
l6e3b:
ld (l7bc2),hl ; Save pointers
ld (l7bc4),de
pop hl
pop bc
ld a,(hl) ; Save type
ld (l7bc1),a
l6e48:
ld hl,(l7bc2)
ld de,(l7bc4)
ld a,(l7bc1)
cp b ; Fix result
ret
;
; Get TYPE from table
; ENTRY Reg B holds TYPE searched for
; Reg C holds flag ???????
; EXIT Zero set if TYPE found
; Reg HL points to TYPE
; (Find label with type in reg B)
;
FndLABEL:
call FndItem ; Find it
ret nz ; .. nope
jr SetLine ; .. set source pointer
;
; Find string
; ENTRY <SP> points to length of code
; followed by address of string
; EXIT Zero flag set indicates found
; (Find constant string list ^PC)
; Z set says found
;
FndTabStr:
ex (sp),hl
ld c,(hl) ; Get length of data following string
inc hl
ld e,(hl) ; Get address of string
inc hl
ld d,(hl)
inc hl
ex (sp),hl
ex de,hl
FndDirStr:
call FndStr ; Find string
ret z ; Got it
dec hl ; Postion to previous character
FndDirStr_fix:
bit _MB,(hl) ; Find end of string
inc hl
jr z,FndDirStr_fix
ld b,0
add hl,bc ; Position to next string in list
ld a,(hl)
or a ; Test more in list
jr nz,FndDirStr ; Yeap
dec a ; Set string not found
ret
;
; Find constant string ^PC
; Z set says found
;
FindStr:
ex (sp),hl
ld e,(hl) ; Get address of string
inc hl
ld d,(hl)
inc hl
ex (sp),hl
ex de,hl
;
; Find string ^HL
;
FndStr:
push ix ; Copy source pointer
pop de
ld a,(hl) ; Get character from searched string
call IsItLab ; Test label character
jr c,l6e92 ; Nope
call l6e9c ; Compare
ret nz ; Not found
ld a,(de) ; Get character from source
call IsItValid ; Test valid character
jr c,SetLine ; Nope
or a
ret
l6e92:
call l6e9c ; Compare
ret nz ; Not found
SetLine:
push de ; Set resulting source pointer
pop ix
jp GetLine ; Process line
;
; Compare reference ^HL: source ^DE
; Z set says match
;
l6e9c:
push bc
l6e9d:
ld b,(hl) ; Get from reference
ld a,(de) ; Get from source
inc hl
inc de
ld c,b ; Save reference
res _MB,b ; Strip off MSB
cp 'a' ; Test range
jr c,l6eae
cp 'z'+1
jr nc,l6eae
sub 'a'-'A' ; Convert to UPPER case
l6eae:
cp b ; Compare
jr nz,l6eb6 ; No match
bit _MB,c ; Test end of reference
jr z,l6e9d ; Nope
xor a ; Force match
l6eb6:
pop bc
ret
;
; Verify no reserved word
;
Reserved:
ld hl,l7513
l6ebb:
ld c,(hl)
inc c
ret z
dec c
inc hl
ld e,(hl)
inc hl
ld d,(hl)
inc hl
push hl
ex de,hl
call FndDirStr
pop hl
jr nz,l6ebb
call ERROR
db _ResWord
DoubleLabel:
ld a,(l7b91) ; Get ???
ld c,a
call l6ddb
ld a,(l7bc1)
or a
ret z
call ERROR
db _DoubleLab
l6ee0:
ld a,'['
call l6f29
ret z
ld a,(ix+0)
cp '('
ret nz
ld a,(ix+1)
cp '.'
ret nz
l6ef2:
inc ix
jp NewLine ; Process line
;
; Test ] - Z set says found
;
l6ef7:
ld a,']'
call l6f29
ret z
;;:::
ld a,(ix+0)
cp '.'
ret nz
ld a,(ix+1)
cp ')'
ret nz
jr l6ef2
;
; Test colon : - Z set says found
;
l6f0b:
ld a,':'
jr l6f29
;
; Test semicolon ; - Z set says found
;
l6f0f:
ld a,';'
jr l6f29
;
; Test comma , - Z set says found
;
l6f13:
ld a,','
jr l6f29
l6f17:
ld a,'.'
jr l6f29
;
; Test left parenthesis ( - Z set says found
;
l6f1b:
ld a,'('
jr l6f29
l6f1f:
ld a,')'
jr l6f29
;
; Test equate = - Z set says found
;
l6f23:
ld a,'='
jr l6f29
l6f27:
ld a,'^'
l6f29:
cp (ix+0)
ret nz
jp NewLine ; Process line
;
; Verify [
;
l6f30:
call l6ee0
ret z
call ERROR
db _LftBrExp
;
; Verify ]
;
l6f38:
call l6ef7 ; Test ]
ret z
call ERROR
db _RgtBrExp
;
; Verify :
;
l6f40:
call l6f0b ; Test :
ret z
call ERROR
db _SemiExp
;
; Verify ;
;
l6f48:
call l6f0f ; Test ;
ret z ; Yeap
l6f4c:
call ERROR
db _ColExp
l6f50:
call l6f0f ; Test ;
ret z ; Yeap
ld a,(l7b98)
or a
jr z,l6f4c
call ERROR
db _Undef
;
; Verify ,
;
l6f5e:
call l6f13 ; Test ,
ret z ; Yeap
call ERROR
db _CommaExp
;
; Verify (
;
l6f66:
call l6f1b ; Test (
ret z ; Yeap
call ERROR
db _LftPar
;
; Verify )
;
l6f6e:
call l6f1f
ret z
call ERROR
db _RgtPar
;
; Verify =
;
l6f76:
call l6f23 ; Find =
ret z
call ERROR
db _EquExp
l6f7e:
call FindStr ; Find :=
dw l7582
ret z ; Yeap
call ERROR
db _AssigExp
l6f88:
call FindStr ; Find OF
dw l7560
ret z ; Yeap
call ERROR
db _NoOF
;
; Process source line
;
NewLine:
call l7124 ; Get character from file
GetLine:
xor a
ld (l7b98),a
dec a
ld (FirstVAR),a
ld a,(ix+0) ; Get a character
or a ; Test empty
jr z,NewLine ; Yeap, so get next
cp ' ' ; Skip blanks
jr z,NewLine
cp tab ; Skip tabs
jr z,NewLine
cp '(' ; Test possible comment
jr z,l6fb5
cp '{' ; Test real comment
jr z,l6fbf
l6fb3:
xor a
ret
l6fb5:
ld a,(ix+1) ; Get next
cp '*' ; Test comment
jr nz,l6fb3 ; Nope
call l7124 ; Get next character
l6fbf:
push bc
ld b,(ix+0) ; Get comment indicator
ld a,(ix+1) ; Get next character
cp '$' ; Test compiler directive
jr z,l6feb ; Maybe
l6fca:
call l7124 ; Get next character
l6fcd:
ld a,b
cp '*' ; Test two character indicators
ld a,(ix+0)
jr nz,l6fe4 ; Nope
cp b
jr nz,l6fca
ld a,(ix+1)
cp ')'
jr nz,l6fca
call l7124 ; Get character from file
jr l6fe8
l6fe4:
cp '}' ; Test end of comment
jr nz,l6fca ; Nope, wait for
l6fe8:
pop bc
jr NewLine
l6feb:
push bc
push de
push hl
call l7124 ; Get character from file
l6ff1:
call l7124 ; Get character from file
ld a,(ix+0)
call doupcase ; Convert to upper case
cp 'I' ; Test include or I/O error
ld b,00000001b
jr z,l704d
cp 'R' ; Test index range test
ld b,00000010b
jr z,l704d
cp 'A' ; Test absolute code
ld b,00000100b
jr z,l704d
cp 'U' ; Test user break
ld b,00001000b
jr z,l704d
cp 'X' ; Test arry optimization
ld b,00010000b
jr z,l704d
cp 'V' ; Test var type test
ld b,00100000b
jr z,l704d
cp 'B' ; Test I/O mode
ld b,01000000b
jr z,l704d
cp 'C' ; Test keyboard interrupt
ld b,10000000b
jr z,l704d
cp 'W' ; Test WITH check
jr z,l707a
;
; Next directives used by MS-DOS only.
; They will be checked for compatibility only
;
ld b,00000000b
cp 'K' ; Test stack check ([$K+, $K-])
jr z,l704d
cp 'D' ; Test device check ([$D+, $D-])
jr z,l704d
cp 'F' ; Test number of open files ([$Fnum])
jr z,l708e
cp 'G' ; Test input buffer ([$Gnum])
jr z,l708e
cp 'P' ; Test output buffer ([$Pnum])
jr z,l708e
call ERROR ; Invalid directive
db _CompDirec
l7048:
pop hl
pop de
pop bc
jr l6fcd
;
; Set or reset directive $x+ or $x-
;
; Bit to be attached held in reg B
;
l704d:
call l7124 ; Get character from file
ld a,(ix+0)
ld c,0 ; Init for set
cp '+' ; Test it
jr z,l7065 ; Yeap
dec c ; Prepare for reset - all bits set
cp '-'
jr z,l7065
dec b ; Remember $I is 00000001b - used multiple
call ErrNZ ; Else error
db _CompDirec
jr l709b ; Now process include
l7065:
ld hl,l7b9d ; Point to options
ld a,(hl) ; Get current bits
xor c ; Toggle bits or let in tact
or b ; Insert bit
xor c ; Set result
ld (hl),a
l706d:
call l7124 ; Get character from file
l7070:
ld a,(ix+0)
cp ',' ; Test more
jp z,l6ff1 ; Yeap
jr l7048
l707a:
call l7124 ; Get character from file
ld a,(ix+0)
call IsItDigit ; Test digit
call ErrCY
db _CompDirec
sub '0'
ld (l7bc7),a ; Change depth for WITH
jr l706d
;
; Process MS-DOS compatible directives
;
l708e:
call l7124 ; Get character from file
ld a,(ix+0)
call IsItDigit ; Test digit
jr nc,l708e ; Yeap, skip over
jr l7070
l709b:
cp ' '
jr nz,l70a7 ; Skip over directive
call l7124 ; Get character from file
ld a,(ix+0)
jr l709b
l70a7: ;include???
ld a,(IncFlg) ; Get memory read flag
or a
call ErrNZ ; Should be memory read
db _INCLerr
push ix
pop de
call l2d2a ; Prepare .PAS file
push de
pop ix
ld de,l005c
push de
;jr $
ld c,_open
call _BDOS ; Open file ;WHERE IS CLOSE???
pop hl
inc a
call ErrZ
db _NoFileErr
ld de,l790f
ld bc,FCBlen
ldir ; Unpack file
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to file
jr z,l70e2 ; Yeap
ld hl,TmpBuff
ld (l7be4),hl ; Save top of .COM file
ld hl,l79d7 ; Get start of source line
ld a,1
jr l7103
l70e2:
ld hl,(LabPtr) ; Get label pointer
ld de,(COMsTop) ; Get top of .COM file
ld (l7be4),de ; Save it
or a
sbc hl,de ; Calculate difference
srl h
rr l
ld a,h
or a
call ErrZ ; If hi zero, no memory
db _CompOvfl
ld a,l
and RecLng
ld l,a
push hl
add hl,hl
ld a,h
pop hl
add hl,de
l7103:
ld (INCsTop),hl
ld (l7be9),hl
ld (l7be8),a
ld (IncFlg),a ; Re/Set memory read flag
ld hl,l0000
ld (l7beb),hl
ld a,(l7b9d) ; Get options
ld (l7b9f),a
ld a,(l7bc7) ; Get depth for WITH
ld (l7bc8),a
jp l7048
;
; Get character from file
;
l7124:
ld a,(ix+0)
inc ix
or a
ret nz
push bc
push de
push hl
ld a,(l7ba2) ; Get end of file
or a
call ErrNZ
db _IllSrcEnd
ld hl,(l7bd7) ; Get source pointer
ld (l7bd9),hl ; Unpack it
ld hl,(l7beb)
ld (l7bed),hl
ld hl,l79d7 ; Get start of source line
push hl
pop ix ; Copy it
ld b,RecLng-1 ; Set max length
l714a:
push hl
push bc
call l71f3
if TERM
;push af
;push ix
;push iy
;PRCHAR_
;pop iy
;pop ix
;pop af
else
;push af
;push ix
;push iy
;PRCHAR
;pop iy
;pop ix
;pop af
endif
pop bc
pop hl
cp cr
jr z,l7175
cp eof
;jr z,$ ;never
jr z,l716a
cp tab
jr z,l7161
cp ' '
jr c,l714a
l7161:
djnz l7166
inc b
jr l714a
l7166:
ld (hl),a
inc hl
jr l714a
l716a:
ld (l7ba2),a ; Set end of file
call l717e
call l718f ; Test abort
jr l7178
l7175:
call l717e ;compile_newline
l7178:
ld (hl),0
pop hl
pop de
pop bc
ret
l717e: ;compile_newline
push af
push hl
ld hl,(l7bef)
inc hl ; Advance line count
ld (l7bef),hl
ld a,l
and 0fh
;jr z,l7191
pop hl
pop af
ret
;
; Test abortion of compilation
;
l718f:
push af
push hl
l7191:
push bc
push de
push ix
push iy
ld a,cr
call puttoconsole_a ; Put to console
ld a,(IncFlg) ; Test memory read
or a
jr z,l71a6 ; Yeap
ld a,'I'
jr l71a8
l71a6:
ld a,' '
l71a8:
call puttoconsole_a ; Put to console
ld a,' '
call puttoconsole_a ; Put to console
ld hl,(l7bef) ; Get line count
call l2e61 ; Print number
call l00a0 ; Test key pressed
or a
jr z,l71ea
call l0200
db ' *** Abort compilation'
db null
call l2d01 ; Ask for YES or NO
call ErrNZ
db _ABORT
ld b,32
l71e1:
call l0200
db bs,' ',bs
db null
djnz l71e1
l71ea:
pop iy
pop ix
pop de
pop bc
pop hl
pop af
ret
;
; Read character from file
;
l71f3:
ld a,(IncFlg) ; Test memory read
or a
jr nz,l7205 ; Nope
l71f9:
ld hl,(l7bd7) ; Get source pointer
ld a,(hl)
cp eof ; Test end of file
ret z ; Yeap
inc hl
ld (l7bd7),hl
ret
l7205:
ld hl,(l7be9)
ld de,(INCsTop)
or a
sbc hl,de
add hl,de
jr c,l7242
ld de,(l7be4) ; Get top of .COM file
ld a,(l7be8)
ld b,a
l721a:
push bc
push de
ld c,_setdma
call _BDOS ; Set disk buffer
ld de,l790f
ld c,_rdseq
call _BDOS ; Read record
pop de
pop bc
;or a
;jr nz,l7237
xor 128 ;EOF in NedoOS
jr z,l7237
;ld hl,RecLng
ld l,a
ld h,0
;CP/M has eofs in the end of last sector?
;do this by hand:
xor 128
jr z,readchar_load_noaddzeros ;full sector
;a=128+bytes loaded
neg
;a=128-bytes loaded
push bc
push de
ld b,a
ld a,e
add a,127
ld e,a
adc a,d
sub e
ld d,a
;de= Point to buffer end
ld a,eof;-1
ld (de),a
dec de
djnz $-2
pop de
pop bc
readchar_load_noaddzeros
add hl,de ; Advance buffer
ex de,hl
djnz l721a
jr l723f
l7237:
ld a,eof ; Set end of file
ld (de),a
inc de
ld (INCsTop),de
l723f:
ld hl,(l7be4) ; Get top of .COM file
l7242:
ld a,(hl)
inc hl
ld (l7be9),hl
cp eof
jr nz,l725d
ld c,_close
call BDOS_with_FCB1
xor a
ld (IncFlg),a ; Enable memory read
ld a,(l7b9f)
ld (l7b9d),a ; Reset options
ld a,(l7bc8)
ld (l7bc7),a ; Set depth for WITH
jp l71f9
l725d:
ld hl,(l7beb)
inc hl
ld (l7beb),hl
ret
;
; Perform OS call
;
_BDOS:
push ix ; Preserve index registers
push iy
call BDOS ; Call system
pop iy
pop ix
ret
;
; Test label character
; C set says no
;
IsItLab:
cp 'A'
ret c
cp 'Z'+1
ccf
ret nc
cp '_'
ret z
cp 'a'
ret c
cp 'z'+1
ccf
ret
;
; Test valid character
; C set says no
;
IsItValid:
call IsItLab ; Test label character
ret nc ; Yeap
;
; Test character a digit
; C set says no
;
IsItDigit:
cp '0' ; Test digit
ret c
cp '9'+1
ccf
ret
;
; Compare signed integers HL:DE
;
; C set if HL<DE
; Z set if HL=DE
;
l728d:
ld a,h
xor d
ld a,h
jp m,l7298
cp d
ret nz
ld a,l
cp e
ret
l7298:
rla
ret
;
; HL:=HL*DE - C set on overflow
;
l729a:
ld b,h
ld c,l
ld hl,0 ; Init product
ld a,16
l72a1:
add hl,hl
ret c
ex de,hl
add hl,hl
ex de,hl
jr nc,l72aa
add hl,bc
ret c
l72aa:
dec a
jr nz,l72a1
ret
;
; HL:=HL DIV DE *** NOT USED HERE
; HL:=HL MOD DE
;
ld b,d
ld c,e
ex de,hl
xor a
ld h,a
ld l,a
ld a,17
l72b6:
adc hl,hl
sbc hl,bc
jr nc,l72be
add hl,bc
scf
l72be:
ccf
rl e
rl d
dec a
jr nz,l72b6
ex de,hl
ret
;
; Process error if entry C
;
ErrCY:
ex (sp),hl
inc hl ; Fix caller's address
ex (sp),hl
ret nc ; No error
jr l72de
l72ce:: ;;**
ex (sp),hl
inc hl ; Fix caller's address
ex (sp),hl
ret c ; No error
jr l72de
;
; Process error if entry Z
;
ErrZ:
ex (sp),hl
inc hl ; Fix caller's address
ex (sp),hl
ret nz ; No error
jr l72de
;
; Process error if entry NZ
;
ErrNZ:
ex (sp),hl
inc hl ; Fix caller's address
ex (sp),hl
ret z ; No error
;
; Common entry of error routine
;
l72de:
pop hl ; Get back caller
dec hl ; Fix pointer
push hl
;
; Process error
;
ERROR:
pop hl ; Get pointer
ld a,(hl) ; Fetch error number
l72e3:
call l718f ; Test abort
ld (l7901),a
or a
jr z,l730c
push ix
pop hl
ld de,l79d7 ; Get start of source line
sbc hl,de
ld de,(l7bed)
ld a,(IncFlg) ; Test memory read
or a
jr nz,l7308 ; Nope
ld de,(l4544) ; Get start of text
sbc hl,de
ld de,(l7bd9) ; Get back source pointer
l7308:
add hl,de
ld (l790c),hl ; Save current editor address
l730c:
ld a,(CmpTyp) ; Get compile flag
dec a ; Test compiling to file
jr nz,l731a ; Nope
ld de,FFCB
ld c,_close
call _BDOS ; Close file
l731a:
ld sp,(l7b71) ; Get back stack
ret ; Exit compiler
;
; Compiler tables
; Internal label table
;
; -->> INTEGER
;
l731f:
dw _.INT
ssINT:
dw l74d3+7
db 'R'+MSB,'EGETNI'
db 0,_Type
_.INT equ $-ssINT
;
; -->> CHAR
;
dw _.CHAR
ssCHAR:
dw l74db+7
db 'R'+MSB,'AHC'
db 0,_Type
_.CHAR equ $-ssCHAR
;
; -->> REAL
;
dw _.REAL
ssREAL:
dw l74e3+7
db 'L'+MSB,'AER'
db 0,_Type
_.REAL equ $-ssREAL
;
; -->> BOOLEAN
;
dw _.BOOL
ssBOOL:
dw l74eb+7
db 'N'+MSB,'AELOOB'
db 0,_Type
_.BOOL equ $-ssBOOL
;
; -->> TEXT
;
dw _.TEXT
ssTEXT:
dw l74f3+7 ;text file type???
db 'T'+MSB,'XET'
db 0,_Type
_.TEXT equ $-ssTEXT
;
; -->> BYTE
;
dw _.BYTE
ssBYTE:
dw l74fb+7 ;byte type
db 'E'+MSB,'TYB'
db 0,_Type
_.BYTE equ $-ssBYTE
;
; -->> TRUE
;
dw _.TRUE
ssTRUE:
dw _TRUE
db _Bool
db 'E'+MSB,'URT'
db 0,_Const
_.TRUE equ $-ssTRUE
;
; -->> FALSE
;
dw _.FALSE
ssFALSE:
dw FALSE
db _Bool
db 'E'+MSB,'SLAF'
db 0,_Const
_.FALSE equ $-ssFALSE
;
; -->> MAXINT
;
dw _.MXINT
ssMAXINT:
dw MAXINT
db _Integ
db 'T'+MSB,'NIXAM'
db 0,_Const
_.MXINT equ $-ssMAXINT
;
; -->> PI
;
dw _.PI
ssPI:
db 082h,021h,0a2h,0dah,00fh,049h
db _Real
db 'I'+MSB,'P'
db 0,_Const
_.PI equ $-ssPI
;
; -->> OUTPUT
;
dw _.OUTP
ssOUTP:
dw l74f3+7 ;text file type???
dw l00c2
db 0
db 'T'+MSB,'UPTUO'
db 0,4
_.OUTP equ $-ssOUTP
;
; -->> INPUT
;
dw _.INPT
ssINPT:
dw l74f3+7 ;text file type???
dw l00c2
db 0
db 'T'+MSB,'UPNI'
db 0,_Ptr
_.INPT equ $-ssINPT
;
; -->> CON
;
dw _.CON
ssCON:
dw l74f3+7 ;text file type???
dw l00b8
db 0
db 'N'+MSB,'OC'
db 0,_Ptr
_.CON equ $-ssCON
;
; -->> TRM
;
dw _.TRM
ssTRM:
dw l74f3+7 ;text file type???
dw l00b8
db 0
db 'M'+MSB,'RT'
db 0,_Ptr
_.TRM equ $-ssTRM
;
; -->> KBD
;
dw _.KBD
ssKBD:
dw l74f3+7 ;text file type???
dw l00ba
db 0
db 'D'+MSB,'BK'
db 0,_Ptr
_.KBD equ $-ssKBD
;
; -->> LST
;
dw _.LST
ssLST:
dw l74f3+7 ;text file type???
dw l00bc
db 0
db 'T'+MSB,'SL'
db 0,_Ptr
_.LST equ $-ssLST
;
; -->> AUX
;
dw _.AUX
ssAUX:
dw l74f3+7 ;text file type???
dw l00be
db 0
db 'X'+MSB,'UA'
db 0,_Ptr
_.AUX equ $-ssAUX
;
; -->> USR
;
dw _.USR
ssUSR:
dw l74f3+7 ;text file type???
dw l00c0
db 0
db 'R'+MSB,'SU'
db 0,_Ptr
_.USR equ $-ssUSR
;
; -->> BUFLEN
;
dw _.BUFL
ssBUFL:
dw l74fb+7 ;byte type
dw l00d1
db 0
db 'N'+MSB,'ELFUB'
db 0,_Ptr
_.BUFL equ $-ssBUFL
;
; -->> HEAPPTR
;
dw _.HEAP
ssHEAP:
dw l74d3+7 ;integer type
dw l00c4
db 0
db 'R'+MSB,'TPPAEH'
db 0,_Ptr
_.HEAP equ $-ssHEAP
;
; -->> RECURPTR
;
dw _.RECUR
ssRECUR:
dw l74d3+7 ;integer type
dw l00c6
db 0
db 'R'+MSB,'TPRUCER'
db 0,_Ptr
_.RECUR equ $-ssRECUR
;
; -->> CONSTPTR
;
dw _.CONSP
ssCONSP:
dw l74d3+7 ;integer type
dw l00a0+1
db 0
db 'R'+MSB,'TPTSNOC'
db 0,_Ptr
_.CONSP equ $-ssCONSP
;
; -->> CONINPTR
;
dw _.CONIP
ssCONIP:
dw l74d3+7 ;integer type
dw l00a3+1
db 0
db 'R'+MSB,'TPNINOC'
db 0,_Ptr
_.CONIP equ $-ssCONIP
;
; -->> CONOUTPTR
;
dw _.CONOP
ssCONOP:
dw l74d3+7 ;integer type
dw l00a6+1
db 0
db 'R'+MSB,'TPTUONOC'
db 0,_Ptr
_.CONOP equ $-ssCONOP
;
; -->> LSTOUTPTR
;
dw _.LSTOP
ssLSTOP:
dw l74d3+7 ;integer type
dw l00a9+1
db 0
db 'R'+MSB,'TPTUOTSL'
db 0,_Ptr
_.LSTOP equ $-ssLSTOP
;
; -->> AUXINPTR
;
dw _.AUXIP
ssAUXIP:
dw l74d3+7 ;integer type
dw l00af+1
db 0
db 'R'+MSB,'TPNIXUA'
db 0,_Ptr
_.AUXIP equ $-ssAUXIP
;
; -->> AUXOUTPTR
;
dw _.AUXOP
ssAUXOP:
dw l74d3+7 ;integer type
dw l00ac+1
db 0
db 'R'+MSB,'TPTUOXUA'
db 0,_Ptr
_.AUXOP equ $-ssAUXOP
;
; -->> USRINPTR
;
dw _.USRIP
ssUSRIP:
dw l74d3+7 ;integer type
dw l00b5+1
db 0
db 'R'+MSB,'TPNIRSU'
db 0,_Ptr
_.USRIP equ $-ssUSRIP
;
; -->> USROUTPTR
;
dw _.USROP
ssUSROP:
dw l74d3+7 ;integer type
dw l00b2+1
db 0
db 'R'+MSB,'TPTUORSU'
db 0,_Ptr
_.USROP equ $-ssUSROP
;
; -->> ERRORPTR
;
dw _.ERRPT
ssERRPT:
dw l74d3+7 ;integer type
dw l00da
db 0
db 'R'+MSB,'TPRORRE'
db 0,_Ptr
_.ERRPT equ $-ssERRPT
;
; -->> CBREAK
;
dw _.CBRK
ssCBRK:
dw l74eb+7
dw l00dd
db 0
db 'K'+MSB,'AERBC'
db 0,_Ptr
_.CBRK equ $-ssCBRK
IntLabTab:
LenLab equ IntLabTab-l731f
;
; Standard type length table
; Note HI-LO entries of definition words
;
dww macro val
db HIGH val
db LOW val
endm
l74d3:
dww 2 ; Length for this type
dww MAXINT ; Max value
dww (-MAXINT-1) ; Min value
dww _Integ ; Type
l74db:
dww 1
dww 255
dww 0
dww _Char
l74e3:
dww 6
dww 0
dww 0
dww _Real
l74eb:
dww 1
dww _TRUE
dww FALSE
dww _Bool
l74f3:
dww (FIBlen+RecLng)
dww 0
dww 0
dww _TxtF
l74fb:
dww 1
dww 255
dww 0
dww _Integ
;
dww (DefSTR+1)
dww 0
dww 0
dww _String
l750b:
dww 0
dww 0
dww 0
dww 0
;
; Table of reserved words
;
l7513:
db 0
dw l7529
db _Byte
dw l7584
db _Addr
dw l75bb
db _Byte
dw l75f5
db _Byte
dw l7604
db _Byte
dw l761d
db _Byte
dw l7634
db -1
;
; Keywords
;
l7529:
dc 'PROGRAM'
l7530:
dc 'END'
l7533:
dc 'FORWARD'
l753a:
dc 'EXTERNAL'
l7542:
dc 'PACKED'
l7548:
dc 'ARRAY'
l754d:
dc 'FILE'
l7551:
dc 'SET'
l7554:
dc 'RECORD'
l755a:
dc 'STRING'
l7560:
dc 'OF'
l7562:
dc 'ABSOLUTE'
l756a:
dc 'THEN'
l756e:
dc 'ELSE'
l7572:
dc 'DO'
l7574:
dc 'UNTIL'
l7579:
dc 'NOT'
l757c:
dc 'NIL'
db 0
l7580:
dc '..'
l7582:
dc ':='
;
; Main block table
; -->> Code is type
;
l7584:
dc 'LABEL'
db 1
dc 'CONST'
db 2
dc 'TYPE'
db 3
l7595:
dc 'VAR'
db 4
dc 'BEGIN'
db 8
l759f:
dc 'OVERLAY'
db 7
l75a7:
dc 'PROCEDURE'
db 5
dc 'FUNCTION'
db 6
db 0
;
; Statement table
;
l75bb:
dc 'BEGIN'
dw l5377
dc 'IF'
dw l53ef
dc 'WHILE'
dw l5424
dc 'REPEAT'
dw l544c
dc 'FOR'
dw l546b
l75da:
dc 'CASE'
dw l5521
dc 'GOTO'
dw l5626
dc 'WITH'
dw l564e
dc 'INLINE'
dw l5698
db 0
l75f5:
dc 'TO'
inc hl
dc 'DOWNTO'
dec hl
db 0
l7600:
db '*'+0x80
db 0
db '/'+0x80
db 1
l7604:
dc 'AND'
db 2
dc 'DIV'
db 3
dc 'MOD'
db 4
dc 'SHL'
db 5
dc 'SHR'
db 6
db 0
l7619:
db '+'+0x80
db 0
db '-'+0x80
db 1
l761d:
dc 'OR'
db 2
dc 'XOR'
db 3
db 0
l7625:
db '='+0x80
db 00000000b
db '<','>'+0x80
db 00001000b
db '>','='+0x80
db 00010000b
db '<','='+0x80
db 00011000b
db '>'+0x80
db 00100000b
db '<'+0x80
db 00101000b
l7634:
dc 'IN'
db 11111111b
db 0
l7638:
dc 'WRITELN'
dw l5ae7
dc 'WRITE'
dw l5ae8
dc 'READLN'
dw l5a32
dc 'READ'
dw l5a33
dc 'DELETE'
dw l5c66
dc 'INSERT'
dw l5c87
dc 'ASSIGN'
dw l5943
dc 'RESET'
dw l59b9
dc 'REWRITE'
dw l59be
dc 'CLOSE'
dw l59db
dc 'ERASE'
dw l5971
dc 'RENAME'
dw l5966
dc 'SEEK'
dw l598c
dc 'GETMEM'
dw l5d94
dc 'NEW'
dw l5d9f
dc 'FREEMEM'
dw l5db4
dc 'DISPOSE'
dw l5dbf
dc 'MARK'
dw l5dd4
dc 'RELEASE'
dw l5dd9
dc 'OVRDRIVE'
dw l5df9
dc 'CRTINIT'
dw l5e38
dc 'CRTEXIT'
dw l5e3d
dc 'GOTOXY'
dw l5d6d
dc 'CLRSCR'
dw l5e42
dc 'CLREOL'
dw l5e48
dc 'NORMVIDEO'
dw l5e4d
dc 'HIGHVIDEO'
dw l5e4d
dc 'LOWVIDEO'
dw l5e52
dc 'INSLINE'
dw l5e57
dc 'DELLINE'
dw l5e5c
dc 'DELAY'
dw l5d89
dc 'BLOCKREAD'
dw l5c16
dc 'BLOCKWRITE'
dw l5c1e
dc 'RANDOMIZE'
dw l5d83
dc 'MOVE'
dw l5e05
dc 'FILLCHAR'
dw l5e1a
dc 'EXIT'
dw l5e61
dc 'HALT'
dw l5e67
dc 'PORT'
dw l5e6d
dc 'STACKPTR'
dw l5e78
dc 'FLUSH'
dw l59ab
dc 'EXECUTE'
dw l597e
dc 'CHAIN'
dw l5979
dc 'STR'
dw l5cba
dc 'VAL'
dw l5d22
dc 'BDOS'
dw l6553
dc 'BIOS'
dw l651e
db 0
l77b1:
dc 'CHR'
dw l6425
dc 'ORD'
dw l6411
dc 'COPY'
dw l6460
dc 'LENGTH'
dw l6441
dc 'POS'
dw l6452
dc 'CONCAT'
dw l6481
dc 'SUCC'
dw l63d4
dc 'PRED'
dw l63d7
dc 'UPCASE'
dw l6437
dc 'TRUNC'
dw l63be
dc 'ROUND'
dw l63c3
dc 'ODD'
dw l6401
dc 'ABS'
dw l6371
dc 'SQR'
dw l6360
dc 'SQRT'
dw l6385
dc 'SIN'
dw l638a
dc 'COS'
dw l638f
dc 'ARCTAN'
dw l6394
dc 'LN'
dw l6399
dc 'EXP'
dw l639e
dc 'INT'
dw l63a3
dc 'FRAC'
dw l63a8
dc 'RANDOM'
dw l64ac
dc 'PARAMCOUNT'
dw l649c
dc 'PARAMSTR'
dw l64a1
dc 'LO'
dw l63e1
dc 'HI'
dw l63eb
dc 'SWAP'
dw l63f6
dc 'PTR'
dw l642b
dc 'IORESULT'
dw l64c4
dc 'EOF'
dw l64c9
dc 'EOLN'
dw l64df
dc 'SEEKEOF'
dw l64d5
dc 'SEEKEOLN'
dw l64da
dc 'FILESIZE'
dw l64fa
dc 'FILEPOS'
dw l64f2
dc 'KEYPRESSED'
dw l640c
dc 'MEMAVAIL'
dw l6514
dc 'MAXAVAIL'
dw l6519
dc 'PORT'
dw l65bf
dc 'STACKPTR'
dw l65ca
dc 'ADDR'
dw l6576
dc 'SIZEOF'
dw l659d
dc 'BDOSHL'
dw l6553
dc 'BDOS'
dw l6554
dc 'BIOSHL'
dw l651e
dc 'BIOS'
dw l651f
db 0
l78fa:
dc 'MEM'
dw 0
db 0
;
; Start of dynamic data
; - originally at page boundary - here : 7900h
;
; Dynamic data area starts - shared by editor and compiler most
;
CmpTyp:
db 1ah ; Compile flag:
; 0: Compile to memory
; 1: Compile to .COM/.CHN file
; 2: Searching
l7901:
db 'd' ; Error code
CodePC:
db 'SE' ; Code pointer
l7904:
db 'EK' ; Code start address
l7906:
db 'EO' ; Code end address
DataBeg:
db 'L',0ceh ; Start of data
l790a:
db 0dah,'d' ; End of code address
l790c:
db 'FI' ; Current editor address
IncFlg:
db 'L' ; Memory read flag (0 is read)
l790f:
db 'ESIZ',0c5h,0fah,'dFILEPO',0d3h,0f2h
db 'dKEYPRESSE',0c4h,0ch,'dMEMAVAI',0cch
;
; FCB of source file
;
FFCB: ;36 bytes???
db 14h
db 'eMAXAVAI'
db 0cch
db 19h,'ePOR',0d4h,0bfh,'eSTACKPT'
db 0d2h,0cah,'eADD',0d2h,'v'
db 'eSI'
;
; DISK BUFFER
;
TmpBuff:
db 'ZEO',0c6h,9dh,'eBDOS'
db 'H',0cch,'SeBDO',0d3h,'TeBIOSH'
db 0cch,1eh,'eBIO',0d3h,1fh,'e'
db 0,'ME',0cdh,0,0,0
l7980:: ;;**
l79d7 equ TmpBuff+RecLng ; Start of source line
l7a57 equ l79d7+RecLng
l7ad7 equ l7a57+RecLng ; Top of used memory on start
Envir1 equ l7ad7+RecLng
l7b58 equ Envir1+1 ; Value of symbol
l7b59 equ l7b58+1
l7b5a equ l7b59+1 ; Type table
l7b5c equ l7b5a+2 ; Type
l7b5d equ l7b5c+1
l7b5e equ l7b5d+1 ; Lo set limit
l7b60 equ l7b5e+2 ; Hi set limit
l7b62 equ l7b60+2 ; Length of type
Envir2 equ l7b62+2
l7b65 equ Envir2+1
l7b69 equ l7b65+4
l7b6b equ l7b69+2
l7b6d equ l7b6b+2 ; Last memory address
l7b6f equ l7b6d+2 ; TEMP
l7b71 equ l7b6f+2 ; TEMP
l7b72 equ l7b71+1 ; EDT: Pointer to delimters
LabPtr equ l7b72+1 ; Label pointer
l7b74 equ LabPtr+1 ; EDT: Edited line
PrevLabPtr equ l7b74+1 ; Previous label pointer
l7b77 equ PrevLabPtr+2 ; Top of available memory
l7b79 equ l7b77+2
CurLab equ l7b79+2 ; Current label pointer
l7b7d equ CurLab+2
l7b7f equ l7b7d+2
l7b81 equ l7b7f+2
l7b83 equ l7b81+2
l7b85 equ l7b83+2
l7b87 equ l7b85+2
l7b88 equ l7b87+1
l7b89 equ l7b88+1
l7b8b equ l7b89+2
l7b8d equ l7b8b+2
l7b8f equ l7b8d+2
l7b90 equ l7b8f+1
l7b91 equ l7b90+1 ; ???
l7b92 equ l7b91+1 ; ???
curtype_l7b93 equ l7b92+1 ; Type
l7b94 equ curtype_l7b93+1 ; ???
l7b95 equ l7b94+1
l7b96 equ l7b95+1 ; OVERLAY number
l7b97 equ l7b96+1 ; PROCEDURE (=0) or FUNCTION (<>0)
l7b98 equ l7b97+1
l7b99 equ l7b98+1 ; Overlay flag (-1)
l7b9a equ l7b99+1
l7b9b equ l7b9a+1
l7b9c equ l7b9b+1
l7b9d equ l7b9c+1 ; Option bits
l7b9e equ l7b9d+1 ; Local PROCEDURE/FUNCTION options
l7b9f equ l7b9e+1
l7ba0 equ l7b9f+1 ; End on break
l7ba1 equ l7ba0+1
l7ba2 equ l7ba1+1 ; End of file
l7ba3 equ l7ba2+1
l7ba4 equ l7ba3+1
l7ba6 equ l7ba4+2
l7ba7 equ l7ba6+1
l7ba9 equ l7ba7+2
l7bab equ l7ba9+2 ; Data pointer for overlay
l7bb0 equ l7bab+5 ; Length of overlay
l7bb2 equ l7bb0+2 ; OVERLAY file name
l7bbd equ l7bb2+11
l7bbe equ l7bbd+1
FirstVAR equ l7bbe+2
l7bc1 equ FirstVAR+1
l7bc2 equ l7bc1+1
l7bc4 equ l7bc2+2
l7bc6 equ l7bc4+2
l7bc7 equ l7bc6+1 ; Depth for WITH
l7bc8 equ l7bc7+1
l7bc9 equ l7bc8+1
l7bca equ l7bc9+1
l7bcc equ l7bca+2
Env_PC equ l7bcc+9
l7bd7 equ Env_PC+2 ; Source pointer
l7bd9 equ l7bd7+2 ; Dtto.
RRN_stat equ l7bd9+2 ; File access
RecPtr equ RRN_stat +1 ; Record pointer
RRN_off equ RecPtr+1 ; Record base
MemsTop equ RRN_off+2
COMsTop equ MemsTop+2 ; Top of .COM file
BackLevel equ COMsTop+2 ; Back fix level
l7be4 equ BackLevel+1 ; Saved top of .COM file
INCsTop equ l7be4+2
l7be8 equ INCsTop+2
l7be9 equ l7be8+1
l7beb equ l7be9+2
l7bed equ l7beb+2
l7bef equ l7bed+2 ; Line count
l7bf5 equ l7bef+6 ; Start of text
end
savebin "tp.com",begin,end-begin
LABELSLIST "../../us/user.l"