urflibs/urasm/labels.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; Z80 Assembler: label manager
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (*
  10   we'll do one pass, so we need to record info for all forward references.
  11   we could as well record *each* label reference to create cross-ref reports.
  12   so let's do it.
  13 *)
  14
  15
  16 vocab-if-none (asm-labels)
  17
  18 vocab-if-none asm-labels
  19 also-defs: asm-labels
  20
  21
  22 0 value fix-pc
  23 0 value fix-disp
  24 0 value fix-value
  25
  26 0 value postpone-expr-list
  27
  28 // record: prev, expr-cfa, fixer-cfa, fix-disp, fix-addr
  29 : remember-expr  ( fix-addr fix-disp fixer-cfa expr-cfa -- )
  30   \ ." *** new postponed expression!" cr
  31   here >r
  32   postpone-expr-list forth:, forth:, forth:, forth:, forth:,
  33   r> to postpone-expr-list
  34 ;
  35
  36
  37 defer (eval-expr-cfa)  ( cfa -- res TRUE / error-code FALSE )
  38 defer (err-undefined?)  ( error -- bool )
  39 defer (err-message)  ( error -- addr count )
  40
  41 ;; if set, we are resolving "@@"
  42 ;; in this calse, "get" should return current "@@" value instead of failing
  43 false value resolve-nameless
  44
  45 // record: prev, expr-cfa, fixer-cfa, fix-disp, fix-addr
  46 : resolve-exprs  ( -- )
  47   ['] postpone-expr-list cfa->pfa >r
  48   postpone-expr-list  ( curr | prev )
  49   begin ?dup while
  50     dup cell+ @ (eval-expr-cfa) if
  51       ;; patch the code
  52       to fix-value
  53       dup 3 +cells @ to fix-disp
  54       dup 4 +cells @ to fix-pc
  55       dup 2 +cells @execute
  56       ;; remove this expression it was succesfully resolved
  57       @ dup r@ !
  58       \ ." *** LABEL FIXUP!" cr
  59     else
  60       dup (err-undefined?) if drop
  61       else (err-message) error
  62       endif
  63       rdrop dup >r @
  64     endif
  65   repeat rdrop
  66   false to resolve-nameless
  67 ;
  68
  69
  70 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71 ;; label types
  72 enum{
  73   def: ltype-unknown  ;; this label was used, but not defined yet
  74   def: ltype-var      ;; "= value" label, variable
  75   def: ltype-equ      ;; "equ value" label, constant
  76   def: ltype-code     ;; code label
  77   def: ltype-data     ;; data label
  78 }
  79
  80
  81 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82 ;; file info, to avoid allocating file name for each line
  83 oof:class: FileInfo
  84   FileInfo obj-value: next
  85   field: fname  ;; handle to file name string
  86   field: id
  87
  88   method: init-append  ( -- )
  89   method: name-str ( -- addr count )
  90 end-class
  91
  92 FileInfo oof:obj-value file-info-head
  93
  94 FileInfo oof:method: init-append  ( -- )
  95   0 (include-file-id) to id
  96   0 (include-file-name)
  97   0 handle:new-init to fname
  98   oof:value-of: file-info-head to next
  99   self to file-info-head
 100 ;
 101
 102 FileInfo oof:method: name-str ( -- addr count )
 103   fname dup handle:size@
 104 ;
 105
 106
 107 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 108 ;; file reference: info and line
 109 oof:class: FileRef
 110   FileInfo obj-value: file  ;; reference file
 111   field: line               ;; reference file line
 112
 113   method: init ( -- )  \ defined way below ;-)
 114   method: name-str ( -- addr count )
 115   method: print ( -- )
 116 end-class
 117
 118
 119 FileRef oof:method: name-str ( -- addr count )
 120   file name-str
 121 ;
 122
 123 ;; print file and line
 124 FileRef oof:method: print ( -- )
 125   name-str xtype [char] : emit
 126   line <# #S #> xtype
 127 ;
 128
 129
 130 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131 ;; main label record
 132 oof:class: Label
 133   0 obj-value: info-head    ;; LabelRef
 134   field: nfa                ;; word nfa, to get a name
 135   field: type               ;; see above
 136   field: value              ;; label value
 137   FileRef obj-value: set-at ;; last initialised at
 138
 139   method: init  ( nfa -- )
 140   method: type!  ( type -- )
 141   method: value!  ( value -- )
 142   method: defined-here  ( -- )
 143   method: new-ref  ( -- )  \ defined way below ;-)
 144   method: info-head@  ( -- info-head )
 145   method: set-at@  ( -- set-at )
 146   method: name  ( -- addr count )
 147 end-class
 148
 149 Label oof:method: init ( nfa -- )  to nfa ltype-unknown to type ;
 150 Label oof:method: type!  ( type -- )  to type ;
 151 Label oof:method: value!  ( value -- )  to value ;
 152 Label oof:method: defined-here  ( -- )  FileRef oof:allot to set-at  set-at init ;
 153 Label oof:method: info-head@  ( -- )  -> info-head @ ;
 154 Label oof:method: set-at@  ( -- )  -> set-at @ ;
 155 Label oof:method: name  ( -- addr count )  nfa id-count ;
 156
 157
 158 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159 ;; each label reference will be recorded
 160 ;; it is used both to create reference file, and to show
 161 ;; diagnostics on undefined labels
 162 oof:class: LabelRef
 163   LabelRef obj-value: prev ;; next info struct addr, or 0
 164   Label obj-value: owner   ;; owner of this struct
 165   field: zx-pc$            ;; pc$ from asm-emit
 166   field: zx-pc             ;; pc from asm-emit
 167   field: zx-emit-pc        ;; disp from asm-emit
 168   FileRef obj-value: ref   ;; file reference
 169
 170   method: init  ( owner prev -- )
 171   method: prev@  ( -- prev )
 172   method: ref@  ( -- ref )
 173 end-class
 174
 175 LabelRef oof:method: init  ( owner prev -- )
 176   to prev to owner
 177   FileRef oof:allot to ref
 178   ref init
 179   asm-emit:pc$ to zx-pc$
 180   asm-emit:pc to zx-pc
 181   asm-emit:emit-pc to zx-emit-pc
 182 ;
 183
 184 LabelRef oof:method: prev@  ( -- prev )  -> prev @ ;
 185 LabelRef oof:method: ref@  ( -- ref )  -> ref @ ;
 186
 187
 188 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 189 LabelRef Label oof:bind-field: info-head
 190
 191 ;; now we can define the method
 192 Label oof:method: new-ref  ( -- )
 193   LabelRef oof:allot >r
 194   self -> info-head @ r@ oof:invoke: LabelRef init
 195   r> to info-head
 196 ;
 197
 198
 199 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 200 ;; return FileInfo for the current source file
 201 ;; will reuse an existing one, or create a new one if required
 202 : curr-file-info  ( -- FileInfo )
 203   oof:value-of: file-info-head
 204   begin
 205     ?dup
 206   while
 207     dup oof:invoke: FileInfo id  0 (include-file-id) = if exit endif
 208     oof:invoke: FileInfo next
 209   repeat
 210   ;; not found, want a new struct
 211   FileInfo oof:allot oof:invoke: FileInfo init-append
 212   oof:value-of: file-info-head
 213 ;
 214
 215
 216 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 217 ;; and finally, we can define this method
 218 FileRef oof:method: init  ( -- )
 219   curr-file-info to file
 220   0 (include-file-line) to line
 221 ;
 222
 223
 224 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 225 ;; some globals
 226
 227 ;; last "@@"/"$$" label value
 228 -1 value last-f/b-label
 229
 230 ;; local labels (starting with dot) will be prefixed with this one
 231 Label oof:obj-value global-prefix
 232
 233
 234 create temp-name-buf 256 cell+ allot create;
 235
 236 : >temp-buf  ( addr count -- )
 237   dup 1 255 within " label name too long" ?not-error
 238   dup temp-name-buf ! temp-name-buf cell+ swap move
 239 ;
 240
 241 : temp-buf+cc  ( addr count -- )
 242   dup 1 255 within " label name too long" ?not-error
 243   dup temp-name-buf @ + dup 1 255 within " label name too long" ?not-error
 244   >r temp-name-buf count + swap move
 245   r> temp-name-buf !
 246 ;
 247
 248 : temp-buf-cc@  ( -- addr count )
 249   temp-name-buf count
 250 ;
 251
 252
 253 ;; "@@" or "$$"?
 254 : f/b-label?  ( addr count -- bool )
 255   2 = if
 256     w@ dup [ [char] @ dup 8 lsh or ] imm-literal =
 257     swap [ [char] $ dup 8 lsh or ] imm-literal = or
 258   else drop false endif
 259 ;
 260
 261 ;; "@f", "$f", "@b", "$b"?
 262 ;; 0: nope; -1: back; 1: forward
 263 : fref-label?  ( addr count -- flag )
 264   2 = if
 265     dup c@ dup [char] @ = swap [char] $ = or if
 266       1+ c@ string:char-upper case
 267         [char] B of -1 endof
 268         [char] F of 1 endof
 269         otherwise drop 0
 270       endcase
 271     else drop 0 endif
 272   else drop 0 endif
 273 ;
 274
 275 : fref-f/b-label?  ( addr count -- bool )
 276   2dup f/b-label? nrot fref-label? logor
 277 ;
 278
 279 : fix-prefix  ( addr count -- addr count )
 280   dup " empty label name, wtf?" ?not-error
 281   2dup fref-f/b-label? ifnot
 282     over c@ case
 283       [char] . of  ;; local label (starts with a dot)
 284           oof:value-of: global-prefix " local label without a global" ?not-error
 285           global-prefix name >temp-buf temp-buf+cc temp-buf-cc@
 286         endof
 287       [char] @ of  ;; "@" means "do not reset global prefix
 288           string:/char
 289           dup " invalid label name" ?not-error
 290           over c@ [char] @ = if
 291             string:/char
 292             dup " invalid label name" ?not-error
 293           endif
 294         endof
 295     endcase
 296   endif
 297 ;
 298
 299 : prefix-set?  ( addr count -- bool )
 300   drop c@ dup [char] @ <> swap [char] . <> and
 301 ;
 302
 303
 304 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 305 ;; find label
 306 : find  ( addr count -- pfa TRUE / FALSE )
 307   vocid: (asm-labels) find-word-in-voc
 308   if cfa->pfa true else false endif
 309 ;
 310
 311
 312 : (new-label-ref)  ( addr count -- Label )
 313   (create)
 314   here >r
 315   latest-nfa Label oof:allot oof:invoke: Label init
 316   create;
 317   r>
 318 ;
 319
 320 ;; note label reference
 321 ;; this introduces new label record if there wasn't one, but
 322 ;; will do nothing for already existing label records
 323 : (ref)  ( addr count -- Label )
 324   2dup find if nrot 2drop
 325   else  ;; create new label word
 326     ;; change current vocab to labels
 327     current @ >r  vocid: (asm-labels) current !
 328     (new-label-ref)
 329     ;; restore old current vocab
 330     r> current !
 331   endif
 332 ;
 333
 334 : ref  ( addr count -- )
 335   2dup fref-f/b-label? ifnot (ref) oof:invoke: Label new-ref
 336   else 2drop endif
 337 ;
 338
 339
 340 : defined?  ( addr count -- bool )
 341   find dup if oof:invoke: Label type ltype-unknown <> endif
 342 ;
 343
 344
 345 : (define-label)  ( addr count value type -- )
 346   swap >r >r
 347   2dup f/b-label? if
 348     r@ ltype-code <> r> ltype-data <> and " invalid nameless label def" ?error
 349     r@ 0 65536 within " invalid nameless label value" ?not-error
 350     r> to last-f/b-label
 351     2drop
 352     true to resolve-nameless
 353   else
 354     2dup fref-label? " invalid label name" ?error
 355     r@ ltype-code >= if 2dup prefix-set? >r else 0 >r endif
 356     fix-prefix (ref)
 357     r> if dup to global-prefix endif
 358     ( Label | value type )
 359     dup oof:invoke: Label type
 360     dup ltype-unknown <> if r@ <> r@ ltype-var <> or " label redefinition" ?error
 361     else drop
 362     endif
 363     r> over oof:invoke: Label type!
 364     r> over oof:invoke: Label value!
 365     oof:invoke: Label defined-here
 366   endif
 367   resolve-exprs
 368 ;
 369
 370 : define-var  ( addr count value -- )  ltype-var (define-label) ;
 371 : define-equ  ( addr count value -- )  ltype-equ (define-label) ;
 372 : define-code ( addr count value -- )  ltype-code (define-label) ;
 373 : define-data ( addr count value -- )  ltype-data (define-label) ;
 374
 375
 376 ;; create new label info struct, return label value (not truncated)
 377 ;; doesn't record label access
 378 : get  ( addr count -- value TRUE / FALSE )
 379   2dup f/b-label? if 2drop false exit endif
 380   2dup fref-label? ?dup if nrot 2drop  ;; "@b" or "@f"
 381     resolve-nameless if ;; resolving "@@"
 382       0< " internal nameless resolver error" ?error -- the thing that should not be
 383       last-f/b-label
 384       dup 0 65536 within " internal nameless resolver error (2)" ?not-error -- assertion
 385       true
 386     else
 387       -if last-f/b-label +0if last-f/b-label true else false endif  ;; backref
 388       else false endif
 389     endif
 390     exit
 391   endif
 392   \ fix-prefix 2dup xtype cr
 393   2dup find ifnot
 394     ." shit: " xtype cr
 395     " label not found, wtf?!" error
 396   endif nrot 2drop
 397   dup oof:invoke: Label type ltype-unknown = if drop false
 398   else oof:invoke: Label value true
 399   endif
 400 ;
 401
 402
 403 : dump-label-refs  ( LabelRef -- )
 404   begin ?dup while
 405     ."   ref: " dup oof:invoke: LabelRef ref@ oof:invoke: FileRef print cr
 406     oof:invoke: LabelRef prev@
 407   repeat
 408 ;
 409
 410 : dump-labels  ( -- )
 411   vocid: (asm-labels) voc-latest
 412   begin ?dup while
 413     ." === LABEL: " dup lfa->nfa id-count xtype ."  ===" cr
 414     dup lfa->pfa
 415     dup oof:invoke: Label type ltype-unknown <> if
 416       dup oof:invoke: Label set-at@
 417       ." defined at: " oof:invoke: FileRef print cr
 418     endif
 419     dup oof:invoke: Label type ."  type: " . cr
 420     dup oof:invoke: Label value ."  value: " . cr
 421     dup oof:invoke: Label info-head@ dump-label-refs
 422     drop
 423   @ repeat
 424 ;
 425
 426
 427 ;; check if all labels are defined
 428 : check-labels  ( -- )
 429   postpone-expr-list if
 430     vocid: (asm-labels) voc-latest
 431     begin ?dup while
 432       dup lfa->pfa
 433       dup oof:invoke: Label type ltype-unknown = if
 434         ." UNDEFINED LABEL: " over lfa->nfa id-count xtype cr
 435         dup oof:invoke: Label info-head@ dump-label-refs
 436       endif
 437       drop
 438     @ repeat
 439   endif
 440 ;
 441
 442 prev-defs