boot_fs

( boot_fs )

( This file is part of Sfera, a library for SuperForth )
( http://programandala.net/en.program.sfera.html )

( Author: Marcos Cruz [programandala.net] )

( ============================================================ )
( License )

( You may do whatever you want with this work, so long as you )
( retain the copyright/authorship/acknowledgment/credit )
( notice[s] and this license in all redistributed copies and )
( derived works.  There is no warranty. )

( ============================================================ )
( History )

( Development history of Sfera: )
( http://programandala.net/en.program.sfera.history.html )

( History of this file: )
( See at the end of the file. )

( ============================================================ )
( Requirements )

( Devices configuration during the development: )

( win1_BLK1 = boot block, which loads this file )
( dev4_     = directory of Sfera )
( dev5_     = directory of Sfera binaries )

( ============================================================ )

LOWER  ( case-insensitive mode )

forth definitions

: sfera  ( -- ca )  read" 0.3.0+201602121620"  ;

: .sfera  ( -- )  ." Sfera v" sfera count type  ;

( ========================================================== ; )
( : Basic stock words )

: noop  ( -- )  ;

: \  ( "ccc<eol>" -- )  10 word drop  ;  immediate
  \ Ignore the rest of the input stream line.

: only  ( -- )  forth  ;
: also  ( -- )  ; immediate
  \ XXX TMP
  \ SuperForth lacks vocabulary search order, and vocabularies
  \ are chained to the vocabulary they were created in, so these
  \ fake temporary definitions are compatible with the real
  \ ones.

\ XXX TMP
\ : get-current  ( -- wid )  current @  ;
\ : set-current  ( wid -- )  current !  ;

: invert  ( x1 -- x2 )  -1 xor  ;

: executing?  ( -- f )  state @ 0=  ;
: compiling?  ( -- f )  executing? 0=  ;

: 0<>  ( x -- f )  0 <>  ;
  \ XXX TODO in assembly

: 2,  ( x1 x2 -- )  , ,  ;

: d->s  ( d -- n )  drop  ;

\ code d->s  ( d -- n )
\   341B  ,   \ move.w (a3)+,d2
\   next,
\   end-code

: bl-word  ( "name" -- ca )  bl word  ;

: compile,  ( cfa -- )  ,  ;

: defined  ( "name" -- ca 0 | cfa 1 | cfa -1 )  bl-word find  ;

: postpone  ( "name" -- )
  defined dup 0= 0 ?error  (  cfa 1 | cfa -1 )
  -1 = if    compile compile  \ non-immediate
       then  compile,
  ; immediate

: move  ( a1 a2 u -- )
  ?dup if
    >r 2dup u< if  r> cmove>  else  r> cmove  then
  else  2drop  then  ;
  \ XXX TODO test

: place  ( ca1 len1 ca2 -- )  2dup c! 1+ swap move  ;

\ ============================================================ ;
\ : Number prefixes

: adjust-number  ( d -- d | n )  dpl @ -1 = if  d->s  then  ;

: numeric-prefix  ( b "name" -- )
  create c, immediate
  does>  ( "name" -- d | n ) ( pfa )
    base @ >r  c@ base !
    bl-word number adjust-number postpone literal
    r> base !  ;
  \ Create a numeric prefix "name" for radix _n_.
  \ XXX FIXME `number` fails with lowercase hex numbers.

 2 numeric-prefix b# ( "name" -- n )
10 numeric-prefix d# ( "name" -- n )
16 numeric-prefix h# ( "name" -- n )

\ ============================================================ ;
\ : Address arithmetic

: +origin  ( n -- a )  32768 +  ;
  \ Leave the address relative by _n_ to the origin of
  \ the SuperForth code.
  \
  \ Origin: fig-Forth.

: aorigin  ( -- da )  32776 2@  ;
  \ Absolute address of SuperForth location 32768.

: >a  ( a -- da )  32768 - s->d aorigin d+  ;
  \ Convert address _a_ to absolute address _da_.

: cell  ( -- n )
  2 compiling? if  [compile] literal  then  ; immediate

: cell+  ( a1 -- a2 )
  compiling? if  compile 2+  else  2+  then  ; immediate

: cell-  ( a1 -- a2 )
  compiling? if  compile 2-  else  2-  then  ; immediate

: cells  ( a1 -- a2 )
  compiling? if  compile 2*  else  2*  then  ; immediate

: chars  ( ca1 -- ca2 )  ; immediate

: char+  ( ca1 -- ca2 )
  compiling? if  compile 1+  else  1+  then  ; immediate

: char-  ( ca1 -- ca2 )
  compiling? if  compile 1-  else  1-  then  ; immediate

: aligned  ( a -- a' )
  [ cell 1 - dup ] literal + [ invert ] literal and  ;
  \ Credit: Code adapted from eForth.

: dp  ( -- a )  h# 88D0 execute  ;
  \ In SuperForth, `dp` is a headerless word whose cfa is $88D0.
  \ This word makes `dp` visible and usable.

: align   ( -- )  here aligned dp !  ;

\ ============================================================ ;
\ : Word headers

: traverse  ( ca1 n -- ca2 )
  swap  begin  over + 127 over c@ <  until
  swap drop  ;
  \ Move across a name field.  _ca1_ is the address of either the
  \ length byte or the last letter.  If _n_=1, the motion is
  \ toward hi memory; if _n_=-l, the motion is toward low
  \ memory.  _ca2_ is the address of the other end
  \ of the name.
  \
  \ Origin: fig-Forth.

: >name       ( cfa -- nfa )
  1- dup c@ 128 and 0= +  \ skip a possible padding
  -1 traverse  ;
  \ XXX FIXME improve: skip any number of padding bytes,
  \ because some new names of original words will be shorter.

: name>       ( nfa -- cfa )  1 traverse 1+ aligned  ;

: name>link   ( nfa -- lfa )  cell-  ;
: name>body   ( nfa -- pfa )  name> >body  ;
: >link       ( cfa -- lfa )  >name name>link  ;
: link>name   ( lfa -- nfa )  cell+  ;
: link>       ( lfa -- ffa )  link>name name>  ;
: body>       ( pfa -- cfa )  cell-  ;
: body>name   ( pfa -- nfa )  body> >name  ;
: body>link   ( pfa -- lfa )  body>name name>link  ;

64 constant immediate-mask
: immediate?  ( cfa -- f )  >name c@ immediate-mask and 0<>  ;

31 constant /name
  \ Maximum length of a word name, also used as bitmask.

: (name>length)  ( nfa -- len len len' )
  dup >r c@ /name and dup  ( len len )
                   r> dup  ( len len nfa nfa )
  1 traverse - abs  ;
  \ Get the actual length _len_ from _nfa_,
  \ and the length _len'_ calculated by `traverse`.
  \ This word is a common factor used for error checking.

: name>length?  ( nfa -- f )
  (name>length) = swap 0<> and  ;
  \ Is the length of _nfa_ valid?

: name>length  ( nfa -- len )
  (name>length) <> abort" Invalid name field"
                dup 0= abort" Name empty"  ;

create name /name 1+ allot
0 name c!  name 1+ /name blank
  \ Name buffer.

: clean-name-bound  ( ca -- )  dup c@ 127 and swap c!  ;
  \ Reset bit 7 of the byte hold in _ca_.
  \ XXX TODO make this word generic

: clean-name  ( -- )
  name dup dup 1+ clean-name-bound
             c@ + clean-name-bound  ;
  \ Reset 7 from the bounds of the name stored in the name buffer.

: name>string  ( nfa -- ca len )
  dup name>length dup name c! >r
  1+ name 1+ r@ cmove  clean-name  name 1+ r>  ;

: .name  ( nfa -- )  name>string type  ;

: link>link?  ( lfa1 -- lfa2 true | 32768 false )
  @ dup 32768 <>  ;
  \ Convert _lfa1_ to its linked _lfa2_ and _true_; else return
  \ _32768_ (which marks the end of links) and _false_.

\ ============================================================ ;
\ : Assembler

vocabulary assembler  assembler definitions

variable abase     \ backup of `base`
variable acontext  \ backup of `context`  \ XXX TMP

: asm  ( -- )
  \ !csp  \ XXX TODO
  base @ abase !  context @ acontext !  hex assembler  ;
  \ Start assembler mode.

: end-asm  ( -- )
  \ ?csp  \ XXX TODO
  abase @ base !  acontext @ context !  ;
  \ End assembler mode.

: next,  ( -- )
  [ base @ hex ]
  3219 ,            \ move.w   (a1)+,d1       ; d1 = cfa of next word
  3A72 , 1000 ,     \ movea.w  0(a2,d1.w),a5  ; a5 = address of its code
  4EF2 , D000 ,     \ jmp      0(a2,a5.w)     ; execute the code
  [ base ! ]  ;
  \ Compile the code of next.

forth definitions assembler

: create-code  ( "name" -- )  create  here dup body> !  ;
  \ Create a header for a code word.

: code  ( "name" -- )  create-code [ assembler ] asm  ;
  \ Define a code word "name".

: end-code  ( -- )  [ assembler ] end-asm  ;
  \ End the definition of a code word.

forth

\ ============================================================ ;
\ : Stacks

\ : nip  ( x1 x2 -- x2 )  swap drop  ;

code nip  ( x1 x2 -- x2 )
  D7FC , 0000 , 0002  ,  \ adda.l #2,a3
  next,
  end-code

\ : tuck  ( x1 x2 -- x2 x1 x2 )  swap over  ;

code tuck  ( x1 x2 -- x2 x1 x2 )
  3013 ,  \ move.w (a3),d0   ; x1 -> d0
  3682 ,  \ move.w d2,(a3)   ; x2 -> NOS
  3700 ,  \ move.w d0,-(a3)  ; push x1
  next,
  end-code

code rdrop  ( R: x -- )
  D9FC , 0000 , 0002 ,  \ adda.l #2,a4
  next,
  end-code

code 2rdrop  ( R: x1 x2 -- )
  D9FC , 0000 , 0004 ,  \ adda.l #4,a4
  next,
  end-code
  \ XXX TODO move to its own file

: bounds  ( ca len -- ca2 ca )  over + swap  ;

: 2>r  ( x1 x2 -- ) ( R: -- x1 x2 )
  r> r> 2swap swap >r >r >r >r  ;
  \ XXX TODO in assembly

: 2r>  ( -- x1 x2 ) ( R: x1 x2 -- )
  r> r> r> r> swap 2swap >r >r  ;
  \ XXX TODO in assembly

\ ============================================================ ;
\ : Flags

 0 dup constant false
   dup constant [false] immediate
0= dup constant true
       constant [true] immediate

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

\ ============================================================ ;
\ : : Parsing

: loading?  ( -- f )  blk @ 0<>  ;
  \ Is the current input stream a block?

: refill ( -- f )
  loading? if    1 blk +!  >in off
           else  query
           then  true  ;
  \ Fill the input buffer from the input source.

: refill-word  ( -- ca )
  begin  bl-word  dup length 0=  while
    drop refill drop
  repeat  ;
  \ Parse the next word from the input stream,
  \ refilling the input buffer if necessary.

\ ============================================================ ;
\ Counted strings

\ ----------------------------------------------
\ SuperForth counted strings

\ SuperForth stores the maximum length of counted strings before
\ the length byte. These words work with these format.

: string!  ( ca1 len1 ca2 -- )
  2dup max_len > 23 ?error  \ string too long?
  place  ;
  \ Store string _ca1 len1_ into counted string _ca2_,
  \ created by `string` or `noname-string`.

: string,  ( ca1 len1 -- ca2 )
  dup c,  \ max length
  here >r dup 1+ allot r@ string! r>  ;
  \ Compile a string _ca1 len1_ and return its address.

: noname-string  ( n -- ca )
  2+ here 1+ swap allot  ;
  \ Create a string without name, with a maximum length _n_,
  \ and return the address of its length byte.

: string+  ( ca1 ca2 -- )  swap append  ;
  \ Concatenates strings _ca1_ and  _ca2_; _ca2_ is appended
  \ to the end of _ca1_.

\ ----------------------------------------------
\ Ordinary counted strings

\ The words defined in this section work with any counted
\ string, even with SuperForth's format.

: different-lengths?  ( ca1 ca2 -- f )
  length swap length <>  ;

: $.  ( ca -- )  count type  ;

\ SuperForth's `$=` and `$==` work only with its own format of
\ counted strings, which have the maximun length stored before
\ the length byte; the following alternatives work also with
\ ordinary counted strings.

: $$=  ( ca1 ca2 -- f )
  2dup different-lengths? if  2drop false exit  then
  1 0 locate ( 1 | 0 ) negate  ;
  \ Case-sensitive comparison of counted strings.
  \ Note: SuperForth's `$=`, works only with counted
  \ strings which have its maximun length stored
  \ before the length byte; this alternative works
  \ also with ordinary counted strings.

: $$==  ( ca1 ca2 -- f )
  2dup different-lengths? if  2drop false exit  then
  1 1 locate ( 1 | 0 ) negate  ;
  \ Case-insensitive comparison of counted strings.

\ ============================================================ ;
\ : Conditional compilation

: [else]  ( "..." -- )
  1 begin refill-word dup read" [if]" $$==
    if    drop 1+
    else  dup read" [else]" $$==
      if    drop 1- dup if  1+  then
      else  read" [then]" $$== if  1-  then
      then
    then
  ?dup 0= until  ; immediate

: [if]  ( f "..." -- )  0= if postpone [else] then  ; immediate

: [then]  ( -- )  ; immediate

: [undefined]  ( "name" -- f )  defined nip 0=  ; immediate
  \ Is "name" undefined?

: [defined]  ( "name" -- f )  [compile] [undefined] 0=  ; immediate
  \ Is "name" defined?

\ ============================================================ ;
\ : Parsing and compiling

: parse-word  ( "name" -- ca len )  bl-word count  ;

: c#  ( "name" -- c )
  parse-word drop c@
  compiling? if  postpone literal  then  ; immediate
  \ Parse a name and return the code of the its first
  \ character. This is an alternative to the standard words
  \ `char` and `[char]`.

[defined] char [if]
  ' char ' forth-83 u<  [if]  \ original `char`?

    ' char >name
    c# R over 3 + c!
    c# @ b# 10000000 or swap 4 + c!
      \ Rename `char` to `chr@`.

    : char    ( "name" -- c )  bl-word 1+ c@  ;
    : [char]  ( "name" -- c )  char postpone literal  ; immediate

  [then]
[then]

\ ============================================================ ;
\ : Text output

: home  ( -- )  0 0 at  ;

\ ============================================================ ;
\ Circular string buffer

\ Credit:
\ http://programandala.net/en.program.csb8.html

1024 constant /csb  \ buffer size

/csb create csb-unused ,          \ unused buffer space
here  /csb allot  constant csb0   \ bottom address

: ?csb  ( len -- )
  dup csb-unused @ > if  /csb csb-unused !  then
  negate csb-unused +!  ;
  \ Make sure there's room for the given characters.
  \ XXX TODO -- rewrite, make it faster

: string-allocate  ( len -- ca )
  ?csb csb0 csb-unused @ +  ;

: save-string  ( ca1 len1 -- ca2 len1 )
  dup string-allocate swap  2dup 2>r  move  2r>  ;

: save-counted-string  ( ca1 len1 -- ca2 )
  dup 1+ string-allocate dup >r place r> ;

\ ============================================================ ;
\ Standard-format strings

: s,  ( ca len -- )
  dup c, tuck here swap cmove allot align  ;
  \ Compile a string.

: slit  ( -- ca len )  h# 8840 execute  ;
  \ Return the string which is compiled after the calling word,
  \ and adjust the instruction pointer to step over the string.
  \ In SuperForth, `slit` is a headerless word whose cfa is
  \ $8840, and it's used only by `."`. This word makes `slit`
  \ visible and usable.

: sliteral  ( ca len -- )  compile slit s,  ; immediate

: (s)  ( compilation: ca len -- )
       ( run-time: ca len -- ca2 len )
  compiling? if  postpone sliteral  else  save-string  then  ;

: parse-string  ( compilation: c "ccc<c>" -- )
                ( run-time: -- ca len )
  word count (s)  ;

: s"  ( "ccc<quote>" -- ca len )  c# " parse-string  ; immediate

: lengths  ( ca1 len1 ca2 len2 -- ca1 len1 ca2 len2 len1 len2 )
  2 pick over  ;

: smove ( ca1 len ca2 -- )  swap move  ;

: s+  ( ca1 len1 ca2 len2 -- ca3 len3 )
  lengths + >r            ( ca1 len2 ca2 len2 ) ( R: len3 )
  r@ string-allocate >r   ( R: len3 ca3 )
  2 pick r@ +             ( ca1 len1 ca2 len2 len1+ca3 )
  smove                   ( ca1 len1 )  \ second string to buffer
  r@ smove                \  first string to buffer
  r> r>  ;
  \ Append string _ca2 len2_ to the end of string _ca1 len1_
  \ returning string _ca3 len3_ in the circular string buffer.

: uppercase  ( ca len -- )
  ?dup  if    bounds do  i c@ up_char i c!  loop
        else  2drop  then  ;
  \ Convert string _ca len_ to uppercase.

\ ============================================================ ;
\ : Hacks

\ ----------------------------------------------
\ Modify `.s`

\ `.s` executes `cr` at the start and at the end, but the word
\ is more versatile without those carriage returns, for example
\ in order to integrate it into debugging code, so we replace
\ those `cr` with `noop`:

' noop dup 41576 ! 41626 !

\ ============================================================ ;
\ : Control structures

: ?pairs  ( -- )  ?comp h# 930E compile,  ; immediate
  \ Compile the cfa of `?pairs` (which is headerless).

: again  ( -- )  ?pairs postpone branch <resolve  ; immediate

code unloop  ( R: loop-sys -- )
  D9FC , 0000 , 0004 ,  \ adda.l #4,a4
  next,
  end-code

\ XXX OLD
\ : throw  ( n -- )  ?dup if  abs 1- error  then  ;
  \ XXX TODO

\ : ?os-error  ( n -- )  h# 9860 execute  ;  \ XXX OLD
: ?os-error  ( n -- )  dup ?error  ;  \ XXX NEW -- simpler
  \ Issue OS error _n_ if it's non-zero.
  \ In SuperForth, this word is headerless.

: default-errors  ( -- )  assign error to-do (error)  ;

\ ============================================================ ;
\ : Number output

: binary  ( -- )  2 base !  ;

\ : hex.  ( n -- )  base @ >r  hex u. r> base !  ;
  \ XXX OLD -- SuperForth has `h.`

: bin.  ( n -- )  base @ >r  binary u. r> base !  ;

: (d.)  ( d n -- ca len )  <# 0 do  #  loop  #>  ;

variable base'

: <hex  ( -- )  base @ base' ! hex  ;  \ switch to hex
: hex>  ( -- )  base' @ base !      ;  \ and back

: (dhex.)  ( d n -- )  <hex (d.) hex> type space  ;

: 32hex.   ( d -- ) 8 (dhex.)  ;
: 16hex.   ( n -- ) s->d 4 (dhex.)  ;
: 8hex.    ( b -- ) s->d 2 (dhex.)  ;

: <bin  ( -- )  base @ base' ! binary  ;  \ switch to binary
: bin>  ( -- )  base' @ base !         ;  \ and back

: (dbin.)  ( d n -- )  <bin (d.) bin> type space  ;

: 32bin.   ( d -- ) 32 (dbin.)  ;
: 16bin.   ( n -- ) s->d 16 (dbin.)  ;
: 8bin.    ( b -- ) s->d 8 (dbin.)  ;

\ XXX TODO move to files.
\ (`8bin` is used in `dot_keyrows_fs`)

\ ============================================================ ;
\ : Keyboard

\ XXX TODO move all this to independent files

: real-key  ( -- c )
  ['] #default h# A122 !  ['] noop h# A124 !  \ patch `key`
  key
  ['] #in h# A122 !  ['] 2@ h# A124 !  ;  \ unpatch `key`
  \ Get a real key from the the keyboard (actually from the
  \ default input-output channel), not from the current input
  \ channel. This word is useful for reading the keyboard while
  \ the input channel has been redirected to a file.

: control-key?  ( -- f )  7 keyrow b# 00000010 and 0<>  ;
: shift-key?    ( -- f )  7 keyrow b# 00000001 and 0<>  ;
: alt-key?      ( -- f )  7 keyrow b# 00000100 and 0<>  ;
: space-key?    ( -- f )  1 keyrow b# 01000000 and 0<>  ;
: escape-key?   ( -- f )  1 keyrow b# 00001000 and 0<>  ;
: enter-key?    ( -- f )  1 keyrow b# 00000001 and 0<>  ;
: tab-key?      ( -- f )  5 keyrow b# 00001000 and 0<>  ;

: break-key?  ( -- f )  control-key? space-key? and  ;

: key?  ( -- f )  0  8 0 do  i keyrow or  loop  0<>  ;
  \ Is any key pressed (including modifiers)?

: no-key  ( -- )  begin  key? 0=  until  ;
  \ Wait until no key is pressed (including modifiers).

: timeout!  ( n -- )  [ ' timeout >body ] literal !  ;
  \ Store _n_ into the constant `timeout`.

: inkey  ( -- c )
  timeout >r  1 timeout! key  r> timeout!  ;
  \ Key the pressed key, if any (without waiting for a key
  \ press).
  \ XXX FIXME

: aborted?  ( c -- f )
  key? if  no-key key =  else  drop false  then  ;
  \ If no key is pressed return _false_.  If a key is pressed,
  \ discard it and wait for a second key. Then return _true_ if
  \ it's _c_, else return _false_.
  \ XXX OLD

  \ Usage example:
  \
  \ : listing  ( -- )
  \   begin  ." bla "  bl aborted?  until  ." Aborted"  ;

10 constant 'cr'  \ code of carriage return
  \ XXX OLD

: nuf?  ( -- f )  'cr' aborted?  ;
  \ XXX OLD

: wait-space-key-pressed  ( -- )  begin  space-key? 0=  until  ;

: wait-space-key-released  ( -- )  begin  space-key?  until  ;

: space-paused  ( -- )
  space-key? if
    wait-space-key-pressed
    wait-space-key-released
    wait-space-key-pressed
  then  ;

: wait-enter-key-pressed  ( -- )  begin  enter-key? 0=  until  ;

: wait-enter-key-released  ( -- )  begin  enter-key?  until  ;

: enter-paused  ( -- )
  enter-key? if
    wait-enter-key-pressed wait-enter-key-released
    wait-enter-key-pressed
  then  ;

\ ============================================================ ;
\ : Tools

: ~~  ( -- )  cr .s key drop  ;

[defined] unused [if]
 
  ' unused ' forth-83 u<  [if]  \ original `unused`?

    ' unused >name
    c# S over 1 + c!
    c# P over 2 + c!
    c# A over 3 + c!
    c# R swap 4 + c!
      \ Rename `unused` to `spared`.

    : unused  ( -- u )  31739 here -  ;
      \ Free bytes in the data space.
      \ 31739 is the address of the block buffer.

  [then]
[then]

: find-cfa  ( cfa -- )
  latest ( lfa )
  begin
    dup link> 16hex. dup id. space space-paused
    link>link? 0=  escape-key? or
  until  drop  ;
  \ XXX TODO

: .n  ( cfa -- )  >link id.  ;

\ ============================================================ ;
\ : Windows

\ Note: The main window can not be changed during interpretation
\ of a file, because `#in` is used to redirect the file being
\ interpreted to the keyboard (see section 10.1 of the
\ SuperForth manual).

exvec: default-colors  ( -- )

: (default-colors)  ( -- )
  0 paper 4 ink 0 strip 0 set_mode 2 1 csize 2 1 border  ;

assign default-colors to-do (default-colors)

default-colors 

: set-window  ( d -- )  2dup #in 2! #out 2!  ;
  \ Make channel _d_ the current window.

: set-default-channel  ( d -- )  ['] #default >body 2!  ;
  \ Make channel _d_ the default main window,
  \ which is restored after an error.

: window  ( d "name" -- )
  2constant
  does>  ( -- ) ( pfa )  2@ set-window  ;
  \ Create a word called "name" which, when executed,
  \ will set channel _d_ as the current window.

: set-main-window  ( d -- )
  2dup set-window set-default-channel default-colors cls  ;
  \ Make channel _d_ the main window.

: main-window  ( d "name" -- )
  2constant
  does>  ( -- ) ( pfa )
    2@ set-main-window  ;
  \ Create a word called "name" which, when executed,
  \ will set channel _d_ as the main window.

\ ============================================================ ;
\ : Devices

: create-device  ( "name" -- )
  create
    latest 5 + @                \ get characters 3 and 4
    dup b# 111111 and c# 0 - ,  \ compile device number
    ,                           \ compile characters 3 and 4
    latest 3 + @ ,              \ compile characters 1 and 2
  does>  ( -- ) ( pfa )
    >r r@ @                     \ device number
    r@ cell+ @                  \ characters 3 and 4
    r> [ 2 cells ] literal + @  \ characters 1 and 2
    \ ." sdv parameters: " .s  cr  \ XXX INFORMER
    sdv  ;
  \ Create a new default device "name" (e.g. "win1_" which, when
  \ executed, will be set as the default one.
  \
  \ Credit: Original code by Gerry Jackson, included with
  \ SuperForth 2.0, 1985. Modified.

\ ============================================================ ;
\ Boot

exvec: boot-device

: closing-error  ( n -- )
  dup -6 =  \ channel not open?
  if  drop  else  (error)  then  ;

: catch-close-error  ( -- )
  assign error to-do closing-error  ;

: boot  ( -- )
  catch-close-error
  #print 2@ close  #file 2@ close
  default-errors
  boot-device  cold  ;
  \ Boot the system.
  \ XXX FIXME `fence` is restored by `cold`

\ ============================================================ ;
\ : Values

: value  ( n "name"  -- )  constant  ;

: to  ( Interpretation: n "name" -- )
      ( Compilation: "name" -- )
  ' >body compiling? if    postpone literal  postpone !
                     else  !  then  ; immediate

\ ============================================================ ;
\ : xstack

\ Credit: Code adapted from Solo Forth
\ (http://programandala.net/en.program.solo_forth.html).

\ Creation and manipulation of xstacks

0 value xsize   \ size in address units (constant)
0 value xp      \ address of the xstack pointer (variable)
0 value xp0     \ initial value of the xstack pointer (constant)
  \ Values of the current xstack.

: xstack  ( n "name" -- )
  create
    cells dup  \ size
    here [ 3 cells cell- ] literal + dup  \ bottom and top
    ( size size top bottom ) , , ,  allot
  does> ( -- )
    ( pfa ) dup @ to xp0  cell+ dup to xp  cell+ @ to xsize  ;
  \ Create a new xstack "name" of _n_ cells, which, when
  \ executed, will become the current one.

: xp@  ( -- a )  xp @  ;

: xp!  ( a -- )  xp !  ;

: xp+!  ( n -- )  xp +!  ;

: xclear  ( -- )  xp0 xp!  ;

\ xstack single-number operations

: >x  ( x -- ) ( X: -- x )  cell xp+!  xp@ !   ;

: x@  ( -- x ) ( X: x -- x )  xp@ @  ;

: xdrop  ( X: x -- )  [ cell negate ] literal xp+!  ;

: x>  ( -- x ) ( X: x -- )  x@ xdrop  ;

: xdup  ( X: x -- x x )  x@ >x  ;

: xpick  ( n -- x'n ) ( X: x'n ... x'0 -- x'n ... x'0 )
  xp@ swap cells - @  ;

: xover  ( X: x1 x2 -- x1 x2 x1 )  1 xpick >x  ;

\ xstack double-number operations

: 2x@  ( -- x1 x2 ) ( X: x1 x2 -- x1 x2 )  x@ 1 xpick swap  ;

: 2>x  ( x1 x2 -- ) ( X: -- x1 x2 )  swap >x >x  ;

: 2x>  ( -- x1 x2 ) ( X: x1 x2 -- )  x> x> swap  ;

: 2xdrop  ( X: x1 x2 -- )  [ -2 cells ] literal xp+!  ;

: 2xdup  ( X: x1 x2 -- x1 x2 x1 x2 )  xover xover  ;

\ xstack tools

: xlen  ( -- n )  xp@ xp0 -  ;
  \ Length of the current xstack, in address units.

: xdepth  ( -- n )  xlen cell /  ;
  \ Depth of the current xstack.

: xdepth.  ( -- )  ." <"  s->d <# #s #> type  ." > "  ;

: (.x)  ( -- )  xp0 cell+ xlen bounds do  i @ . cell +loop  ;
  \ Display a list of the items in the xstack; TOS is the right-most item.

: .x  ( -- )  xdepth dup xdepth. if  (.x)  then  ;
  \ Display the number of items on the current xstack,
  \ followed by a list of the items, if any; TOS is the right-most item.

\ ============================================================ ;
\ : String list

\ Credit: Code based on Gforth's public-domain file
\ <compat/required.fs>. Modified to use SuperForth's counted
\ strings.

: string>list ( ca a -- )
  \ cr ." string>list" .s key drop  \ XXX INFORMER
  here >r
  dup @ ,     \ point this node to the previous one
  r> swap !   \ point the list to this node
  ,  ;        \ point to the string
  \ Add string _ca_ to the list pointed by _a_.

exvec: string=  ( ca1 ca2 -- f )
  \ Compare two strings.

assign string= to-do $$==
  \ Case-insensitive comparison by default.

: string-listed? ( ca a -- f )
  @ swap >r
  begin  ( a' ) ( R: ca )  dup  while
    dup cell+ @
    r@ string= if  drop rdrop true exit  then  @
  repeat  drop rdrop false  ;
  \ Is the filename stored in _ca_ in the list pointed by _a_?

: ?string>list  ( ca a -- )
  2dup string-listed? if  2drop  else  string>list  then  ;
  \ Add string _ca_ to the list pointed by _a_, if the string
  \ is not already in the list.

exvec: item-separator  ( -- )
: item-separator-cr  ( -- )  assign item-separator to-do cr  ;
: item-separator-bl  ( -- )  assign item-separator to-do bl  ;
item-separator-cr

: .list  ( a -- )
  begin  @ dup  while
    dup cell+ @ $. item-separator
  repeat  drop  ;
  \ Print the contents of list pointed by _a_.

\ ============================================================ ;
\ : Files

\ File access methods
0 constant old-exclusive
1 constant old-shared
2 constant new-exclusive
3 constant directory

: file-exists?  ( ca len -- f )
  save-counted-string device_status -8 =  ;

\ ============================================================ ;
\ : Paths

5 constant /device
  \ Maximum length of a device.

36 constant /filename
  \ Maximum length of a filename.

/device /filename + string filename
  \ A temporary string variable which holds the current filename.

: filename!  ( ca len -- )  filename string!  ;

9 constant paths
  \ Paths in the table. Path 0 is supposed to be always empty,
  \ thus representing the filename as is. This makes the code
  \ a bit simpler. Paths 1..8 can be configured by the user.
2 cells constant /path
  \ Bytes per path item in the table.
paths /path * constant /paths-table
  \ Length of the paths table.

create paths-table  /paths-table allot  \ paths table

: erase-paths  ( -- )  paths-table /paths-table erase  ;
erase-paths

: >path-address  ( n -- a )  /path * paths-table +  ;
  \ Return address _a_ of path number _n_.

: path!  ( ca len n -- )  >path-address 2!  ;
: path@  ( n -- ca len )  >path-address 2@  ;

: copy-paths  ( a1 a2 -- )
  [ paths 2- /path * ] literal  move  ;
  \ Copy all paths from _a1_ to _a2_.

: also-path  ( -- )
  [ 1 >path-address ] literal    \ origin
  [ 2 >path-address ] literal    \ destination
  copy-paths  ;
  \ Copy all paths from path 1 to path 2.
  \ The first two paths become identical.
  \ The last path is lost.

: previous-path  ( -- )
  [ 2 >path-address ] literal    \ origin
  [ 1 >path-address ] literal    \ destination
  copy-paths  ;
  \ Copy all paths from path 2 to path 1.
  \ Path 1 is lost.
  \ The last two paths become identical.

: >path  ( ca len -- )  also-path 1 path!  ;
  \ Add path _ca len_ to the top of the paths list.
  \ The last path is lost.

: pathed  ( ca len -- ca' len' )
  paths 0 do 
    i path@ 2over s+
    2dup file-exists? if    2swap 2drop unloop exit
                      else  2drop  then
  loop  ;

: .paths  ( -- )  paths 0 do  i . i path@ type cr  loop  ;

\ ============================================================ ;
\ : Source files

8 constant include-levels
include-levels 2 * xstack include-stack
  \ Stack for the included files.
  \ 2 cells per include level.

: default-prompt  ( -- )  assign prompt to-do ok  ;
: no-prompt       ( -- )  assign prompt to-do noop  ;

variable included-files  0 included-files !
  \ Pointer to the latest node of the list of included
  \ filenames.

: .included  ( -- )  included-files .list  ;

: included?  ( ca len -- f )
  pathed filename! filename included-files string-listed?  ;

: (filename>list)  ( ca1 len1 -- ca2 a )
  2dup filename! string, included-files  ;
  \ Store _ca1 len1_ into `filename`, save it and return
  \ its new address and `included-files`.

: ?filename>list  ( ca len -- ) (filename>list) ?string>list  ;
  \ Add _ca len_ to the list of included files, if not already
  \ there.

: filename>list  ( ca len -- ) (filename>list) string>list  ;
  \ Add _ca len_ to the list of included files.

exvec: including-error

: catch-eof-error  ( -- )
  assign error to-do including-error  ;

: including-mode-off  ( -- )  default-errors default-prompt  ;

: including-mode-on  ( -- )  catch-eof-error no-prompt  ;

: unnest-included  ( -- )
  2x> #file 2!  2x> 2dup #in 2!
  #default d= if  including-mode-off  then  ;

: including?  ( -- f )  include-stack xdepth 0<>  ;

: end-of-included  ( -- )
  end_file including-mode-on
  including? if  unnest-included  then  ;

: (including-error)  ( n -- )
  dup -10 =  \ end of file?
  if    drop end-of-included
  else  including-mode-off error  then  ;

assign including-error to-do (including-error)

: ?nest-included  ( -- )
  include-stack xdepth include-levels =
  abort" Too many nested included files"  ;

: nest-included  ( -- )
  ?nest-included
  #in 2@ 2>x  #file 2@ 2>x
  0 filename open_device 2dup #file 2! #in 2!
  including-mode-on  ;
  \ Note: `include-stack` has been already executed by
  \ `?nest-include`.

: included  ( ca len -- )
  pathed ?filename>list nest-included  ;

: include  ( "name" -- )  parse-word included  ;

: required  ( ca len -- )
  pathed 2dup included?
  if     2drop
  else   filename>list nest-included  then  ;

: require   ( "name" -- )  parse-word required  ;

\ ============================================================ ;
\ : User configuration

\ ----------------------------------------------
\ Devices

create-device win1_  \ location of BLK1
create-device dev4_  \ Sfera
create-device nfa4_  \ generic Forth sources
dev4_

assign boot-device to-do win1_
  \ Device of the SuperForth BLK1 boot block.

\ ----------------------------------------------
\ Printer

\ XXX TODO -- make this configurable and managed by `boot`

\ status nfa4_printout.txt ( ior )
\ \ file does not exist: ior = 0
\ \ file already exist: ior = -8 (other errors are ignored)
\ 0= abs 2* ( 0 | 2 )  \ calculate file access method
\ open nfa4_printout.txt #print 2!

old-exclusive open nfa4_printout.txt #print 2!

\ ----------------------------------------------
\ Windows

0 open con_512x256a0x0  2constant #512x256
0 open con_800x600a0x0  2constant #800x600
0 open con_1024x768a0x0 2constant #1024x768

 #512x256 main-window w512    ( -- )
 #800x600 main-window w800    ( -- )
#1024x768 main-window w1024   ( -- )

cr
.( Change the main window size with:)  cr
.( w512 w800 w1024) cr

\ w800

\ ----------------------------------------------
\ Paths

: default-paths  ( -- )
  erase-paths
  s" dev4_"     1 path!
  s" dev4_bin_" 2 path!
  s" nfa4_"     3 path!  ;

default-paths

\ ----------------------------------------------
\ Requirements

\ include decode_fs
\ include dump_fs

\ ============================================================ ;
\ : End

here fence !
\ XXX FIXME `fence` is restored by `cold`

cr .sfera

end_file

\ ============================================================ ;
\ : History

\ 2015-12-31: First version, as a boot for SuperForth.
\
\ 2016-01-01..2016-01-05: Many changes.
\
\ 2016-01-06: File splitted into the first modules: decode,
\ words, xwords, wdump. New: `$$=` and `$$==`, which allow to
\ fix `[else]`.
\
\ 2016-01-09: Factored the checking of name field lengths.
\ Moved `dump` to its own file.
\
\ 2016-01-09..2016-01-14: Many changes.
\
\ 2016-01-15: Moved `endcase` to its own file
\ <standard_endcase_fs>.
\
\ 2016-01-25: Some changes.
\
\ 2016-02-07: Wrote improved versions of `include` and related
\ words, which don't need `end-of-file`.
\
\ 2016-02-08: Removed the old versions of `include` and related
\ words, already deactivated with conditional compilation.
\
\ 2016-02-09: Reorganized. Added a circular string buffer.
\ Added `sliteral`, added `dp` , `align` , `move`. Finished
\ `s"`.
\
\ 2016-02-10: Added `slit`, Moved `dump-address`, `allocate` and
\ `save-mem` to their own files. Changed `uppercase` to expect
\ an address and a length. Finished the path system.
\ 
\ 2016-02-11: Simplified and improved the path system. Fixed
\ `set-default-channel`.

\ vim: filetype=superforthsfera