Browse Source

added KERNAL_TED and BASIC_TED

master
Michael Steil 4 months ago
parent
commit
f92ea6fb67
100 changed files with 21274 additions and 0 deletions
  1. 76
    0
      BASIC_TED/basic.src
  2. 73
    0
      BASIC_TED/bground.src
  3. 335
    0
      BASIC_TED/code0.src
  4. 198
    0
      BASIC_TED/code1.src
  5. 324
    0
      BASIC_TED/code10.src
  6. 344
    0
      BASIC_TED/code11.src
  7. 194
    0
      BASIC_TED/code12.src
  8. 313
    0
      BASIC_TED/code13.src
  9. 149
    0
      BASIC_TED/code15.src
  10. 267
    0
      BASIC_TED/code16.src
  11. 165
    0
      BASIC_TED/code17.src
  12. 266
    0
      BASIC_TED/code18.src
  13. 324
    0
      BASIC_TED/code19.src
  14. 134
    0
      BASIC_TED/code2.src
  15. 191
    0
      BASIC_TED/code20.src
  16. 207
    0
      BASIC_TED/code21.src
  17. 183
    0
      BASIC_TED/code22.src
  18. 97
    0
      BASIC_TED/code23.src
  19. 208
    0
      BASIC_TED/code24.src
  20. 294
    0
      BASIC_TED/code26.src
  21. 347
    0
      BASIC_TED/code4.src
  22. 520
    0
      BASIC_TED/code5.src
  23. 188
    0
      BASIC_TED/code7.src
  24. 241
    0
      BASIC_TED/code8.src
  25. 271
    0
      BASIC_TED/code9.src
  26. 208
    0
      BASIC_TED/crunch.src
  27. 806
    0
      BASIC_TED/declare.src
  28. 106
    0
      BASIC_TED/delete.src
  29. 44
    0
      BASIC_TED/disclaim.src
  30. 436
    0
      BASIC_TED/dos1.src
  31. 305
    0
      BASIC_TED/dos2.src
  32. 141
    0
      BASIC_TED/dos3.src
  33. 33
    0
      BASIC_TED/entries.src
  34. 102
    0
      BASIC_TED/errmsgs.src
  35. 298
    0
      BASIC_TED/exten1.src
  36. 176
    0
      BASIC_TED/exten2.src
  37. 145
    0
      BASIC_TED/exten3.src
  38. 136
    0
      BASIC_TED/for.src
  39. 399
    0
      BASIC_TED/graphic1.src
  40. 177
    0
      BASIC_TED/graphic10.src
  41. 38
    0
      BASIC_TED/graphic11.src
  42. 213
    0
      BASIC_TED/graphic12.src
  43. 106
    0
      BASIC_TED/graphic13.src
  44. 196
    0
      BASIC_TED/graphic14.src
  45. 140
    0
      BASIC_TED/graphic15.src
  46. 205
    0
      BASIC_TED/graphic16.src
  47. 243
    0
      BASIC_TED/graphic2.src
  48. 202
    0
      BASIC_TED/graphic3.src
  49. 331
    0
      BASIC_TED/graphic4.src
  50. 166
    0
      BASIC_TED/graphic5.src
  51. 121
    0
      BASIC_TED/graphic6.src
  52. 227
    0
      BASIC_TED/graphic7.src
  53. 209
    0
      BASIC_TED/graphic8.src
  54. 214
    0
      BASIC_TED/graphic9.src
  55. 285
    0
      BASIC_TED/grbcol.src
  56. 11
    0
      BASIC_TED/header.src
  57. 47
    0
      BASIC_TED/indjumps.src
  58. 206
    0
      BASIC_TED/init.src
  59. 194
    0
      BASIC_TED/keydefs.src
  60. 163
    0
      BASIC_TED/list.src
  61. 107
    0
      BASIC_TED/noise.src
  62. 48
    0
      BASIC_TED/overflow.src
  63. 385
    0
      BASIC_TED/renumber.src
  64. 180
    0
      BASIC_TED/tokens1.src
  65. 133
    0
      BASIC_TED/tokens2.src
  66. 126
    0
      BASIC_TED/trig.src
  67. 735
    0
      BASIC_TED/using.src
  68. 19
    0
      BASIC_TED/vectors.src
  69. 254
    0
      KERNAL_TED/assem.src
  70. 198
    0
      KERNAL_TED/banking.src
  71. 255
    0
      KERNAL_TED/channelio.src
  72. 75
    0
      KERNAL_TED/clall.src
  73. 154
    0
      KERNAL_TED/close.src
  74. 307
    0
      KERNAL_TED/cmds1.src
  75. 167
    0
      KERNAL_TED/cmds2.src
  76. 807
    0
      KERNAL_TED/declare.src
  77. 258
    0
      KERNAL_TED/disasm.src
  78. 45
    0
      KERNAL_TED/disclaim.src
  79. 420
    0
      KERNAL_TED/ed1.src
  80. 144
    0
      KERNAL_TED/ed2.src
  81. 199
    0
      KERNAL_TED/ed3.src
  82. 323
    0
      KERNAL_TED/ed4.src
  83. 266
    0
      KERNAL_TED/ed5.src
  84. 200
    0
      KERNAL_TED/ed6.src
  85. 344
    0
      KERNAL_TED/ed7.src
  86. 68
    0
      KERNAL_TED/errorhdlr.src
  87. 325
    0
      KERNAL_TED/init.src
  88. 72
    0
      KERNAL_TED/interrupt.src
  89. 49
    0
      KERNAL_TED/kernal.src
  90. 255
    0
      KERNAL_TED/load.src
  91. 30
    0
      KERNAL_TED/messages.src
  92. 27
    0
      KERNAL_TED/music.src
  93. 195
    0
      KERNAL_TED/open.src
  94. 266
    0
      KERNAL_TED/openchanl.src
  95. 25
    0
      KERNAL_TED/overflow.src
  96. 119
    0
      KERNAL_TED/patches.src
  97. 206
    0
      KERNAL_TED/rs232.src
  98. 154
    0
      KERNAL_TED/save.src
  99. 396
    0
      KERNAL_TED/serial.src
  100. 0
    0
      KERNAL_TED/split.src

