\ ***************************************************************************** \ * 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(resolve) ( -- ) ?compile-mode IF postpone then THEN ; immediate : b(;) compile, reveal postpone [ ; immediate : b(:) ( -- ) 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 = over = OR IF \ Destination is value or defer drop >body cell - ( val addr ) ?compile-mode IF literal, postpone ! ELSE ! THEN ELSE <> IF ( val xt ) TRUE ABORT" Invalid destination for FCODE b(to)" THEN dup cell+ @ ( val xt @xt+1cell ) dup <> swap <> 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 , \ Needed for "(instance?)" for example , (create-instance-var) FALSE TO fc-instance? ELSE , , THEN reveal ; : b(variable) fc-instance? IF , \ Needed for "(instance?)" , 0 (create-instance-var) FALSE TO fc-instance? ELSE , 0 , THEN reveal ; : b(constant) , , reveal ; : undefined-defer cr cr ." Uninitialized defer word has been executed!" cr cr true fcode-end ! ; : b(defer) fc-instance? IF , \ Needed for "(instance?)" , ['] undefined-defer (create-instance-var) reveal FALSE TO fc-instance? ELSE , reveal postpone undefined-defer THEN ; : b(create) , postpone noop reveal ; : b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size ) , over literal, postpone + compile, reveal + ; : b(buffer:) ( E: -- a-addr) ( F: size -- ) fc-instance? IF , \ Needed for "(instance?)" , (create-instance-buf) FALSE TO fc-instance? ELSE , 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-= IF 10000 - THEN ; : fc-l@ ( addr -- long ) dup MIN-RAM-SIZE > IF rl@ ELSE l@ THEN ; : fc- 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 ;