urflibs/urasm/asm-test.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; Z80 Assembler: main module
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 $INCLUDE-ONCE <../zxdisasm>
  10
  11 asm-emit:init-memory
  12
  13 :noname  ( addr -- byte )
  14   0xffff and asm-emit:zx-mem + c@
  15 ; to zxdis:(zx-c@)
  16
  17
  18 : disasm  ( -- )
  19   0 asm-emit:find-used " no code" ?not-error
  20   to zxdis:pc
  21   begin
  22     zxdis:pc asm-emit:.hex4 ." : "
  23     zxdis:disasm-one  ( addr count )
  24     xtype cr
  25     zxdis:pc asm-emit:used?
  26   not-until
  27 ;
  28
  29
  30
  31
  32 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;; DEFFMT: ignore for now
  34 ;;
  35
  36 also asm-lexer
  37 also-defs: asm-instr
  38
  39 : DEFFMT  ( -- )
  40   next-token tok-type tk-id <> " identifier expected" ?error
  41   next-token
  42 ;
  43
  44 previous prev-defs
  45
  46
  47 also asm-lexer
  48
  49 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50 ;; lexer test
  51 ;;
  52
  53 : test  ( -- )
  54   \ " AYMute.zas" false false (include)
  55   \ " cls_ei.zas" false false (include)
  56   argc " assemble what?" ?not-error
  57   0 argv false false (include)
  58   true to line-start
  59   begin
  60     begin
  61       next-token tok-type tk-eos =
  62     while
  63       ." *** NEWLINE ***\n"
  64       refill-nocross ifnot ." EOF!\n" exit endif
  65       true to line-start
  66       ." <"
  67       (tib-in) 0 begin dup tib-peekch-ofs while 1+ repeat xtype ." >" cr
  68     repeat
  69     ." TOKEN: type="
  70     tok-type case
  71       tk-eos of ." <EOS>\n" endof
  72       tk-id  of ." <ID>; str=<" token xtype ." >\n" endof
  73       tk-num of ." <NUM>; num=" tok-num . ." str=<" token xtype ." >\n" endof
  74       tk-str of ." <STR>; str=<" token xtype ." >\n" endof
  75       tk-punct of ." <PUNCT>; num=" tok-num . ." str=<" token xtype ." >\n" endof
  76       tk-label of ." <LABEL>; str=<" token xtype ." >\n" endof
  77       tk-mnemo of ." <MNEMO>; str=<" token xtype ." > cfa=" tok-mnemo-cfa 0 .r cr endof
  78       tk-resw of ." <RES-WORD>; str=<" token xtype ." > uo=" tok-uo . ." kind=" tok-kind 0 .r cr endof
  79       otherwise . " wutafuck?" error
  80     endcase
  81     depth " unbalanced stack" ?error
  82   again
  83 ;
  84
  85
  86 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87 ;; simple test assembler
  88 ;;
  89
  90 : assemble-simple  ( -- )
  91   \ " AYMute.zas" false false (include)
  92   \ " cls_ei.zas" false false (include)
  93   argc " assemble what?" ?not-error
  94   0 argv false false (include)
  95   true to line-start next-token
  96   begin
  97     begin
  98       tok-type tk-eos =
  99     while
 100       ." *** NEWLINE ***\n"
 101       refill-nocross ifnot ." EOF!\n" exit endif
 102       true to line-start
 103       ." <"
 104       (tib-in) 0 begin dup tib-peekch-ofs while 1+ repeat xtype ." >" cr
 105       true to line-start next-token
 106     repeat
 107     \ ." TOKEN: type="
 108     asm-emit:instruction-start
 109  \ debug:backtrace
 110     tok-type case
 111       tk-eos of ." <EOS>\n" endof
 112       \ tk-id  of ." <ID>; str=<" token xtype ." >\n" endof
 113       \ tk-num of ." <NUM>; num=" tok-num . ." str=<" token xtype ." >\n" endof
 114       \ tk-str of ." <STR>; str=<" token xtype ." >\n" endof
 115       tk-punct of
 116           token-colon? ifnot
 117             ." <PUNCT>; num=" tok-num . ." str=<" token xtype ." >\n"
 118             abort
 119           endif
 120           next-token
 121         endof
 122       tk-label of
 123           ." <LABEL>; str=<" token xtype ." >\n"
 124           token string:>pad next-token pad count
 125           token-equ? if asm-equ
 126           else token-=? if asm-ass
 127           else asm-emit:pc-$ asm-labels:define-code
 128           endif endif
 129         endof
 130       tk-mnemo of
 131           \ ." <MNEMO>; str=<" token xtype ." > cfa=" tok-mnemo-cfa 0 .r cr
 132           tok-mnemo-cfa execute
 133           token-colon-eol? " end of instruction expected" ?not-error
 134         endof
 135       otherwise . " wutafuck?" error
 136     endcase
 137     depth " ASSEMBLER: unbalanced stack" ?error
 138   again
 139 ;
 140
 141 previous
 142
 143
 144 : RUN-URASM  ( -- )
 145   $IF $TEST-PARSER
 146     test
 147   $ELSE
 148     assemble-simple
 149     disasm
 150     (*
 151     " zxsnap.sna" files:create " cannot create output .SNA" ?not-error
 152     dup asm-writers:write-sna-48
 153     files:close drop
 154     *)
 155     0 argv asm-writers:write-raw
 156   $ENDIF
 157 ;