--- /dev/null
+\ tag: FCode table setup
+\
+\ this code implements an fcode evaluator
+\ as described in IEEE 1275-1994
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+hex
+
+: undefined-fcode ." undefined fcode word." cr ;
+: reserved-fcode ." reserved fcode word." cr ;
+
+: ['], ( <word> -- )
+ ' ,
+;
+
+: n['], ( n <word> -- )
+ ' swap 0 do
+ dup ,
+ loop
+ drop
+;
+
+\ the table used
+create fcode-master-table
+ ['], end0
+ f n['], reserved-fcode
+ ['], b(lit)
+ ['], b(')
+ ['], b(")
+ ['], bbranch
+ ['], b?branch
+ ['], b(loop)
+ ['], b(+loop)
+ ['], b(do)
+ ['], b(?do)
+ ['], i
+ ['], j
+ ['], b(leave)
+ ['], b(of)
+ ['], execute
+ ['], +
+ ['], -
+ ['], *
+ ['], /
+ ['], mod
+ ['], and
+ ['], or
+ ['], xor
+ ['], invert
+ ['], lshift
+ ['], rshift
+ ['], >>a
+ ['], /mod
+ ['], u/mod
+ ['], negate
+ ['], abs
+ ['], min
+ ['], max
+ ['], >r
+ ['], r>
+ ['], r@
+ ['], exit
+ ['], 0=
+ ['], 0<>
+ ['], 0<
+ ['], 0<=
+ ['], 0>
+ ['], 0>=
+ ['], <
+ ['], >
+ ['], =
+ ['], <>
+ ['], u>
+ ['], u<=
+ ['], u<
+ ['], u>=
+ ['], >=
+ ['], <=
+ ['], between
+ ['], within
+ ['], drop
+ ['], dup
+ ['], over
+ ['], swap
+ ['], rot
+ ['], -rot
+ ['], tuck
+ ['], nip
+ ['], pick
+ ['], roll
+ ['], ?dup
+ ['], depth
+ ['], 2drop
+ ['], 2dup
+ ['], 2over
+ ['], 2swap
+ ['], 2rot
+ ['], 2/
+ ['], u2/
+ ['], 2*
+ ['], /c
+ ['], /w
+ ['], /l
+ ['], /n
+ ['], ca+
+ ['], wa+
+ ['], la+
+ ['], na+
+ ['], char+
+ ['], wa1+
+ ['], la1+
+ ['], cell+
+ ['], chars
+ ['], /w*
+ ['], /l*
+ ['], cells
+ ['], on
+ ['], off
+ ['], +!
+ ['], @
+ ['], l@
+ ['], w@
+ ['], <w@
+ ['], c@
+ ['], !
+ ['], l!
+ ['], w!
+ ['], c!
+ ['], 2@
+ ['], 2!
+ ['], move
+ ['], fill
+ ['], comp
+ ['], noop
+ ['], lwsplit
+ ['], wljoin
+ ['], lbsplit
+ ['], bljoin
+ ['], wbflip
+ ['], upc
+ ['], lcc
+ ['], pack
+ ['], count
+ ['], body>
+ ['], >body
+ ['], fcode-revision
+ ['], span
+ ['], unloop
+ ['], expect
+ ['], alloc-mem
+ ['], free-mem
+ ['], key?
+ ['], key
+ ['], emit
+ ['], type
+ ['], (cr
+ ['], cr
+ ['], #out
+ ['], #line
+ ['], hold
+ ['], <#
+ ['], u#>
+ ['], sign
+ ['], u#
+ ['], u#s
+ ['], u.
+ ['], u.r
+ ['], .
+ ['], .r
+ ['], .s
+ ['], base
+ ['], convert \ reserved (compatibility)
+ ['], $number
+ ['], digit
+ ['], -1
+ ['], 0
+ ['], 1
+ ['], 2
+ ['], 3
+ ['], bl
+ ['], bs
+ ['], bell
+ ['], bounds
+ ['], here
+ ['], aligned
+ ['], wbsplit
+ ['], bwjoin
+ ['], b(<mark)
+ ['], b(>resolve)
+ ['], set-token-table
+ ['], set-table
+ ['], new-token
+ ['], named-token
+ ['], b(:)
+ ['], b(value)
+ ['], b(variable)
+ ['], b(constant)
+ ['], b(create)
+ ['], b(defer)
+ ['], b(buffer:)
+ ['], b(field)
+ ['], b(code)
+ ['], instance
+ ['], reserved-fcode
+ ['], b(;)
+ ['], b(to)
+ ['], b(case)
+ ['], b(endcase)
+ ['], b(endof)
+ ['], #
+ ['], #s
+ ['], #>
+ ['], external-token
+ ['], $find
+ ['], offset16
+ ['], evaluate
+ ['], reserved-fcode
+ ['], reserved-fcode
+ ['], c,
+ ['], w,
+ ['], l,
+ ['], ,
+ ['], um*
+ ['], um/mod
+ ['], reserved-fcode
+ ['], reserved-fcode
+ ['], d+
+ ['], d-
+ ['], get-token
+ ['], set-token
+ ['], state
+ ['], compile,
+ ['], behavior
+ 11 n['], reserved-fcode
+ ['], start0
+ ['], start1
+ ['], start2
+ ['], start4
+ 8 n['], reserved-fcode
+ ['], ferror
+ ['], version1
+ ['], 4-byte-id
+ ['], end1
+ ['], reserved-fcode
+ ['], dma-alloc
+ ['], my-address
+ ['], my-space
+ ['], memmap
+ ['], free-virtual
+ ['], >physical
+ 8 n['], reserved-fcode
+ ['], my-params
+ ['], property
+ ['], encode-int
+ ['], encode+
+ ['], encode-phys
+ ['], encode-string
+ ['], encode-bytes
+ ['], reg
+ ['], intr
+ ['], driver
+ ['], model
+ ['], device-type
+ ['], parse-2int
+ ['], is-install
+ ['], is-remove
+ ['], is-selftest
+ ['], new-device
+ ['], diagnostic-mode?
+ ['], display-status
+ ['], memory-test-suite
+ ['], group-code
+ ['], mask
+ ['], get-msecs
+ ['], ms
+ ['], finish-device
+ ['], decode-phys \ 128
+ ['], push-package
+ ['], pop-package
+ ['], interpose \ extension (recommended practice)
+ 4 n['], reserved-fcode
+ ['], map-low
+ ['], sbus-intr>cpu
+ 1e n['], reserved-fcode
+ ['], #lines
+ ['], #columns
+ ['], line#
+ ['], column#
+ ['], inverse?
+ ['], inverse-screen?
+ ['], frame-buffer-busy?
+ ['], draw-character
+ ['], reset-screen
+ ['], toggle-cursor
+ ['], erase-screen
+ ['], blink-screen
+ ['], invert-screen
+ ['], insert-characters
+ ['], delete-characters
+ ['], insert-lines
+ ['], delete-lines
+ ['], draw-logo
+ ['], frame-buffer-adr
+ ['], screen-height
+ ['], screen-width
+ ['], window-top
+ ['], window-left
+ 3 n['], reserved-fcode
+ ['], default-font
+ ['], set-font
+ ['], char-height
+ ['], char-width
+ ['], >font
+ ['], fontbytes
+ 10 n['], reserved-fcode \ fb1 words
+ ['], fb8-draw-character
+ ['], fb8-reset-screen
+ ['], fb8-toggle-cursor
+ ['], fb8-erase-screen
+ ['], fb8-blink-screen
+ ['], fb8-invert-screen
+ ['], fb8-insert-characters
+ ['], fb8-delete-characters
+ ['], fb8-insert-lines
+ ['], fb8-delete-lines
+ ['], fb8-draw-logo
+ ['], fb8-install
+ 4 n['], reserved-fcode \ reserved
+ 7 n['], reserved-fcode \ VME-bus support
+ 9 n['], reserved-fcode \ reserved
+ ['], return-buffer
+ ['], xmit-packet
+ ['], poll-packet
+ ['], reserved-fcode
+ ['], mac-address
+ 5c n['], reserved-fcode \ 1a5-200 reserved
+ ['], device-name
+ ['], my-args
+ ['], my-self
+ ['], find-package
+ ['], open-package
+ ['], close-package
+ ['], find-method
+ ['], call-package
+ ['], $call-parent
+ ['], my-parent
+ ['], ihandle>phandle
+ ['], reserved-fcode
+ ['], my-unit
+ ['], $call-method
+ ['], $open-package
+ ['], processor-type
+ ['], firmware-version
+ ['], fcode-version
+ ['], alarm
+ ['], (is-user-word)
+ ['], suspend-fcode
+ ['], abort
+ ['], catch
+ ['], throw
+ ['], user-abort
+ ['], get-my-property
+ ['], decode-int
+ ['], decode-string
+ ['], get-inherited-property
+ ['], delete-property
+ ['], get-package-property
+ ['], cpeek
+ ['], wpeek
+ ['], lpeek
+ ['], cpoke
+ ['], wpoke
+ ['], lpoke
+ ['], lwflip
+ ['], lbflip
+ ['], lbflips
+ ['], adr-mask
+ 4 n['], reserved-fcode \ 22a-22d
+64bit? [IF]
+ ['], (rx@)
+ ['], (rx!)
+[ELSE]
+ 2 n['], reserved-fcode \ 22e-22f
+[THEN]
+ ['], rb@
+ ['], rb!
+ ['], rw@
+ ['], rw!
+ ['], rl@
+ ['], rl!
+ ['], wbflips
+ ['], lwflips
+ ['], probe
+ ['], probe-virtual
+ ['], reserved-fcode
+ ['], child
+ ['], peer
+ ['], next-property
+ ['], byte-load
+ ['], set-args
+ ['], left-parse-string \ 240
+64bit? [IF]
+ ['], bxjoin
+ ['], <l@
+ ['], lxjoin
+ ['], wxjoin
+ ['], x,
+ ['], x@
+ ['], x!
+ ['], /x
+ ['], /x*
+\ ['], /xa+
+\ ['], /xa1+
+ ['], xbflip
+ ['], xbflips
+ ['], xbsplit
+ ['], xlflip
+ ['], xlflips
+ ['], xlsplit
+ ['], xwflip
+ ['], xwflips
+ ['], xwsplit
+[ELSE]
+ 7 n['], reserved-fcode \ 241-247 (Part of IEEE1275 64-bit draft standard)
+ ['], /x
+ c n['], reserved-fcode \ 249-254 (Part of IEEE1275 64-bit draft standard)
+[THEN]
+
+
+here fcode-master-table - constant fcode-master-table-size
+
+
+: nreserved ( fcode-table-ptr first last xt -- )
+ -rot 1+ swap do
+ 2dup swap i cells + !
+ loop
+ 2drop
+;
+
+:noname
+ 800 cells alloc-mem to fcode-sys-table
+
+ fcode-sys-table
+ dup 0 5ff ['] reserved-fcode nreserved \ built-in fcodes
+ dup 600 7ff ['] undefined-fcode nreserved \ vendor fcodes
+
+ \ copy built-in fcodes
+ fcode-master-table swap fcode-master-table-size move
+; initializer
+
+: (init-fcode-table) ( -- )
+ fcode-sys-table fcode-table 800 cells move
+ \ clear local fcodes
+ fcode-table 800 fff ['] undefined-fcode nreserved
+;
+
+['] (init-fcode-table) to init-fcode-table
Code Review / kvmfornfv.git / blobdiff