+ 76
- 0
BASIC_TED/basic.src View File

@@ -0,0 +1,76 @@
.nam ted_basic

.include disclaim

true =-1
false =0
truted =true
palmod =false

.include declare
.include entries
.include bground
.include header
.include init
.include indjumps
.include tokens1
.include tokens2
.include errmsgs
.include code0
.include code1
.include crunch
.include code2
.include list
.include code4
.include code5
.include code7
.include code8
.include code9
.include code10
.include code11
.include code12
.include code13
.include code15
.include code16
.include code17
.include code18
.include code19
.include code20
.include code21
.include code22
.include code23
.include code24
.include code26
.include grbcol
.include trig
.include renumber
.include for
.include delete
.include using
.include exten1
.include exten2
.include exten3
.include keydefs
.include noise
.include graphic1
.include graphic2
.include graphic3
.include graphic4
.include graphic5
.include graphic6
.include graphic7
.include graphic8
.include graphic9
.include graphic10
.include graphic11
.include graphic12
.include graphic13
.include graphic14
.include graphic15
.include graphic16
.include dos1
.include dos2
.include dos3
.include overflow
.include vectors
.end

+ 73
- 0
BASIC_TED/bground.src View File

@@ -0,0 +1,73 @@
.page 'background'
; a brief explanation of the pointer structure in basic:


; highest memory
; ================ <== memsiz
; * strings *
; * *
; ================ <== fretop builds down as strings
; * * are created.
; * *
; * *
; * available *
; * ram *
; * *
; * *
; ================ <== strend builds up
; * *
; * array area *
; * *
; ================ <== arytab
; * *
; * variables *
; * *
; ================ <== vartab
; * *
; * *
; * *
; * text area *
; * *
; * *
; ================ <== txttab
; lowest ram
.page
; a little insight into basics many and curious bit mapped memory maps


; * 64k ted * 16k ted
; * *
; * b * <==basic text area
; * *
; *-----------* <--------$4000--------> *---------*
; * * * *
; * * * *
; * * * *
; * * * *
; * * <==bit map screen 8k ==> * *
; * * * *
; * * * *
; * * * *
; * * * *
; * * * *
; *-----------* <--------$2000--------> *---------*
; * * <==hires text & attr==> * *
; * * * *
; *-----------* <--------$1800--------> *---------*
; * * <==unused * b *
; * * basic text==> * *
; *-----------* <--------$1000--------> *---------*
; * * * *
; * * <==normal text & atr==> * *
; *-----------* *---------*
; * * * *
; * * <=== system storage===> * *
; *-----------* <--------$0000--------> *---------*

; since the basic text area in each machine is in a different
; area, two graphic area allocation schemes are required. in the
; case of the 16k ted, existing text remains in place, but the
; top of memory pointer is lowered by 10k, and strings & variables
; are trashed. for the 64k ted, however, basic text is moved above
; the hires ram, relinked, and strings and var's are left intact.
;end

+ 335
- 0
BASIC_TED/code0.src View File

@@ -0,0 +1,335 @@
.page
.subttl 'code0'
ready
ldx #$80
.byte $2c
omerr
ldx #errom
error
jmp (ierror)
nerror
txa
bmi readyx
stx errnum ;save error # for 'er'
bit runmod ;direct mode?
bpl errisd ;yes...always display error text

ldy #1 ;copy curlin to errlin, oldtxt to errtxt
error1
lda curlin,y
sta errlin,y
lda oldtxt,y
sta errtxt,y
dey
bpl error1

cpx #errus ;don't trap undefined statement errors
beq errisd
ldy trapno+1 ;is trap set?
iny
beq errisd ;no.
dey ;restore msb of line #
sty linnum+1
sty tmptrp ;save until a resume is executed
ldy trapno
sty linnum

ldx #$ff
stx trapno+1 ;flag no more traps
ldx oldstk
txs
jsr luk4it
jmp newstt
errisd
dex
txa
pha
lda #0 ;make sure we're in text mode
sta graphm
jsr go2txt ;switch to text mode
pla
jsr erstup ;set up address of error msg in .a in index2
jsr clrch
lda #0
sta channl
jsr crdo
jsr outqst
ldy #0
geterr
lda (index2),y ;ind.ok
pha
and #127
jsr outdo
iny
pla
bpl geterr
jsr stkini
jsr primm
.byte ' ERROR',0
errfin
ldy curlin+1 ;direct mode?
iny
beq readyx ;yes...no line #
jsr inprt




readyx
jsr reddy ;print 'ready'
lda #$80
jsr setmsg ;turn kernal messages on
lda #0
sta runmod ;turn run mode off



main
jmp (imain)
nmain
ldx #$ff
stx curlin+1
jsr inlin ;get a line from terminal
stx txtptr ;txtptr is ptr to index buffer
sty txtptr+1
jsr chrget
tax
main00
beq main ;if end of line
bcc main1 ;if line number
jsr crunch
jsr chrgot ;get command
jmp xeqdir ;execute command



