| 0 avalue fpath ( -- path-addr ) \ gforth |
0 avalue fpath ( -- path-addr ) \ gforth |
| |
|
| : os-cold ( -- ) |
: os-cold ( -- ) |
| 1024 chars dup 2 cells + allocate throw to fpath |
$400 chars dup 2 cells + allocate throw to fpath |
| 0 swap fpath 2! |
0 swap fpath 2! |
| pathstring 2@ fpath only-path |
pathstring 2@ fpath only-path |
| init-included-files ; |
init-included-files ; |
| \G Make a complete new Forth search path; the path separator is |. |
\G Make a complete new Forth search path; the path separator is |. |
| fpath path= ; |
fpath path= ; |
| |
|
| : path>counted cell+ dup cell+ swap @ ; |
: path>string ( path -- c-addr u ) |
| |
\ string contains NULs to separate/terminate components |
| |
cell+ dup cell+ swap @ ; |
| |
|
| : next-path ( adr len -- adr2 len2 ) |
: next-path ( addr u -- addr1 u1 addr2 u2 ) |
| |
\ addr2 u2 is the first component of the path, addr1 u1 is the rest |
| 2dup 0 scan |
2dup 0 scan |
| dup 0= IF 2drop 0 -rot 0 -rot EXIT THEN |
dup 0= IF 2drop 0 -rot 0 -rot EXIT THEN |
| >r 1+ -rot r@ 1- -rot |
>r 1+ -rot r@ 1- -rot |
| |
|
| : previous-path ( path^ -- ) |
: previous-path ( path^ -- ) |
| \ !! "fpath previous-path" doesn't work |
\ !! "fpath previous-path" doesn't work |
| dup path>counted |
dup path>string |
| BEGIN tuck dup WHILE repeat ; |
BEGIN tuck dup WHILE repeat ; |
| |
|
| : .path ( path-addr -- ) \ gforth |
: .path ( path-addr -- ) \ gforth |
| \G Display the contents of the search path @var{path-addr}. |
\G Display the contents of the search path @var{path-addr}. |
| path>counted |
path>string |
| BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; |
BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; |
| |
|
| : .fpath ( -- ) \ gforth |
: .fpath ( -- ) \ gforth |
| ofile +place |
ofile +place |
| THEN ; |
THEN ; |
| |
|
| : compact.. ( adr len -- adr2 len2 ) |
: del-string ( addr u u1 -- addr u2 ) |
| \ deletes phrases like "xy/.." out of our directory name 2dec97jaw |
\ delete u1 characters from string by moving stuff from further up |
| over swap |
2 pick >r /string r@ over >r swap cmove 2r> ; |
| BEGIN dup WHILE |
|
| dup >r '/ scan 2dup s" /../" string-prefix? |
: del-./s ( addr u -- addr u2 ) |
| IF |
\ deletes (/*./)* at the start of the string |
| dup r> - >r 4 /string over r> + 4 - |
BEGIN ( current-addr u ) |
| swap 2dup + >r move dup r> over - |
BEGIN ( current-addr u ) |
| ELSE |
over c@ '/ = WHILE |
| rdrop dup 1 min /string |
1 del-string |
| THEN |
REPEAT |
| REPEAT drop over - ; |
2dup s" ./" string-prefix? WHILE |
| |
2 del-string |
| |
REPEAT ; |
| |
|
| |
: preserve-root ( addr1 u1 -- addr2 u2 ) |
| |
over c@ '/ = if \ preserve / at start |
| |
1 /string |
| |
endif ; |
| |
|
| |
|
| |
: skip-..-prefixes ( addr1 u1 -- addr2 u2 ) |
| |
\ deal with ../ at start |
| |
begin ( current-addr u ) |
| |
del-./s 2dup s" ../" string-prefix? while |
| |
3 /string |
| |
repeat ; |
| |
|
| |
: compact-filename ( addr u1 -- addr u2 ) |
| |
\ rewrite filename in place, eliminating multiple slashes, "./", and "x/.." |
| |
over swap preserve-root skip-..-prefixes |
| |
( start current-addr u ) |
| |
over swap '/ scan dup if ( start addr3 addr4 u4 ) |
| |
1 /string del-./s recurse |
| |
2dup s" ../" string-prefix? if ( start addr3 addr4 u4 ) |
| |
3 /string ( start to from count ) |
| |
>r swap 2dup r@ cmove r> |
| |
endif |
| |
endif |
| |
+ nip over - ; |
| |
|
| |
\ test cases: |
| |
\ s" z/../../../a" compact-filename type cr |
| |
\ s" ../z/../../../a/c" compact-filename type cr |
| |
\ s" /././//./../..///x/y/../z/.././..//..//a//b/../c" compact-filename type cr |
| |
|
| : reworkdir ( -- ) |
: reworkdir ( -- ) |
| remove~+ |
remove~+ |
| ofile count compact.. |
ofile count compact-filename |
| nip ofile c! ; |
nip ofile c! ; |
| |
|
| : open-ofile ( -- fid ior ) |
: open-ofile ( -- fid ior ) |
| IF rdrop |
IF rdrop |
| ofile place open-ofile |
ofile place open-ofile |
| dup 0= IF >r ofile count r> THEN EXIT |
dup 0= IF >r ofile count r> THEN EXIT |
| ELSE r> path>counted |
ELSE r> path>string |
| BEGIN next-path dup |
BEGIN next-path dup |
| WHILE 5 pick 5 pick check-path |
WHILE 5 pick 5 pick check-path |
| 0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN |
0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN |
