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, 0 insertions, 465 deletions
diff --git a/qemu/roms/SLOF/slof/fs/fcode/1275.fs b/qemu/roms/SLOF/slof/fs/fcode/1275.fs deleted file mode 100644 index c2a67bcc9..000000000 --- a/qemu/roms/SLOF/slof/fs/fcode/1275.fs +++ /dev/null @@ -1,465 +0,0 @@ -\ ***************************************************************************** -\ * 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 -; |