main1
jsr linget ;read line # into linnum
jsr crunch
sty count ;retain char count
jsr fndlin
bcc nodel ;no match, so don't delete
ldy #1
jsr indlow
sta index1+1
lda vartab ;text end
sta index1
lda lowtr+1 ;set xfer to
sta index2+1
dey
jsr indlow ;compute length
clc
sbc lowtr
eor #$ff ;make it negative
clc
adc vartab ;compute new text end
sta vartab
sta index2 ;set low of xfer to
lda vartab+1
adc #255
sta vartab+1 ;compute high of text end
sbc lowtr+1 ;compute # of blocks to move
tax
sec
lda lowtr
sbc vartab ;compute offset
tay
bcs qdect1 ;if vartab <= lowtr
inx ;dec due to carry and
dec index2+1 ;dec store so carry works
qdect1
clc
adc index1
bcc mloop
dec index1+1
clc
mloop
jsr indin1
sta (index2),y
iny
bne mloop
inc index1+1
inc index2+1
dex
bne mloop
nodel
jsr clearc
jsr lnkprg
ldy #0
jsr indtxt ;delete line?
beq main00
clc ;no...something to insert

lda vartab
ldy vartab+1
sta hightr
sty hightr+1 ;top of block to move

adc count ;length of characters in line
bcc nodel1
iny
nodel1 clc
adc #4 ;plus link and line #
bcc nodelc
iny
nodelc sta highds ;destination of top
sty highds+1

; low block address is lowtr
; where it was left in the call to fndlin
;
jsr bltu
;
; make links non-null to fool chead
;
ldy #0
lda #1
sta (lowtr),y
iny
sta (lowtr),y
;
; put line number in text
;
iny
lda linnum
sta (lowtr),y
lda linnum+1
iny
sta (lowtr),y
;
; advance lowtr to start of line
;
iny
tya
clc
adc lowtr
sta lowtr
bcc main2
inc lowtr+1
main2
lda strend ;64k only
ldy strend+1
sta vartab
sty vartab+1
;
; block move line to text
;
ldy count
dey
stolop
jsr indtxt
sta (lowtr),y
dey
bpl stolop
jsr lnkprg
jsr runc
;
; test if auto in effect
;
lda autinc ;if in auto mode, increment val <> 0
ora autinc+1
beq gomain ;not in
lda linnum ;yes, construct new line number
clc
adc autinc
sta facho+1
lda linnum+1
adc autinc+1
sta facho
ldx #$90
sec
jsr floatc ;float it
jsr fout ;make it into a string
ldx #0 ;move string into kbd buffer
aline1
lda $101,x ;copy number formed into buffer, ignoring leading space
beq aline2 ;a null marks end
sta keyd,x
inx
bne aline1 ;always

aline2
lda #29 ;cursor right
sta keyd,x
inx
stx ndx
gomain
jmp main


lnkprg
lda txttab
ldy txttab+1
sta index
sty index+1
clc
chead
ldy #0
jsr indin1 ;lda (index),y .. check for null link
bne chea3
iny
jsr indin1 ;lda (index),y
beq lnkrts
chea3
ldy #4
czloop
iny
jsr indin1 ;lda (index),y
bne czloop
iny
tya
adc index
tax
ldy #0
sta (index),y
tya
adc index+1
iny
sta (index),y
stx index
sta index+1
bcc chead ;always



fixlnk
clc
lda index ;set pointer to end of text
ldy index+1 ;(called only when allocating or deallocating bit maps)
adc #2
bcc *+3
iny
sta vartab
sty vartab+1
lnkrts
rts


;
; function to get a line one character at a time from the input
; channel and build it in the input buffer.
;
inlin
ldx #0


inlinc
jsr inchr
cmp #cr ;a carriage return?
beq finin1 ;yes...done build

sta buf,x ;put it away
inx
cpx #buflen ;max character line?
bcc inlinc ;no...o.k.

jmp errlen

finin1
jmp fininl

;.end

+ 198
- 0
BASIC_TED/code1.src View File

@@ -0,0 +1,198 @@
.page
.subttl 'code1'
; find a specific token in the run-time stack. token to be found is
; in srchtk.
;
; if called by 'for' or 'next', scan entries in stack, looking for
; a specific 'for-variable' (in (forpnt)). if found, (fndpnt) will
; point to it, and z is set. otherwise, (fndpnt) will point to
; either :
; 1) the non-for token
; 2) bottom-of-stack
;
; special case : 'next' with no argument will match first 'for'
; entry on stack found, if any. this case is signaled by a (forpnt)
; with a msb of $ff (an impossible value).
;
; all other calls to search will result in either
; 1) (success) z = 1, (fndpnt) = address
; 2) (failure) z = 0



search
;
; set up temporary pointer with current top of stack
;
jsr movtos ;tos => fndpnt

srch05
;
; test if pointer at bottom of stack. if so, item not found.
;
lda fndpnt
cmp #<stkbot
bne srch10 ;(fndpnt) <> bottom, ok
lda fndpnt+1 ;lsb's the same, test msb's
cmp #>stkbot
beq srch98 ;stack empty, rts

srch10
ldy #0
lda srchtk ;what are we looking for?
cmp #fortk ;'for' tokens are special cases
bne srch20

; looking for a 'for' token. if next token examined is not a 'for'
; token, return with z = 0. otherwise, check the pointer to it's
; 'for' variable. if the variable pointer = (forpnt), or if
; (forpnt) = ffxx, return with z = 1. otherwise, set up x with
; length of a 'for' entry, and use the usual mechanisim for
; examining the next entry.

