-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathforth.asm
1578 lines (1552 loc) · 36.7 KB
/
forth.asm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
* vim: syn=asm6809 noexpandtab ts=8
* title micro forth 1.0
*
* micro forth 1.0
*
* this is a small fast implementation of a forth language for
* the motorola 6809 microprocessor. it is unique in that there is
* no interpreter, all words are directly executable.
*
* copyright 1984-2005 dave dunfield
* all rights reserved.
*
* system equates
*
osram equ $8000
sysram equ $8030
width equ 65 terminal screen width margin
rstack equ sysram+254 return stack
dstack equ sysram+510 data stack
aciasr equ $e100
aciadr equ $e101
* the Mirage has IRQ handlers and stuff at the start
org osram beginning of forth code
* system variables used by ROM
fdccmd fcb 0 store FDC command byte
fdcrtry fcb $09 FDC retries
fdctrak fcb $0b FDC track
fdcsect fcb $05 FDC sector
fdcldad fdb $0000 used for OS loader address?
fdcstat fcb $00 fdc status
fdcerr fcb $00 error message for ROM routine
* jump table, IRQs point to this
irqj jmp irqhandler
firqj jmp firqhandler
osj jmp start
sysvars equ *
lstlok fdb 0
temp fdb 0
inpbuf equ *
*lstlok equ sysvars pointer to last word processed from input buffer
*temp equ lstlok+2 temporary storage
*inpbuf equ temp+2 input buffer
* the Mirage OS saves parameters from $8011 to $802e
org sysram+$230 top of data stack
*** set up FIRQ handler, runopsys configured the UART for us
serialinit
orcc #$55 disable interrupts
ldx #aciabuffer
stx aciain
stx aciaout buffer is empty
clra
serial_loop1
sta ,x+ zero out 16 bytes
cmpx #aciain
bne serial_loop1
lda #$95 ACIA control = RX interrupt, 8n1, no TX interrupt
sta aciasr
rts
*** test if a character is available
serialchr
pshs x
ldx aciain
cmpx aciaout
puls x
rts
*** get a character from buffer
serialget
pshs x
ldx aciaout
ldb ,x+
cmpx #aciain
bne serialgetend
ldx #aciabuffer
serialgetend
stx aciaout
puls x
rts
serialput
pshs a
serialput1
lda aciasr
bita #$02 transmit flag?
beq serialput1
stb aciadr
puls a
rts
irqhandler
rti dummy routine
firqhandler
pshs a,x save registers
lda #$07
sta $e201
ldx aciain input pointer
lda aciasr get ACIA status
bita #$80 IRQ fired?
beq firqend no, must have been an error but we don't care
lda aciadr get the data from the ACIA
sta ,x+ save and nudge the pointer
cmpx #aciain ran off end?
bne firqend
ldx #aciabuffer
firqend
stx aciain save pointer
puls x,a restore
rti
aciabuffer
fcb 00,00,00,00,00,00,00,00,00,00,00,00,00,00,00,00
aciain fdb aciabuffer
aciaout fdb aciabuffer
* initializations, start up forth
start
lda #$0
lds #rstack set up return stack
ldu #dstack set up data stack
lda #$18 turn off LEDs
sta $e201
lda #$7f
sta $e20e disable VIA interrupts
jsr serialinit
andcc #$bf enable interrupt
ldx #strtmsg point to startup message
lbsr pmsg1 display it
jsr [boot+3] execute preset routine (usually 'quit')
lbra bye exit forth
* subroutine to obtain variables address on stack.
* used by 'variable' type words
variab ldx ,s++ get following address
pshu x save
rts return to caller
* messages
prompt fcb $0a,$0d new line
fccz 'ok>' ; prompt
ermsg1
fccz /error: '/ ;error prefix
ermsg2
fccz /' / ;error suffix
redmsg
fccz 'redef: ' ;re-definition indicator
delmsg fcb 8,32,8,0 bug when using strings?
strtmsg
fcb $0d,$0a
fcc "Mirage micro forth"
fcb $0d,$0a,0
ledval fdb 0
ledctr fdb 0
ledctr1 fdb 0
*
* start of user dictionary
* dictionary format:
* 1) - word descriptor byte, format:
* bit 7 - always set, indicates this is descriptor byte
* bits 7-3 - currently not used
* bit 2 - no-compile bit, word cannot be used in compiles
* bit 1 - no-interactive bit, word cannot be used interactively
* bit 0 - execute on compile bit, compiler executes word immediatly
* instead of compiling into definition
* 2) - word name, variable length, stored backwards
* 3) - address of previous word in dictionary, address must point to first
* byte of code which immediatly follows this field in the word
*
*
* 'dropn' - drops a number of words from the stack
fcb $80
fcc 'npord'
fdb 0 ** end of dictionary **
dropn ldd ,u++ get operand
aslb multiply by
rola two for word stack entries
leau d,u move user stack
rts
* 'drop' - drop one word from the stack
fcb $80
fcc 'pord'
fdb dropn
drop leau 2,u move stack pointer
rts
* 'dup' - duplicate top of stack
fcb $80
fcc 'pud'
fdb drop
dup ldd ,u get top of user stack
std ,--u duplicate
rts
* 'over' duplicate one down from top of stack
fcb $80
fcc 'revo'
fdb dup
over ldd 2,u get element
std ,--u duplicate
rts
* 'rot' - rotate top three elements on stack
fcb $80
fcc 'tor'
fdb over
rot ldd 4,u get bottom
ldx 2,u get middle
stx 4,u put on bottom
bra swap1 do rest
* 'swap' - swap top two elements on stack
fcb $80
fcc 'paws'
fdb rot
swap ldd 2,u get lower one
swap1 ldx ,u get top
stx 2,u place top at lower
std ,u place lower at top
rts
* '0=' - test for tos equal to zero
fcb $80
fcc '=0'
fdb swap
zequ ldd ,u get top of stack
beq ret1 equal to zero?
bra ret0 no, return one
* '=' - test for equality
fcb $80
fcc '='
fdb zequ
equals ldd ,u++ get top of stack
cmpd ,u compare with next
beq ret1 same, return 1
bra ret0 no, return zero
* '<>' - test for not equal
fcb $80
fcc '><'
fdb equals
notequ ldd ,u++ get tos
cmpd ,u compare with next
beq ret0 not same, return 1
bra ret1 no, return 0
* '>' - test for greater
fcb $80
fcc '>'
fdb notequ
grtr ldd 2,u get lower element
cmpd ,u++ compare with tos
bgt ret1 greater, return 1
bra ret0 no, return false
* '<' - test for less
fcb $80
fcc '<'
fdb grtr
less ldd 2,u get lower element
cmpd ,u++ compare with tos
blt ret1 lower, return 1
bra ret0 no, return false
* '>=' - test for greater or equal to
fcb $80
fcc '=>'
fdb less
grequ ldd 2,u get lower
cmpd ,u++ compare with tos
blt ret0 less, return false
ret1 ldb #1 get one
bra rets return it
* '<=' - test for less or equal to
fcb $80
fcc '=<'
fdb grequ
lesequ ldd 2,u get lower
cmpd ,u++ compare with tos
ble ret1 lower or equal, return one
ret0 clrb get zero result
rets clra zero high byte
std ,u save on stack
rts
* '$out' - output character to terminal
fcb $80
fcc 'tuo$'
fdb lesequ
dolout
ldb #$f1
jsr serialput
ldd ,u++ get char from stack
andb #$7f mask top bit
jsr serialput
rts
* '$in' - input character from terminal
fcb $80
fcc 'ni$'
fdb dolout
dolin jsr serialchr
bne dolin1
dolin0
inc ledctr
bne dolin
inc ledctr1
lda ledctr1
cmpa #$0a
bne dolin
clr ledctr1
lda ledval
inca
cmpa #$6
bne dolin2
clra
dolin2 sta ledval
ora #$08
sta $e201
bra dolin
dolin1
jsr serialget
cmpb #$f1
bne dolin
dolin9
jsr serialchr
beq dolin9
jsr serialget
clra
std ,--u save on stack
rts
* 'emit' - output character to general output
fcb $80
fcc 'time'
fdb dolin
emit jmp [disp+3] execute output routine in '(out)' variable
* 'key' - get character from general input
fcb $80
fcc 'yek'
fdb emit
key jmp [inpt+3] execute input routine in '(in)' variable
* 'u.' - output unsigned number in current base
fcb $80
fcc '.u'
fdb key
udot bra dot01 execute number output routine
* '.' - output signed number in current base
fcb $80
fcc '.'
fdb udot
dot ldd ,u get number from stack
bpl dot01 is positive, its ok
ldb #'-' get minus sign
pshu a,b save on stack
jsr emit output minus sign
jsr neg negate number
dot01 lda #$ff end if stream indicator
pshs a save marker on return stack
dot1 ldd base+3 get number base from 'base' variable
pshu a,b save base
jsr usmod perform division
pulu a,b get remainder
pshs b save for later
ldd ,u get result
bne dot1 if more, keep going
leau 2,u skip last result on stack
dot2 ldb ,s+ get character from stack
lbmi space end of digits, output space and exit
addb #$30 convert to decimal number
cmpb #$39 in range?
bls dot3 yes, its ok
addb #7 convert to alpha
dot3 pshu a,b save on stack
bsr emit output character
bra dot2 keep outputing
* '-!' - subtract from self and reassign
fcb $80
fcc '!-'
fdb dot
mstor ldx ,u++ get address
ldd ,x get contents
subd ,u++ subtract tos
std ,x resave contents
rts
* '+!' - add to self and reassign
fcb $80
fcc '!+'
fdb mstor
pstor ldx ,u++ get address
ldd ,x get contents
addd ,u++ add is tos
std ,x resave contents
rts
* 'c!' - character (byte) store operation
fcb $80
fcc '!c'
fdb pstor
vstorc ldx ,u++ get address
ldd ,u++ get data from stack
stb ,x save in variable
rts
* '!' - word store operation
fcb $80
fcc '!'
fdb vstorc
vstor ldx ,u++ get address
ldd ,u++ get data
std ,x perform store
rts
* 'c@' - character read operation
fcb $80
fcc '@c'
fdb vstor
vreadc ldb [,u] get character from address
clra zero high byte
bra savsd move to stack
* '@' - word read operation
fcb $80
fcc '@'
fdb vreadc
vread ldd [,u] get word from address
bra savsd place on stack
* '2/' - divide by two
fcb $80
fcc '/2'
fdb vread
shr lsr ,u shift high
ror 1,u shift low
rts
* '2*' - multiply by two
fcb $80
fcc '*2'
fdb shr
shl lsl 1,u shift low
rol ,u shift high
rts
* '+' - add operator
fcb $80
fcc '+'
fdb shl
add ldd ,u++ get tos
addd ,u add in next
bra savsd place result on stack
* '-' - subtract operator
fcb $80
fcc '-'
fdb add
sub ldd 2,u get lower operand
subd ,u++ subtract tos
savsd std ,u place result on stack
rts
* 'd-' double precision subtraction
fcb $80
fcc '-d'
fdb sub
dminus ldd 6,u get low word of lower operand
subd 2,u subtract low word off higher operand
std 6,u resave lower word of operand
ldd 4,u get high word of lower operand
sbcb 1,u subtract top of stack
sbcb ,u with borrow from previous
leau 4,u fix up stack
std ,u place high word of result on stack
rts
* 'd+' - double precision addition
fcb $80
fcc '+d'
fdb dminus
dplus ldd 2,u get low word of first operand
addd 6,u add low word of second operand
std 6,u resave
ldd ,u get high word of first
adcb 5,u add in high word of
adca 4,u second with carry
leau 4,u fix up stack
std ,u resave
rts
* 'u*' - unsigned multiply
fcb $80
fcc '*u'
fdb dplus
umult lda 1,u
ldb 3,u
mul
pshs a,b
lda ,u
ldb 2,u
mul
pshs a,b
lda 1,u
ldb 2,u
mul
addd 1,s
bcc umul1
inc ,s
umul1 std 1,s
lda ,u
ldb 3,u
mul
addd 1,s
bcc umul2
inc ,s
umul2 std 1,s
puls d,x
std ,u
stx 2,u
rts
* '*' - signed multiply
fcb $80
fcc '*'
fdb umult
mult lda 1,u
ldb 3,u
mul
pshs a,b
lda ,u
ldb 3,u
mul
addb ,s
stb ,s
lda 1,u
ldb 2,u
mul
addb ,s
stb ,s
puls d
leau 2,u
std ,u
rts
* 'm/mod' - division with remainder
fcb $80
fcc 'dom/m'
fdb mult
msmod clra
clrb
ldx #33
msmodl andcc #$fe
msmodm rol 5,u
rol 4,u
rol 3,u
rol 2,u
leax -1,x
beq msmodd
rolb
rola
cmpd ,u
blo msmodl
subd ,u
orcc #1
bra msmodm
msmodd std ,u
rts
* 'u/mod' - unsigned division with remainder
fcb $80
fcc 'dom/u'
fdb msmod
usmod ldd ,u++
clr ,-u
clr ,-u
std ,--u
jsr msmod
ldd ,u++
std ,u
rts
* '/mod' - division giving remainder
fcb $80
fcc 'dom/'
fdb usmod
slmod lda 2,u
pshs a
bpl slmod2
clra
clrb
subd 2,u
std 2,u
lda ,s
slmod2 eora ,u
pshs a
ldd ,u
beq slmodr
bpl slmod1
coma
comb
addd #1
std ,u
slmod1 clra
clrb
ldx #17
slmodl andcc #$fe
slmodm rol 3,u
rol 2,u
leax -1,x
beq slmodd
rolb
rola
cmpd ,u
blo slmodl
subd ,u
orcc #1
bra slmodm
slmodd tst 1,s
bpl slmod3
coma
comb
addd #1
slmod3 std ,u
tst ,s++
bpl slmodr
clra
clrb
subd 2,u
std 2,u
slmodr rts
* '/' - division
fcb $80
fcc '/'
fdb slmod
slash bsr slmod
leau 2,u
rts
* 'and' - logical and
fcb $80
fcc 'dna'
fdb slash
and ldd ,u++ get top of stack
anda ,u and high byte
andb 1,u and low byte
bra savds save result and exit
* 'or' - logical or
fcb $80
fcc 'ro'
fdb and
or ldd ,u++ get top of stack
ora ,u or high byte
orb 1,u or low byte
bra savds save result and exit
* 'xor' - logcal exclusive or
fcb $80
fcc 'rox'
fdb or
xor ldd ,u++ get top of stack
eora ,u xor high byte
eorb 1,u xor low byte
bra savds save result and exit
* 'com' - complement operand
fcb $80
fcc 'moc'
fdb xor
com com ,u complement high byte
com 1,u complement low byte
rts
* 'neg' - negate operand
fcb $80
fcc 'gen'
fdb com
neg bsr com complement operand
bra onep increment (two's complement)
* 'abs' - give absolute value of operand
fcb $80
fcc 'sba'
fdb neg
abs ldd ,u get value from stack
bmi neg negative, convert
rts
* '2-' - decrement by two
fcb $80
fcc '-2'
fdb abs
twom ldd ,u get top of stack
subd #2 decrement by two
savds std ,u resave top of stack
rts
* '2+' - increment by two
fcb $80
fcc '+2'
fdb twom
twop ldd ,u get top of stack
addd #2 increment by two
bra savds resave top of stack
* '1-' - decrement by one
fcb $80
fcc '-1'
fdb twop
onem ldd ,u get top of stack
subd #1 decrement by one
bra savds resave top of stack
* '1+' - increment by one
fcb $80
fcc '+1'
fdb onem
onep ldd ,u get top of stack
addd #1 increment by one
bra savds resave top of stack
* 'skip' - advance input pointer to non-blank
fcb $80
fcc 'piks'
fdb onep
qskip ldy inptr+3 get current position in input buffer
qski1 lda ,y+ get character from input buffer
cmpa #' ' is it a space
beq qski1 yes, keep going
leay -1,y backup to it
sty inptr+3 resave input pointer
tsta test for end of line
rts
*
* subroutine to lookup words in dictionary from input line
* on exit: 'z' is set if word not found
* if word is found ('z'=0), its address is stacked on the
* data stack, and the word descriptor byte is returned in
* the 'a' accumulator
*
lookup pshs x,y save registers
bsr qskip advance to word
sty lstlok save incase error
ldx here+3 get start of dictionary
* scan dictionary, looking for word
lok1 pshs x save current address
leax -2,x backup past preceding address
lok2 lda ,-x get character from name
bmi lok3 decreiptor byte, start of word
cmpa ,y+ does it match input buffer?
beq lok2 yes, keep matching till end of word
lok5 puls x restore pointer
ldx ,--x get address of previous word
beq lok4 end of dictionary, quit
ldy inptr+3 restore input pointer
bra lok1 try for this word
lok3 ldb ,y get net char from input stream
bsr tsterm is it a terminator?
bne lok5 no, word does not match
puls a,b restore address of word
std ,--u save on stack
bsr qski1 skip to next non-blank
lda ,x get descriptor byte
andcc #$fb clear 'z' flag
lok4 puls x,y,pc
* routine to test for terminator character
tsterm cmpb #' ' is it a space?
beq tster1 yes, its ok
tstb is it null (end of line)?
tster1 rts
* ''' - tick: return address of a word
fcb $81
fcc /'/
fdb qskip
tick bsr lookup look up word
bne tster1 found, return
lbra lokerr word not found, cause error
fcb $80
fcc 'cexe'
fdb tick
exec jmp [,u++] execute at address on [tos]
* 'number' - get number from input stream in current base
fdb $80
fcc 'rebmun'
fdb exec
number pshs x,y save regs
lbsr qskip advance to next word in input stream
cmpa #'-' is it a negative number?
pshs cc save flags fo later test
bne num4 no, not negative
leay 1,y skip '-' sign
num4 clra start off
clrb with a zero result
pshu a,b save on stack
num2 ldb ,y+ get char from souce
subb #'0' convert to binary
cmpb #9 is it numeric digit?
bls num1 yes, its ok
andb #$df smash case
subb #7 convert from alpha
cmpb #$0a is it a valid number?
blo num3 no, cause error
num1 clra zero high byte
cmpd base+3 are we within range of current base
bhs num3 no, cause error
pshs a,b save number
ldd base+3 get base
pshu a,b stack
jsr mult perform multiply (old value already on data stack)
puls a,b get new digit back
addd ,u add to old value
std ,u resave old value
ldb ,y get next character from number
lbsr tsterm is it a terminator
bne num2 no, keep evaluating number
sty inptr+3 resave input pointer
puls cc,x,y restore registers
bne num5 no negative, don't negate
jsr neg negate value
num5 lbra one return true (success)
num3 puls cc,x,y clean up stack
lbra zero return false (failure)
* 'space' - display a space on general output
fcb $80
fcc 'ecaps'
fdb number
space ldb #' ' get a space
pshu a,b placeon data stack
jmp emit output
* 'cr' - display carriage-return, line-feed on general output
fcb $80
fcc 'rc'
fdb space
cr ldd #$0d get carriage return
pshu a,b place on stack
jsr emit output to general output
ldb #$0a get line-feed
pshu a,b place on stack
jmp emit output to general output
* 'read' - read a line from input device
fcb $80
fcc 'daer'
fdb cr
read bsr cr new line
readnc ldy #inpbuf point to input buffer
read1 jsr key get a key
cmpb #$0d is it carriage return?
beq rdcrlf yes, exit
cmpb #$0a is it newline?
beq rdcrlf
cmpb #$08 is it backspace?
beq rdbksp
cmpb #$7f is it delete?
beq rdbksp
* normal key
stb ,y+ save key in buffer
jsr emit echo key
bra read1 go back for another
* delete key, delete previous character
rdbksp leau 2,u remove keycode from stack
leay -1,y backup up input buffer pointer
cmpy #inpbuf past beginning?
blo read if so, re-initiate read
ldx #delmsg point to delete message
bsr pmsg1 display
bra read1 go back for next key
* carriage return, terminate input
rdcrlf leau 2,u remove keycode from stack
clr ,y indicate end of input line
ldy #inpbuf point to input buffer
sty inptr+3 set up input buffer pointer
pmsg2 rts
* '.msg' - display message, address on stack
fcb $80
fcc 'gsm.'
fdb read
pmsg ldx ,u++ get address
pmsg1 ldb ,x+ get character from message
beq pmsg2 end of message, exit
pshu a,b save on stack
jsr emit output to general output
bra pmsg1 get next character
* '.wrd' - display a word on general output (string)
fcb $80
fcc 'drw.'
fdb pmsg
pwrd ldx ,u++ get address of word
pwrd1 ldb ,x+ get character from word
lbsr tsterm is it a terminator?
beq pmsg2 yes, quit
pshu a,b save data on stack
jsr emit output to general output
bra pwrd1 get next word
* 'quit - general command interpreter, used to terminate words
fcb $80
fcc 'tiuq'
fdb pwrd
quit jsr rpfix reset return stack
ldx #prompt point to prompt
bsr pmsg1 display prompt
lbsr readnc read a line of input
jsr space seperate by a space
qui1 jsr qskip adance to non-blank
beq quit null line, do nothing
jsr lookup look up word
beq qui2 not found, try number
bita #$02 ok to execute interactivly?
bne conerr no, force error
jsr [,u++] execute word
andcc #$bf FIXME EVIL HACK nmi routine comes back with FIRQ disabled
cmpu #dstack did stack underflow?
bls qui1 no, keep interpreting
bsr error generate error message
fccz 'stack empty'
* not a word, try for number
qui2 jsr number try for number
ldd ,u++ get flag byte
beq lokerr not a number. indicate not found
bra qui1 keep interpreting
* subroutine to generate error message, first displays 'error:' message,
* then name of last word processed, then error message text
error ldx #ermsg1 ; get pointer to error message prefix
bsr pmsg1 display prefix
ldx lstlok get address of last word from input buffer
bsr pwrd1 display word
ldx #ermsg2 ; point to error message suffix
bsr pmsg1 display suffix
ldx ,s++ get address of error message
bsr pmsg1 display message
jsr spfix reset data stack
bra quit and enter command intrepreter
* word was not found in the dictionary
lokerr bsr error generate error message
fccz 'not found'
* word can not be executed interactively
conerr bsr error generate error message
fccz 'cannot execute'
* '>r' - move word from data to return stack
fcb $80
fcc 'r>'
fdb quit
tor ldx ,s get return address
ldd ,u++ get data from data stack
std ,s place on return stack
tfr x,pc return to caller
* '<r' - move word from return stack to data stack
fcb $80
fcc 'r<'
fdb tor
fromr ldx ,s++ get return address
ldd ,s++ get data from return stack
std ,--u place on data stack
tfr x,pc return to caller
* 'rp!' - reset return stack
fcb $80
fcc '!pr'
fdb fromr
rpfix puls a,b get return address
lds #rstack reset return stack
tfr d,pc return to caller
* 'sp!' - reset data stack
fcb $80
fcc '!ps'
fdb rpfix
spfix ldu #dstack reset data stack
voc9 rts
* ''s' - obtain stack address
fcb $80
fcc /s'/
fdb spfix
tics stu ,--u save data stack pointer
rts
* 'vlist' - display words in dictionary
fcb $80
fcc 'tsilv'
fdb tics
voc ldx here+3 get address of start of dictionary
voc1 jsr cr new line
clra zero character count
voc2 pshs a,x save count, current position
leax -2,x backup to word name
voc3 ldb ,-x get character from word name
bmi voc4 descriptor byte, end of name
pshu a,b save on data stack
jsr emit output to general output
inc ,s increment character count
bra voc3 keep outputing
voc4 jsr space seperate with a space
puls a,x restore character count, position in dictionary
inca advance character count for space
ldx ,--x get address of next word
beq voc9 end of dictionary, exit
cmpa #width are we beyond terminal width?
blo voc2 no, its ok
bra voc1 continue on new line
* 'bye' - exit forth
fcb $80
fcc 'eyb'
fdb voc
bye nop
* gjcp - fixme ssr
* ssr 22 new line
* ssr 0 exit to system
jsr cr
lda #$00
swi
* 'forget' - remove one or more words from dictionary
fcb $80
fcc 'tegrof'
fdb bye
forget jsr tick locate words address
pulu x get address
cmpx #usrspc is it in kernal dictionary?
blo proerr if so, can't be forgotton
ldd ,--x get address of previous word
std here+3 new dictionary start
forg1 lda ,-x get character from name
bpl forg1 keep going till we find descriptor byte
stx free+3 new free space for dictionary
rts
* word is protected, can't 'forget' it
proerr lbsr error generate error message
fccz 'protected'
* 'create' - create new word in dictionary
fdb $80
fcc 'etaerc'
fdb forget
create ldy inptr+3 get input buffer position