Initial checkin of tracer and 6502 assembler fth files as copied from converted disk image vforth4_3.fth

6502/C64/src/6502asm.fth

@@ -0,0 +1,222 @@
+\ *** Block No. 5, Hexblock 5
+
+\ Forth-6502 Assembler        clv10oct87
+
+\ Basis: Forth Dimensions VOL III No. 5)
+
+Onlyforth  Assembler also definitions
+
+1 7  +thru
+ -3  +load \ Makros: rom ram sys
+
+Onlyforth
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ Forth-83 6502-Assembler      20oct87re
+
+: end-code   context 2- @  context ! ;
+
+Create index
+$0909 , $1505 , $0115 , $8011 ,
+$8009 , $1D0D , $8019 , $8080 ,
+$0080 , $1404 , $8014 , $8080 ,
+$8080 , $1C0C , $801C , $2C80 ,
+
+| Variable mode
+
+: Mode:  ( n -)   Create c,
+  Does>  ( -)     c@ mode ! ;
+
+0   Mode: .A        1    Mode: #
+2 | Mode: mem       3    Mode: ,X
+4   Mode: ,Y        5    Mode: X)
+6   Mode: )Y       $F    Mode: )
+
+
+
+
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+\ upmode  cpu                  20oct87re
+
+| : upmode ( addr0 f0 - addr1 f1)
+ IF mode @  8 or mode !   THEN
+ 1 mode @  $F and ?dup IF
+ 0 DO  dup +  LOOP THEN
+ over 1+ @ and 0= ;
+
+: cpu  ( 8b -)   Create  c,
+  Does>  ( -)    c@ c, mem ;
+
+ 00 cpu brk $18 cpu clc $D8 cpu cld
+$58 cpu cli $B8 cpu clv $CA cpu dex
+$88 cpu dey $E8 cpu inx $C8 cpu iny
+$EA cpu nop $48 cpu pha $08 cpu php
+$68 cpu pla $28 cpu plp $40 cpu rti
+$60 cpu rts $38 cpu sec $F8 cpu sed
+$78 cpu sei $AA cpu tax $A8 cpu tay
+$BA cpu tsx $8A cpu txa $9A cpu txs
+$98 cpu tya
+
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ m/cpu                        20oct87re
+
+: m/cpu  ( mode opcode -)  Create c, ,
+ Does>
+ dup 1+ @ $80 and IF $10 mode +! THEN
+ over $FF00 and upmode upmode
+ IF mem true Abort" invalid" THEN
+ c@ mode @ index + c@ + c, mode @ 7 and
+ IF mode @  $F and 7 <
+  IF c, ELSE , THEN THEN mem ;
+
+$1C6E $60 m/cpu adc $1C6E $20 m/cpu and
+$1C6E $C0 m/cpu cmp $1C6E $40 m/cpu eor
+$1C6E $A0 m/cpu lda $1C6E $00 m/cpu ora
+$1C6E $E0 m/cpu sbc $1C6C $80 m/cpu sta
+$0D0D $01 m/cpu asl $0C0C $C1 m/cpu dec
+$0C0C $E1 m/cpu inc $0D0D $41 m/cpu lsr
+$0D0D $21 m/cpu rol $0D0D $61 m/cpu ror
+$0414 $81 m/cpu stx $0486 $E0 m/cpu cpx
+$0486 $C0 m/cpu cpy $1496 $A2 m/cpu ldx
+$0C8E $A0 m/cpu ldy $048C $80 m/cpu sty
+$0480 $14 m/cpu jsr $8480 $40 m/cpu jmp
+$0484 $20 m/cpu bit
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ Assembler conditionals       20oct87re
+
+| : range?   ( branch -- branch )
+ dup abs  $7F u> Abort" out of range " ;
+
+: [[  ( BEGIN)  here ;
+
+: ?]  ( UNTIL)  c, here 1+ - range? c, ;
+
+: ?[  ( IF)     c,  here 0 c, ;
+
+: ?[[ ( WHILE)  ?[ swap ;
+
+: ]?  ( THEN)   here over c@  IF swap !
+ ELSE over 1+ - range? swap c! THEN ;
+
+: ][  ( ELSE)   here 1+   1 jmp
+ swap here over 1+ - range?  swap c! ;
+
+: ]]  ( AGAIN)  jmp ;
+
+: ]]? ( REPEAT) jmp ]? ;
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ Assembler conditionals       20oct87re
+
+$90 Constant CS     $B0 Constant CC
+$D0 Constant 0=     $F0 Constant 0<>
+$10 Constant 0<     $30 Constant 0>=
+$50 Constant VS     $70 Constant VC
+
+: not    $20 [ Forth ] xor ;
+
+: beq    0<> ?] ;   : bmi   0>= ?] ;
+: bne    0=  ?] ;   : bpl   0<  ?] ;
+: bcc    CS  ?] ;   : bvc   VS  ?] ;
+: bcs    CC  ?] ;   : bvs   VC  ?] ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+\ 2inc/2dec   winc/wdec        20oct87re
+
+: 2inc  ( adr -- )
+ dup lda  clc  2 # adc
+ dup sta  CS ?[  swap 1+ inc  ]?  ;
+
+: 2dec  ( adr -- )
+ dup lda  sec  2 # sbc
+ dup sta  CC ?[  swap 1+ dec  ]?  ;
+
+: winc  ( adr -- )
+ dup inc  0= ?[  swap 1+ inc  ]?  ;
+
+: wdec  ( adr -- )
+ dup lda  0= ?[  over 1+ dec  ]?  dec  ;
+
+: ;c:
+ recover jsr  end-code ]  0 last !  0 ;
+
+
+
+
+
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ ;code Code code>          bp/re03feb85
+
+Onlyforth
+
+: Assembler
+ Assembler   [ Assembler ] mem ;
+
+: ;Code
+ [compile] Does>  -3 allot
+ [compile] ;      -2 allot   Assembler ;
+immediate
+
+: Code  Create here dup 2- ! Assembler ;
+
+: >label  ( adr -)
+ here | Create  immediate  swap ,
+ 4 hallot heap 1 and hallot ( 6502-alig)
+ here 4 - heap  4  cmove
+ heap last @ count $1F and + !  dp !
+  Does>  ( - adr)   @
+  state @ IF  [compile] Literal  THEN ;
+
+: Label
+ [ Assembler ]  here >label Assembler ;

6502/C64/src/rom-ram-sys.fth

@@ -0,0 +1,51 @@
+\ *** Block No. 2, Hexblock 2
+
+\ rom ram sys                 cas16aug06
+\              Shadow with Ctrl+W--->
+
+\ needed for jumps
+\ in the ROM Area
+
+Assembler also definitions
+(16 \ Switch Bank 8000-FFFF
+: rom here 9 + $8000 u> abort" not here"
+       $ff3e sta ;
+: ram  $ff3f sta ;
+: sys rom jsr ram ;
+\  if suffering from abort" not here"
+\  see next screen Screen --> C)
+
+
+(64 \ Switch Bank A000-BFFF
+: rom here 9 + $A000 u> abort" not here"
+      $37 # lda 1 sta ;
+: ram $36 # lda 1 sta ;
+C)
+
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ sysMacro Long               cas16aug06
+
+(64  .( not for C64 !) \\ C)
+
+\ for advanced users, use macros
+
+here $8000 $20 - u> ?exit \ not possible
+
+
+' 0 | Alias ???
+
+Label long   ROM
+Label long1  ??? jsr  RAM  rts end-code
+
+| : sysMacro ( adr -- )
+ $100 u/mod  pha  # lda  long1 2+ sta
+ # lda  long1 1+ sta  pla  long jsr ;
+
+: sys ( adr -- ) \ for Jsr to ROM
+ here 9 + $8000 u>
+ IF  sysMacro  ELSE  sys  THEN ;

6502/C64/src/tracer.fth

