\ Do not use this file except in compliance with the License. You may
\ obtain a copy of the License at http://www.microcore.org/License/
\ Software distributed under the License is distributed on an "AS IS" basis,
\ WITHOUT WARRANTY OF ANY KIND, either express or implied.
\ See the License for the specific language governing rights and limitations
\ under the License.
\
\ The Original Code is: GFORTH-CONFIG.FS
\
\ Last change: KS 16.09.2015 10:27:59
\
\ Port to the gforth system and extensions by Ulrich.E.Hoffmann AT xlerb.de
\
\ MicroCore Forth Cross-compiler configuration
\ compatibility layer loads on top of gforth_062, or gforth_070 depending on Constant gforth_062
Only Forth also definitions hex
warnings off
version-string s" 0.6.2" str= Constant gforth_062
version-string s" 0.7.0" str= Constant gforth_070
gforth_062 gforth_070 or 0= [IF]
cr .( gforth ) version-string type .( not supported) abort
[THEN]
: cell_width ( -- u )
0 1 BEGIN swap 1+ swap 2* ?dup 0= UNTIL
;
: cell- 1 cells - ;
: mem-save ( x1 ... xn n -- addr )
dup 1+ cells allocate Abort" memstore: Cannot allocate memory" ( x1 ... xn n addr )
dup >r
2dup ! cell+ \ store length
swap 0 ?DO ( x1 .. xi addr_i )
swap over ! cell+ ( x1 ... xi-1 addr_i-1 )
LOOP ( addr1 )
drop r> ;
: mem-restore ( addr -- x1 ... xn n )
dup >r ( addr )
dup @ ( addr len )
dup >r cells + ( addr' )
r@ 0 ?DO ( x1 .. xi addri )
dup @ swap cell- ( x1 ... xi xi+1 addr_i+1 )
LOOP ( x1 ... xn addr )
drop r> ( x1 ... xn n )
r> free Abort" mem-restore: could not free memory" ;
: source> ( -- sca ) save-input mem-save ;
: >source ( sca -- ) mem-restore restore-input abort" couldn't restore input" ;
: drop-source ( sca -- ) free Abort" drop-source: cannot free source code info" ;
: skip-input ( c -- )
source dup >in @ min /string over >r
rot skip drop r> - >in +!
;
: scan-input ( c ccccc[c] -- )
loadfile @ 0= abort" can only be loaded from file"
BEGIN >in @ over parse nip
>in @ rot - = \ is there no delimter?
WHILE
refill 0= IF drop EXIT THEN
REPEAT drop
;
: u2/ ( u1 -- u2 ) 1 rshift ; \ Assumes 2's complement arithmetic
: 2** ( n -- 2**n ) 1 swap lshift ;
: binary ( -- ) 2 base ! ;
\ IO Redirection
: _CR ( -- ) newline (type) ;
Defer CR
: _EMIT ( c -- ) (emit) ;
: _TYPE ( c-addr len -- )
2dup newline d= IF 2drop CR EXIT THEN \ make old cr invoke new CR
(type) ;
' _TYPE IS TYPE
' _CR IS CR
' _EMIT IS EMIT
: ascii ( -- ch ) char ;
: Module ( <name> -- )
>IN @ >R BL WORD FIND IF EXECUTE ELSE DROP THEN R> >IN ! MARKER ;
: ?comp state @ 0= Abort" compilation only" ;
: ?exec state @ Abort" execution only" ;
: [NOTIF] ( flag -- ) \ tools-ext bracket-notif
IF countif off
lookup @ [ [struct]-voc 3 cells + ] ALiteral !
[struct]-voc lookup !
THEN
; immediate
: becomes ( <name> new-xt -- ) \ makes <name> behave as new-xt
here >r
>r ' >body dp !
postpone ahead r> >body dp ! postpone THEN
r> dp !
;
Create save[ 2 cells allot ' [ >body save[ 2 cells cmove
Create save] 2 cells allot ' ] >body save] 2 cells cmove
: unpatch ( -- )
save[ [ ' [ >body ] Literal 2 cells cmove
save] [ ' ] >body ] Literal 2 cells cmove
;
gforth_062 [IF]
: unknown ( addr u -- ) type space -&13 throw ;
' unknown IS compiler-notfound
' unknown IS interpreter-notfound
\ ' .error-string IS DoError
Variable 'interpreter ' interpreter 'interpreter !
Variable 'compiler ' compiler 'compiler !
: new[ ( -- ) 'interpreter @ IS parser state off ; immediate
' new[ becomes [
: new] ( -- ) 'compiler @ IS parser state on ;
' new] becomes ]
[THEN]
gforth_070 [IF]
' interpreter-notfound1 Alias interpreter-notfound
' compiler-notfound1 Alias compiler-notfound
Variable 'interpreter ' interpreter1 'interpreter !
Variable 'compiler ' compiler1 'compiler !
: new[ ( -- ) 'interpreter @ IS parser1 state off ; immediate
' new[ becomes [
: new] ( -- ) 'compiler @ IS parser1 state on ;
' new] becomes ]
[THEN]
' noop IS dobacktrace
: forget ' drop ;
\ floored division
: / ( n1 n2 -- n3 ) >r s>d r> fm/mod nip ;
: ?missing ( f -- ) ABORT" not found" ;
: defined ( <name> -- xxxx ff | xt tf )
parse-word over swap name-too-short?
find-name dup IF name?int nip true THEN
;
: hide ( -- ) \ manipulate word header so it won't be found
latest name>string $80 or swap cell- c!
;
: reveal ( -- ) \ manipulate word header so it will be found again
latest name>string $7F and swap cell- c!
;
: new.voc ( wid -- )
dup >r wordlist-struct %size + dup head? -1 =
IF ( wid nt )
dup name>int dup >code-address
docon: = swap >body @ r@ = and
IF id. rdrop EXIT THEN
THEN
drop r> body> >head-noprim id. ;
' new.voc becomes .voc
: close-port ;
\ ---------------------------------------------------------------------------
\ Some System word (re)definitions for a more sympathetic environment
\ ---------------------------------------------------------------------------
: ?cr ( -- ) ;
$0A Constant #lf
$0D Constant #cr
: stop? ( -- flag )
key? IF key #cr = ?dup ?EXIT
key #cr = EXIT
THEN false
;
: .wordname ( pfa -- ) body> >name .name space ;
: have ( ccc -- xt | false ) BL word find and ;
: shift ( n1 quan -- n2 ) dup 0< IF abs rshift EXIT THEN lshift ;
: ashift ( n1 n2 -- n3 ) dup 0< IF negate 0 DO 2/ LOOP EXIT THEN 0 ?DO 2* LOOP ;
: m/mod ( d n -- rem quot ) fm/mod ;
: ndrop ( n1 .. nn n -- ) 0 ?DO drop LOOP ;
: pack ( c u -- u' ) $100 um* drop swap $FF and or ;
: unpack ( u -- c u' ) 0 $100 um/mod ;
Variable debugging debugging off
: comp? ( -- f ) State @ 0<> ;
: exec? ( -- f ) State @ 0= ;
: dbg? ( -- f ) debugging @ exec? and ;
: ?dbg ( -- ) dbg? 0= Abort" debugging only" ;
: ?pairs ( n1 n2 -- ) - abort" unstructured!" ; \ for checking conditional constructs
: : ( -- 0 ) : 0 ; \ this allows to create an "intelligent" ; later on
\ for MACRO definitions to pick the proper
: ; ( 0 -- ) 0 ?pairs postpone ; [ 0 ?pairs ] ; immediate \ ; behaviour
: Does> ( 0 -- 0 ) >r postpone Does> r> ; immediate
: :noname ( -- 0 ) :noname 0 ;
: case? ( n1 n2 -- n1 ff | tf ) over = dup IF nip THEN ; \ the most primitive case operator
Create restore ] r> r> ! exit [
: save ( var -- ) r> swap dup >r @ >r restore >r >r ;
: temp_hex ( -- ) r> Base save hex >r ;
: udump ( addr u -- ) \ dumps 32-bit data items as unsigned
8 /mod swap 0= 1+ +
0 ?DO cr dup u. ." : "
8 0 DO dup @ cell_width 2/ 2/ 1+ u.r cell+ LOOP
LOOP drop
;
: \\ ( -- ) source-id IF BEGIN refill 0= UNTIL THEN postpone \ ; immediate \ \\
Forth Root definitions
' udump Alias udump
' have Alias have
Forth definitions