urflibs/urasm/ext/macro.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; Z80 Assembler: Forth macros
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (*
  10 usage:
  11
  12 $FORTH
  13 macro: xte_rstack_put_imm16  ( -- )
  14   mc-arg-count 1 <> " one argument expected" ?error
  15   mc" ld (hl),low($0)"
  16   mc" inc hl"
  17   mc" ld (hl),high($0)"
  18   mc" inc hl"
  19 ;
  20 $END
  21
  22 xte_rstack_put_imm16 0x29a
  23
  24 it is ok to use "EXIT" in macro word (but not other return stack tricks).
  25 *)
  26
  27
  28 vocabulary asm-macro-helpers
  29 also-defs: asm-macro-helpers
  30
  31
  32 define-accessors marg
  33   def: start
  34   def: end
  35 end-accessors
  36
  37 0 value (mac-argv)  ;; header, then margs
  38 0 value (mac-argc)  ;; argument count
  39 0 value (mc-buffer) ;; string buffer
  40
  41 ;; at exit, token is comma or eol
  42 : (skip-arg)  ( -- )
  43   0  ;; current paren level
  44   begin token-eol? not-while
  45     case
  46       token-`,`? if-of
  47           dup ifnot break endif
  48         endof
  49       token-`(`? if-of 1+ endof
  50       token-`[`? if-of 1+ endof
  51       token-`)`? if-of 1- 0 max endof
  52       token-`]`? if-of 1- 0 max endof
  53       token-`:`? if-of " macro cannot be combined with other instructions" error endof
  54       otherwise  ;; suppress "DROP"
  55     endcase
  56   next-token repeat drop
  57 ;
  58
  59 ;; build arglist
  60 ;; token is at the first arg
  61 : (build-args)  ( -- )
  62   forth:(max-handle-ofs) 1+ 0 handle:new-alloc to (mc-buffer)
  63   0 to (mac-argc)
  64   forth:(max-handle-ofs) 1+ 0 handle:new-alloc
  65   dup to (mac-argv)
  66   a>r >a
  67   begin token-eol? not-while
  68     (mac-argc) dup 255 >= " too many macro arguments" ?error
  69     1+ to (mac-argc)
  70     (tok->in) >in ! parse-skip-blanks next-token
  71     tib @ (tok->in) + !+4>a  ;; start
  72     (skip-arg)
  73     tib @ (tok->in) + !+4>a  ;; end
  74     token-eol? ifnot expect-`,` endif
  75   repeat r>a
  76 ;
  77
  78 : (free-args)  ( -- )
  79   (mac-argv) dup " FREE-ARGS without BUILD-ARGS" ?not-error
  80   handle:free 0 to (mac-argv)
  81   (mc-buffer) handle:free 0 to (mc-buffer)
  82 ;
  83
  84 : mc-arg-count  ( -- count )
  85   (mac-argv) " call BUILD-ARGS first" ?not-error
  86   (mac-argc)
  87 ;
  88 alias mc-arg-count arg#
  89
  90 : mc-arg-str  ( idx -- addr count )
  91   (mac-argv) " call BUILD-ARGS first" ?not-error
  92   dup 0 (mac-argc) within " invalid argument index" ?not-error
  93   marg-size * (mac-argv) +
  94   dup marg->start@ swap marg->end@ over -
  95 ;
  96 alias mc-arg-str arg@
  97
  98
  99 : mc-start  ( -- )
 100   0 (mc-buffer) handle:used!
 101 ;
 102
 103 : mc+char  ( ch -- )
 104   (mc-buffer) " MACRO-START is not called" ?not-error
 105   (mc-buffer) handle:used@
 106   dup (mc-buffer) handle:size@ cell- u>= " macro string too long" ?error
 107   swap over (mc-buffer) + c!
 108   1+ (mc-buffer) handle:used!
 109 ;
 110
 111 : mc+str  ( addr count -- )
 112   (mc-buffer) " MACRO-START is not called" ?not-error
 113   dup 0< " invalid macro string" ?error
 114   ?dup if
 115     (mc-buffer) handle:used@ over +
 116     0 (mc-buffer) handle:size@ cell- within " macro string too long" ?not-error
 117     dup >r  ;; save counter
 118     (mc-buffer) dup handle:used@ + swap cmove
 119     (mc-buffer) handle:used@ r> + (mc-buffer) handle:used!
 120   else drop endif
 121 ;
 122
 123 : mc+arg  ( aidx -- )
 124   mc-arg-str mc+str
 125 ;
 126
 127 : mc-compile  ( -- )
 128   (mc-buffer) " MACRO-START is not called" ?not-error
 129   0 (mc-buffer) dup handle:used@ + c!
 130   (mc-buffer) tib ! >in 0!
 131   $IF 0
 132     ." <" (tib-in) 0 begin dup tib-peekch-ofs while 1+ repeat xtype ." >" cr
 133   $ENDIF
 134   next-token do-assemble-line
 135 ;
 136
 137 : mc-compile-str  ( addr count -- )
 138   mc-start mc+str mc-compile
 139 ;
 140
 141 ;; A is string address
 142 : (mc-parse-number)  ( count -- num count )
 143   >r 0 begin r@ while c@a 10 string:digit while swap 10 U* + +1>a r> 1- >r repeat
 144   dup 0< " numeric overflow" ?error
 145   r>
 146 ;
 147
 148 ;; A is string address, at '['
 149 : (mc-char-indexed)  ( idx count -- count )
 150   +1>a 1-
 151   c@a 10 string:digit? " number expected" ?not-error
 152   (mc-parse-number)  ( idx str-idx count )
 153   dup 0<= " `]` expected" ?error
 154   c@a [char] ] <> " `]` expected" ?error
 155   +1>a 1-
 156   >r >r
 157   mc-arg-str r@ <= " invalid string index" ?error
 158   r> + c@ mc+char
 159   r>
 160 ;
 161
 162 ;; A is string address
 163 : (mc-indexed)  ( idx count -- )
 164   dup if c@a [char] [ = if (mc-char-indexed) exit endif endif
 165   swap mc-arg-str mc+str
 166 ;
 167
 168 : (mc-")  ( addr count -- )
 169   dup if
 170     mc-start swap a>r >a
 171     begin ( count ) dup +while
 172       c@+1>a dup [char] $ <> if mc+char 1-
 173       else drop c@a 10 string:digit? if (mc-parse-number) (mc-indexed)
 174       else [char] $ mc+char 1-
 175       endif endif
 176     repeat drop r>a
 177     mc-compile
 178   else 2drop endif
 179 ;
 180
 181 ;; compile asm string
 182 ;; use "%idx" for arg substitution
 183 : mc"  ( -- )  ;; "
 184   compiler:?comp
 185   34 parse " string expected" ?not-error
 186   strliteral compile (mc-")
 187 ; immediate
 188
 189
 190 : label@  ( addr count -- value )
 191   2dup asm-labels:get ifnot
 192     endcr space ." label '" xtype ." ' not defined" cr
 193     " label not defined" error
 194   else nrot 2drop endif
 195 ;
 196
 197 : eval-const  ( addr count -- value )
 198   mc-start mc+str
 199   0 (mc-buffer) dup handle:used@ + c!
 200   (mc-buffer) tib ! >in 0!
 201   $IF 0
 202     ." <" (tib-in) 0 begin dup tib-peekch-ofs while 1+ repeat xtype ." >" cr
 203   $ENDIF
 204   next-token asm-expr:expression-const
 205 ;
 206
 207 : eval-arg  ( idx -- value )
 208   mc-arg-str eval-const
 209 ;
 210
 211 prev-defs
 212
 213
 214 vocabulary (asm-in-macro)
 215 also-defs: (asm-in-macro)
 216
 217 0 value saved-current
 218
 219 : ;  -- end macro definition
 220   compiler:?comp compiler:(ctlid-colon) 2- compiler:?pairs
 221   saved-current " wut?!" ?not-error
 222   compiler:(ctlid-colon) [compile] ;
 223   previous previous previous saved-current current !
 224   0 to saved-current
 225 ; immediate
 226
 227 prev-defs
 228
 229
 230 also-defs: forth
 231
 232 : MACRO:  ( -- )  \ name
 233   parse-name dup " macro name expected" ?not-error
 234   (asm-in-macro):saved-current " already defining a macro" ?error
 235   current @ to (asm-in-macro):saved-current
 236   vocid: asm-instr current !
 237   \ compiler:(create-forth-header)
 238   (create)
 239   also asm-lexer
 240   also asm-macro-helpers
 241   also (asm-in-macro)
 242   compiler:(ctlid-colon) 2- [compile] ]
 243  does>  ( pfa )
 244   tib @ >r >in @ >r
 245   asm-lexer:next-token  ;; skip macro name
 246   asm-macro-helpers:(mac-argv) >r
 247   asm-macro-helpers:(mac-argc) >r
 248   asm-macro-helpers:(mc-buffer) >r
 249   asm-macro-helpers:(build-args)
 250   forth:(forth-call)
 251   asm-macro-helpers:(free-args)
 252   r> to asm-macro-helpers:(mc-buffer)
 253   r> to asm-macro-helpers:(mac-argc)
 254   r> to asm-macro-helpers:(mac-argv)
 255   \ r> >in ! r> tib ! next-token  ;; restore last token
 256   r> >in ! r> tib ! parse-skip-line next-token
 257 ;
 258
 259 prev-defs