\ Copyright 2021 Bradley D. Nelson 
\ 
\ Licensed under the Apache License, Version 2.0 (the "License"); 
\ you may not use this file except in compliance with the License. 
\ You may obtain a copy of the License at 
\ 
\     http://www.apache.org/licenses/LICENSE-2.0 
\ 
\ Unless required by applicable law or agreed to in writing, software 
\ distributed under the License is distributed on an "AS IS" BASIS, 
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 
\ See the License for the specific language governing permissions and 
\ limitations under the License. 
 
( Including Files ) 
 
internals definitions 
 
: ends/ ( a n -- f ) 1- + c@ [char] / = ; 
: dirname ( a n -- ) 
   dup if 
     2dup ends/ if 1- then 
   then 
   begin dup while 
     2dup ends/ if exit then 1- 
   repeat ; 
 
: starts./ ( a n -- f ) 
   2 < if drop 0 exit then 
   2 s" ./" str= ; 
 
: starts../ ( a n -- f ) 
   3 < if drop 0 exit then 
   3 s" ../" str= ; 
 
0 value sourcefilename& 
0 value sourcefilename# 
: sourcefilename ( -- a n ) sourcefilename& sourcefilename# ; 
: sourcefilename! ( a n -- ) to sourcefilename# to sourcefilename& ; 
: sourcedirname ( -- a n ) sourcefilename dirname ; 
 
: include-file ( fh -- ) 
   dup file-size throw 
   dup allocate throw 
   swap over >r 
   rot read-file throw 
   r@ swap evaluate 
   r> free throw ; 
 
: raw-included ( a n -- ) 
   r/o open-file throw 
   dup >r include-file 
   r> close-file throw ; 
 
0 value included-files 
 
: path-join { a a# b b# -- a n } 
  a# b# + { r# } r# cell+ cell+ allocate throw { r } 
  2 cells +to r 
  b c@ [char] / = if 0 to a# then 
  begin b b# starts./ while 
    2 +to b -2 +to b# 
    a# b# + to r# 
  repeat 
  begin b b# starts../ a# 0<> and while 
    3 +to b -3 +to b# 
    a a# dirname to a# to a 
    a# b# + to r# 
  repeat 
  a r a# cmove b r a# + b# cmove 
  r# r cell - ! 
  r r# ; 
: include+ 2 cells - { a } 
  included-files a ! a to included-files ; 
 
forth definitions internals 
 
: included ( a n -- ) 
   sourcefilename >r >r 
   >r >r sourcedirname r> r> path-join 2dup sourcefilename! 
   ['] raw-included catch if 
      ." Error including: " sourcefilename type cr 
      -38 throw 
   then 
   sourcefilename& include+ 
   r> r> sourcefilename! ; 
 
: include ( "name" -- ) bl parse included ; 
 
: included? { a n -- f } 
  sourcedirname a n path-join to n to a 
  included-files begin dup while 
    dup cell+ cell+ over cell+ @ a n str= if 
      a 2 cells - free throw drop -1 exit 
    then @ 
  repeat 
  a 2 cells - free throw ; 
 
: required ( a n -- ) 2dup included? if 2drop else included then ; 
: needs ( "name" -- ) bl parse required ; 
 
: file-exists? ( "name" -- f ) r/o open-file if drop 0 else close-file throw -1 then ; 
 
forth 
 

Legal: site web personnel sans commerce / personal site without seling