Diff for /gforth/Attic/kernal.fs between versions 1.36 and 1.38

version 1.36, 1995/04/30 23:18:23 version 1.38, 1995/06/07 10:05:06
Line 1215  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1215  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 create pathfilenamebuf 256 chars allot \ !! make this grow on demand  create pathfilenamebuf 256 chars allot \ !! make this grow on demand
   
 : check-file-prefix  ( addr len -- addr' len' flag )  \ : check-file-prefix  ( addr len -- addr' len' flag )
   dup 0=                    IF  true EXIT  THEN   \   dup 0=                    IF  true EXIT  THEN 
   over c@ '/ =              IF  true EXIT  THEN   \   over c@ '/ =              IF  true EXIT  THEN 
   over 2 S" ./" compare 0=  IF  true EXIT  THEN   \   over 2 S" ./" compare 0=  IF  true EXIT  THEN 
   over 3 S" ../" compare 0= IF  true EXIT  THEN  \   over 3 S" ../" compare 0= IF  true EXIT  THEN
   over 2 S" ~/" compare 0=  \   over 2 S" ~/" compare 0=
   IF     1 /string  \   IF     1 /string
          S" HOME" getenv tuck pathfilenamebuf swap move  \          S" HOME" getenv tuck pathfilenamebuf swap move
          2dup + >r pathfilenamebuf + swap move  \          2dup + >r pathfilenamebuf + swap move
          pathfilenamebuf r> true  \          pathfilenamebuf r> true
   ELSE   false  \   ELSE   false
   THEN ;  \   THEN ;
   
 : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )  : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )
     \ opens a file for reading, searching in the path for it; c-addr2      \ opens a file for reading, searching in the path for it (unless
     \ u2 is the full filename (valid until the next call); if the file      \ the filename contains a slash); c-addr2 u2 is the full filename
     \ is not found (or in case of other errors for each try), -38      \ (valid until the next call); if the file is not found (or in
     \ (non-existant file) is thrown. Opening for other access modes      \ case of other errors for each try), -38 (non-existant file) is
     \ makes little sense, as the path will usually contain dirs that      \ thrown. Opening for other access modes makes little sense, as
     \ are only readable for the user      \ the path will usually contain dirs that are only readable for
     \ !! check for "/", "./", "../" in original filename; check for "~/"?      \ the user
     check-file-prefix 0=       \ !! use file-status to determine access mode?
     IF  pathdirs 2@ 0      2dup [char] / scan nip ( 0<> )
       if \ the filename contains a slash
           2dup r/o open-file throw ( c-addr1 u1 file-id )
           -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
           pathfilenamebuf r> EXIT
       then
       pathdirs 2@ 0
   \    check-file-prefix 0= 
   \    IF  pathdirs 2@ 0
     ?DO ( c-addr1 u1 dirnamep )      ?DO ( c-addr1 u1 dirnamep )
         dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )          dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
         2dup pathfilenamebuf r@ chars + swap cmove ( addr u )          2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
         pathfilenamebuf over r> + dup >r r/o open-file 0=          pathfilenamebuf over r> + dup >r r/o open-file 0=
         IF ( addr u file-id )          IF ( addr u file-id )
             nip nip r> rdrop 0 leave              nip nip r> rdrop 0 LEAVE
         THEN          THEN
         rdrop drop r> cell+ cell+          rdrop drop r> cell+ cell+
     LOOP      LOOP
     ELSE   2dup open-file throw -rot  THEN   \    ELSE   2dup open-file throw -rot  THEN 
     0<> -&38 and throw ( file-id u2 )      0<> -&38 and throw ( file-id u2 )
     pathfilenamebuf swap ;      pathfilenamebuf swap ;
   
Line 1522  Defer 'cold ' noop IS 'cold Line 1530  Defer 'cold ' noop IS 'cold
         THEN          THEN
     THEN      THEN
     cr      cr
     ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr      ." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr
     ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr      ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
     ." Type `bye' to exit"      ." Type `bye' to exit"
     loadline off quit ;      loadline off quit ;

Removed from v.1.36  
changed lines
  Added in v.1.38


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>