forth/device/table.fs

   1 \ tag: FCode table setup
   2 \
   3 \ this code implements an fcode evaluator
   4 \ as described in IEEE 1275-1994
   5 \
   6 \ Copyright (C) 2003 Stefan Reinauer
   7 \
   8 \ See the file "COPYING" for further information about
   9 \ the copyright and warranty status of this work.
  10 \
  11
  12 hex
  13
  14 : undefined-fcode ." undefined fcode word." cr ;
  15 : reserved-fcode  ." reserved fcode word."  cr ;
  16
  17 : ['], ( <word> -- )
  18   ' ,
  19 ;
  20
  21 : n['], ( n <word> -- )
  22   ' swap 0 do
  23     dup ,
  24   loop
  25   drop
  26 ;
  27
  28 \ the table used
  29 create fcode-master-table
  30   ['], end0
  31   f n['], reserved-fcode
  32   ['], b(lit)
  33   ['], b(')
  34   ['], b(")
  35   ['], bbranch
  36   ['], b?branch
  37   ['], b(loop)
  38   ['], b(+loop)
  39   ['], b(do)
  40   ['], b(?do)
  41   ['], i
  42   ['], j
  43   ['], b(leave)
  44   ['], b(of)
  45   ['], execute
  46   ['], +
  47   ['], -
  48   ['], *
  49   ['], /
  50   ['], mod
  51   ['], and
  52   ['], or
  53   ['], xor
  54   ['], invert
  55   ['], lshift
  56   ['], rshift
  57   ['], >>a
  58   ['], /mod
  59   ['], u/mod
  60   ['], negate
  61   ['], abs
  62   ['], min
  63   ['], max
  64   ['], >r
  65   ['], r>
  66   ['], r@
  67   ['], exit
  68   ['], 0=
  69   ['], 0<>
  70   ['], 0<
  71   ['], 0<=
  72   ['], 0>
  73   ['], 0>=
  74   ['], <
  75   ['], >
  76   ['], =
  77   ['], <>
  78   ['], u>
  79   ['], u<=
  80   ['], u<
  81   ['], u>=
  82   ['], >=
  83   ['], <=
  84   ['], between
  85   ['], within
  86   ['], drop
  87   ['], dup
  88   ['], over
  89   ['], swap
  90   ['], rot
  91   ['], -rot
  92   ['], tuck
  93   ['], nip
  94   ['], pick
  95   ['], roll
  96   ['], ?dup
  97   ['], depth
  98   ['], 2drop
  99   ['], 2dup
 100   ['], 2over
 101   ['], 2swap
 102   ['], 2rot
 103   ['], 2/
 104   ['], u2/
 105   ['], 2*
 106   ['], /c
 107   ['], /w
 108   ['], /l
 109   ['], /n
 110   ['], ca+
 111   ['], wa+
 112   ['], la+
 113   ['], na+
 114   ['], char+
 115   ['], wa1+
 116   ['], la1+
 117   ['], cell+
 118   ['], chars
 119   ['], /w*
 120   ['], /l*
 121   ['], cells
 122   ['], on
 123   ['], off
 124   ['], +!
 125   ['], @
 126   ['], l@
 127   ['], w@
 128   ['], <w@
 129   ['], c@
 130   ['], !
 131   ['], l!
 132   ['], w!
 133   ['], c!
 134   ['], 2@
 135   ['], 2!
 136   ['], move
 137   ['], fill
 138   ['], comp
 139   ['], noop
 140   ['], lwsplit
 141   ['], wljoin
 142   ['], lbsplit
 143   ['], bljoin
 144   ['], wbflip
 145   ['], upc
 146   ['], lcc
 147   ['], pack
 148   ['], count
 149   ['], body>
 150   ['], >body
 151   ['], fcode-revision
 152   ['], span
 153   ['], unloop
 154   ['], expect
 155   ['], alloc-mem
 156   ['], free-mem
 157   ['], key?
 158   ['], key
 159   ['], emit
 160   ['], type
 161   ['], (cr
 162   ['], cr
 163   ['], #out
 164   ['], #line
 165   ['], hold
 166   ['], <#
 167   ['], u#>
 168   ['], sign
 169   ['], u#
 170   ['], u#s
 171   ['], u.
 172   ['], u.r
 173   ['], .
 174   ['], .r
 175   ['], .s
 176   ['], base
 177   ['], convert                  \ reserved (compatibility)
 178   ['], $number
 179   ['], digit
 180   ['], -1
 181   ['], 0
 182   ['], 1
 183   ['], 2
 184   ['], 3
 185   ['], bl
 186   ['], bs
 187   ['], bell
 188   ['], bounds
 189   ['], here
 190   ['], aligned
 191   ['], wbsplit
 192   ['], bwjoin
 193   ['], b(<mark)
 194   ['], b(>resolve)
 195   ['], set-token-table
 196   ['], set-table
 197   ['], new-token
 198   ['], named-token
 199   ['], b(:)
 200   ['], b(value)
 201   ['], b(variable)
 202   ['], b(constant)
 203   ['], b(create)
 204   ['], b(defer)
 205   ['], b(buffer:)
 206   ['], b(field)
 207   ['], b(code)
 208   ['], instance
 209   ['], reserved-fcode
 210   ['], b(;)
 211   ['], b(to)
 212   ['], b(case)
 213   ['], b(endcase)
 214   ['], b(endof)
 215   ['], #
 216   ['], #s
 217   ['], #>
 218   ['], external-token
 219   ['], $find
 220   ['], offset16
 221   ['], evaluate
 222   ['], reserved-fcode
 223   ['], reserved-fcode
 224   ['], c,
 225   ['], w,
 226   ['], l,
 227   ['], ,
 228   ['], um*
 229   ['], um/mod
 230   ['], reserved-fcode
 231   ['], reserved-fcode
 232   ['], d+
 233   ['], d-
 234   ['], get-token
 235   ['], set-token
 236   ['], state
 237   ['], compile,
 238   ['], behavior
 239   11 n['], reserved-fcode
 240   ['], start0
 241   ['], start1
 242   ['], start2
 243   ['], start4
 244   8 n['], reserved-fcode
 245   ['], ferror
 246   ['], version1
 247   ['], 4-byte-id
 248   ['], end1
 249   ['], reserved-fcode
 250   ['], dma-alloc
 251   ['], my-address
 252   ['], my-space
 253   ['], memmap
 254   ['], free-virtual
 255   ['], >physical
 256   8 n['], reserved-fcode
 257   ['], my-params
 258   ['], property
 259   ['], encode-int
 260   ['], encode+
 261   ['], encode-phys
 262   ['], encode-string
 263   ['], encode-bytes
 264   ['], reg
 265   ['], intr
 266   ['], driver
 267   ['], model
 268   ['], device-type
 269   ['], parse-2int
 270   ['], is-install
 271   ['], is-remove
 272   ['], is-selftest
 273   ['], new-device
 274   ['], diagnostic-mode?
 275   ['], display-status
 276   ['], memory-test-suite
 277   ['], group-code
 278   ['], mask
 279   ['], get-msecs
 280   ['], ms
 281   ['], finish-device
 282   ['], decode-phys           \ 128
 283   ['], push-package
 284   ['], pop-package
 285   ['], interpose             \ extension (recommended practice)
 286   4 n['], reserved-fcode
 287   ['], map-low
 288   ['], sbus-intr>cpu
 289   1e n['], reserved-fcode
 290   ['], #lines
 291   ['], #columns
 292   ['], line#
 293   ['], column#
 294   ['], inverse?
 295   ['], inverse-screen?
 296   ['], frame-buffer-busy?
 297   ['], draw-character
 298   ['], reset-screen
 299   ['], toggle-cursor
 300   ['], erase-screen
 301   ['], blink-screen
 302   ['], invert-screen
 303   ['], insert-characters
 304   ['], delete-characters
 305   ['], insert-lines
 306   ['], delete-lines
 307   ['], draw-logo
 308   ['], frame-buffer-adr
 309   ['], screen-height
 310   ['], screen-width
 311   ['], window-top
 312   ['], window-left
 313   3 n['], reserved-fcode
 314   ['], default-font
 315   ['], set-font
 316   ['], char-height
 317   ['], char-width
 318   ['], >font
 319   ['], fontbytes
 320   10 n['], reserved-fcode             \ fb1 words
 321   ['], fb8-draw-character
 322   ['], fb8-reset-screen
 323   ['], fb8-toggle-cursor
 324   ['], fb8-erase-screen
 325   ['], fb8-blink-screen
 326   ['], fb8-invert-screen
 327   ['], fb8-insert-characters
 328   ['], fb8-delete-characters
 329   ['], fb8-insert-lines
 330   ['], fb8-delete-lines
 331   ['], fb8-draw-logo
 332   ['], fb8-install
 333   4 n['], reserved-fcode           \ reserved
 334   7 n['], reserved-fcode           \ VME-bus support
 335   9 n['], reserved-fcode           \ reserved
 336   ['], return-buffer
 337   ['], xmit-packet
 338   ['], poll-packet
 339   ['], reserved-fcode
 340   ['], mac-address
 341   5c n['], reserved-fcode          \ 1a5-200 reserved
 342   ['], device-name
 343   ['], my-args
 344   ['], my-self
 345   ['], find-package
 346   ['], open-package
 347   ['], close-package
 348   ['], find-method
 349   ['], call-package
 350   ['], $call-parent
 351   ['], my-parent
 352   ['], ihandle>phandle
 353   ['], reserved-fcode
 354   ['], my-unit
 355   ['], $call-method
 356   ['], $open-package
 357   ['], processor-type
 358   ['], firmware-version
 359   ['], fcode-version
 360   ['], alarm
 361   ['], (is-user-word)
 362   ['], suspend-fcode
 363   ['], abort
 364   ['], catch
 365   ['], throw
 366   ['], user-abort
 367   ['], get-my-property
 368   ['], decode-int
 369   ['], decode-string
 370   ['], get-inherited-property
 371   ['], delete-property
 372   ['], get-package-property
 373   ['], cpeek
 374   ['], wpeek
 375   ['], lpeek
 376   ['], cpoke
 377   ['], wpoke
 378   ['], lpoke
 379   ['], lwflip
 380   ['], lbflip
 381   ['], lbflips
 382   ['], adr-mask
 383   4 n['], reserved-fcode       \ 22a-22d
 384 64bit? [IF]
 385   ['], (rx@)
 386   ['], (rx!)
 387 [ELSE]
 388    2 n['], reserved-fcode       \ 22e-22f
 389 [THEN]
 390   ['], rb@
 391   ['], rb!
 392   ['], rw@
 393   ['], rw!
 394   ['], rl@
 395   ['], rl!
 396   ['], wbflips
 397   ['], lwflips
 398   ['], probe
 399   ['], probe-virtual
 400   ['], reserved-fcode
 401   ['], child
 402   ['], peer
 403   ['], next-property
 404   ['], byte-load
 405   ['], set-args
 406   ['], left-parse-string        \ 240
 407 64bit? [IF]
 408   ['], bxjoin
 409   ['], <l@
 410   ['], lxjoin
 411   ['], wxjoin
 412   ['], x,
 413   ['], x@
 414   ['], x!
 415   ['], /x
 416   ['], /x*
 417 \   ['], /xa+
 418 \   ['], /xa1+
 419   ['], xbflip
 420   ['], xbflips
 421   ['], xbsplit
 422   ['], xlflip
 423   ['], xlflips
 424   ['], xlsplit
 425   ['], xwflip
 426   ['], xwflips
 427   ['], xwsplit
 428 [ELSE]
 429   7 n['], reserved-fcode        \ 241-247 (Part of IEEE1275 64-bit draft standard)
 430   ['], /x
 431   c n['], reserved-fcode        \ 249-254 (Part of IEEE1275 64-bit draft standard)
 432 [THEN]
 433
 434
 435 here fcode-master-table - constant fcode-master-table-size
 436
 437
 438 : nreserved ( fcode-table-ptr first last xt -- )
 439   -rot 1+ swap do
 440     2dup swap i cells + !
 441   loop
 442   2drop
 443 ;
 444
 445 :noname
 446   800 cells alloc-mem to fcode-sys-table
 447
 448   fcode-sys-table
 449   dup 0 5ff ['] reserved-fcode nreserved        \ built-in fcodes
 450   dup 600 7ff ['] undefined-fcode nreserved     \ vendor fcodes
 451
 452   \ copy built-in fcodes
 453   fcode-master-table swap fcode-master-table-size move
 454 ; initializer
 455
 456 : (init-fcode-table) ( -- )
 457   fcode-sys-table fcode-table 800 cells move
 458   \ clear local fcodes
 459   fcode-table 800 fff ['] undefined-fcode nreserved
 460 ;
 461
 462 ['] (init-fcode-table) to init-fcode-table