| \ ***************************************************************************** |
| \ * 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 substract 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 |
| ; |