cmp (fndpnt),y
bne srch99 ;not 'for', do rts with z = 0
ldy #2 ;point to msb of 'for' variable
lda forpnt+1
cmp #$ff
beq srch99 ;do rts with z = 1
cmp (fndpnt),y
bne srch15 ;not right variable, keep looking.
dey
lda forpnt ;test lsb
cmp (fndpnt),y
beq srch99 ;a hit! rts with z = 1
srch15
ldx #lenfor
bne srch30 ;keep looking.

srch20
lda (fndpnt),y
cmp srchtk ;is this the correct type of entry?
beq srch99 ;rts with z = 1

; the entry on top of the run-time stack is not the entry we are
; looking for. find out what is there, and advance temp. pointer
; past it.

ldx #lenfor ;is it a 'for' entry?
cmp #fortk
beq srch30
ldx #5 ;must be gosub or do by default

srch30
txa
clc
adc fndpnt
sta fndpnt
bcc srch05
inc fndpnt+1
bne srch05 ;always

srch98
ldy #1 ;clear z flag
srch99
rts

bltu
jsr reason
sta strend
sty strend+1
sec
lda hightr
sbc lowtr
sta index
tay
lda hightr+1
sbc lowtr+1
tax
inx
tya
beq decblt
lda hightr
sec
sbc index
sta hightr
bcs blt1
dec hightr+1
sec
blt1
lda highds
sbc index
sta highds
bcs moren1
dec highds+1
bcc moren1
bltlp
jsr indhtr ;lda (hightr),y
sta (highds),y
moren1
dey
bne bltlp
jsr indhtr ;lda (hightr),y
sta (highds),y
decblt
dec hightr+1
dec highds+1
dex
bne moren1
rts


; add (y) elements to top of run-time stack. error if result exceeds tos
;
getstk
sty syreg
sec
lda tos
sbc syreg
sta tos
lda tos+1
sbc #0
sta tos+1
cmp #>stktop
bcc gomerr
bne gets99
lda tos
cmp #<stktop
bcc gomerr
gets99
rts

reason
cpy fretop+1
bcc rearts
bne trymor
cmp fretop
bcc rearts
trymor
pha
ldx #8+addprc
tya
reasav
pha
lda highds-1,x
dex
bpl reasav
jsr garba2
ldx #248-addprc
reasto
pla
sta highds+8+addprc,x
inx
bmi reasto
pla
tay
pla
cpy fretop+1
bcc rearts
bne gomerr
cmp fretop
bcs gomerr
rearts
rts

gomerr
jmp omerr

;.end

+ 324
- 0
BASIC_TED/code10.src View File

@@ -0,0 +1,324 @@
.page
.subttl 'code10'
isvar
jsr ptrget ;parse variable name, put name in varnam
isvret
sta facmo ;save pointer to variable
sty facmo+1
ldx varnam
ldy varnam+1
lda valtyp ;test if numeric or string
beq gooo ;branch if numeric
lda #0
sta facov
cpx #'T' ;'ti$' is a special case. look for it.
bne isvds ;go test for ds$
cpy #$c9 ;shifted 'i'
bne strrts

; variable name is 'ti$'. to see if this is 'the' ti$, and not an
; array ti$(), test to see if it has a pointer to the zero in rom.
; if it is an array item, it's pointer will be to a real value, or
; a real zero. if it isn't an array item, it's pointer will point
; to a dummy zero in rom.
;
lda facmo
cmp #<zero
bne strrts ;not ti$
lda facmo+1
cmp #>zero
bne strrts ;not ti$

jsr gettim ;it is ti$, create a string.
sty tenexp
dey
sty fbufpt
ldy #6
sty deccnt
ldy #fdcend-foutbl
jsr foutim
jmp timstr



isvds
cpx #'D' ;is this ds$?
bne strrts
cpy #$d3 ;'s'+$80
bne strrts
jsr chkds
lda dsdesc+1
ldy dsdesc+2
jmp strlit



chkds
lda dsdesc
bne strrts
jmp errchl ;get status



gooo
bit intflg ;is this an integer?
bpl gooooo ;no, branch.
ldy #0
jsr indfmo
tax
iny
jsr indfmo
tay
txa
jmp givayf



;screen out ti,st,er, and el, and assign values to them.
;first test if pointer points to rom zero. if not, it can't
;be any of the above.
;
gooooo
lda facmo+1
cmp #>zero
bne gomovf ;not ti,st,....
lda facmo
cmp #<zero
bne gomovf ;not ti,st,....
;
; pointer does point to the rom zero. now it is necessary to
; examine the actual variable name case by case.
;
cpx #'T'
bne qstatv
cpy #'I'
bne gomovf
jsr gettim
tya
ldx #160
jmp floatb

gettim
jsr rdtim
stx facmo
sty facmoh
sta faclo
ldy #0
sty facho
strrts
rts

qstatv
cpx #'S' ;'st'?
bne qdsav ;no, go test 'ds'
cpy #'T'
bne gomovf
jsr readst
jmp float



qdsav
cpx #'D' ;'ds'?
bne qerlin ;no, go test 'er' & 'el'
cpy #'S'
bne gomovf

jsr chkds
ldy #0
lda #dsdesc+1 ;lda (dsdesc+1),y
jsr indsub ;..indirectly
and #$0f
asl a
sta garbfl
asl a
asl a
adc garbfl
sta garbfl
iny
lda #dsdesc+1 ;lda (dsdesc+1),y
jsr indsub ;..indirectly
and #$0f
adc garbfl
jmp float

