--- /dev/null
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ * IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+: fcode-revision ( -- n )
+ 00030000 \ major * 65536 + minor
+ ;
+
+: b(lit) ( -- n )
+ next-ip read-fcode-num32
+ ?compile-mode IF literal, THEN
+ ;
+
+: b(")
+ next-ip read-fcode-string
+ ?compile-mode IF fc-string, align postpone count THEN
+ ;
+
+: b(')
+ next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN
+ ;
+
+: ?jump-direction ( n -- )
+ dup 8000 >= IF
+ 10000 - \ Create cell-sized negative value
+ THEN
+ fcode-offset - \ IP is already behind offset, so subtract offset size
+;
+
+: ?negative
+ 8000 and
+ ;
+
+: dest-on-top
+ 0 >r BEGIN dup @ 0= WHILE >r REPEAT
+ BEGIN r> dup WHILE swap REPEAT
+ drop
+ ;
+
+: read-fcode-offset
+ next-ip
+ ?offset16 IF
+ read-fcode-num16
+ ELSE
+ read-byte
+ dup 80 and IF FF00 or THEN \ Fake 16-bit signed offset
+ THEN
+;
+
+: b?branch ( flag -- )
+ ?compile-mode IF
+ read-fcode-offset ?negative IF
+ dest-on-top postpone until
+ ELSE
+ postpone if
+ THEN
+ ELSE
+ ( flag ) IF
+ fcode-offset jump-n-ip \ Skip over offset value
+ ELSE
+ read-fcode-offset
+ ?jump-direction jump-n-ip
+ THEN
+ THEN
+; immediate
+
+: bbranch ( -- )
+ ?compile-mode IF
+ read-fcode-offset
+ ?negative IF
+ dest-on-top postpone again
+ ELSE
+ postpone else
+ get-ip next-ip fcode@ B2 = IF
+ drop
+ ELSE
+ set-ip
+ THEN
+ THEN
+ ELSE
+ read-fcode-offset ?jump-direction jump-n-ip
+ THEN
+; immediate
+
+: b(<mark) ( -- )
+ ?compile-mode IF postpone begin THEN
+ ; immediate
+
+: b(>resolve) ( -- )
+ ?compile-mode IF postpone then THEN
+ ; immediate
+
+: b(;)
+ <semicolon> compile, reveal
+ postpone [
+; immediate
+
+: b(:) ( -- )
+ <colon> compile, ]
+ ; immediate
+
+: b(case) ( sel -- sel )
+ postpone case
+ ; immediate
+
+: b(endcase)
+ postpone endcase
+ ; immediate
+
+: b(of)
+ postpone of
+ read-fcode-offset drop \ read and discard offset
+ ; immediate
+
+: b(endof)
+ postpone endof
+ read-fcode-offset drop
+ ; immediate
+
+: b(do)
+ postpone do
+ read-fcode-offset drop
+ ; immediate
+
+: b(?do)
+ postpone ?do
+ read-fcode-offset drop
+ ; immediate
+
+: b(loop)
+ postpone loop
+ read-fcode-offset drop
+ ; immediate
+
+: b(+loop)
+ postpone +loop
+ read-fcode-offset drop
+ ; immediate
+
+: b(leave)
+ postpone leave
+ ; immediate
+
+
+0 VALUE fc-instance?
+: fc-instance ( -- ) \ Mark next defining word as instance-specific.
+ TRUE TO fc-instance?
+;
+
+: new-token \ unnamed local fcode function
+ align here next-ip read-fcode# 0 swap set-token
+ ;
+
+: external-token ( -- ) \ named local fcode function
+ next-ip read-fcode-string
+ \ fc-instance? IF cr ." ext instance token: " 2dup type ." in " pwd cr THEN
+ header ( str len -- ) \ create a header in the current dictionary entry
+ new-token
+ ;
+
+: new-token
+ eva-debug? IF
+ s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup
+ header
+ THEN
+ new-token
+;
+
+\ decide wether or not to give a new token an own name in the dictionary
+: named-token
+ fcode-debug? IF
+ external-token
+ ELSE
+ next-ip read-fcode-string 2drop \ Forget about the name
+ new-token
+ THEN
+;
+
+: b(to) ( val -- )
+ next-ip read-fcode#
+ get-token drop ( val xt )
+ dup @ ( val xt @xt )
+ dup <value> = over <defer> = OR IF
+ \ Destination is value or defer
+ drop
+ >body cell -
+ ( val addr )
+ ?compile-mode IF
+ literal, postpone !
+ ELSE
+ !
+ THEN
+ ELSE
+ <create> <> IF ( val xt )
+ TRUE ABORT" Invalid destination for FCODE b(to)"
+ THEN
+ dup cell+ @ ( val xt @xt+1cell )
+ dup <instancevalue> <> swap <instancedefer> <> AND IF
+ TRUE ABORT" Invalid destination for FCODE b(to)"
+ THEN
+ \ Destination is instance-value or instance-defer
+ >body @ ( val instance-offset )
+ ?compile-mode IF
+ literal, postpone >instance postpone !
+ ELSE
+ >instance !
+ THEN
+ ELSE
+ THEN
+; immediate
+
+: b(value)
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)" for example
+ <instancevalue> ,
+ (create-instance-var)
+ FALSE TO fc-instance?
+ ELSE
+ <value> , ,
+ THEN
+ reveal
+;
+
+: b(variable)
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)"
+ <instancevariable> ,
+ 0 (create-instance-var)
+ FALSE TO fc-instance?
+ ELSE
+ <variable> , 0 ,
+ THEN
+ reveal
+;
+
+: b(constant)
+ <constant> , , reveal
+ ;
+
+: undefined-defer
+ cr cr ." Uninitialized defer word has been executed!" cr cr
+ true fcode-end !
+ ;
+
+: b(defer)
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)"
+ <instancedefer> ,
+ ['] undefined-defer (create-instance-var)
+ reveal
+ FALSE TO fc-instance?
+ ELSE
+ <defer> , reveal
+ postpone undefined-defer
+ THEN
+;
+
+: b(create)
+ <variable> ,
+ postpone noop reveal
+ ;
+
+: b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size )
+ <colon> , over literal,
+ postpone +
+ <semicolon> compile,
+ reveal
+ +
+;
+
+: b(buffer:) ( E: -- a-addr) ( F: size -- )
+ fc-instance? IF
+ <create> , \ Needed for "(instance?)"
+ <instancebuffer> ,
+ (create-instance-buf)
+ FALSE TO fc-instance?
+ ELSE
+ <buffer:> , allot
+ THEN
+ reveal
+;
+
+: suspend-fcode ( -- )
+ noop \ has to be implemented more efficiently ;-)
+ ;
+
+: offset16 ( -- )
+ 2 to fcode-offset
+ ;
+
+: version1 ( -- )
+ 1 to fcode-spread
+ 1 to fcode-offset
+ read-header
+ ;
+
+: start0 ( -- )
+ 0 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: start1 ( -- )
+ 1 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: start2 ( -- )
+ 2 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: start4 ( -- )
+ 4 to fcode-spread
+ offset16
+ read-header
+ ;
+
+: end0 ( -- )
+ true fcode-end !
+ ;
+
+: end1 ( -- )
+ end0
+ ;
+
+: ferror ( -- )
+ clear end0
+ cr ." FCode# " fcode-num @ . ." not assigned!"
+ cr ." FCode evaluation aborted." cr
+ ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr
+ abort
+ ;
+
+: reset-local-fcodes
+ FFF 800 DO ['] ferror 0 i set-token LOOP
+ ;
+
+: byte-load ( addr xt -- )
+ >r >r
+ save-evaluator-state
+ r> r>
+ reset-fcode-end
+ 1 to fcode-spread
+ dup 1 = IF drop ['] rb@ THEN to fcode-rb@
+ set-ip
+ reset-local-fcodes
+ depth >r
+ evaluate-fcode
+ r> depth 1- <> IF
+ clear end0
+ cr ." Ambiguous stack depth after byte-load!"
+ cr ." FCode evaluation aborted." cr cr
+ ELSE
+ restore-evaluator-state
+ THEN
+ ['] c@ to fcode-rb@
+;
+
+\ Functions for accessing memory ... since some FCODE programs use the normal
+\ memory access functions for accessing MMIO memory, too, we got to use a little
+\ hack to support them: When address is bigger than MIN-RAM-SIZE, assume the
+\ FCODE is trying to access MMIO memory and use the register based access
+\ functions instead!
+: fc-c@ ( addr -- byte ) dup MIN-RAM-SIZE > IF rb@ ELSE c@ THEN ;
+: fc-w@ ( addr -- word ) dup MIN-RAM-SIZE > IF rw@ ELSE w@ THEN ;
+: fc-<w@ ( addr -- word ) fc-w@ dup 8000 >= IF 10000 - THEN ;
+: fc-l@ ( addr -- long ) dup MIN-RAM-SIZE > IF rl@ ELSE l@ THEN ;
+: fc-<l@ ( addr -- long ) fc-l@ signed ;
+: fc-x@ ( addr -- dlong ) dup MIN-RAM-SIZE > IF rx@ ELSE x@ THEN ;
+: fc-c! ( byte addr -- ) dup MIN-RAM-SIZE > IF rb! ELSE c! THEN ;
+: fc-w! ( word addr -- ) dup MIN-RAM-SIZE > IF rw! ELSE w! THEN ;
+: fc-l! ( long addr -- ) dup MIN-RAM-SIZE > IF rl! ELSE l! THEN ;
+: fc-x! ( dlong addr -- ) dup MIN-RAM-SIZE > IF rx! ELSE x! THEN ;
+
+: fc-fill ( add len byte -- ) 2 pick MIN-RAM-SIZE > IF rfill ELSE fill THEN ;
+: fc-move ( src dst len -- )
+ 2 pick MIN-RAM-SIZE > \ Check src
+ 2 pick MIN-RAM-SIZE > \ Check dst
+ OR IF rmove ELSE move THEN
+;
+
+\ Destroy virtual mapping (should maybe also update "address" property here?)
+: free-virtual ( virt size -- )
+ s" map-out" $call-parent
+;
+
+\ Map the specified region, return virtual address
+: map-low ( phys.lo ... size -- virt )
+ my-space swap s" map-in" $call-parent
+;
+
+\ Get MAC address
+: mac-address ( -- mac-str mac-len )
+ s" local-mac-address" get-my-property IF
+ 0 0
+ THEN
+;
+
+\ Output line and column number - not used yet
+VARIABLE #line
+0 #line !
+VARIABLE #out
+0 #out !
+
+\ Display device status
+: display-status ( n -- )
+ ." Device status: " . cr
+;
+
+\ Obsolete variables:
+VARIABLE group-code
+0 group-code !
+
+\ Obsolete: Allocate memory for DMA
+: dma-alloc ( byte -- virtual )
+ s" dma-alloc" $call-parent
+;
+
+\ Obsolete: Get params property
+: my-params ( -- addr len )
+ s" params" get-my-property IF
+ 0 0
+ THEN
+;
+
+\ Obsolete: Convert SBus interrupt level to CPU interrupt level
+: sbus-intr>cpu ( sbus-intr# -- cpu-intr# )
+;
+
+\ Obsolete: Set "intr" property
+: intr ( interrupt# vector -- )
+ >r sbus-intr>cpu encode-int r> encode-int+ s" intr" property
+;
+
+\ Obsolete: Create the "name" property
+: driver ( addr len -- )
+ encode-string s" name" property
+;
+
+\ Obsolete: Return type of CPU
+: processor-type ( -- cpu-type )
+ 0
+;
+
+\ Obsolete: Return firmware version
+: firmware-version ( -- n )
+ 10000 \ Just a dummy value
+;
+
+\ Obsolete: Return fcode-version
+: fcode-version ( -- n )
+ fcode-revision
+;
Code Review / kvmfornfv.git / blobdiff