version 1.18, 1994/09/02 15:23:36
|
version 1.19, 1994/09/05 17:36:20
|
Line 110 Defer source
|
Line 110 Defer source
|
|
|
\ (word) 22feb93py |
\ (word) 22feb93py |
|
|
: scan ( addr1 n1 char -- addr2 n2 ) >r |
: scan ( addr1 n1 char -- addr2 n2 ) |
BEGIN dup WHILE over c@ r@ <> WHILE 1 /string |
\ skip all characters not equal to char |
REPEAT THEN rdrop ; |
>r |
: skip ( addr1 n1 char -- addr2 n2 ) >r |
BEGIN |
BEGIN dup WHILE over c@ r@ = WHILE 1 /string |
dup |
REPEAT THEN rdrop ; |
WHILE |
|
over c@ r@ <> |
|
WHILE |
|
1 /string |
|
REPEAT THEN |
|
rdrop ; |
|
: skip ( addr1 n1 char -- addr2 n2 ) |
|
\ skip all characters equal to char |
|
>r |
|
BEGIN |
|
dup |
|
WHILE |
|
over c@ r@ = |
|
WHILE |
|
1 /string |
|
REPEAT THEN |
|
rdrop ; |
|
|
: (word) ( addr1 n1 char -- addr2 n2 ) |
: (word) ( addr1 n1 char -- addr2 n2 ) |
dup >r skip 2dup r> scan nip - ; |
dup >r skip 2dup r> scan nip - ; |
Line 1151 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1167 create nl$ 1 c, A c, 0 c, \ gnu includes
|
loadfile @ close-file swap |
loadfile @ close-file swap |
pop-file throw throw ; |
pop-file throw throw ; |
|
|
|
create pathfilenamebuf 256 chars allot \ !! make this grow on demand |
|
|
|
: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) |
|
\ opens a file for reading, searching in the path for it; c-addr2 |
|
\ u2 is the full filename (valid until the next call); if the file |
|
\ is not found (or in case of other errors for each try), -38 |
|
\ (non-existant file) is thrown. Opening for other access modes |
|
\ makes little sense, as the path will usually contain dirs that |
|
\ are only readable for the user |
|
\ !! check for "/", "./", "../" in original filename; check for "~/"? |
|
pathdirs 2@ 0 |
|
?DO ( c-addr1 u1 dirnamep ) |
|
dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u ) |
|
2dup pathfilenamebuf r@ chars + swap cmove ( addr u ) |
|
pathfilenamebuf over r> + dup >r r/o open-file 0= |
|
if ( addr u file-id ) |
|
nip nip r> rdrop 0 leave |
|
then |
|
rdrop drop r> cell+ cell+ |
|
LOOP |
|
0<> -&38 and throw ( file-id u2 ) |
|
pathfilenamebuf swap ; |
|
|
: included ( i*x addr u -- j*x ) |
: included ( i*x addr u -- j*x ) |
loadfilename 2@ >r >r |
loadfilename 2@ >r >r |
dup allocate throw over loadfilename 2! |
open-path-file ( file-id c-addr2 u2 ) |
over loadfilename 2@ move |
dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 ) |
r/o open-file throw include-file |
drop loadfilename 2@ move |
|
include-file |
\ don't free filenames; they don't take much space |
\ don't free filenames; they don't take much space |
\ and are used for debugging |
\ and are used for debugging |
r> r> loadfilename 2! ; |
r> r> loadfilename 2! ; |
Line 1302 DEFER DOERROR
|
Line 1342 DEFER DOERROR
|
\ : words listwords @ |
\ : words listwords @ |
\ BEGIN @ dup WHILE dup .name REPEAT drop ; |
\ BEGIN @ dup WHILE dup .name REPEAT drop ; |
|
|
: >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ; |
: cstring>sstring ( cstring -- addr n ) -1 0 scan 0 swap 1+ /string ; |
: arg ( n -- addr count ) cells argv @ + @ >len ; |
: arg ( n -- addr count ) cells argv @ + @ cstring>sstring ; |
: #! postpone \ ; immediate |
: #! postpone \ ; immediate |
|
|
Variable env |
Create pathstring 2 cells allot \ string |
|
Create pathdirs 2 cells allot \ dir string array, pointer and count |
Variable argv |
Variable argv |
Variable argc |
Variable argc |
|
|
0 Value script? ( -- flag ) |
0 Value script? ( -- flag ) |
|
|
|
: process-path ( addr1 u1 -- addr2 u2 ) |
|
\ addr1 u1 is a path string, addr2 u2 is an array of dir strings |
|
here >r |
|
BEGIN |
|
over >r [char] : scan |
|
over r> tuck - ( rest-str this-str ) |
|
dup |
|
IF |
|
2dup 1- chars + c@ [char] / <> |
|
IF |
|
2dup chars + [char] / swap c! |
|
1+ |
|
THEN |
|
2, |
|
ELSE |
|
2drop |
|
THEN |
|
dup |
|
WHILE |
|
1 /string |
|
REPEAT |
|
2drop |
|
here r> tuck - 2 cells / ; |
|
|
: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; |
: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; |
|
|
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
Line 1320 Variable argc
|
Line 1385 Variable argc
|
IF 2drop ">tib interpret 2 EXIT THEN |
IF 2drop ">tib interpret 2 EXIT THEN |
." Unknown option: " type cr 2drop 1 ; |
." Unknown option: " type cr 2drop 1 ; |
|
|
: process-args ( -- ) argc @ 1 |
: process-args ( -- ) |
?DO I arg over c@ [char] - <> |
argc @ 1 |
IF true to script? included false to script? 1 |
?DO |
ELSE I 1+ arg do-option |
I arg over c@ [char] - <> |
THEN |
IF |
+LOOP ; |
true to script? included false to script? 1 |
|
ELSE |
|
I 1+ arg do-option |
|
THEN |
|
+LOOP ; |
|
|
: cold ( -- ) |
: cold ( -- ) |
|
pathstring 2@ process-path pathdirs 2! |
argc @ 1 > |
argc @ 1 > |
IF |
IF |
['] process-args catch ?dup |
['] process-args catch ?dup |
Line 1356 Variable argc
|
Line 1426 Variable argc
|
." along with this program; if not, write to the Free Software" cr |
." along with this program; if not, write to the Free Software" cr |
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
|
|
: boot ( **env **argv argc -- ) |
: boot ( path **argv argc -- ) |
argc ! argv ! env ! main-task up! |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
|
|
: bye script? 0= IF cr THEN 0 (bye) ; |
: bye script? 0= IF cr THEN 0 (bye) ; |