Revert "Merge branch 'master' of https://github.com/tehologist/forthkit"

This reverts commit acbc44b78e27995fbfcbced08e736113c335bc7d, reversing
changes made to 59ff3352d7cce3f7be728064c8fb9fcdc054f240.

: + UM+  DROP   ;
: CELLS  DUP +  ;
: CELL+  2   +  ;
: CELL- -2   +  ;
: CELL   2      ;
: BOOT     0 CELLS ;
: FORTH    4 CELLS ;
: DPL      5 CELLS ;
: SP0      6 CELLS ;
: RP0      7 CELLS ;
: '?KEY    8 CELLS ;
: 'EMIT    9 CELLS ;
: 'EXPECT 10 CELLS ;
: 'TAP    11 CELLS ;
: 'ECHO   12 CELLS ;
: 'PROMPT 13 CELLS ;
: BASE    14 CELLS ;
: tmp     15 CELLS ;
: SPAN    16 CELLS ;
: >IN     17 CELLS ;
: #TIBB   18 CELLS ;
: TIBB    19 CELLS ;
: CSP     20 CELLS ;
: 'EVAL   21 CELLS ;
: 'NUMBER 22 CELLS ;
: HLD     23 CELLS ;
: HANDLER 24 CELLS ;
: CONTEXT 25 CELLS ;
: CURRENT 27 CELLS ;
: CP      29 CELLS ;
: NP      30 CELLS ;
: LAST    31 CELLS ;
: STATE   32 CELLS ;
: SPP     33 CELLS ;
: RPP     34 CELLS ;
: TRUE -1 ;
: FALSE 0 ;
: BL 32 ;
: BS 8 ;
: =IMMED    3 ;
: =WORDLIST 2 ;
: IMMEDIATE =IMMED LAST @ CELL- ! ;
: HERE CP @ ;
: ALLOT CP @ + CP ! ;
: , HERE CELL ALLOT ! ;
: C, HERE 1 ALLOT C! ;
: +! SWAP OVER @ + SWAP ! ;
: COMPILE R> DUP @ , CELL+ >R ;
: STATE? STATE @ ;
: LITERAL COMPILE LIT , ; IMMEDIATE
: [ FALSE STATE ! ; IMMEDIATE
: ] TRUE STATE ! ; IMMEDIATE
: IF COMPILE 0BRANCH HERE 0 , ; IMMEDIATE
: THEN HERE SWAP ! ; IMMEDIATE
: FOR COMPILE >R HERE ; IMMEDIATE
: NEXT COMPILE next , ; IMMEDIATE
: BEGIN HERE ; IMMEDIATE
: AGAIN COMPILE BRANCH , ; IMMEDIATE
: UNTIL COMPILE 0BRANCH , ; IMMEDIATE
: AHEAD COMPILE BRANCH HERE 0 , ; IMMEDIATE
: REPEAT COMPILE BRANCH , HERE SWAP ! ; IMMEDIATE
: AFT DROP COMPILE BRANCH HERE 0 ,  HERE SWAP ; IMMEDIATE
: ELSE COMPILE BRANCH HERE 0 ,  SWAP HERE SWAP !  ; IMMEDIATE
: WHILE COMPILE 0BRANCH HERE 0 , SWAP ; IMMEDIATE
: EXECUTE >R ;
: @EXECUTE @ DUP IF EXECUTE THEN ;
: R@ R> R> DUP >R SWAP >R ;
: #TIB #TIBB @ ;
: TIB TIBB @ ;
: \ #TIB @ >IN ! ; IMMEDIATE
: ROT >R SWAP R> SWAP ;
: -ROT SWAP >R SWAP R> ;
: NIP SWAP DROP ;
: TUCK SWAP OVER ;
: 2>R SWAP R> SWAP >R SWAP >R >R ;
: 2R> R> R> SWAP R> SWAP >R SWAP ;
: 2R@ R> R> R@ SWAP >R SWAP R@ SWAP >R ;
: 2DROP DROP DROP ;
: 2DUP OVER OVER ;
: 2SWAP ROT >R ROT R> ;
: 2OVER >R >R 2DUP R> R> 2SWAP ;
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
: -2ROT 2ROT 2ROT ;
: 2NIP 2SWAP 2DROP ;
: 2TUCK 2SWAP 2OVER ;
: NOT DUP NAND ;
: AND NAND NOT ;
: OR NOT SWAP NOT NAND ;
: NOR OR NOT ;
: XOR 2DUP AND -ROT NOR NOR ;
: XNOR XOR NOT ;
: NEGATE NOT 1 + ;
: - NEGATE + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: D+ >R SWAP >R UM+ R> R> + + ;
: DNEGATE NOT >R NOT 1 UM+ R> + ;
: D- DNEGATE D+ ;
: 2! SWAP OVER ! CELL+ ! ;
: 2@ DUP CELL+ @ SWAP @ ;
: ?DUP DUP IF DUP THEN ;
: S>D DUP 0< ;
: ABS DUP 0< IF NEGATE THEN ;
: DABS DUP 0< IF DNEGATE THEN ;
: U< 2DUP XOR 0< IF SWAP DROP 0< EXIT THEN - 0< ;
: U> SWAP U< ;
: = XOR IF FALSE EXIT THEN TRUE ;
: < 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ;
: > SWAP < ;
: 0> NEGATE 0< ;
: 0<> IF TRUE EXIT THEN FALSE ;
: 0= 0 = ;
: <> = 0= ;
: D0< SWAP DROP 0< ;
: D0> DNEGATE D0< ;
: D0= OR 0= ;
: D= D- D0= ;
: D< ROT 2DUP XOR IF SWAP 2SWAP 2DROP < ;
: DU< ROT 2DUP XOR IF SWAP 2SWAP THEN THEN 2DROP U< ;
: DMIN 2OVER 2OVER 2SWAP D< IF 2SWAP THEN 2DROP ;
: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
: M+ S>D D+ ;
: M- S>D D- ;
: MIN 2DUP SWAP < IF SWAP THEN DROP ;
: MAX 2DUP < IF SWAP THEN DROP ;
: UMIN 2DUP SWAP U< IF SWAP THEN DROP ;
: UMAX 2DUP U< IF SWAP THEN DROP ;
: WITHIN OVER - >R - R> U< ;
: UM/MOD
    2DUP U<
    IF NEGATE
        15 FOR
            >R DUP UM+
                >R >R DUP UM+
                R> + DUP R> R@ SWAP
            >R UM+
            R> OR
                IF >R DROP 1+ R>
                ELSE DROP
            THEN R>
        NEXT DROP SWAP EXIT
    THEN DROP 2DROP -1 DUP ;
: M/MOD
    DUP 0< DUP >R
        IF NEGATE >R
            DNEGATE R>
        THEN >R DUP 0<
        IF R@ +
        THEN R> UM/MOD
    R>
    IF SWAP NEGATE SWAP THEN ;
: /MOD OVER 0< SWAP M/MOD ;
: MOD /MOD DROP ;
: / /MOD NIP ;
: UM*
    0 SWAP
    15 FOR
        DUP UM+ >R >R
        DUP UM+
        R> +
        R>
        IF >R OVER UM+
            R> +
        THEN
    NEXT
    ROT DROP ;
: * UM* DROP ;
: M*
    2DUP XOR 0< >R
    ABS SWAP ABS UM*
    R> IF DNEGATE THEN ;
: */MOD >R M* R> M/MOD ;
: */ */MOD SWAP DROP ;
: 2* 2 * ;
: 2/ 2 / ;
: MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
: D2* 2DUP D+ ;
: DU2/ 2 MU/MOD ROT DROP ;
: D2/ DUP >R 1 AND DU2/ R> 2/ OR ;
: ALIGNED DUP 0 2 UM/MOD DROP DUP IF 2 SWAP - THEN + ;
: parse
    tmp ! OVER >R DUP
    IF
        1- tmp @ BL =
        IF
            FOR BL OVER C@ - 0< NOT
            WHILE 1+
                NEXT R> DROP 0 DUP EXIT
            THEN R>
        THEN
            OVER SWAP
        FOR tmp @ OVER C@ - tmp @ BL =
            IF 0< THEN
        WHILE 1+
        NEXT DUP >R
        ELSE R> DROP DUP 1+ >R
        THEN OVER - R> R> - EXIT
    THEN OVER R> - ;
: PARSE >R TIB >IN @ + #TIB C@ >IN @ - R> parse >IN +! ;
: CHAR BL PARSE DROP C@ ;
: TX! 1 PUTC ;
: EMIT 'EMIT @EXECUTE ;
: TYPE FOR AFT DUP C@ EMIT 1+ THEN NEXT DROP ;
: ?RX 0 GETC ;
: ?KEY '?KEY @EXECUTE ;
: KEY BEGIN ?KEY UNTIL ;
: COUNT DUP 1+ SWAP C@ ;
: CMOVE
    FOR
        AFT
            >R DUP C@ R@ C! 1+ R> 1+
        THEN
    NEXT 2DROP ;
: FILL
    SWAP
    FOR SWAP
        AFT 2DUP C! 1+ THEN
    NEXT 2DROP ;
: -TRAILING
    FOR
        AFT
        BL OVER R@ + C@ <
        IF
            R> 1+ EXIT
        THEN
    THEN
    NEXT 0 ;
: PACK$
    DUP >R
        2DUP C! 1+ 2DUP + 0 SWAP ! SWAP CMOVE
    R> ;
: WORD PARSE HERE PACK$ ;
: TOKEN BL PARSE 31 MIN NP @ OVER - 1- PACK$ ;
: LINK> 3 CELLS - ;
: CODE> 2 CELLS - ;
: TYPE> 1 CELLS - ;
: DATA> CELL+ ;
: SAME?
    FOR AFT
        OVER R@ CELLS + @
        OVER R@ CELLS + @
        - ?DUP
        IF R> DROP EXIT THEN
    THEN
    NEXT 0 ;
: find
    @ BEGIN DUP WHILE
        2DUP C@ SWAP C@ = IF
        2DUP 1+ SWAP COUNT ALIGNED CELL / >R SWAP R>
        SAME? 0= IF
            2DROP SWAP DROP DUP CODE> @ SWAP -1 EXIT
        THEN 2DROP THEN
    LINK> @ REPEAT ;