qerlin
cpx #'E'
bne gomovf
cpy #'R'
beq qnumer
cpy #'L'
bne gomovf

lda errlin+1 ;they want the last error line #
ldy errlin
jmp nosflt

qnumer
lda errnum ;'er', or type number of last error
jmp float

gomovf
lda facmo
ldy facmo+1
jmp movfrm ;move value from ram



; at this point, eval has determined that the token in a has to be a
; function. it must therefor be in the range sgn..mid$ (old basic),
; or rgr..instr (new extensions). we will collapse these two
; disjoint blocks into one continuous range.
;
; on entry, we can assume the token is >= 'sgn'

isfun
cmp #elsetk ;1 greater than instr
bcs snerr6
cmp #middtk+1
bcc isfun1 ;no need to adjust
sbc #rgrtk-middtk-1

isfun1

; yet another special case. instr$, left$, right$, and mid$ get a special
; pre-processing.

pha ;save token
tax
jsr chrget
cpx #insttk-1 ;look for (adjusted) instr token
beq isfun2
cpx #middtk+1
bcs oknorm
cpx #lefttk
bcc oknorm

isfun2
jsr chkopn
jsr frmevl
jsr chkcom
jsr chkstr

pla ;move token to x
cmp #insttk-1 ;yet another special case: instr bails out here.
beq instgo
tax
lda facmo+1
pha
lda facmo
pha
txa ;push token on stack
pha
jsr getbyt
pla ;put token in y
tay
txa
pha
tya ;put token in a
jmp fingo ;go set up to evaluate fn



oknorm
jsr parchk ;check for open parens, evaluate argument
pla ;restore token

fingo
sec ;convert token to index into jump table
sbc #onefun
asl a
tay
lda fundsp+1,y
sta jmper+2
lda fundsp,y
sta jmper+1
jsr jmper
jmp chknum



instgo
jmp instr

snerr6
jmp snerr


orop
ldy #255
.byte $2c
andop
ldy #0
sty count
jsr ayint
lda facmo
eor count
sta integr
lda faclo
eor count
sta integr+1
jsr movfa
jsr ayint
lda faclo
eor count
and integr+1
eor count
tay
lda facmo
eor count
and integr
eor count
jmp givayf


dorel
jsr chkval
bcs strcmp
lda argsgn
ora #$7f
and argho
sta argho
lda #<argexp
ldy #>argexp
jsr fcomp
tax
jmp qcomp



strcmp
lda #0
sta valtyp
dec opmask
jsr frefac
sta dsctmp
stx dsctmp+1
sty dsctmp+2
lda argmo
ldy argmo+1
jsr fretmp
stx argmo
sty argmo+1
tax
sec
sbc dsctmp
beq stasgn
lda #1
bcc stasgn
ldx dsctmp
lda #$ff
stasgn sta facsgn
ldy #255
inx
nxtcmp iny
dex
bne getcmp
ldx facsgn
qcomp bmi docmp
clc
bcc docmp
getcmp
jsr indamo ;(argmo),y

;.end

+ 344
- 0
BASIC_TED/code11.src View File

@@ -0,0 +1,344 @@
.page
.subttl 'code11'
pha
jsr inddsc ;(dsctmp+1),y
sta syntmp
pla
cmp syntmp
beq nxtcmp
ldx #$ff
bcs docmp
ldx #1



docmp
inx
txa
rol a
and domask
beq goflot
lda #$ff
goflot
jmp float



dim3 jsr chkcom
dim tax
jsr ptrgt1
jsr chrgot
bne dim3
rts



ptrget
ldx #0
jsr chrgot
ptrgt1 stx dimflg
ptrgt2 sta varnam
jsr chrgot
jsr isletc
bcs ptrgt3



interr
jmp snerr



ptrgt3
ldx #0
stx valtyp
stx intflg
jsr chrget
bcc issec
jsr isletc
bcc nosec
issec tax
eatem
jsr chrget
bcc eatem
jsr isletc
bcs eatem
nosec cmp #'$'
bne notstr
lda #$ff
sta valtyp
bne turnon

notstr
cmp #'%'
bne strnam
lda subflg
bne interr
lda #$80
sta intflg
ora varnam
sta varnam
turnon
txa
ora #$80
tax
jsr chrget
strnam
stx varnam+1
sec
ora subflg
sbc #40
bne *+5
jmp isary

ldy #0
sty subflg
lda vartab
ldx vartab+1
stxfnd
stx lowtr+1
lopfnd
sta lowtr
cpx arytab+1
bne lopfn
cmp arytab
beq notfns
lopfn
jsr indlow ;(lowtr),y
sta syntmp
lda varnam
cmp syntmp
bne notit
iny
jsr indlow
sta syntmp
lda varnam+1
cmp syntmp
bne *+5
jmp finptr

dey
notit clc
lda lowtr
adc #6+addprc
bcc lopfnd
inx
bne stxfnd
isletc
cmp #'A'
bcc islrts
sbc #$5b
sec
sbc #@245
islrts rts


notfns pla
pha

zz6 =isvret-1

cmp #<zz6
bne notevl
ldzr
lda #<zero
ldy #>zero
rts

qst001
cpy #$c9 ;we know first is 't', is second shift i?
beq ldzr
cpy #$49 ;or 'i'?
bne varok
beq gobadv
qst004
cpy #$d3 ;check for 'ds$'
beq gobadv
cpy #'S' ;check for 'ds'
bne varok
beq gobadv
qst002
cpy #'T' ;check for 'st'
bne varok
beq gobadv
qst003
cpy #'R' ;check for 'er'
beq gobadv
cpy #'L' ;check for 'el'
bne varok
gobadv
jmp snerr



