init.mind

\ mind -- a Forth interpreter
\ Copyright 2011-2014 Markus Redeker <cep@ibp.de>
\
\ Published under the GNU General Public License version 2 or any
\ later version, at your choice. There is NO WARRANY, not at all. See
\ the file "copying" for details.

\ At the beginning of each section (a section is marked by "==") there
\ is a list of the words that are defined in the section and belong to
\ the mind language proper.

\ == Bootstrapping of colon definitions ==
\ immediate Alias : ; (')

:, 'last ( -- xt )    ] last @ link>  ;; [
:, immediate          ] 'last dup flags@  #immediate or  swap flags! ;; [

:, Alias ( xt -- )    ] ^dodefer Create,  'last >doer ! ;; [

:, (')  ( <word> -- xt | 0 )    ] parse find ;; [

\ Create an alias for ?pairs so that it can be defined later.
(') 2drop Alias ?pairs ( n1 n2 -- )

:, : ( <word> cf -- )    ] :,  1 state !   lit :  ;; [
:, ; ( cf -- )           ] lit : ?pairs
                           lit ;; ,   0 state !  ;; [  immediate


\ == Constant-like words ==
\ Create does> Variable Constant

: Create ( <word> -- )   ^dovar Create, ;
: does>                  ^dodoes 'last !   r> 'last >doer ! ;

: Variable ( <word> -- )     Create  /cell allot ;
: Constant ( <word> n -- )   Create ,  does> @ ;


\ == Literals ==
\ '

\ create { ' lit | n } in code.
: literal, ( n -- )   lit lit ,  , ;

(') literal, Alias literal ( n -- )  immediate

: '  ( <word> -- xt )                  (')  dup if; notfound ;
\ Compile the XT of the following word
: [']  ( -- xt; Compile: <word> -- )   ' literal, ;  immediate
\ Compile the following word
: [compile]   ( Compile: <word> -- )   ' , ;  immediate


\ == Control structures: building blocks ==

: >mark    ( -- a )	align  here 0 , ;
: >resolve ( a -- )	align  here swap ! ;

: <mark    ( -- a )	align here ;
: <resolve ( a -- )	, ;


\ == Control structures: conditionals ==
\ if, else, then, IF ELSE THEN

: if,   ( -- addr )         ['] 0branch ,  >mark ;
: else, ( addr1 -- addr2 )  ['] branch ,   >mark  swap >resolve ;
: then, ( addr -- )         >resolve ;

: IF   ( -- addr cf )
  if,  ['] if, ;  immediate
: ELSE ( addr1 cf1 -- addr2 cf2 )
  ['] if, ?pairs  else,  ['] else, ;  immediate

: ?then ( cf -- )               \ Are we inside an IF-ELSE-THEN structure?
  dup ['] if, <> [ if, ] ['] else, ?pairs [ else, ] drop [ then, ] ;
: THEN ( addr cf -- )
  ?then then, ;  immediate


\ == Control structures: loops ==
\ begin, while, repeat, BEGIN WHILE REPEAT

: begin,  ( -- a )        <mark ;
: while,  ( a -- a' a )   if, swap ;
: repeat, ( a -- )        ['] branch ,  <resolve ;

: BEGIN ( -- 0 a )
  0  begin,  ['] begin, ;  immediate
: WHILE ( a -- a' a )
  ['] begin, ?pairs  while,  ['] begin, ;  immediate
: REPEAT ( 0 a'1 ... a'n a -- )
  ['] begin, ?pairs  repeat,
  [ begin, ]  0;  then, [ repeat, ] ;  immediate


\ == Number comparison ==
\ min max

: within+  ( n n0 n1 -- flag )	1+ within ; \ true if n0 <= n <= n1

: ?nip ( n1 n2 flag -- n3 ) IF nip ELSE drop THEN ;
: max ( n1 n2 -- n3 )   2dup <  ?nip ; \ Maximum of n1 and n2
: min ( n1 n2 -- n3 )   2dup >  ?nip ; \ Minimum of n1 and n2


\ == Characters ==
\ char [char] space spaces

: char   ( <char> -- c )        \  Ascii (or other) code for <char>
  parse c@ ;
: [char] ( -- c | Compile: <char> -- ) \ Compile code for <char>
  char literal, ;  immediate

: space    bl emit ;            \ Print a single space
: spaces  ( n -- )              \ Print n spaces
  0 max  BEGIN  ?dup WHILE 1- space REPEAT ;


\ == Inlined strings ==
\ (.") (") ," ." "

\ data structure: { ' 'inlined | ' end | data ... | }
\ return address of data following in code, relative to the word
\ calling `'inlined`
: 'inlined ( -- addr )   rr> dup @ >rr  cell+ ;

: (.")  ( -- )       'inlined puts ; \ Print inlined string
: (")   ( -- addr )  'inlined ;      \ Address of inlined string

: ,"  ( <text"> -- )
  here  (") [ >mark  char " c, 0 c,  >resolve ]  parse-to
  here strlen 1+ allot ;

: Stringlit ( xt -- )   Create ,  immediate  does>  @ ,  >mark  ," >resolve ;

' (.") Stringlit ."
' (")  Stringlit  "


\ == Debug tools ==
\ no-defer Defer is

: .abort    ( str -- )	       ." Abort: "  here puts  space  puts  cr ;
: do-abort  ( flag str -- )    swap IF  .abort abort  ELSE drop THEN ;
: (abort")  ( flag -- )        'inlined do-abort ;
' (abort") Stringlit abort"

: no-defer   true abort" undefined Defer" ;
: Defer ( <word> -- )      ['] no-defer Alias ;
: is    ( xt <word> -- )   ' >doer ! ;

: (?pairs)  ( n1 n2 -- )    <> abort" Mismatching control structure" ;
' (?pairs) is ?pairs

: .name ( xt -- )   >name @ puts ; \ Print name of word


\ == Conversion: string to number ==
\ base

Variable base                   \ Base for number conversion.

Variable #acc                   \ Number accumulator
: accumulate ( n -- )           \ Put n as new last digit into #acc
  #acc @  base @ * +  #acc ! ;

: digit?   ( n -- ? )	base @ u< ; \ is n a digit under the current base?
: digit>#  ( char -- n ? )
  dup  [char] 0 [char] 9 within+  IF  [char] 0 -  dup digit? ;; THEN
  dup  [char] a [char] z within+  IF  [char] a -
                [ char 9 char 0 - 1+ ] literal +  dup digit? ;; THEN
  false ;

: udigits  ( str -- str' )      \ accumulate unsigned digits as long as possible
  BEGIN dup c@  digit># IF accumulate ELSE drop ;; THEN  1+ REPEAT ;
: ?rest    ( str -- )           \ abort if there are unconverted characters
  c@ abort" not found" ;
: >unumber ( str -- n )         \ convert string to unsigned number
  0 #acc !  udigits ?rest  #acc @ ;

: read-sign ( str -- a' sign )   \ read leading minus sign if it is there
  dup c@  [char] - =  IF 1+  -1 ELSE 1 THEN ;
: >number  ( str -- n )         \ convert string to signed number
  read-sign swap  >unumber  * ;


\ Add number conversion to the outer interpreter

: convert-number             \ Convert number at `here`, compile it if necessary
  here >number  state @ IF literal, THEN ;

' convert-number word? !        \ Activate number conversion

2 base !
1010 base !   \ going decimal


\ ==== Now the bootstrapping of the language is complete ======================

\ == Data structures ==
\ cells on off erase clearstack

: cells ( n -- n' )   /cell * ;

: on  ( addr -- )   true swap ! ;
: off ( addr -- )   false swap ! ;

: cmove, ( addr n -- )   here swap   dup allot  cmove ;

: erase  ( addr u -- )   0 fill ;

: clearstack      ( ... -- )   s0 @ sp! ;
: clear-rstack ( R: ... -- )   r@  r0 @ rp!  >r ;
     \ clear-rstack saves the caller's address to make itself callable


\ == Control flow ==

: perform ( `xt -- )   @ execute ;

: LATER   rr> >r ;
: push ( addr -- )       \ Save content of addr during execution of current word
  dup >rr @ >rr  LATER  r> r> ! ;


\ == Conversion: numbers to string (Modified f.i.g. model.) ==

128 Constant /numbuf
Create numbuf  /numbuf 1+ allot
Variable 'num                  \ points to the beginning of the generated string

: #>digit ( n - char )
  dup 10 <  IF [char] 0 +  ELSE  10 - [char] a +  THEN ;

: hold   ( char -- )  -1 'num +!   'num @  c! ;
: hold-sign ( n -- )   0< IF  [char] - hold  THEN ;

: <#	            numbuf /numbuf + 'num !   0 hold ;
: # ( u -- u')	    base @ u/mod  #>digit hold ;
: #s ( u -- )	    BEGIN  ?dup WHILE  # REPEAT ;
: #> ( -- addr )    'num @ ;


\ == Number conversion ==
\ (u.) u. (.) . binary octal decimal hex h.

: (u.)  ( u -- str )    <# # #s #> ;
: u.    ( u -- )        (u.) puts space ;
: (.)   ( n -- str )    dup abs  <# # #s hold-sign #> ;
: .     ( n -- )        (.)  puts space ;

: binary     2 base ! ;
: octal      8 base ! ;
: decimal   10 base ! ;
: hex       16 base ! ;

: h.    ( n -- )   base push  hex . ;


\ == Objects ==

: odepth ( -- n )    op0 @ op @ -  /ref / ;

: Ref   ( <word> -- )       Create /ref allot ;
: @obj  ( this class -- )   @class @this ;

: @oclear    op0 @ op !  0 0 @obj ;


\ == Structures ==

         \ Reserve space for a field in a structure
: CField ( n size <word> -- n' )   Create over ,  +
  does>  ( {obj} -- 'field )       @ class+ ;

         \ Allocate a new empty region in memory
: Struct ( size <word> -- {obj} ) Create  here @class  allot
  does>  ( -- {obj} )             0 swap @obj ;
         \ Copy of an existing object
: Copy   ( n {obj} -- {obj1} )    Create here swap  class swap cmove,  @class
  does>  ( -- {obj} )             0 swap @obj ;


\ == Text files ==

: TStream ( <word> -- {tstream} )   textfile0 /textfile Copy ;

: ?open-error  errno @ abort" could not open file" ;
: read-file ( str {tstream} -- )
  file-open ?open-error  file-ref ref!  do-stream ;


\ init.mind is not a normal word:
: tstream-body> ( tstream -- xt )
  dup init.mind =  IF drop  ['] init.mind ELSE body> THEN ;

: .tstream-name ( {tstream} -- )   class tstream-body> .name ;
: .tstream      ( {tstream} -- )
  .tstream-name
  'infile-name @  ?dup IF [char] = emit  puts THEN  [char] : emit
  'line# @ .
  'infile @  IF ." (open) "  THEN ;


\ == Line Streams ==

/lines Struct @stdin   ' lines-get  'get !
  ' lines-i    'i !
  ' lines-i?   'i? !
    stdin      'infile !
    here       'infile-name !  ," <stdin>"
    0          'current !
    0          'line# !


\ == Text Streams and String Streams ==

: Stream ( <word> -- {stream} )   /stream Struct ;

/stream
  /cell CField str-pointer      \ Address of the current character
Constant /stringstream

: str-get   ( -- )        1 str-pointer +! ;
: str-i     ( -- char )   str-pointer @ c@ ;
: str-i?    ( -- flag )   str-i 0<> ;

/stringstream Struct @stringstream
  ' str-get  'get !
  ' str-i    'i !
  ' str-i?   'i? !

: Stringstream ( <word> -- {stream} )  @stringstream /stringstream Copy ;

: str-interpret ( str {stream} -- )
  file-ref ref!  str-pointer !  do-stream ;


\ == Command interpreter ==

Stringstream @line        \ The current input line

: interactive? ( -- flag )    arg-interactive @  argc 0= and ;

: do-lines    BEGIN ." ok" cr
                { @stdin get i? } WHILE
                { @stdin i } @line str-interpret REPEAT ;
: ?do-lines   interactive? IF do-lines THEN ;

: command-interpret    clear-rstack clearstack @oclear  ?do-lines  bye ;
' command-interpret is abort


\ == Boot sequence ==

TStream @bootfile               \ File that is read as first command parameter

: ?bootfile      argc IF argv @  @bootfile read-file THEN ;
: ?bootmsg       interactive? IF space ." . o ( mind )" cr THEN ;
: ?do-cmdline    arg-cmdline @ 0;  @line str-interpret ;

: do-boot   ?bootfile ?bootmsg ?do-cmdline  abort ;
' do-boot is boot


\ == Debug and Display ==

\ Number of entries on the stack
: depth ( -- n )    sp@  s0 @  swap -  /cell / ;

: ?stack            depth 0< abort" Stack empty" ;

: .s                            \ print content of stack
  ?stack  sp@ >r  s0 @  BEGIN cell-  dup r@ u>= WHILE  dup @ h. REPEAT
  drop rdrop ;

: words   last  BEGIN @  ?dup WHILE  dup link> .name space  REPEAT ;