: ' TOKEN CONTEXT @ find IF DROP ELSE SWAP DROP 0 THEN ;
: ! ! ;
' TX! 'EMIT !
' ?RX '?KEY !
: ['] COMPILE ' ; IMMEDIATE
: POSTPONE ' , ; IMMEDIATE
: [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE
: ( [CHAR] ) PARSE 2DROP ; IMMEDIATE
: :NONAME HERE POSTPONE ] ;
: OVERT LAST @ CURRENT @ ! ;
: $,n
    DUP LAST ! CELL-
    DUP =WORDLIST
    SWAP !
    CELL- DUP HERE
    SWAP !
    CELL- DUP CURRENT @ @
    SWAP !
    CELL- NP ! ;
: : TOKEN $,n POSTPONE ] ;
: ; COMPILE EXIT POSTPONE [ OVERT ; IMMEDIATE
: RECURSE LAST @ CURRENT @ ! ; IMMEDIATE
: doVAR R> ;
: CREATE TOKEN $,n COMPILE doVAR OVERT ;
: DOES LAST @ CODE> @ R> SWAP ! ;
: DOES> COMPILE DOES COMPILE R> ; IMMEDIATE
: CONSTANT CREATE , DOES> @ ;
: VARIABLE CREATE 0 , ;
: 2LITERAL SWAP POSTPONE LITERAL
    POSTPONE LITERAL ; IMMEDIATE
: 2CONSTANT CREATE , , DOES> 2@ ;
: 2VARIABLE CREATE 2 CELLS ALLOT ;
: SPACE BL EMIT ;
: SPACES 0 MAX FOR SPACE NEXT ;
: PAD HERE 80 + ;
: DECIMAL 10 BASE ! ;
: HEX 16 BASE ! ;
: BINARY 2 BASE ! ;
: OCTAL 8 BASE ! ;
DECIMAL
: CHAR- 1- ;
: CHAR+ 1+ ;
: CHARS ;
: >CHAR 127 AND DUP 127 BL WITHIN IF DROP 95 THEN ;
: DIGIT 9 OVER < 7 AND + [CHAR] 0 + ;
: <# PAD HLD ! ;
: HOLD HLD @ CHAR- DUP HLD ! C! ;
: # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;
: #S BEGIN # 2DUP OR 0= UNTIL ;
: SIGN 0< IF [CHAR] - HOLD THEN ;
: #> 2DROP HLD @ PAD OVER - ;
: S.R OVER - SPACES TYPE ;
: D.R >R DUP >R DABS <# #S R> SIGN #> R> S.R ;
: U.R 0 SWAP D.R ;
: .R >R S>D R> D.R ;
: D. 0 D.R SPACE ;
: U. 0 D. ;
: . BASE @ 10 XOR IF U. EXIT THEN S>D D. ;
: ? @ . ;
: DU.R >R <# #S #> R> S.R ;
: DU. DU.R SPACE ;
: do$ R> R@ R> COUNT + ALIGNED >R SWAP >R ;
: ."| do$ COUNT TYPE ;
: $," [CHAR] " WORD COUNT + ALIGNED CP ! ;
: ." COMPILE ."| $," ; IMMEDIATE
: .( [CHAR] ) PARSE TYPE ; IMMEDIATE
: $"| do$ ;
: $" COMPILE $"| $," ; IMMEDIATE
: s" [CHAR] " PARSE HERE PACK$ ;
: CR 10 EMIT ;
: TAP OVER C! 1+ ;
: KTAP
    10 XOR
    IF
        BL TAP EXIT
    THEN
    NIP DUP ;
: ACCEPT
    OVER + OVER
    BEGIN
        2DUP XOR
    WHILE
        KEY
        DUP BL - 95 U<
        IF TAP ELSE KTAP THEN
    REPEAT DROP OVER - ;
: EXPECT ACCEPT SPAN ! DROP ;
: QUERY TIB 80 ACCEPT #TIB C! DROP 0 >IN ! ;
: DIGIT?
    >R [CHAR] 0 -
    9 OVER <
    IF 7 - DUP 10 < OR THEN
    DUP R> U< ;
: /STRING DUP >R - SWAP R> + SWAP ;
: >NUMBER
    BEGIN DUP
    WHILE >R DUP >R C@ BASE @ DIGIT?
    WHILE SWAP BASE @ UM* DROP ROT
    BASE @ UM* D+ R> CHAR+ R> 1 -
    REPEAT DROP R> R> THEN ;
: NUMBER?
    OVER C@ [CHAR] - = DUP >R IF 1 /STRING THEN
    >R >R 0 DUP R> R> -1 DPL !
    BEGIN >NUMBER DUP
    WHILE OVER C@ [CHAR] . XOR
        IF ROT DROP ROT R> 2DROP FALSE EXIT
    THEN 1 - DPL ! CHAR+ DPL @
    REPEAT 2DROP R> IF DNEGATE THEN TRUE ;
' NUMBER? 'NUMBER !
: $INTERPRET
    CONTEXT @ find
    IF DROP EXECUTE EXIT THEN
    COUNT 'NUMBER @EXECUTE IF
        DPL @ 0< IF DROP THEN EXIT THEN ." ?" TYPE ;
: $COMPILE
    CONTEXT @ find
    IF CELL- @ =IMMED =
        IF EXECUTE ELSE , THEN EXIT
    THEN COUNT 'NUMBER @EXECUTE
    IF
        DPL @ 0<
        IF DROP POSTPONE LITERAL
        ELSE POSTPONE 2LITERAL
        THEN EXIT
    THEN ." ?" TYPE ;
: eval STATE? IF $COMPILE ELSE $INTERPRET THEN ;
' eval 'EVAL !
: EVAL
    BEGIN TOKEN DUP C@ WHILE
        'EVAL @EXECUTE
    REPEAT DROP ;
: OK CR ." OK." SPACE ;
' OK 'PROMPT !
: QUIT
    BEGIN 'PROMPT @EXECUTE QUERY
    EVAL AGAIN ;
: BYE ." Good Bye " CR HALT ;
' QUIT BOOT !
: SP@ SPP @ ;
: DEPTH SP@ SP0 @ - CELL / ;
: PICK CELLS SP@ SWAP - 2 CELLS - @ ;
: .S CR DEPTH FOR AFT R@ PICK . THEN NEXT SPACE ." <SP " CR ;
: WORDS
    CONTEXT @ @ BEGIN DUP WHILE DUP COUNT TYPE LINK>
    @ SPACE REPEAT DROP CR ;

VARIABLE FILE
: OPEN F_OPEN FILE ! ;
: CLOSE FILE @ F_CLOSE ;
: FPUT FILE @ PUTC ;
: FGET FILE @ GETC ;
: FPUTS COUNT FOR AFT DUP C@ FPUT 1+ THEN NEXT DROP ;

: SAVEVM $" eforth.img" $" wb" OPEN 0
    16384 FOR AFT DUP C@ FPUT 1+ THEN NEXT CLOSE DROP ;

SAVEVM

: + um+  drop   ;
: cells  dup +  ;
: cell+  2   +  ;
: cell- -2   +  ;
: cell   2      ;
: boot     0 cells ;
: forth    4 cells ;
: dpl      5 cells ;
: sp0      6 cells ;
: rp0      7 cells ;
: '?key    8 cells ;
: 'emit    9 cells ;
: 'expect 10 cells ;
: 'tap    11 cells ;
: 'echo   12 cells ;
: 'prompt 13 cells ;
: base    14 cells ;
: tmp     15 cells ;
: span    16 cells ;
: >in     17 cells ;
: #tibb   18 cells ;
: tibb    19 cells ;
: csp     20 cells ;
: 'eval   21 cells ;
: 'number 22 cells ;
: hld     23 cells ;
: handler 24 cells ;
: context 25 cells ;
: current 27 cells ;
: cp      29 cells ;
: np      30 cells ;
: last    31 cells ;
: state   32 cells ;
: spp     33 cells ;
: rpp     34 cells ;
: true -1 ;
: false 0 ;
: bl 32 ;
: bs 8 ;
: =immed    3 ;
: =wordlist 2 ;
: immediate =immed last @ cell- ! ;
: here cp @ ;
: allot cp @ + cp ! ;
: , here cell allot ! ;
: c, here 1 allot c! ;
: +! swap over @ + swap ! ;
: compile r> dup @ , cell+ >r ;
: state? state @ ;
: literal compile lit , ; immediate
: [ false state ! ; immediate
: ] true state ! ; immediate
: if compile 0branch here 0 , ; immediate
: then here swap ! ; immediate
: for compile >r here ; immediate
: next compile next , ; immediate
: begin here ; immediate
: again compile branch , ; immediate
: until compile 0branch , ; immediate
: ahead compile branch here 0 , ; immediate
: repeat compile branch , here swap ! ; immediate
: aft drop compile branch here 0 ,  here swap ; immediate
: else compile branch here 0 ,  swap here swap !  ; immediate
: while compile 0branch here 0 , swap ; immediate
: execute >r ;
: @execute @ dup if execute then ;
: r@ r> r> dup >r swap >r ;
: #tib #tibb @ ;
: tib tibb @ ;
: \ #tib @ >in ! ; immediate
: rot >r swap r> swap ;
: -rot swap >r swap r> ;
: nip swap drop ;
: tuck swap over ;
: 2>r swap r> swap >r swap >r >r ;
: 2r> r> r> swap r> swap >r swap ;
: 2r@ r> r> r@ swap >r swap r@ swap >r ;
: 2drop drop drop ;
: 2dup over over ;
: 2swap rot >r rot r> ;
: 2over >r >r 2dup r> r> 2swap ;
: 2rot 2>r 2swap 2r> 2swap ;
: -2rot 2rot 2rot ;
: 2nip 2swap 2drop ;
: 2tuck 2swap 2over ;
: not dup nand ;
: and nand not ;
: or not swap not nand ;
: nor or not ;
: xor 2dup and -rot nor nor ;
: xnor xor not ;
: negate not 1 + ;
: - negate + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: d+ >r swap >r um+ r> r> + + ;
: dnegate not >r not 1 um+ r> + ;
: d- dnegate d+ ;
: 2! swap over ! cell+ ! ;
: 2@ dup cell+ @ swap @ ;
: ?dup dup if dup then ;
: s>d dup 0< ;
: abs dup 0< if negate then ;
: dabs dup 0< if dnegate then ;
: u< 2dup xor 0< if swap drop 0< exit then - 0< ;
: u> swap u< ;
: = xor if false exit then true ;
: < 2dup xor 0< if drop 0< exit then - 0< ;
: > swap < ;
: 0> negate 0< ;
: 0<> if true exit then false ;
: 0= 0 = ;
: <> = 0= ;
: d0< swap drop 0< ;
: d0> dnegate d0< ;
: d0= or 0= ;
: d= d- d0= ;
: d< rot 2dup xor if swap 2swap 2drop < ;
: du< rot 2dup xor if swap 2swap then then 2drop u< ;
: dmin 2over 2over 2swap d< if 2swap then 2drop ;
: dmax 2over 2over d< if 2swap then 2drop ;
: m+ s>d d+ ;
: m- s>d d- ;
: min 2dup swap < if swap then drop ;
: max 2dup < if swap then drop ;
: umin 2dup swap u< if swap then drop ;
: umax 2dup u< if swap then drop ;
: within over - >r - r> u< ;
: um/mod
    2dup u<
    if negate
        15 for
            >r dup um+
                >r >r dup um+
                r> + dup r> r@ swap
            >r um+
            r> or
                if >r drop 1+ r>
                else drop
            then r>
        next drop swap exit
    then drop 2drop -1 dup ;
: m/mod
    dup 0< dup >r
        if negate >r
            dnegate r>
        then >r dup 0<
        if r@ +
        then r> um/mod
    r>
    if swap negate swap then ;
: /mod over 0< swap m/mod ;
: mod /mod drop ;
: / /mod nip ;
: um*
    0 swap
    15 for
        dup um+ >r >r
        dup um+
        r> +
        r>
        if >r over um+
            r> +
        then
    next
    rot drop ;
: * um* drop ;
: m*
    2dup xor 0< >r
    abs swap abs um*
    r> if dnegate then ;
: */mod >r m* r> m/mod ;
: */ */mod swap drop ;
: 2* 2 * ;
: 2/ 2 / ;
: mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ;
: d2* 2dup d+ ;
: du2/ 2 mu/mod rot drop ;
: d2/ dup >r 1 and du2/ r> 2/ or ;
: aligned dup 0 2 um/mod drop dup if 2 swap - then + ;
: parse
    tmp ! over >r dup
    if
        1- tmp @ bl =
        if
            for bl over c@ - 0< not
            while 1+
                next r> drop 0 dup exit
            then r>
        then
            over swap
        for tmp @ over c@ - tmp @ bl =
            if 0< then
        while 1+
        next dup >r
        else r> drop dup 1+ >r
        then over - r> r> - exit
    then over r> - ;
: parse >r tib >in @ + #tib c@ >in @ - r> parse >in +! ;
: char bl parse drop c@ ;
: tx! 1 putc ;
: emit 'emit @execute ;
: type for aft dup c@ emit 1+ then next drop ;
: ?rx 0 getc ;
: ?key '?key @execute ;
: key begin ?key until ;
: count dup 1+ swap c@ ;
: cmove
    for
        aft
            >r dup c@ r@ c! 1+ r> 1+
        then
    next 2drop ;
: fill
    swap
    for swap
        aft 2dup c! 1+ then
    next 2drop ;
: -trailing
    for
        aft
        bl over r@ + c@ <
        if
            r> 1+ exit
        then
    then
    next 0 ;
: pack$
    dup >r
        2dup c! 1+ 2dup + 0 swap ! swap cmove
    r> ;
: word parse here pack$ ;
: token bl parse 31 min np @ over - 1- pack$ ;
: link> 3 cells - ;
: code> 2 cells - ;
: type> 1 cells - ;
: data> cell+ ;
: same?
    for aft
        over r@ cells + @
        over r@ cells + @
        - ?dup
        if r> drop exit then
    then
    next 0 ;
: find
    @ begin dup while
        2dup c@ swap c@ = if
        2dup 1+ swap count aligned cell / >r swap r>
        same? 0= if
            2drop swap drop dup code> @ swap -1 exit
        then 2drop then
    link> @ repeat ;
: ' token context @ find if drop else swap drop 0 then ;
: ! ! ;
' tx! 'emit !
' ?rx '?key !
: ['] compile ' ; immediate
: postpone ' , ; immediate
: [char] char postpone literal ; immediate
: ( [char] ) parse 2drop ; immediate
: :noname here postpone ] ;
: overt last @ current @ ! ;
: $,n
    dup last ! cell-
    dup =wordlist
    swap !
    cell- dup here
    swap !
    cell- dup current @ @
    swap !
    cell- np ! ;
: : token $,n postpone ] ;
: ; compile exit postpone [ overt ; immediate
: recurse last @ code> @ , ; immediate
: dovar r> ;
: create token $,n compile dovar overt ;
: does last @ code> @ r> swap ! ;
: does> compile does compile r> ; immediate
: constant create , does> @ ;
: variable create 0 , ;
: 2literal swap postpone literal
    postpone literal ; immediate
: 2constant create , , does> 2@ ;
: 2variable create 2 cells allot ;
: space bl emit ;
: spaces 0 max for space next ;
: pad here 80 + ;
: decimal 10 base ! ;
: hex 16 base ! ;
: binary 2 base ! ;
: octal 8 base ! ;
decimal
: char- 1- ;
: char+ 1+ ;
: chars ;
: >char 127 and dup 127 bl within if drop 95 then ;
: digit 9 over < 7 and + [char] 0 + ;
: <# pad hld ! ;
: hold hld @ char- dup hld ! c! ;
: # 0 base @ um/mod >r base @ um/mod swap digit hold r> ;
: #s begin # 2dup or 0= until ;
: sign 0< if [char] - hold then ;
: #> 2drop hld @ pad over - ;
: s.r over - spaces type ;
: d.r >r dup >r dabs <# #s r> sign #> r> s.r ;
: u.r 0 swap d.r ;
: .r >r s>d r> d.r ;
: d. 0 d.r space ;
: u. 0 d. ;
: . base @ 10 xor if u. exit then s>d d. ;
: ? @ . ;
: du.r >r <# #s #> r> s.r ;
: du. du.r space ;
: do$ r> r@ r> count + aligned >r swap >r ;
: ."| do$ count type ;
: $," [char] " word count + aligned cp ! ;
: ." compile ."| $," ; immediate
: .( [char] ) parse type ; immediate
: $"| do$ ;
: $" compile $"| $," ; immediate
: s" [char] " parse here pack$ ;
: cr 10 emit ;
: tap over c! 1+ ;
: ktap
    10 xor
    if
        bl tap exit
    then
    nip dup ;
: accept
    over + over
    begin
        2dup xor
    while
        key
        dup bl - 95 u<
        if tap else ktap then
    repeat drop over - ;
: expect accept span ! drop ;
: query tib 80 accept #tib c! drop 0 >in ! ;
: digit?
    >r [char] 0 -
    9 over <
    if 7 - dup 10 < or then
    dup r> u< ;
: /string dup >r - swap r> + swap ;
: >number
    begin dup
    while >r dup >r c@ base @ digit?
    while swap base @ um* drop rot
    base @ um* d+ r> char+ r> 1 -
    repeat drop r> r> then ;
: number?
    over c@ [char] - = dup >r if 1 /string then
    >r >r 0 dup r> r> -1 dpl !
    begin >number dup
    while over c@ [char] . xor
        if rot drop rot r> 2drop false exit
    then 1 - dpl ! char+ dpl @
    repeat 2drop r> if dnegate then true ;
' number? 'number !
: $interpret
    context @ find
    if drop execute exit then
    count 'number @execute if
        dpl @ 0< if drop then exit then ." ?" type ;
: $compile
    context @ find
    if cell- @ =immed =
        if execute else , then exit
    then count 'number @execute
    if
        dpl @ 0<
        if drop postpone literal
        else postpone 2literal
        then exit
    then ." ?" type ;
: eval state? if $compile else $interpret then ;
' eval 'eval !
: eval
    begin token dup c@ while
        'eval @execute
    repeat drop ;
: ok cr ." ok." space ;
' ok 'prompt !
: quit
    begin 'prompt @execute query
    eval again ;
: bye ." good bye " cr halt ;
' quit boot !
: sp@ spp @ ;
: depth sp@ sp0 @ - cell / ;
: pick cells sp@ swap - 2 cells - @ ;
: .s cr depth for aft r@ pick . then next space ." <sp " cr ;
: words
    context @ @ begin dup while dup count type link>
    @ space repeat drop cr ;

: rpick r> rpp @ swap >r + 2- @ ;
: do compile 2>r postpone begin ; immediate
: _loop r> r> 1+ dup r@ 1- > swap >r swap >r ;
: _+loop r> swap r> swap + dup r@ 1- > swap >r swap >r ;
: leave r> 2r> 2drop >r ;
: unloop r> r> drop r@ r> r> ;
: loop compile _loop postpone until compile leave ; immediate
: +loop compile _+loop postpone until compile leave ; immediate
: i r> r> tuck >r >r ;
: j 4 rpick ;
: k 4 rpick ;

variable file
: open f_open file ! ;
: close file @ f_close ;
: fput file @ putc ;
: fget file @ getc ;
: fputs count for aft dup c@ fput 1+ then next drop ;

: savevm $" eforth.img" $" wb" open 0
    16384 for aft dup c@ fput 1+ then next close drop ;

savevm


4 assertions added

4 assertions added

\ KataDiversion tests, in Forth
\ running tests:
\   gforth KataDiversion_tests.fth -e bye

REQUIRE KataDiversion.fth

VARIABLE ASSERT-COUNT
0 ASSERT-COUNT !

: ASSERT-EQUAL ( n1 n2 -- n1 n2 )
    2DUP <> IF 1 ABORT" AssertEqual: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ - tests -

\ ?MAX-NB
0 ?MAX-NB   0   ASSERT-EQUAL
1 ?MAX-NB   2   ASSERT-EQUAL
2 ?MAX-NB   4   ASSERT-EQUAL
3 ?MAX-NB   8   ASSERT-EQUAL

\ ---------

ASSERT-COUNT @ . ." assertions successfully passed." CR

\ KataDiversion tests, in Forth

INCLUDE KataDiversion.ft


PROBLEM: putting in a loader config file a line of the form

        loader_conf_files="foo bar baz"

should cause loading the files listed, and then resume with the
remaining config files (from previous values of the variable).
Unfortunately, sometimes the line was ignored -- actually even
modifying the line in /boot/default/loader.conf  sometimes doesn't work.

ANALYSIS: After much investigation, turned out to be a bug in the logic.
The existing code detected a new assignment by looking at the address
of the the variable containing the string. This only worked by pure
chance, i.e. if the new string is longer than the previous value
then the memory allocator may return a different address
to store the string hence triggering the detection.

SOLUTION: This commit contains a minimal change to fix the problem,
without altering too much the existing structure of the code.
However, as a step towards improving the quality and reliability of
this code, I have introduced a handful of one-line functions
(strget, strset, strfree, string= ) that could be used in dozens
of places in the existing code.

HOWEVER:
There is a much bigger problem here. Even though I am no Forth
expert (as most fellow src committers) I can tell that much of the
forth code (in support.4th at least) is in severe need of a
review/refactoring:

+ pieces of code are replicated multiple times instead of writing
  functions (see e.g.  set_module_*);

+ a lot of stale code (e.g. "structure" definitions for
  preloaded_files, kernel_module, pnp stuff) which is not used
  or at least belongs elsewhere.
  The code bload is extremely bad as the loader runs with very small
  memory constraints, and we already hit the limit once (see

    http://svn.freebsd.org/viewvc/base?view=revision&revision=185132
  Reducing the footprint of the forth files is critical.

+ two different styles of coding, one using pure stack functions
  (maybe beautiful but surely highly unreadable), one using
  high level mechanisms to give names to arguments and local
  variables (which leads to readable code).

Note that this code is used by default by all FreeBSD installations,
so the fragility and the code bloat are extremely damaging.
I will try to work fixing the three items above, but if others have
time, please have a look at these issues.

MFC after:	4 weeks

\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

\ Loader.rc support functions:
\
\ initialize_support ( -- )	initialize global variables
\ initialize ( addr len -- )	as above, plus load_conf_files
\ load_conf ( addr len -- )	load conf file given
\ include_conf_files ( -- )	load all conf files in load_conf_files
\ print_syntax_error ( -- )	print line and marker of where a syntax
\				error was detected
\ print_line ( -- )		print last line processed
\ load_kernel ( -- )		load kernel
\ load_modules ( -- )		load modules flagged
\
\ Exported structures:
\
\ string			counted string structure
\	cell .addr			string address
\	cell .len			string length
\ module			module loading information structure
\	cell module.flag		should we load it?
\	string module.name		module's name
\	string module.loadname		name to be used in loading the module
\	string module.type		module's type
\	string module.args		flags to be passed during load
\	string module.beforeload	command to be executed before load
\	string module.afterload		command to be executed after load
\	string module.loaderror		command to be executed if load fails
\	cell module.next		list chain
\
\ Exported global variables;
\
\ string conf_files		configuration files to be loaded
\ string password		password
\ cell modules_options		pointer to first module information
\ value verbose?		indicates if user wants a verbose loading
\ value any_conf_read?		indicates if a conf file was succesfully read
\
\ Other exported words:
\
\ strdup ( addr len -- addr' len)			similar to strdup(3)
\ strcat ( addr len addr' len' -- addr len+len' )	similar to strcat(3)
\ strlen ( addr -- len )				similar to strlen(3)
\ s' ( | string' -- addr len | )			similar to s"
\ rudimentary structure support

\ Exception values

1 constant syntax_error
2 constant out_of_memory
3 constant free_error
4 constant set_error
5 constant read_error
6 constant open_error
7 constant exec_error
8 constant before_load_error
9 constant after_load_error

\ I/O constants

0 constant SEEK_SET
1 constant SEEK_CUR
2 constant SEEK_END

0 constant O_RDONLY
1 constant O_WRONLY
2 constant O_RDWR

\ Crude structure support

: structure:
  create here 0 , ['] drop , 0
  does> create here swap dup @ allot cell+ @ execute
;
: member: create dup , over , + does> cell+ @ + ;
: ;structure swap ! ;
: constructor! >body cell+ ! ;
: constructor: over :noname ;
: ;constructor postpone ; swap cell+ ! ; immediate
: sizeof ' >body @ state @ if postpone literal then ; immediate
: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
: ptr 1 cells member: ;
: int 1 cells member: ;

\ String structure

structure: string
	ptr .addr
	int .len
	constructor:
	  0 over .addr !
	  0 swap .len !
	;constructor
;structure

\ Module options linked list

structure: module
	int module.flag
	sizeof string member: module.name
	sizeof string member: module.loadname
	sizeof string member: module.type
	sizeof string member: module.args
	sizeof string member: module.beforeload
	sizeof string member: module.afterload
	sizeof string member: module.loaderror
	ptr module.next
;structure

\ Internal loader structures
structure: preloaded_file
	ptr pf.name
	ptr pf.type
	ptr pf.args
	ptr pf.metadata	\ file_metadata
	int pf.loader
	int pf.addr
	int pf.size
	ptr pf.modules	\ kernel_module
	ptr pf.next	\ preloaded_file
;structure

structure: kernel_module
	ptr km.name
	\ ptr km.args
	ptr km.fp	\ preloaded_file
	ptr km.next	\ kernel_module
;structure

structure: file_metadata
	int		md.size
	2 member:	md.type	\ this is not ANS Forth compatible (XXX)
	ptr		md.next	\ file_metadata
	0 member:	md.data	\ variable size
;structure

structure: config_resource
	ptr cf.name
	int cf.type
0 constant RES_INT
1 constant RES_STRING
2 constant RES_LONG
	2 cells member: u
;structure

structure: config_device
	ptr cd.name
	int cd.unit
	int cd.resource_count
	ptr cd.resources	\ config_resource
;structure

structure: STAILQ_HEAD
	ptr stqh_first	\ type*
	ptr stqh_last	\ type**
;structure

structure: STAILQ_ENTRY
	ptr stqe_next	\ type*
;structure

structure: pnphandler
	ptr pnph.name
	ptr pnph.enumerate
;structure

structure: pnpident
	ptr pnpid.ident					\ char*
	sizeof STAILQ_ENTRY cells member: pnpid.link	\ pnpident
;structure

structure: pnpinfo
	ptr pnpi.desc
	int pnpi.revision
	ptr pnpi.module				\ (char*) module args
	int pnpi.argc
	ptr pnpi.argv
	ptr pnpi.handler			\ pnphandler
	sizeof STAILQ_HEAD member: pnpi.ident	\ pnpident
	sizeof STAILQ_ENTRY member: pnpi.link	\ pnpinfo
;structure

\ Global variables

string conf_files
string nextboot_conf_file
string password
create module_options sizeof module.next allot 0 module_options !
create last_module_option sizeof module.next allot 0 last_module_option !
0 value verbose?
0 value nextboot?

\ Support string functions

: strdup  ( addr len -- addr' len )
  >r r@ allocate if out_of_memory throw then
  tuck r@ move
  r>
;

: strcat  { addr len addr' len' -- addr len+len' }
  addr' addr len + len' move
  addr len len' +
;

: strlen ( addr -- len )
  0 >r
  begin
    dup c@ while
    1+ r> 1+ >r repeat
  drop r>
;

: s'
  [char] ' parse
  state @ if
    postpone sliteral
  then
; immediate

: 2>r postpone >r postpone >r ; immediate
: 2r> postpone r> postpone r> ; immediate
: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate

: getenv?
  getenv
  -1 = if false else drop true then
;

\ Private definitions

vocabulary support-functions
only forth also support-functions definitions

\ Some control characters constants

7 constant bell
8 constant backspace
9 constant tab
10 constant lf
13 constant <cr>

\ Read buffer size

80 constant read_buffer_size

\ Standard suffixes

: load_module_suffix s" _load" ;
: module_loadname_suffix s" _name" ;
: module_type_suffix s" _type" ;
: module_args_suffix s" _flags" ;
: module_beforeload_suffix s" _before" ;
: module_afterload_suffix s" _after" ;
: module_loaderror_suffix s" _error" ;

\ Support operators

: >= < 0= ;
: <= > 0= ;

\ Assorted support funcitons

: free-memory free if free_error throw then ;

: strget { var -- addr len } var .addr @ var .len @ ;

\ assign addr len to variable.
: strset  { addr len var -- } addr var .addr ! len var .len ! ;

\ free memory and reset fields
: strfree { var -- } var .addr @ ?dup if free-memory 0 0 var strset then ;

\ free old content, make a copy of the string and assign to variable
: string= { addr len var -- } var strfree addr len strdup var strset ;

\ Assignment data temporary storage

string name_buffer
string value_buffer

\ Line by line file reading functions
\
\ exported:
\	line_buffer
\	end_of_file?
\	fd
\	read_line
\	reset_line_reading

vocabulary line-reading
also line-reading definitions also

\ File data temporary storage

string read_buffer
0 value read_buffer_ptr

\ File's line reading function

support-functions definitions

string line_buffer
0 value end_of_file?
variable fd

line-reading definitions

: skip_newlines
  begin
    read_buffer .len @ read_buffer_ptr >
  while
    read_buffer .addr @ read_buffer_ptr + c@ lf = if
      read_buffer_ptr char+ to read_buffer_ptr
    else
      exit
    then
  repeat
;

: scan_buffer  ( -- addr len )
  read_buffer_ptr >r
  begin
    read_buffer .len @ r@ >
  while
    read_buffer .addr @ r@ + c@ lf = if
      read_buffer .addr @ read_buffer_ptr +  ( -- addr )
      r@ read_buffer_ptr -                   ( -- len )
      r> to read_buffer_ptr
      exit
    then
    r> char+ >r
  repeat
  read_buffer .addr @ read_buffer_ptr +  ( -- addr )
  r@ read_buffer_ptr -                   ( -- len )
  r> to read_buffer_ptr
;

: line_buffer_resize  ( len -- len )
  >r
  line_buffer .len @ if
    line_buffer .addr @
    line_buffer .len @ r@ +
    resize if out_of_memory throw then
  else
    r@ allocate if out_of_memory throw then
  then
  line_buffer .addr !
  r>
;

: append_to_line_buffer  ( addr len -- )
  line_buffer .addr @ line_buffer .len @
  2swap strcat
  line_buffer .len !
  drop
;

: read_from_buffer
  scan_buffer            ( -- addr len )
  line_buffer_resize     ( len -- len )
  append_to_line_buffer  ( addr len -- )
;

: refill_required?
  read_buffer .len @ read_buffer_ptr =
  end_of_file? 0= and
;

: refill_buffer
  0 to read_buffer_ptr
  read_buffer .addr @ 0= if
    read_buffer_size allocate if out_of_memory throw then
    read_buffer .addr !
  then
  fd @ read_buffer .addr @ read_buffer_size fread
  dup -1 = if read_error throw then
  dup 0= if true to end_of_file? then
  read_buffer .len !
;

: reset_line_buffer
  line_buffer .addr @ ?dup if
    free-memory
  then
  0 line_buffer .addr !
  0 line_buffer .len !
;

support-functions definitions

: reset_line_reading
  0 to read_buffer_ptr
;

: read_line
  reset_line_buffer
  skip_newlines
  begin
    read_from_buffer
    refill_required?
  while
    refill_buffer
  repeat
;

only forth also support-functions definitions

\ Conf file line parser:
\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
\            <spaces>[<comment>]
\ <name> ::= <letter>{<letter>|<digit>|'_'}
\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
\ <character_set> ::= ASCII 32 to 126, except '\' and '"'
\ <comment> ::= '#'{<anything>}
\
\ exported:
\	line_pointer
\	process_conf

0 value line_pointer

vocabulary file-processing
also file-processing definitions

\ parser functions
\
\ exported:
\	get_assignment

vocabulary parser
also parser definitions also

0 value parsing_function
0 value end_of_line

: end_of_line?
  line_pointer end_of_line =
;

: letter?
  line_pointer c@ >r
  r@ [char] A >=
  r@ [char] Z <= and
  r@ [char] a >=
  r> [char] z <= and
  or
;

: digit?
  line_pointer c@ >r
  r@ [char] - =
  r@ [char] 0 >=
  r> [char] 9 <= and
  or
;

: quote?
  line_pointer c@ [char] " =
;

: assignment_sign?
  line_pointer c@ [char] = =
;

: comment?
  line_pointer c@ [char] # =
;

: space?
  line_pointer c@ bl =
  line_pointer c@ tab = or
;

: backslash?
  line_pointer c@ [char] \ =
;

: underscore?
  line_pointer c@ [char] _ =
;

: dot?
  line_pointer c@ [char] . =
;

: skip_character
  line_pointer char+ to line_pointer
;

: skip_to_end_of_line
  end_of_line to line_pointer
;

: eat_space
  begin
    space?
  while
    skip_character
    end_of_line? if exit then
  repeat
;

: parse_name  ( -- addr len )
  line_pointer
  begin
    letter? digit? underscore? dot? or or or
  while
    skip_character
    end_of_line? if
      line_pointer over -
      strdup
      exit
    then
  repeat
  line_pointer over -
  strdup
;

: remove_backslashes  { addr len | addr' len' -- addr' len' }
  len allocate if out_of_memory throw then
  to addr'
  addr >r
  begin
    addr c@ [char] \ <> if
      addr c@ addr' len' + c!
      len' char+ to len'
    then
    addr char+ to addr
    r@ len + addr =
  until
  r> drop
  addr' len'
;

: parse_quote  ( -- addr len )
  line_pointer
  skip_character
  end_of_line? if syntax_error throw then
  begin
    quote? 0=
  while
    backslash? if
      skip_character
      end_of_line? if syntax_error throw then
    then
    skip_character
    end_of_line? if syntax_error throw then
  repeat
  skip_character
  line_pointer over -
  remove_backslashes
;

: read_name
  parse_name		( -- addr len )
  name_buffer .len !
  name_buffer .addr !
;

: read_value
  quote? if
    parse_quote		( -- addr len )
  else
    parse_name		( -- addr len )
  then
  value_buffer .len !
  value_buffer .addr !
;

: comment
  skip_to_end_of_line
;

: white_space_4
  eat_space
  comment? if ['] comment to parsing_function exit then
  end_of_line? 0= if syntax_error throw then
;

: variable_value
  read_value
  ['] white_space_4 to parsing_function
;

: white_space_3
  eat_space
  letter? digit? quote? or or if
    ['] variable_value to parsing_function exit
  then
  syntax_error throw
;

: assignment_sign
  skip_character
  ['] white_space_3 to parsing_function
;

: white_space_2
  eat_space
  assignment_sign? if ['] assignment_sign to parsing_function exit then
  syntax_error throw
;

: variable_name
  read_name
  ['] white_space_2 to parsing_function
;

: white_space_1
  eat_space
  letter?  if ['] variable_name to parsing_function exit then
  comment? if ['] comment to parsing_function exit then
  end_of_line? 0= if syntax_error throw then
;

file-processing definitions

: get_assignment
  line_buffer .addr @ line_buffer .len @ + to end_of_line
  line_buffer .addr @ to line_pointer
  ['] white_space_1 to parsing_function
  begin
    end_of_line? 0=
  while
    parsing_function execute
  repeat
  parsing_function ['] comment =
  parsing_function ['] white_space_1 =
  parsing_function ['] white_space_4 =
  or or 0= if syntax_error throw then
;

only forth also support-functions also file-processing definitions also

\ Process line

: assignment_type?  ( addr len -- flag )
  name_buffer .addr @ name_buffer .len @
  compare 0=
;

: suffix_type?  ( addr len -- flag )
  name_buffer .len @ over <= if 2drop false exit then
  name_buffer .len @ over - name_buffer .addr @ +
  over compare 0=
;

: loader_conf_files?
  s" loader_conf_files" assignment_type?
;

: nextboot_flag?
  s" nextboot_enable" assignment_type?
;

: nextboot_conf?
  s" nextboot_conf" assignment_type?
;

: verbose_flag?
  s" verbose_loading" assignment_type?
;

: execute?
  s" exec" assignment_type?
;

: password?
  s" password" assignment_type?
;

: module_load?
  load_module_suffix suffix_type?
;

: module_loadname?
  module_loadname_suffix suffix_type?
;

: module_type?
  module_type_suffix suffix_type?
;

: module_args?
  module_args_suffix suffix_type?
;

: module_beforeload?
  module_beforeload_suffix suffix_type?
;

: module_afterload?
  module_afterload_suffix suffix_type?
;

: module_loaderror?
  module_loaderror_suffix suffix_type?
;

: set_nextboot_conf
  nextboot_conf_file .addr @ ?dup if
    free-memory
  then
  value_buffer .addr @ c@ [char] " = if
    value_buffer .addr @ char+ value_buffer .len @ 2 chars -
  else
    value_buffer .addr @ value_buffer .len @
  then
  strdup
  nextboot_conf_file .len ! nextboot_conf_file .addr !
;

: append_to_module_options_list  ( addr -- )
  module_options @ 0= if
    dup module_options !
    last_module_option !
  else
    dup last_module_option @ module.next !
    last_module_option !
  then
;

: set_module_name  ( addr -- )
  name_buffer .addr @ name_buffer .len @
  strdup
  >r over module.name .addr !
  r> swap module.name .len !
;

: yes_value?
  value_buffer .addr @ value_buffer .len @
  2dup s' "YES"' compare >r
  2dup s' "yes"' compare >r
  2dup s" YES" compare >r
  s" yes" compare r> r> r> and and and 0=
;

: find_module_option  ( -- addr | 0 )
  module_options @
  begin
    dup
  while
    dup module.name dup .addr @ swap .len @
    name_buffer .addr @ name_buffer .len @
    compare 0= if exit then
    module.next @
  repeat
;

: new_module_option  ( -- addr )
  sizeof module allocate if out_of_memory throw then
  dup sizeof module erase
  dup append_to_module_options_list
  dup set_module_name
;

: get_module_option  ( -- addr )
  find_module_option
  ?dup 0= if new_module_option then
;

: set_module_flag
  name_buffer .len @ load_module_suffix nip - name_buffer .len !
  yes_value? get_module_option module.flag !
;

: set_module_args
  name_buffer .len @ module_args_suffix nip - name_buffer .len !
  get_module_option module.args
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_loadname
  name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
  get_module_option module.loadname
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_type
  name_buffer .len @ module_type_suffix nip - name_buffer .len !
  get_module_option module.type
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_beforeload
  name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
  get_module_option module.beforeload
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_afterload
  name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
  get_module_option module.afterload
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_loaderror
  name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
  get_module_option module.loaderror
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_environment_variable
  name_buffer .len @
  value_buffer .len @ +
  5 chars +
  allocate if out_of_memory throw then
  dup 0  ( addr -- addr addr len )
  s" set " strcat
  name_buffer .addr @ name_buffer .len @ strcat
  s" =" strcat
  value_buffer .addr @ value_buffer .len @ strcat
  ['] evaluate catch if
    2drop free drop
    set_error throw
  else
    free-memory
  then
;

: set_conf_files
  set_environment_variable
  s" loader_conf_files" getenv conf_files string=
;

: set_nextboot_flag
  yes_value? to nextboot?
;

: set_verbose
  yes_value? to verbose?
;

: execute_command
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 - swap char+ swap
  then
  ['] evaluate catch if exec_error throw then
;

: set_password
  password .addr @ ?dup if free if free_error throw then then
  value_buffer .addr @ c@ [char] " = if
    value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
    value_buffer .addr @ free if free_error throw then
  else
    value_buffer .addr @ value_buffer .len @
  then
  password .len ! password .addr !
  0 value_buffer .addr !
;

: process_assignment
  name_buffer .len @ 0= if exit then
  loader_conf_files?	if set_conf_files exit then
  nextboot_flag?	if set_nextboot_flag exit then
  nextboot_conf?	if set_nextboot_conf exit then
  verbose_flag?		if set_verbose exit then
  execute?		if execute_command exit then
  password?		if set_password exit then
  module_load?		if set_module_flag exit then
  module_loadname?	if set_module_loadname exit then
  module_type?		if set_module_type exit then
  module_args?		if set_module_args exit then
  module_beforeload?	if set_module_beforeload exit then
  module_afterload?	if set_module_afterload exit then
  module_loaderror?	if set_module_loaderror exit then
  set_environment_variable
;

\ free_buffer  ( -- )
\
\ Free some pointers if needed. The code then tests for errors
\ in freeing, and throws an exception if needed. If a pointer is
\ not allocated, it's value (0) is used as flag.

: free_buffers
  name_buffer .addr @ dup if free then
  value_buffer .addr @ dup if free then
  or if free_error throw then
;

: reset_assignment_buffers
  0 name_buffer .addr !
  0 name_buffer .len !
  0 value_buffer .addr !
  0 value_buffer .len !
;

\ Higher level file processing

support-functions definitions

: process_conf
  begin
    end_of_file? 0=
  while
    reset_assignment_buffers
    read_line
    get_assignment
    ['] process_assignment catch
    ['] free_buffers catch
    swap throw throw
  repeat
;

: peek_file
  0 to end_of_file?
  reset_line_reading
  O_RDONLY fopen fd !
  fd @ -1 = if open_error throw then
  reset_assignment_buffers
  read_line
  get_assignment
  ['] process_assignment catch
  ['] free_buffers catch
  fd @ fclose
;

only forth also support-functions definitions

\ Interface to loading conf files

: load_conf  ( addr len -- )
  0 to end_of_file?
  reset_line_reading
  O_RDONLY fopen fd !
  fd @ -1 = if open_error throw then
  ['] process_conf catch
  fd @ fclose
  throw
;

: print_line
  line_buffer .addr @ line_buffer .len @ type cr
;

: print_syntax_error
  line_buffer .addr @ line_buffer .len @ type cr
  line_buffer .addr @
  begin
    line_pointer over <>
  while
    bl emit
    char+
  repeat
  drop
  ." ^" cr
;

\ Debugging support functions

only forth definitions also support-functions

: test-file
  ['] load_conf catch dup .
  syntax_error = if cr print_syntax_error then
;

: show-module-options
  module_options @
  begin
    ?dup
  while
    ." Name: " dup module.name dup .addr @ swap .len @ type cr
    ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
    ." Type: " dup module.type dup .addr @ swap .len @ type cr
    ." Flags: " dup module.args dup .addr @ swap .len @ type cr
    ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
    ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
    ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
    ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
    module.next @
  repeat
;

only forth also support-functions definitions

\ Variables used for processing multiple conf files

string current_file_name

\ Indicates if any conf file was succesfully read

0 value any_conf_read?

\ loader_conf_files processing support functions

: get_conf_files ( -- addr len )  \ put addr/len on stack, reset var
  conf_files strget 0 0 conf_files strset
;

: skip_leading_spaces  { addr len pos -- addr len pos' }
  begin
    pos len = if addr len pos exit then
    addr pos + c@ bl =
  while
    pos char+ to pos
  repeat
  addr len pos
;

: get_file_name  { addr len pos -- addr len pos' addr' len' || 0 }
  pos len = if
    addr free abort" Fatal error freeing memory"
    0 exit
  then
  pos >r
  begin
    addr pos + c@ bl <>
  while
    pos char+ to pos
    pos len = if
      addr len pos addr r@ + pos r> - exit
    then
  repeat
  addr len pos addr r@ + pos r> -
;

: get_next_file  ( addr len ptr -- addr len ptr' addr' len' | 0 )
  skip_leading_spaces
  get_file_name
;

: set_current_file_name
  over current_file_name .addr !
  dup current_file_name .len !
;

: print_current_file
  current_file_name .addr @ current_file_name .len @ type
;

: process_conf_errors
  dup 0= if true to any_conf_read? drop exit then
  >r 2drop r>
  dup syntax_error = if
    ." Warning: syntax error on file " print_current_file cr
    print_syntax_error drop exit
  then
  dup set_error = if
    ." Warning: bad definition on file " print_current_file cr
    print_line drop exit
  then
  dup read_error = if
    ." Warning: error reading file " print_current_file cr drop exit
  then
  dup open_error = if
    verbose? if ." Warning: unable to open file " print_current_file cr then
    drop exit
  then
  dup free_error = abort" Fatal error freeing memory"
  dup out_of_memory = abort" Out of memory"
  throw  \ Unknown error -- pass ahead
;

\ Process loader_conf_files recursively
\ Interface to loader_conf_files processing

: include_conf_files
  get_conf_files 0
  begin
    get_next_file ?dup
  while
    set_current_file_name
    ['] load_conf catch
    process_conf_errors
    conf_files .addr @ if recurse then
  repeat
;

: get_nextboot_conf_file ( -- addr len )
  nextboot_conf_file .addr @ nextboot_conf_file .len @ strdup
;

: rewrite_nextboot_file ( -- )
  get_nextboot_conf_file
  O_WRONLY fopen fd !
  fd @ -1 = if open_error throw then
  fd @ s' nextboot_enable="NO" ' fwrite
  fd @ fclose
;

: include_nextboot_file
  get_nextboot_conf_file
  ['] peek_file catch
  nextboot? if
    get_nextboot_conf_file
    ['] load_conf catch
    process_conf_errors
    ['] rewrite_nextboot_file catch
  then
;

\ Module loading functions

: load_module?
  module.flag @
;

: load_parameters  ( addr -- addr addrN lenN ... addr1 len1 N )
  dup >r
  r@ module.args .addr @ r@ module.args .len @
  r@ module.loadname .len @ if
    r@ module.loadname .addr @ r@ module.loadname .len @
  else
    r@ module.name .addr @ r@ module.name .len @
  then
  r@ module.type .len @ if
    r@ module.type .addr @ r@ module.type .len @
    s" -t "
    4 ( -t type name flags )
  else
    2 ( name flags )
  then
  r> drop
;

: before_load  ( addr -- addr )
  dup module.beforeload .len @ if
    dup module.beforeload .addr @ over module.beforeload .len @
    ['] evaluate catch if before_load_error throw then
  then
;

: after_load  ( addr -- addr )
  dup module.afterload .len @ if
    dup module.afterload .addr @ over module.afterload .len @
    ['] evaluate catch if after_load_error throw then
  then
;

: load_error  ( addr -- addr )
  dup module.loaderror .len @ if
    dup module.loaderror .addr @ over module.loaderror .len @
    evaluate  \ This we do not intercept so it can throw errors
  then
;

: pre_load_message  ( addr -- addr )
  verbose? if
    dup module.name .addr @ over module.name .len @ type
    ." ..."
  then
;

: load_error_message verbose? if ." failed!" cr then ;

: load_succesful_message verbose? if ." ok" cr then ;

: load_module
  load_parameters load
;

: process_module  ( addr -- addr )
  pre_load_message
  before_load
  begin
    ['] load_module catch if
      dup module.loaderror .len @ if
        load_error			\ Command should return a flag!
      else
        load_error_message true		\ Do not retry
      then
    else
      after_load
      load_succesful_message true	\ Succesful, do not retry
    then
  until
;

: process_module_errors  ( addr ior -- )
  dup before_load_error = if
    drop
    ." Module "
    dup module.name .addr @ over module.name .len @ type
    dup module.loadname .len @ if
      ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
    then
    cr
    ." Error executing "
    dup module.beforeload .addr @ over module.afterload .len @ type cr
    abort
  then

  dup after_load_error = if
    drop
    ." Module "
    dup module.name .addr @ over module.name .len @ type
    dup module.loadname .len @ if
      ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
    then
    cr
    ." Error executing "
    dup module.afterload .addr @ over module.afterload .len @ type cr
    abort
  then

  throw  \ Don't know what it is all about -- pass ahead
;

\ Module loading interface

: load_modules  ( -- ) ( throws: abort & user-defined )
  module_options @
  begin
    ?dup
  while
    dup load_module? if
      ['] process_module catch
      process_module_errors
    then
    module.next @
  repeat
;

\ h00h00 magic used to try loading either a kernel with a given name,
\ or a kernel with the default name in a directory of a given name
\ (the pain!)

: bootpath s" /boot/" ;
: modulepath s" module_path" ;

\ Functions used to save and restore module_path's value.
: saveenv ( addr len | -1 -- addr' len | 0 -1 )
  dup -1 = if 0 swap exit then
  strdup
;
: freeenv ( addr len | 0 -1 )
  -1 = if drop else free abort" Freeing error" then
;
: restoreenv  ( addr len | 0 -1 -- )
  dup -1 = if ( it wasn't set )
    2drop
    modulepath unsetenv
  else
    over >r
    modulepath setenv
    r> free abort" Freeing error"
  then
;

: clip_args   \ Drop second string if only one argument is passed
  1 = if
    2swap 2drop
    1
  else
    2
  then
;

also builtins

\ Parse filename from a comma-separated list

: parse-; ( addr len -- addr' len-x addr x )
  over 0 2swap
  begin
    dup 0 <>
  while
    over c@ [char] ; <>
  while
    1- swap 1+ swap
    2swap 1+ 2swap
  repeat then
  dup 0 <> if
    1- swap 1+ swap
  then
  2swap
;

\ Try loading one of multiple kernels specified

: try_multiple_kernels ( addr len addr' len' args -- flag )
  >r
  begin
    parse-; 2>r
    2over 2r>
    r@ clip_args
    s" DEBUG" getenv? if
      s" echo Module_path: ${module_path}" evaluate
      ." Kernel     : " >r 2dup type r> cr
      dup 2 = if ." Flags      : " >r 2over type r> cr then
    then
    1 load
  while
    dup 0=
  until
    1 >r \ Failure
  else
    0 >r \ Success
  then
  2drop 2drop
  r>
  r> drop
;

\ Try to load a kernel; the kernel name is taken from one of
\ the following lists, as ordered:
\
\   1. The "bootfile" environment variable
\   2. The "kernel" environment variable
\
\ Flags are passed, if available. If not, dummy values must be given.
\
\ The kernel gets loaded from the current module_path.

: load_a_kernel ( flags len 1 | x x 0 -- flag )
  local args
  2local flags
  0 0 2local kernel
  end-locals

  \ Check if a default kernel name exists at all, exits if not
  s" bootfile" getenv dup -1 <> if
    to kernel
    flags kernel args 1+ try_multiple_kernels
    dup 0= if exit then
  then
  drop

  s" kernel" getenv dup -1 <> if
    to kernel
  else
    drop
    1 exit \ Failure
  then

  \ Try all default kernel names
  flags kernel args 1+ try_multiple_kernels
;

\ Try to load a kernel; the kernel name is taken from one of
\ the following lists, as ordered:
\
\   1. The "bootfile" environment variable
\   2. The "kernel" environment variable
\
\ Flags are passed, if provided.
\
\ The kernel will be loaded from a directory computed from the
\ path given. Two directories will be tried in the following order:
\
\   1. /boot/path
\   2. path
\
\ The module_path variable is overridden if load is succesful, by
\ prepending the successful path.

: load_from_directory ( path len 1 | flags len' path len 2 -- flag )
  local args
  2local path
  args 1 = if 0 0 then
  2local flags
  0 0 2local oldmodulepath
  0 0 2local newmodulepath
  end-locals

  \ Set the environment variable module_path, and try loading
  \ the kernel again.
  modulepath getenv saveenv to oldmodulepath

  \ Try prepending /boot/ first
  bootpath nip path nip +
  oldmodulepath nip dup -1 = if
    drop
  else
    1+ +
  then
  allocate
  if ( out of memory )
    1 exit
  then

  0
  bootpath strcat
  path strcat
  2dup to newmodulepath
  modulepath setenv

  \ Try all default kernel names
  flags args 1- load_a_kernel
  0= if ( success )
    oldmodulepath nip -1 <> if
      newmodulepath s" ;" strcat
      oldmodulepath strcat
      modulepath setenv
      newmodulepath drop free-memory
      oldmodulepath drop free-memory
    then
    0 exit
  then

  \ Well, try without the prepended /boot/
  path newmodulepath drop swap move
  newmodulepath drop path nip
  2dup to newmodulepath
  modulepath setenv

  \ Try all default kernel names
  flags args 1- load_a_kernel
  if ( failed once more )
    oldmodulepath restoreenv
    newmodulepath drop free-memory
    1
  else
    oldmodulepath nip -1 <> if
      newmodulepath s" ;" strcat
      oldmodulepath strcat
      modulepath setenv
      newmodulepath drop free-memory
      oldmodulepath drop free-memory
    then
    0
  then
;

\ Try to load a kernel; the kernel name is taken from one of
\ the following lists, as ordered:
\
\   1. The "bootfile" environment variable
\   2. The "kernel" environment variable
\   3. The "path" argument
\
\ Flags are passed, if provided.
\
\ The kernel will be loaded from a directory computed from the
\ path given. Two directories will be tried in the following order:
\
\   1. /boot/path
\   2. path
\
\ Unless "path" is meant to be kernel name itself. In that case, it
\ will first be tried as a full path, and, next, search on the
\ directories pointed by module_path.
\
\ The module_path variable is overridden if load is succesful, by
\ prepending the successful path.

: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
  local args
  2local path
  args 1 = if 0 0 then
  2local flags
  end-locals

  \ First, assume path is an absolute path to a directory
  flags path args clip_args load_from_directory
  dup 0= if exit else drop then

  \ Next, assume path points to the kernel
  flags path args try_multiple_kernels
;

: initialize  ( addr len -- )
  strdup conf_files .len ! conf_files .addr !
;

: kernel_options ( -- addr len 1 | 0 )
  s" kernel_options" getenv
  dup -1 = if drop 0 else 1 then
;

: standard_kernel_search  ( flags 1 | 0 -- flag )
  local args
  args 0= if 0 0 then
  2local flags
  s" kernel" getenv
  dup -1 = if 0 swap then
  2local path
  end-locals

  path nip -1 = if ( there isn't a "kernel" environment variable )
    flags args load_a_kernel
  else
    flags path args 1+ clip_args load_directory_or_file
  then
;

: load_kernel  ( -- ) ( throws: abort )
  kernel_options standard_kernel_search
  abort" Unable to load a kernel!"
;

: set_defaultoptions  ( -- )
  s" kernel_options" getenv dup -1 = if
    drop
  else
    s" temp_options" setenv
  then
;

: argv[]  ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
  2dup = if 0 0 exit then
  dup >r
  1+ 2* ( skip N and ui )
  pick
  r>
  1+ 2* ( skip N and ai )
  pick
;

: drop_args  ( aN uN ... a1 u1 N -- )
  0 ?do 2drop loop
;

: argc
  dup
;

: queue_argv  ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
  >r
  over 2* 1+ -roll
  r>
  over 2* 1+ -roll
  1+
;

: unqueue_argv  ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
  1- -rot
;

: strlen(argv)
  dup 0= if 0 exit then
  0 >r	\ Size
  0 >r	\ Index
  begin
    argc r@ <>
  while
    r@ argv[]
    nip
    r> r> rot + 1+
    >r 1+ >r
  repeat
  r> drop
  r>
;

: concat_argv  ( aN uN ... a1 u1 N -- a u )
  strlen(argv) allocate if out_of_memory throw then
  0 2>r

  begin
    argc
  while
    unqueue_argv
    2r> 2swap
    strcat
    s"  " strcat
    2>r
  repeat
  drop_args
  2r>
;

: set_tempoptions  ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
  \ Save the first argument, if it exists and is not a flag
  argc if
    0 argv[] drop c@ [char] - <> if
      unqueue_argv 2>r  \ Filename
      1 >r		\ Filename present
    else
      0 >r		\ Filename not present
    then
  else
    0 >r		\ Filename not present
  then

  \ If there are other arguments, assume they are flags
  ?dup if
    concat_argv
    2dup s" temp_options" setenv
    drop free if free_error throw then
  else
    set_defaultoptions
  then

  \ Bring back the filename, if one was provided
  r> if 2r> 1 else 0 then
;

: get_arguments ( -- addrN lenN ... addr1 len1 N )
  0
  begin
    \ Get next word on the command line
    parse-word
  ?dup while
    queue_argv
  repeat
  drop ( empty string )
;

: load_kernel_and_modules  ( args -- flag )
  set_tempoptions
  argc >r
  s" temp_options" getenv dup -1 <> if
    queue_argv
  else
    drop
  then
  r> if ( a path was passed )
    load_directory_or_file
  else
    standard_kernel_search
  then
  ?dup 0= if ['] load_modules catch then
;

: read-password { size | buf len -- }
  size allocate if out_of_memory throw then
  to buf
  0 to len
  begin
    key
    dup backspace = if
      drop
      len if
        backspace emit bl emit backspace emit
        len 1 - to len
      else
        bell emit
      then
    else
      dup <cr> = if cr drop buf len exit then
      [char] * emit
      len size < if
        buf len chars + c!
      else
        drop
      then
      len 1+ to len
    then
  again
;

\ Go back to straight forth vocabulary

only forth also definitions

\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

\ Loader.rc support functions:
\
\ initialize_support ( -- )	initialize global variables
\ initialize ( addr len -- )	as above, plus load_conf_files
\ load_conf ( addr len -- )	load conf file given
\ include_conf_files ( -- )	load all conf files in load_conf_files
\ print_syntax_error ( -- )	print line and marker of where a syntax
\				error was detected
\ print_line ( -- )		print last line processed
\ load_kernel ( -- )		load kernel
\ load_modules ( -- )		load modules flagged
\
\ Exported structures:
\
\ string			counted string structure
\	cell .addr			string address
\	cell .len			string length
\ module			module loading information structure
\	cell module.flag		should we load it?
\	string module.name		module's name
\	string module.loadname		name to be used in loading the module
\	string module.type		module's type
\	string module.args		flags to be passed during load
\	string module.beforeload	command to be executed before load
\	string module.afterload		command to be executed after load
\	string module.loaderror		command to be executed if load fails
\	cell module.next		list chain
\
\ Exported global variables;
\
\ string conf_files		configuration files to be loaded
\ string password		password
\ cell modules_options		pointer to first module information
\ value verbose?		indicates if user wants a verbose loading
\ value any_conf_read?		indicates if a conf file was succesfully read
\
\ Other exported words:
\
\ strdup ( addr len -- addr' len)			similar to strdup(3)
\ strcat ( addr len addr' len' -- addr len+len' )	similar to strcat(3)
\ strlen ( addr -- len )				similar to strlen(3)
\ s' ( | string' -- addr len | )			similar to s"
\ rudimentary structure support

\ Exception values

1 constant syntax_error
2 constant out_of_memory
3 constant free_error
4 constant set_error
5 constant read_error
6 constant open_error
7 constant exec_error
8 constant before_load_error
9 constant after_load_error

\ I/O constants

0 constant SEEK_SET
1 constant SEEK_CUR
2 constant SEEK_END

0 constant O_RDONLY
1 constant O_WRONLY
2 constant O_RDWR

\ Crude structure support

: structure:
  create here 0 , ['] drop , 0
  does> create here swap dup @ allot cell+ @ execute
;
: member: create dup , over , + does> cell+ @ + ;
: ;structure swap ! ;
: constructor! >body cell+ ! ;
: constructor: over :noname ;
: ;constructor postpone ; swap cell+ ! ; immediate
: sizeof ' >body @ state @ if postpone literal then ; immediate
: offsetof ' >body cell+ @ state @ if postpone literal then ; immediate
: ptr 1 cells member: ;
: int 1 cells member: ;

\ String structure

structure: string
	ptr .addr
	int .len
	constructor:
	  0 over .addr !
	  0 swap .len !
	;constructor
;structure

\ Module options linked list

structure: module
	int module.flag
	sizeof string member: module.name
	sizeof string member: module.loadname
	sizeof string member: module.type
	sizeof string member: module.args
	sizeof string member: module.beforeload
	sizeof string member: module.afterload
	sizeof string member: module.loaderror
	ptr module.next
;structure

\ Internal loader structures
structure: preloaded_file
	ptr pf.name
	ptr pf.type
	ptr pf.args
	ptr pf.metadata	\ file_metadata
	int pf.loader
	int pf.addr
	int pf.size
	ptr pf.modules	\ kernel_module
	ptr pf.next	\ preloaded_file
;structure

structure: kernel_module
	ptr km.name
	\ ptr km.args
	ptr km.fp	\ preloaded_file
	ptr km.next	\ kernel_module
;structure

structure: file_metadata
	int		md.size
	2 member:	md.type	\ this is not ANS Forth compatible (XXX)
	ptr		md.next	\ file_metadata
	0 member:	md.data	\ variable size
;structure

structure: config_resource
	ptr cf.name
	int cf.type
0 constant RES_INT
1 constant RES_STRING
2 constant RES_LONG
	2 cells member: u
;structure

structure: config_device
	ptr cd.name
	int cd.unit
	int cd.resource_count
	ptr cd.resources	\ config_resource
;structure

structure: STAILQ_HEAD
	ptr stqh_first	\ type*
	ptr stqh_last	\ type**
;structure

structure: STAILQ_ENTRY
	ptr stqe_next	\ type*
;structure

structure: pnphandler
	ptr pnph.name
	ptr pnph.enumerate
;structure

structure: pnpident
	ptr pnpid.ident					\ char*
	sizeof STAILQ_ENTRY cells member: pnpid.link	\ pnpident
;structure

structure: pnpinfo
	ptr pnpi.desc
	int pnpi.revision
	ptr pnpi.module				\ (char*) module args
	int pnpi.argc
	ptr pnpi.argv
	ptr pnpi.handler			\ pnphandler
	sizeof STAILQ_HEAD member: pnpi.ident	\ pnpident
	sizeof STAILQ_ENTRY member: pnpi.link	\ pnpinfo
;structure

\ Global variables

string conf_files
string nextboot_conf_file
string password
create module_options sizeof module.next allot 0 module_options !
create last_module_option sizeof module.next allot 0 last_module_option !
0 value verbose?
0 value nextboot?

\ Support string functions

: strdup  ( addr len -- addr' len )
  >r r@ allocate if out_of_memory throw then
  tuck r@ move
  r>
;

: strcat  { addr len addr' len' -- addr len+len' }
  addr' addr len + len' move
  addr len len' +
;

: strlen ( addr -- len )
  0 >r
  begin
    dup c@ while
    1+ r> 1+ >r repeat
  drop r>
;

: s'
  [char] ' parse
  state @ if
    postpone sliteral
  then
; immediate

: 2>r postpone >r postpone >r ; immediate
: 2r> postpone r> postpone r> ; immediate
: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate

: getenv?
  getenv
  -1 = if false else drop true then
;

\ Private definitions

vocabulary support-functions
only forth also support-functions definitions

\ Some control characters constants

7 constant bell
8 constant backspace
9 constant tab
10 constant lf
13 constant <cr>

\ Read buffer size

80 constant read_buffer_size

\ Standard suffixes

: load_module_suffix s" _load" ;
: module_loadname_suffix s" _name" ;
: module_type_suffix s" _type" ;
: module_args_suffix s" _flags" ;
: module_beforeload_suffix s" _before" ;
: module_afterload_suffix s" _after" ;
: module_loaderror_suffix s" _error" ;

\ Support operators

: >= < 0= ;
: <= > 0= ;

\ Assorted support funcitons

: free-memory free if free_error throw then ;

\ Assignment data temporary storage

string name_buffer
string value_buffer

\ Line by line file reading functions
\
\ exported:
\	line_buffer
\	end_of_file?
\	fd
\	read_line
\	reset_line_reading

vocabulary line-reading
also line-reading definitions also

\ File data temporary storage

string read_buffer
0 value read_buffer_ptr

\ File's line reading function

support-functions definitions

string line_buffer
0 value end_of_file?
variable fd

line-reading definitions

: skip_newlines
  begin
    read_buffer .len @ read_buffer_ptr >
  while
    read_buffer .addr @ read_buffer_ptr + c@ lf = if
      read_buffer_ptr char+ to read_buffer_ptr
    else
      exit
    then
  repeat
;

: scan_buffer  ( -- addr len )
  read_buffer_ptr >r
  begin
    read_buffer .len @ r@ >
  while
    read_buffer .addr @ r@ + c@ lf = if
      read_buffer .addr @ read_buffer_ptr +  ( -- addr )
      r@ read_buffer_ptr -                   ( -- len )
      r> to read_buffer_ptr
      exit
    then
    r> char+ >r
  repeat
  read_buffer .addr @ read_buffer_ptr +  ( -- addr )
  r@ read_buffer_ptr -                   ( -- len )
  r> to read_buffer_ptr
;

: line_buffer_resize  ( len -- len )
  >r
  line_buffer .len @ if
    line_buffer .addr @
    line_buffer .len @ r@ +
    resize if out_of_memory throw then
  else
    r@ allocate if out_of_memory throw then
  then
  line_buffer .addr !
  r>
;

: append_to_line_buffer  ( addr len -- )
  line_buffer .addr @ line_buffer .len @
  2swap strcat
  line_buffer .len !
  drop
;

: read_from_buffer
  scan_buffer            ( -- addr len )
  line_buffer_resize     ( len -- len )
  append_to_line_buffer  ( addr len -- )
;

: refill_required?
  read_buffer .len @ read_buffer_ptr =
  end_of_file? 0= and
;

: refill_buffer
  0 to read_buffer_ptr
  read_buffer .addr @ 0= if
    read_buffer_size allocate if out_of_memory throw then
    read_buffer .addr !
  then
  fd @ read_buffer .addr @ read_buffer_size fread
  dup -1 = if read_error throw then
  dup 0= if true to end_of_file? then
  read_buffer .len !
;

: reset_line_buffer
  line_buffer .addr @ ?dup if
    free-memory
  then
  0 line_buffer .addr !
  0 line_buffer .len !
;

support-functions definitions

: reset_line_reading
  0 to read_buffer_ptr
;

: read_line
  reset_line_buffer
  skip_newlines
  begin
    read_from_buffer
    refill_required?
  while
    refill_buffer
  repeat
;

only forth also support-functions definitions

\ Conf file line parser:
\ <line> ::= <spaces><name><spaces>'='<spaces><value><spaces>[<comment>] |
\            <spaces>[<comment>]
\ <name> ::= <letter>{<letter>|<digit>|'_'}
\ <value> ::= '"'{<character_set>|'\'<anything>}'"' | <name>
\ <character_set> ::= ASCII 32 to 126, except '\' and '"'
\ <comment> ::= '#'{<anything>}
\
\ exported:
\	line_pointer
\	process_conf

0 value line_pointer

vocabulary file-processing
also file-processing definitions

\ parser functions
\
\ exported:
\	get_assignment

vocabulary parser
also parser definitions also

0 value parsing_function
0 value end_of_line

: end_of_line?
  line_pointer end_of_line =
;

: letter?
  line_pointer c@ >r
  r@ [char] A >=
  r@ [char] Z <= and
  r@ [char] a >=
  r> [char] z <= and
  or
;

: digit?
  line_pointer c@ >r
  r@ [char] - =
  r@ [char] 0 >=
  r> [char] 9 <= and
  or
;

: quote?
  line_pointer c@ [char] " =
;

: assignment_sign?
  line_pointer c@ [char] = =
;

: comment?
  line_pointer c@ [char] # =
;

: space?
  line_pointer c@ bl =
  line_pointer c@ tab = or
;

: backslash?
  line_pointer c@ [char] \ =
;

: underscore?
  line_pointer c@ [char] _ =
;

: dot?
  line_pointer c@ [char] . =
;

: skip_character
  line_pointer char+ to line_pointer
;

: skip_to_end_of_line
  end_of_line to line_pointer
;

: eat_space
  begin
    space?
  while
    skip_character
    end_of_line? if exit then
  repeat
;

: parse_name  ( -- addr len )
  line_pointer
  begin
    letter? digit? underscore? dot? or or or
  while
    skip_character
    end_of_line? if
      line_pointer over -
      strdup
      exit
    then
  repeat
  line_pointer over -
  strdup
;

: remove_backslashes  { addr len | addr' len' -- addr' len' }
  len allocate if out_of_memory throw then
  to addr'
  addr >r
  begin
    addr c@ [char] \ <> if
      addr c@ addr' len' + c!
      len' char+ to len'
    then
    addr char+ to addr
    r@ len + addr =
  until
  r> drop
  addr' len'
;

: parse_quote  ( -- addr len )
  line_pointer
  skip_character
  end_of_line? if syntax_error throw then
  begin
    quote? 0=
  while
    backslash? if
      skip_character
      end_of_line? if syntax_error throw then
    then
    skip_character
    end_of_line? if syntax_error throw then
  repeat
  skip_character
  line_pointer over -
  remove_backslashes
;

: read_name
  parse_name		( -- addr len )
  name_buffer .len !
  name_buffer .addr !
;

: read_value
  quote? if
    parse_quote		( -- addr len )
  else
    parse_name		( -- addr len )
  then
  value_buffer .len !
  value_buffer .addr !
;

: comment
  skip_to_end_of_line
;

: white_space_4
  eat_space
  comment? if ['] comment to parsing_function exit then
  end_of_line? 0= if syntax_error throw then
;

: variable_value
  read_value
  ['] white_space_4 to parsing_function
;

: white_space_3
  eat_space
  letter? digit? quote? or or if
    ['] variable_value to parsing_function exit
  then
  syntax_error throw
;

: assignment_sign
  skip_character
  ['] white_space_3 to parsing_function
;

: white_space_2
  eat_space
  assignment_sign? if ['] assignment_sign to parsing_function exit then
  syntax_error throw
;

: variable_name
  read_name
  ['] white_space_2 to parsing_function
;

: white_space_1
  eat_space
  letter?  if ['] variable_name to parsing_function exit then
  comment? if ['] comment to parsing_function exit then
  end_of_line? 0= if syntax_error throw then
;

file-processing definitions

: get_assignment
  line_buffer .addr @ line_buffer .len @ + to end_of_line
  line_buffer .addr @ to line_pointer
  ['] white_space_1 to parsing_function
  begin
    end_of_line? 0=
  while
    parsing_function execute
  repeat
  parsing_function ['] comment =
  parsing_function ['] white_space_1 =
  parsing_function ['] white_space_4 =
  or or 0= if syntax_error throw then
;

only forth also support-functions also file-processing definitions also

\ Process line

: assignment_type?  ( addr len -- flag )
  name_buffer .addr @ name_buffer .len @
  compare 0=
;

: suffix_type?  ( addr len -- flag )
  name_buffer .len @ over <= if 2drop false exit then
  name_buffer .len @ over - name_buffer .addr @ +
  over compare 0=
;

: loader_conf_files?
  s" loader_conf_files" assignment_type?
;

: nextboot_flag?
  s" nextboot_enable" assignment_type?
;

: nextboot_conf?
  s" nextboot_conf" assignment_type?
;

: verbose_flag?
  s" verbose_loading" assignment_type?
;

: execute?
  s" exec" assignment_type?
;

: password?
  s" password" assignment_type?
;

: module_load?
  load_module_suffix suffix_type?
;

: module_loadname?
  module_loadname_suffix suffix_type?
;

: module_type?
  module_type_suffix suffix_type?
;

: module_args?
  module_args_suffix suffix_type?
;

: module_beforeload?
  module_beforeload_suffix suffix_type?
;

: module_afterload?
  module_afterload_suffix suffix_type?
;

: module_loaderror?
  module_loaderror_suffix suffix_type?
;

: set_conf_files
  conf_files .addr @ ?dup if
    free-memory
  then
  value_buffer .addr @ c@ [char] " = if
    value_buffer .addr @ char+ value_buffer .len @ 2 chars -
  else
    value_buffer .addr @ value_buffer .len @
  then
  strdup
  conf_files .len ! conf_files .addr !
;

: set_nextboot_conf
  nextboot_conf_file .addr @ ?dup if
    free-memory
  then
  value_buffer .addr @ c@ [char] " = if
    value_buffer .addr @ char+ value_buffer .len @ 2 chars -
  else
    value_buffer .addr @ value_buffer .len @
  then
  strdup
  nextboot_conf_file .len ! nextboot_conf_file .addr !
;

: append_to_module_options_list  ( addr -- )
  module_options @ 0= if
    dup module_options !
    last_module_option !
  else
    dup last_module_option @ module.next !
    last_module_option !
  then
;

: set_module_name  ( addr -- )
  name_buffer .addr @ name_buffer .len @
  strdup
  >r over module.name .addr !
  r> swap module.name .len !
;

: yes_value?
  value_buffer .addr @ value_buffer .len @
  2dup s' "YES"' compare >r
  2dup s' "yes"' compare >r
  2dup s" YES" compare >r
  s" yes" compare r> r> r> and and and 0=
;

: find_module_option  ( -- addr | 0 )
  module_options @
  begin
    dup
  while
    dup module.name dup .addr @ swap .len @
    name_buffer .addr @ name_buffer .len @
    compare 0= if exit then
    module.next @
  repeat
;

: new_module_option  ( -- addr )
  sizeof module allocate if out_of_memory throw then
  dup sizeof module erase
  dup append_to_module_options_list
  dup set_module_name
;

: get_module_option  ( -- addr )
  find_module_option
  ?dup 0= if new_module_option then
;

: set_module_flag
  name_buffer .len @ load_module_suffix nip - name_buffer .len !
  yes_value? get_module_option module.flag !
;

: set_module_args
  name_buffer .len @ module_args_suffix nip - name_buffer .len !
  get_module_option module.args
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_loadname
  name_buffer .len @ module_loadname_suffix nip - name_buffer .len !
  get_module_option module.loadname
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_type
  name_buffer .len @ module_type_suffix nip - name_buffer .len !
  get_module_option module.type
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_beforeload
  name_buffer .len @ module_beforeload_suffix nip - name_buffer .len !
  get_module_option module.beforeload
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_afterload
  name_buffer .len @ module_afterload_suffix nip - name_buffer .len !
  get_module_option module.afterload
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_module_loaderror
  name_buffer .len @ module_loaderror_suffix nip - name_buffer .len !
  get_module_option module.loaderror
  dup .addr @ ?dup if free-memory then
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 chars - swap char+ swap
  then
  strdup
  >r over .addr !
  r> swap .len !
;

: set_environment_variable
  name_buffer .len @
  value_buffer .len @ +
  5 chars +
  allocate if out_of_memory throw then
  dup 0  ( addr -- addr addr len )
  s" set " strcat
  name_buffer .addr @ name_buffer .len @ strcat
  s" =" strcat
  value_buffer .addr @ value_buffer .len @ strcat
  ['] evaluate catch if
    2drop free drop
    set_error throw
  else
    free-memory
  then
;

: set_nextboot_flag
  yes_value? to nextboot?
;

: set_verbose
  yes_value? to verbose?
;

: execute_command
  value_buffer .addr @ value_buffer .len @
  over c@ [char] " = if
    2 - swap char+ swap
  then
  ['] evaluate catch if exec_error throw then
;

: set_password
  password .addr @ ?dup if free if free_error throw then then
  value_buffer .addr @ c@ [char] " = if
    value_buffer .addr @ char+ value_buffer .len @ 2 - strdup
    value_buffer .addr @ free if free_error throw then
  else
    value_buffer .addr @ value_buffer .len @
  then
  password .len ! password .addr !
  0 value_buffer .addr !
;

: process_assignment
  name_buffer .len @ 0= if exit then
  loader_conf_files?	if set_conf_files exit then
  nextboot_flag?	if set_nextboot_flag exit then
  nextboot_conf?	if set_nextboot_conf exit then
  verbose_flag?		if set_verbose exit then
  execute?		if execute_command exit then
  password?		if set_password exit then
  module_load?		if set_module_flag exit then
  module_loadname?	if set_module_loadname exit then
  module_type?		if set_module_type exit then
  module_args?		if set_module_args exit then
  module_beforeload?	if set_module_beforeload exit then
  module_afterload?	if set_module_afterload exit then
  module_loaderror?	if set_module_loaderror exit then
  set_environment_variable
;

\ free_buffer  ( -- )
\
\ Free some pointers if needed. The code then tests for errors
\ in freeing, and throws an exception if needed. If a pointer is
\ not allocated, it's value (0) is used as flag.

: free_buffers
  name_buffer .addr @ dup if free then
  value_buffer .addr @ dup if free then
  or if free_error throw then
;

: reset_assignment_buffers
  0 name_buffer .addr !
  0 name_buffer .len !
  0 value_buffer .addr !
  0 value_buffer .len !
;

\ Higher level file processing

support-functions definitions

: process_conf
  begin
    end_of_file? 0=
  while
    reset_assignment_buffers
    read_line
    get_assignment
    ['] process_assignment catch
    ['] free_buffers catch
    swap throw throw
  repeat
;

: peek_file
  0 to end_of_file?
  reset_line_reading
  O_RDONLY fopen fd !
  fd @ -1 = if open_error throw then
  reset_assignment_buffers
  read_line
  get_assignment
  ['] process_assignment catch
  ['] free_buffers catch
  fd @ fclose
;

only forth also support-functions definitions

\ Interface to loading conf files

: load_conf  ( addr len -- )
  0 to end_of_file?
  reset_line_reading
  O_RDONLY fopen fd !
  fd @ -1 = if open_error throw then
  ['] process_conf catch
  fd @ fclose
  throw
;

: print_line
  line_buffer .addr @ line_buffer .len @ type cr
;

: print_syntax_error
  line_buffer .addr @ line_buffer .len @ type cr
  line_buffer .addr @
  begin
    line_pointer over <>
  while
    bl emit
    char+
  repeat
  drop
  ." ^" cr
;

\ Debugging support functions

only forth definitions also support-functions

: test-file
  ['] load_conf catch dup .
  syntax_error = if cr print_syntax_error then
;

: show-module-options
  module_options @
  begin
    ?dup
  while
    ." Name: " dup module.name dup .addr @ swap .len @ type cr
    ." Path: " dup module.loadname dup .addr @ swap .len @ type cr
    ." Type: " dup module.type dup .addr @ swap .len @ type cr
    ." Flags: " dup module.args dup .addr @ swap .len @ type cr
    ." Before load: " dup module.beforeload dup .addr @ swap .len @ type cr
    ." After load: " dup module.afterload dup .addr @ swap .len @ type cr
    ." Error: " dup module.loaderror dup .addr @ swap .len @ type cr
    ." Status: " dup module.flag @ if ." Load" else ." Don't load" then cr
    module.next @
  repeat
;

only forth also support-functions definitions

\ Variables used for processing multiple conf files

string current_file_name
variable current_conf_files

\ Indicates if any conf file was succesfully read

0 value any_conf_read?

\ loader_conf_files processing support functions

: set_current_conf_files
  conf_files .addr @ current_conf_files !
;

: get_conf_files
  conf_files .addr @ conf_files .len @ strdup
;

: recurse_on_conf_files?
  current_conf_files @ conf_files .addr @ <>
;

: skip_leading_spaces  { addr len pos -- addr len pos' }
  begin
    pos len = if addr len pos exit then
    addr pos + c@ bl =
  while
    pos char+ to pos
  repeat
  addr len pos
;

: get_file_name  { addr len pos -- addr len pos' addr' len' || 0 }
  pos len = if
    addr free abort" Fatal error freeing memory"
    0 exit
  then
  pos >r
  begin
    addr pos + c@ bl <>
  while
    pos char+ to pos
    pos len = if
      addr len pos addr r@ + pos r> - exit
    then
  repeat
  addr len pos addr r@ + pos r> -
;

: get_next_file  ( addr len ptr -- addr len ptr' addr' len' | 0 )
  skip_leading_spaces
  get_file_name
;

: set_current_file_name
  over current_file_name .addr !
  dup current_file_name .len !
;

: print_current_file
  current_file_name .addr @ current_file_name .len @ type
;

: process_conf_errors
  dup 0= if true to any_conf_read? drop exit then
  >r 2drop r>
  dup syntax_error = if
    ." Warning: syntax error on file " print_current_file cr
    print_syntax_error drop exit
  then
  dup set_error = if
    ." Warning: bad definition on file " print_current_file cr
    print_line drop exit
  then
  dup read_error = if
    ." Warning: error reading file " print_current_file cr drop exit
  then
  dup open_error = if
    verbose? if ." Warning: unable to open file " print_current_file cr then
    drop exit
  then
  dup free_error = abort" Fatal error freeing memory"
  dup out_of_memory = abort" Out of memory"
  throw  \ Unknown error -- pass ahead
;

\ Process loader_conf_files recursively
\ Interface to loader_conf_files processing

: include_conf_files
  set_current_conf_files
  get_conf_files 0
  begin
    get_next_file ?dup
  while
    set_current_file_name
    ['] load_conf catch
    process_conf_errors
    recurse_on_conf_files? if recurse then
  repeat
;

: get_nextboot_conf_file ( -- addr len )
  nextboot_conf_file .addr @ nextboot_conf_file .len @ strdup
;

: rewrite_nextboot_file ( -- )
  get_nextboot_conf_file
  O_WRONLY fopen fd !
  fd @ -1 = if open_error throw then
  fd @ s' nextboot_enable="NO" ' fwrite
  fd @ fclose
;

: include_nextboot_file
  get_nextboot_conf_file
  ['] peek_file catch
  nextboot? if
    get_nextboot_conf_file
    ['] load_conf catch
    process_conf_errors
    ['] rewrite_nextboot_file catch
  then
;

\ Module loading functions

: load_module?
  module.flag @
;

: load_parameters  ( addr -- addr addrN lenN ... addr1 len1 N )
  dup >r
  r@ module.args .addr @ r@ module.args .len @
  r@ module.loadname .len @ if
    r@ module.loadname .addr @ r@ module.loadname .len @
  else
    r@ module.name .addr @ r@ module.name .len @
  then
  r@ module.type .len @ if
    r@ module.type .addr @ r@ module.type .len @
    s" -t "
    4 ( -t type name flags )
  else
    2 ( name flags )
  then
  r> drop
;

: before_load  ( addr -- addr )
  dup module.beforeload .len @ if
    dup module.beforeload .addr @ over module.beforeload .len @
    ['] evaluate catch if before_load_error throw then
  then
;

: after_load  ( addr -- addr )
  dup module.afterload .len @ if
    dup module.afterload .addr @ over module.afterload .len @
    ['] evaluate catch if after_load_error throw then
  then
;

: load_error  ( addr -- addr )
  dup module.loaderror .len @ if
    dup module.loaderror .addr @ over module.loaderror .len @
    evaluate  \ This we do not intercept so it can throw errors
  then
;

: pre_load_message  ( addr -- addr )
  verbose? if
    dup module.name .addr @ over module.name .len @ type
    ." ..."
  then
;

: load_error_message verbose? if ." failed!" cr then ;

: load_succesful_message verbose? if ." ok" cr then ;

: load_module
  load_parameters load
;

: process_module  ( addr -- addr )
  pre_load_message
  before_load
  begin
    ['] load_module catch if
      dup module.loaderror .len @ if
        load_error			\ Command should return a flag!
      else
        load_error_message true		\ Do not retry
      then
    else
      after_load
      load_succesful_message true	\ Succesful, do not retry
    then
  until
;

: process_module_errors  ( addr ior -- )
  dup before_load_error = if
    drop
    ." Module "
    dup module.name .addr @ over module.name .len @ type
    dup module.loadname .len @ if
      ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
    then
    cr
    ." Error executing "
    dup module.beforeload .addr @ over module.afterload .len @ type cr
    abort
  then

  dup after_load_error = if
    drop
    ." Module "
    dup module.name .addr @ over module.name .len @ type
    dup module.loadname .len @ if
      ." (" dup module.loadname .addr @ over module.loadname .len @ type ." )"
    then
    cr
    ." Error executing "
    dup module.afterload .addr @ over module.afterload .len @ type cr
    abort
  then

  throw  \ Don't know what it is all about -- pass ahead
;

\ Module loading interface

: load_modules  ( -- ) ( throws: abort & user-defined )
  module_options @
  begin
    ?dup
  while
    dup load_module? if
      ['] process_module catch
      process_module_errors
    then
    module.next @
  repeat
;

\ h00h00 magic used to try loading either a kernel with a given name,
\ or a kernel with the default name in a directory of a given name
\ (the pain!)

: bootpath s" /boot/" ;
: modulepath s" module_path" ;

\ Functions used to save and restore module_path's value.
: saveenv ( addr len | -1 -- addr' len | 0 -1 )
  dup -1 = if 0 swap exit then
  strdup
;
: freeenv ( addr len | 0 -1 )
  -1 = if drop else free abort" Freeing error" then
;
: restoreenv  ( addr len | 0 -1 -- )
  dup -1 = if ( it wasn't set )
    2drop
    modulepath unsetenv
  else
    over >r
    modulepath setenv
    r> free abort" Freeing error"
  then
;

: clip_args   \ Drop second string if only one argument is passed
  1 = if
    2swap 2drop
    1
  else
    2
  then
;

also builtins

\ Parse filename from a comma-separated list

: parse-; ( addr len -- addr' len-x addr x )
  over 0 2swap
  begin
    dup 0 <>
  while
    over c@ [char] ; <>
  while
    1- swap 1+ swap
    2swap 1+ 2swap
  repeat then
  dup 0 <> if
    1- swap 1+ swap
  then
  2swap
;

\ Try loading one of multiple kernels specified

: try_multiple_kernels ( addr len addr' len' args -- flag )
  >r
  begin
    parse-; 2>r
    2over 2r>
    r@ clip_args
    s" DEBUG" getenv? if
      s" echo Module_path: ${module_path}" evaluate
      ." Kernel     : " >r 2dup type r> cr
      dup 2 = if ." Flags      : " >r 2over type r> cr then
    then
    1 load
  while
    dup 0=
  until
    1 >r \ Failure
  else
    0 >r \ Success
  then
  2drop 2drop
  r>
  r> drop
;

\ Try to load a kernel; the kernel name is taken from one of
\ the following lists, as ordered:
\
\   1. The "bootfile" environment variable
\   2. The "kernel" environment variable
\
\ Flags are passed, if available. If not, dummy values must be given.
\
\ The kernel gets loaded from the current module_path.

: load_a_kernel ( flags len 1 | x x 0 -- flag )
  local args
  2local flags
  0 0 2local kernel
  end-locals

  \ Check if a default kernel name exists at all, exits if not
  s" bootfile" getenv dup -1 <> if
    to kernel
    flags kernel args 1+ try_multiple_kernels
    dup 0= if exit then
  then
  drop

  s" kernel" getenv dup -1 <> if
    to kernel
  else
    drop
    1 exit \ Failure
  then

  \ Try all default kernel names
  flags kernel args 1+ try_multiple_kernels
;

\ Try to load a kernel; the kernel name is taken from one of
\ the following lists, as ordered:
\
\   1. The "bootfile" environment variable
\   2. The "kernel" environment variable
\
\ Flags are passed, if provided.
\
\ The kernel will be loaded from a directory computed from the
\ path given. Two directories will be tried in the following order:
\
\   1. /boot/path
\   2. path
\
\ The module_path variable is overridden if load is succesful, by
\ prepending the successful path.

: load_from_directory ( path len 1 | flags len' path len 2 -- flag )
  local args
  2local path
  args 1 = if 0 0 then
  2local flags
  0 0 2local oldmodulepath
  0 0 2local newmodulepath
  end-locals

  \ Set the environment variable module_path, and try loading
  \ the kernel again.
  modulepath getenv saveenv to oldmodulepath

  \ Try prepending /boot/ first
  bootpath nip path nip +
  oldmodulepath nip dup -1 = if
    drop
  else
    1+ +
  then
  allocate
  if ( out of memory )
    1 exit
  then

  0
  bootpath strcat
  path strcat
  2dup to newmodulepath
  modulepath setenv

  \ Try all default kernel names
  flags args 1- load_a_kernel
  0= if ( success )
    oldmodulepath nip -1 <> if
      newmodulepath s" ;" strcat
      oldmodulepath strcat
      modulepath setenv
      newmodulepath drop free-memory
      oldmodulepath drop free-memory
    then
    0 exit
  then

  \ Well, try without the prepended /boot/
  path newmodulepath drop swap move
  newmodulepath drop path nip
  2dup to newmodulepath
  modulepath setenv

  \ Try all default kernel names
  flags args 1- load_a_kernel
  if ( failed once more )
    oldmodulepath restoreenv
    newmodulepath drop free-memory
    1
  else
    oldmodulepath nip -1 <> if
      newmodulepath s" ;" strcat
      oldmodulepath strcat
      modulepath setenv
      newmodulepath drop free-memory
      oldmodulepath drop free-memory
    then
    0
  then
;

\ Try to load a kernel; the kernel name is taken from one of
\ the following lists, as ordered:
\
\   1. The "bootfile" environment variable
\   2. The "kernel" environment variable
\   3. The "path" argument
\
\ Flags are passed, if provided.
\
\ The kernel will be loaded from a directory computed from the
\ path given. Two directories will be tried in the following order:
\
\   1. /boot/path
\   2. path
\
\ Unless "path" is meant to be kernel name itself. In that case, it
\ will first be tried as a full path, and, next, search on the
\ directories pointed by module_path.
\
\ The module_path variable is overridden if load is succesful, by
\ prepending the successful path.

: load_directory_or_file ( path len 1 | flags len' path len 2 -- flag )
  local args
  2local path
  args 1 = if 0 0 then
  2local flags
  end-locals

  \ First, assume path is an absolute path to a directory
  flags path args clip_args load_from_directory
  dup 0= if exit else drop then

  \ Next, assume path points to the kernel
  flags path args try_multiple_kernels
;

: initialize  ( addr len -- )
  strdup conf_files .len ! conf_files .addr !
;

: kernel_options ( -- addr len 1 | 0 )
  s" kernel_options" getenv
  dup -1 = if drop 0 else 1 then
;

: standard_kernel_search  ( flags 1 | 0 -- flag )
  local args
  args 0= if 0 0 then
  2local flags
  s" kernel" getenv
  dup -1 = if 0 swap then
  2local path
  end-locals

  path nip -1 = if ( there isn't a "kernel" environment variable )
    flags args load_a_kernel
  else
    flags path args 1+ clip_args load_directory_or_file
  then
;

: load_kernel  ( -- ) ( throws: abort )
  kernel_options standard_kernel_search
  abort" Unable to load a kernel!"
;

: set_defaultoptions  ( -- )
  s" kernel_options" getenv dup -1 = if
    drop
  else
    s" temp_options" setenv
  then
;

: argv[]  ( aN uN ... a1 u1 N i -- aN uN ... a1 u1 N ai+1 ui+1 )
  2dup = if 0 0 exit then
  dup >r
  1+ 2* ( skip N and ui )
  pick
  r>
  1+ 2* ( skip N and ai )
  pick
;

: drop_args  ( aN uN ... a1 u1 N -- )
  0 ?do 2drop loop
;

: argc
  dup
;

: queue_argv  ( aN uN ... a1 u1 N a u -- a u aN uN ... a1 u1 N+1 )
  >r
  over 2* 1+ -roll
  r>
  over 2* 1+ -roll
  1+
;

: unqueue_argv  ( aN uN ... a1 u1 N -- aN uN ... a2 u2 N-1 a1 u1 )
  1- -rot
;

: strlen(argv)
  dup 0= if 0 exit then
  0 >r	\ Size
  0 >r	\ Index
  begin
    argc r@ <>
  while
    r@ argv[]
    nip
    r> r> rot + 1+
    >r 1+ >r
  repeat
  r> drop
  r>
;

: concat_argv  ( aN uN ... a1 u1 N -- a u )
  strlen(argv) allocate if out_of_memory throw then
  0 2>r

  begin
    argc
  while
    unqueue_argv
    2r> 2swap
    strcat
    s"  " strcat
    2>r
  repeat
  drop_args
  2r>
;

: set_tempoptions  ( addrN lenN ... addr1 len1 N -- addr len 1 | 0 )
  \ Save the first argument, if it exists and is not a flag
  argc if
    0 argv[] drop c@ [char] - <> if
      unqueue_argv 2>r  \ Filename
      1 >r		\ Filename present
    else
      0 >r		\ Filename not present
    then
  else
    0 >r		\ Filename not present
  then

  \ If there are other arguments, assume they are flags
  ?dup if
    concat_argv
    2dup s" temp_options" setenv
    drop free if free_error throw then
  else
    set_defaultoptions
  then

  \ Bring back the filename, if one was provided
  r> if 2r> 1 else 0 then
;

: get_arguments ( -- addrN lenN ... addr1 len1 N )
  0
  begin
    \ Get next word on the command line
    parse-word
  ?dup while
    queue_argv
  repeat
  drop ( empty string )
;

: load_kernel_and_modules  ( args -- flag )
  set_tempoptions
  argc >r
  s" temp_options" getenv dup -1 <> if
    queue_argv
  else
    drop
  then
  r> if ( a path was passed )
    load_directory_or_file
  else
    standard_kernel_search
  then
  ?dup 0= if ['] load_modules catch then
;

: read-password { size | buf len -- }
  size allocate if out_of_memory throw then
  to buf
  0 to len
  begin
    key
    dup backspace = if
      drop
      len if
        backspace emit bl emit backspace emit
        len 1 - to len
      else
        bell emit
      then
    else
      dup <cr> = if cr drop buf len exit then
      [char] * emit
      len size < if
        buf len chars + c!
      else
        drop
      then
      len 1+ to len
    then
  again
;

\ Go back to straight forth vocabulary

only forth also definitions