notevl
lda varnam
ldy varnam+1
cmp #'T' ;screen out 'ti',
beq qst001
cmp #'S' ;...and 'st',
beq qst002
cmp #'E' ;...and er and el,
beq qst003
cmp #'D' ;...and ds.
beq qst004
varok
lda arytab
ldy arytab+1
sta lowtr
sty lowtr+1
lda strend
ldy strend+1
sta hightr
sty hightr+1
clc
adc #6+addprc
bcc noteve
iny
noteve
sta highds
sty highds+1
jsr bltu
lda highds
ldy highds+1
iny
sta arytab
sty arytab+1


; scan thru array entries, looking for string arrays. if any
; are found, it will be necessary to adjust the back-links
; on the strings in that array, since the array descriptor
; block itself was moved

sta arypnt ;set pointer to arrays
sty arypnt+1
aryva2
lda arypnt
ldx arypnt+1
aryva3
cpx strend+1 ;end of arrays ?
bne aryvgo
cmp strend
bne aryvgo
beq arydon ;always..finished

aryvgo
sta index1
stx index1+1
ldy #1-addprc
jsr indin1 ;look at array name
tax
iny
jsr indin1 ;name 2nd char
php ;save status reg
iny
jsr indin1 ;point to offset to next array
adc arypnt
sta arypnt ;save start of next array in arypnt
iny
jsr indin1
adc arypnt+1
sta arypnt+1
plp ;restore status
bpl aryva2 ;not a string type
txa
bmi aryva2 ;not a string array
iny ;ok we have a string array
jsr indin1 ;get number of dimensions
ldy #0
asl a ;move index to ptr to 1st string (add 2*number of dims + 5)
adc #5
adc index1
sta index1
bcc aryget
inc index1+1

aryget
ldx index1+1
cpx arypnt+1 ;done with this array?
bne gogo
cmp arypnt
beq aryva3 ;yes
gogo
ldy #0 ;process string pointer
jsr indin1 ;get length of string
beq dvarts ;skip if null string
sta syntmp
iny
jsr indin1 ;get lo byte of string ptr
clc
adc syntmp ;and add string length
sta hightr
iny
jsr indin1 ;get hi byte of string ptr
adc #0 ;adjust high byte
sta hightr+1

; test for strings in basic text was removed-
; in ted all strings are copied to string area!
;
; fix backwards pointer by adding
; move length to it

ldy #0
jsr indhtr ;lda (hightr),y
adc #6+addprc ;carry clear (careful!)
sta (hightr),y
iny
jsr indhtr ;lda (hightr),y
adc #0
sta (hightr),y ;done with this string
;
; fix the next string in the array
;
dvarts
lda #strsiz
clc
adc index1
sta index1
bcc aryget
inc index1+1
bne aryget ;branch always

arydon
ldy #0
lda varnam
sta (lowtr),y
iny ;.y=1
lda varnam+1
sta (lowtr),y
lda #0
arydo1
iny
sta (lowtr),y
cpy #6
bne arydo1

finptr
lda lowtr
clc
adc #2
ldy lowtr+1
bcc finnow
iny
finnow
sta varpnt
sty varpnt+1
rts


fmaptr
lda count
asl a
adc #5
adc lowtr
ldy lowtr+1
bcc jsrgm
iny
jsrgm
sta arypnt
sty arypnt+1
rts

;end

+ 194
- 0
BASIC_TED/code12.src View File

@@ -0,0 +1,194 @@
.page
.subttl 'code12'
n32768 .byte 144,128,0,0,0

flpint
jsr ayint
lda facmo
ldy faclo
rts

intidx
jsr chrget
jsr frmevl
posint
jsr chknum
lda facsgn
bmi nonono
ayint
lda facexp
cmp #144
bcc qintgo
lda #<n32768
ldy #>n32768
jsr fcomp
nonono
bne qintgo
jmp fcerr

qintgo
jmp qint



isary
lda dimflg
ora intflg
pha
lda valtyp
pha
ldy #0

indlop tya
pha
lda varnam+1
pha
lda varnam
pha
jsr intidx
pla
sta varnam
pla
sta varnam+1
pla
tay
tsx
lda 258,x
pha
lda 257,x
pha
lda indice
sta 258,x
lda indice+1
sta 257,x
iny ;y counts # of subscripts
sty count ;protect y from chrget
jsr chrgot
ldy count
cmp #',' ;more subscripts?
beq indlop

jsr chkcls
pla
sta valtyp
pla
sta intflg
and #$7f
sta dimflg
ldx arytab
lda arytab+1
lopfda
stx lowtr
sta lowtr+1
cmp strend+1
bne lopfdv
cpx strend
beq notfdd
lopfdv
ldy #0
jsr indlow
iny
cmp varnam
bne nmary1
jsr indlow
sta syntmp
lda varnam+1
cmp syntmp
beq gotary
nmary1
iny
jsr indlow
clc
adc lowtr
tax
iny
jsr indlow
adc lowtr+1
bcc lopfda
bserr ldx #errbs
.byte $2c

fcerr ldx #errfc
errgo3 jmp error



gotary
ldx #errdd
lda dimflg
bne errgo3
jsr fmaptr
ldy #4
jsr indlow
sta syntmp
lda count
cmp syntmp
bne bserr
jmp getdef