@@ -0,0 +1,244 @@
+\ *** Block No. 47, Hexblock 2f
+
+\ tracer: loadscreen          cas16aug06
+
+Onlyforth
+
+\needs Code -$2B +load \ Trans Assembler
+
+\needs Tools   Vocabulary Tools
+
+Tools also definitions
+
+   1 6  +thru  \ Tracer
+   7 8  +thru  \ Tools for decompiling
+
+Onlyforth
+
+\\
+
+This nice Forth Tracer has been
+developed by B. Pennemann and co
+for Atari ST. CL Vogt has ported it
+back to the volksForth 6502 C-16 and
+C-64
+
+
+
+
+\ *** Block No. 48, Hexblock 30
+
+\ tracer: wcmp variables      clv04aug87
+
+Assembler also definitions
+
+: wcmp ( adr1 adr2--) \ Assembler-Macro
+ over lda dup cmp swap  \ compares word
+ 1+   lda 1+  sbc ;
+
+
+Only Forth also Tools also definitions
+
+| Variable (W
+| Variable <ip      | Variable ip>
+| Variable nest?    | Variable trap?
+| Variable last'    | Variable #spaces
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 49, Hexblock 31
+
+\ tracer:cpush oneline        cas16aug06
+
+| Create cpull    0  ]
+ rp@ count 2dup + rp! r> swap cmove ;
+
+: cpush  ( addr len -)
+ r> -rot   over  >r
+ rp@ over 1+ - dup rp!  place
+ cpull >r  >r ;
+
+| : oneline  &82 allot keyboard display
+ .status  space  query  interpret
+ -&82 allot  rdrop
+ ( delete quit from tnext )  ;
+
+: range ( adr--) \ gets <ip ip>
+ ip> off  dup <ip !
+ BEGIN 1+ dup @
+   [ Forth ] ['] unnest = UNTIL
+ 3+ ip> ! ;
+
+
+
+
+
+
+\ *** Block No. 50, Hexblock 32
+
+\ tracer:step tnext           clv04aug87
+
+| Code step
+ $ff # lda trap? sta trap? 1+ sta
+           RP X) lda  IP sta
+ RP )Y lda  IP 1+ sta  RP 2inc
+ (W lda  W sta   (W 1+ lda   W 1+ sta
+Label W1-  W 1- jmp  end-code
+
+| Create: nextstep step ;
+
+Label  tnext IP 2inc
+ trap? lda  W1- beq
+ nest? lda 0=  \ low(!)Byte test
+ ?[ IP <ip wcmp W1- bcc
+    IP ip> wcmp W1- bcs
+ ][ nest? stx  \ low(!)Byte clear
+ ]?
+  trap? dup stx 1+ stx \ disable tracer
+  W lda  (W sta    W 1+ lda   (W 1+ sta
+
+
+
+
+
+
+\ *** Block No. 51, Hexblock 33
+
+\ tracer:..tnext              clv12oct87
+
+ ;c: nest? @
+ IF nest? off r> ip> push <ip push
+    dup 2- range
+    #spaces push 1 #spaces +! >r THEN
+ r@  nextstep >r
+ input push    output push
+ 2- dup last' !
+ cr #spaces @ spaces
+ dup 4 u.r @ dup 5 u.r space
+ >name .name  $10 col - 0 max spaces .s
+ state push  blk push  >in push
+ [ ' 'quit      >body ] Literal  push
+ [ ' >interpret >body ] Literal  push
+ #tib push  tib #tib @ cpush  r0 push
+ rp@ r0 !
+ ['] oneline Is 'quit  quit ;
+
+
+
+
+
+
+
+
+\ *** Block No. 52, Hexblock 34
+
+\ tracer:do-trace traceable   cas16aug06
+
+| Code do-trace \ installs TNEXT
+ tnext 0 $100 m/mod
+     # lda  Next $c + sta
+     # lda  Next $b + sta
+ $4C # lda  Next $a + sta  Next jmp
+end-code
+
+| : traceable ( cfa--<IP ) recursive
+ dup @
+ ['] :    @ case? IF >body     exit THEN
+ ['] key  @ case? IF >body c@ Input  @ +
+                   @ traceable exit THEN
+ ['] type @ case? IF >body c@ Output @ +
+                   @ traceable exit THEN
+ ['] r/w  @ case? IF >body
+                   @ traceable exit THEN
+ @  [ ' Forth @ @ ] Literal =
+                  IF @ 3 + exit THEN
+ \ for defining words with DOES>
+ >name .name ." can't be DEBUGged"
+ quit ;
+
+
+
+\ *** Block No. 53, Hexblock 35
+
+\ tracer:User-Words           cas16aug06
+
+: nest   \ trace into current word
+ last' @ @ traceable drop nest? on ;
+
+: unnest \ proceeds at calling word
+ <ip on ip> off ; \ clears trap range
+
+: endloop last' @ 4 + <ip ! ;
+\ no trace of next word to skip LOOP..
+
+' end-trace Alias unbug \ cont. execut.
+
+: (debug  ( cfa-- )
+ traceable range
+ nest? off trap? on #spaces off
+ Tools do-trace ;
+
+Forth definitions
+
+: debug  ' (debug ; \ word follows
+
+: trace'            \ word follows
+ ' dup (debug execute end-trace ;
+
+
+\ *** Block No. 54, Hexblock 36
+
+\ tools for decompiling,      clv12oct87
+
+( interactive use                      )
+
+Onlyforth Tools also definitions
+
+| : ?:  ?cr dup 4 u.r ." :"  ;
+| : @?  dup @ 6 u.r ;
+| : c?  dup c@ 3 .r ;
+| : bl  $24 col - 0 max spaces ;
+
+: s  ( adr - adr+)
+ ( print literal string)
+ ?:  space c? 4 spaces dup count type
+ dup c@ + 1+ bl  ;  ( count + re)
+
+: n  ( adr - adr+2)
+ ( print name of next word by its cfa)
+ ?: @? 2 spaces
+ dup @ >name .name 2+ bl ;
+
+: k  ( adr - adr+2)
+ ( print literal value)
+ ?: @? 2+ bl ;
+
+
+\ *** Block No. 55, Hexblock 37
+
+( tools for decompiling, interactive   )
+
+: d  ( adr n - adr+n) ( dump n bytes)
+ 2dup swap ?: 3 spaces  swap 0
+ DO  c? 1+ LOOP
+ 4 spaces -rot type bl ;
+
+: c  ( adr - adr+1)
+ ( print byte as unsigned value)
+ 1 d ;
+
+: b  ( adr - adr+2)
+ ( print branch target location )
+ ?: @? dup @  over + 6 u.r 2+ bl  ;
+
+( used for : )
+( Name String Literal Dump Clit Branch )
+( -    -      -       -    -    -      )

6502/C64/src/trns6502asm.fth

@@ -0,0 +1,15 @@
+\ *** Block No. 4, Hexblock 4
+
+\ transient Assembler         clv10oct87
+
+\ Basis: Forth Dimensions VOL III No. 5)
+
+\ internal loading         04may85BP/re)
+
+here   $800 hallot  heap dp !
+
+         1  +load
+
+dp !
+
+Onlyforth