CoreForth-0

p3216/files.ft.md


0 constant r/w
0 constant w/o
1 constant r/o

$2000 buffer: #include-stack
variable include-stack#
$400 buffer: tmp-path

: include-stack #include-stack include-stack# @ ;

: include-stack@   ( -- #path path# )
                include-stack dup$ [char] : find<$ 0= if drop$ s" ." exit then
                1+ tail$
                ;

: >include-stack   ( #path path# -- )
                include-stack [char] : cappend$ dup include-stack# !
                swap$ append$ include-stack# ! drop
                ;

: include-stack>   ( -- #path #path# )
                include-stack dup$ [char] : find<$ 0= if drop$ s" ." exit then
                dup >r 1+ tail$ r> include-stack# !
                ;

: dirname       ( -- #dir dir# )
                dup$ [char] / find<$ if
                  ?dup if nip else drop$ s" /" then
                else
                  drop$ s" ."
                then
                ;

: basename      ( -- #basename basename# )
                dup$ [char] / find<$ if 1+ dup >r - r> rot + swap exit then ;

: make-path     ( #result #result-max #rel-path rel-path# -- #result result# )
                over$ 0> swap c@ [char] / <> and if
                  include-stack@ append$
                  [char] / cappend$ swap$ append$
                else drop$
                then
                dup$ dirname >include-stack
                ;

: get-dir       ( -- #dir dir# )
                over swap pwd ;

: read-line     swap dup >r 0 do
                  dup getc dup 0< if drop 2drop i false 0 unloop rdrop exit then
                           dup #10 = if drop 2drop i true 0 unloop rdrop exit then
                  rot tuck i + c! swap
                loop
                2drop r> true 0
                ;

: included      source-id >r
                tmp-path 0 make-path r/o open-file abort" file not found" (source-id) !
                begin
                  tib dup tib# source-id read-line abort" error readline line" while
                  dup$ type cr
                  ['] evaluate catch if ex. space tib >in @ type cr bye then
                repeat
                2drop
                source-id close-file abort" error closing file"
                r> (source-id) !
                include-stack> drop$
                ;

: include       bl word count included ;

: arg           pad $100 rot (arg) pad swap ;
: argc          (argc) pad tuck ! ;