notfdd
jsr fmaptr
jsr reason
ldy #0
sty curtol+1
ldx #5
lda varnam
sta (lowtr),y
bpl notflt
dex
notflt
iny
lda varnam+1
sta (lowtr),y
bpl stomlt
dex
dex
stomlt
stx curtol
lda count
iny
iny
iny
sta (lowtr),y
loppta
ldx #11
lda #0
bit dimflg
bvc notdim
pla
clc
adc #1
tax
pla
adc #0
notdim
iny
sta (lowtr),y
iny
txa
sta (lowtr),y
jsr umult
stx curtol
sta curtol+1
ldy index
dec count
bne loppta
adc arypnt+1
bcs omerr1
sta arypnt+1
tay
txa
adc arypnt
bcc grease
iny
beq omerr1
grease
jsr reason
sta strend
sty strend+1
lda #0
inc curtol+1

;.end

+ 313
- 0
BASIC_TED/code13.src View File

@@ -0,0 +1,313 @@
.page
.subttl 'code13'
ldy curtol
beq deccur
zerita
dey
sta (arypnt),y
bne zerita
deccur
dec arypnt+1
dec curtol+1
bne zerita
inc arypnt+1
sec
lda strend
sbc lowtr
ldy #2
sta (lowtr),y
lda strend+1
iny
sbc lowtr+1
sta (lowtr),y
lda dimflg
bne dimrts
iny
getdef
jsr indlow
sta count
lda #0
sta curtol
inlpnm
sta curtol+1
iny
pla
tax
sta indice
jsr indlow
sta syntmp
pla
sta indice+1
cmp syntmp
bcc inlpn2
bne bserr7
iny
jsr indlow
sta syntmp
cpx syntmp
bcc inlpn1

bserr7 jmp bserr

omerr1 jmp omerr

inlpn2
iny
inlpn1 lda curtol+1
ora curtol
clc
beq addind
jsr umult
txa
adc indice
tax
tya
ldy index1
addind
adc indice+1
stx curtol
dec count
bne inlpnm
sta curtol+1
ldx #5
lda varnam
bpl notfl1
dex
notfl1
lda varnam+1
bpl stoml1
dex
dex
stoml1
stx addend
lda #0
jsr umultd
txa
adc arypnt
sta varpnt
tya
adc arypnt+1
sta varpnt+1
tay
lda varpnt
dimrts rts



umult
sty index
jsr indlow
sta addend
dey
jsr indlow
umultd
sta addend+1
lda #16
sta deccnt
ldx #0
ldy #0
umultc
txa
asl a
tax
tya
rol a
tay
bcs omerr1
asl curtol
rol curtol+1
bcc umlcnt
clc
txa
adc addend
tax
tya
adc addend+1
tay
bcs omerr1
umlcnt
dec deccnt
bne umultc
rts



fre
lda valtyp
beq nofref
jsr frefac
nofref
jsr garba2
sec
lda fretop
sbc strend
tay
lda fretop+1
sbc strend+1 ;fall through to nosflt!



nosflt ;float an unsigned double byte integer
;entry: msb in a, lsb in y
jsr stoint
sec ;sign is positive
jmp floatc



pos
sec
jsr jplot ;get tab pos in .y
sngflt
lda #0
jmp givayf



errdir
bit runmod ;direct mode?
bmi dimrts ;no
ldx #errid
.byte $2c
errguf
ldx #erruf
jmp error



stoint ;move int to fac & compute proper exponents
ldx #0
stx valtyp
sta facho
sty facho+1
ldx #$90
rts


; simple user defined function code
;
; note only single arguments are allowed to functions,
; and functions must be of the single line form:
; def fna(x)=x~2 + x-2
; no strings may be involved with these functions.
;
; idea: create a simple variable entry whose first
; character has the msb set.
; the value will be:
; a text pointer to the formula
; a pointer to the argument variable

def
jsr getfnm ;get a pointer to the function
jsr errdir
jsr chkopn ;must have a (
lda #$80 ;prohibit subscripted variables
sta subflg
jsr ptrget ;get pointer to argument
jsr chknum ;is it a number?
jsr chkcls ;must have )
lda #equltk ;followed by =
jsr synchr
pha
lda varpnt+1
pha
lda varpnt
pha
lda txtptr+1
pha
lda txtptr
pha
jsr data
jmp deffin



; subroutine to get a pointer to a function name
;
getfnm
lda #fntk ;must start with fn
jsr synchr
ora #$80 ;put function bit on
sta subflg
jsr ptrgt2 ;get pointer to function or create anew
sta defpnt
sty defpnt+1
jmp chknum ;make sure it's not a string, and return



fndoer
jsr getfnm ;get the function's name
lda defpnt+1
pha
lda defpnt
pha
jsr parchk ;evaluate parameter
jsr chknum
pla
sta defpnt
pla
sta defpnt+1
ldy #2
jsr inddef ;get pointer to the variable
sta varpnt
tax
iny
jsr inddef
beq errguf
sta varpnt+1
iny
defstf
jsr indvar
pha ;push it all on the stack, since we might be recursing
dey
bpl defstf
ldy varpnt+1
jsr movmf ;put current fac into our argument variable
lda txtptr+1 ;save variable pointer
pha
lda txtptr
pha
jsr inddef ;get pointer to function
sta txtptr
iny
jsr inddef
sta txtptr+1
lda varpnt+1 ;save variable pointer
pha
lda varpnt
pha
jsr frmnum ;evaluate variable, and check numeric
pla
sta defpnt
pla
sta defpnt+1
jsr chrgot
beq *+5
jmp snerr ;it didn't terminate, syntax error

