\ 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