diff options
Diffstat (limited to 'qemu/roms/SLOF/slof/fs/fcode/1275.fs')
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/fcode/1275.fs | 465 |
1 files changed, 465 insertions, 0 deletions
diff --git a/qemu/roms/SLOF/slof/fs/fcode/1275.fs b/qemu/roms/SLOF/slof/fs/fcode/1275.fs new file mode 100644 index 000000000..c2a67bcc9 --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/fcode/1275.fs @@ -0,0 +1,465 @@ +\ ***************************************************************************** +\ * 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 +; |