pla ;restore text pointer
sta txtptr
pla
sta txtptr+1
deffin
ldy #0
pla ;get old arg value off stack,
sta (defpnt),y ;and put it back in variable
pla
iny
sta (defpnt),y
pla
iny
sta (defpnt),y
pla
iny
sta (defpnt),y
pla
iny
sta (defpnt),y
rts

;.end

+ 149
- 0
BASIC_TED/code15.src View File

@@ -0,0 +1,149 @@
.page
.subttl 'code15'
;
; strini gets string space for the creation of a string,
; and creates a descriptor for it in dsctmp
;
strini
ldx facmo ;get facmo to store in dscpnt
ldy facmo+1
stx dscpnt ;retain the descriptor pointer
sty dscpnt+1
strspa
jsr getspa ;get string space
stx dsctmp+1 ;save location
sty dsctmp+2
sta dsctmp ;save length
rts ;done



; the str function takes a number and gives a string with
; the characters the output of the number would have given.
;
strd
jsr chknum ;arg has to be numeric
ldy #0
jsr foutc ;do it's output
pla
pla
timstr
lda #<lofbuf
ldy #>lofbuf ;fall thru to strlit



; strlt2 takes the string literal whose first character is pointed
; to by (xreg)+1 and builds a descriptor for it. the descriptor is
; initially built in 'dsctmp', but 'putnew' transfers it into a
; temporary, and leaves a pointer at the temporary in facmo & lo.
; the characters other than zero that terminates the string
; should be set up in 'charac' and 'endchr'. if the terminator
; is a quote, the quote is skipped over. leading quotes should
; be skipped before jsr. on return, the character after the string
; literal is pointed to by (strng2).

strlit
ldx #'"' ;assume string ends on quote
stx charac
stx endchr
strlt2
sta strng1 ;save pointer to string
sty strng1+1
sta dsctmp+1 ;in case no strcpy
sty dsctmp+2
ldy #255 ;initialize character count
strget
iny
jsr indst1
beq strfi1
cmp charac
beq strfin
cmp endchr
bne strget
strfin
cmp #'"'
beq strfi2
strfi1
clc
strfi2
sty dsctmp
tya
adc strng1
sta strng2
ldx strng1+1
bcc strst2
inx
strst2
stx strng2+1
tya
jsr strini
ldx strng1
ldy strng1+1
jsr movstr

putnew
ldx temppt
cpx #tempst+strsiz+strsiz+strsiz
bne putnw1
ldx #errst
jmp error

putnw1
lda dsctmp
sta 0,x
lda dsctmp+1
sta 1,x
lda dsctmp+2
sta 2,x
ldy #0
stx facmo
sty facmo+1
sty facov
dey
sty valtyp
stx lastpt
inx
inx
inx
stx temppt
rts



cat
lda faclo
pha
lda facmo
pha
jsr eval
jsr chkstr
pla
sta strng1
pla
sta strng1+1
ldy #0
jsr indst1
sta syntmp
jsr indfmo
clc
adc syntmp
bcc sizeok
jmp errlen



sizeok
jsr strini
jsr movins
lda dscpnt
ldy dscpnt+1
jsr fretmp
jsr movdo
lda strng1
ldy strng1+1
jsr fretmp
jsr putnew
jmp tstop

;.end

+ 267
- 0
BASIC_TED/code16.src View File

@@ -0,0 +1,267 @@
.page
.subttl 'code16'
movins
ldy #0
jsr indst1
pha
iny
jsr indst1
tax
iny
jsr indst1
tay
pla
movstr
stx index
sty index+1
movdo
tay
beq mvdone
pha
movlp
dey
jsr indin1
sta (frespc),y
tya
bne movlp
pla
mvdone
clc
adc frespc
sta frespc
bcc mvstrt
inc frespc+1
mvstrt
rts

frmstr
jsr frmevl
frestr
jsr chkstr
frefac
lda facmo
ldy facmo+1
fretmp
sta index
sty index+1
jsr fretms ;check desc. if last
bne fre02 ;one then scratch it
jsr stradj ;index points to link
bcc fre02 ;literal no fix
dey ;.y=1
lda #$ff ;flag string as garbage
sta (index),y
dey
txa
sta (index),y ;put in length
pha ;save length on stack
eor #$ff ;put index back
sec ;to first byte
adc index
ldy index+1
bcs res00
dey
res00
sta index
sty index+1
tax ;lo into x
pla ;pull length from stack
cpy fretop+1 ;test for eq to fretop
bne frerts
cpx fretop
bne frerts
; string was last into string space
; save garbage collection some time
; by freeing up. (length + 2)
pha ;save length on stack
sec ;plus one
adc fretop
sta fretop
bcc fre01
inc fretop+1
fre01
inc fretop ;+ one more
bne frepla
inc fretop+1
frepla
pla ;pull length off stack
rts

fre02
ldy #0 ;set up x,y,a and index
jsr indin1 ;length
pha ;on stack
iny
jsr indin1 ;pointer lo
tax
iny
jsr indin1 ;pointer hi
tay
stx index
sty index+1
pla ;get back length
rts



fretms
cpy lastpt+1
bne frerts
cmp lastpt
bne frerts
sta temppt
sbc #strsiz
sta lastpt
ldy #0
frerts rts



chrd
jsr conint
txa
pha
lda #1
jsr strspa
pla
ldy #0
sta (dsctmp+1),y
chrd1
pla
pla
jmp putnew



leftd
jsr pream
pha
jsr inddpt
sta syntmp
pla
cmp syntmp
tya
rleft