--- gforth/Attic/kernal.fs	1995/04/14 18:56:55	1.34
+++ gforth/Attic/kernal.fs	1995/06/07 10:05:06	1.38
@@ -153,14 +153,14 @@ Defer source
 \ word parse                                           23feb93py
 
 : parse-word  ( char -- addr len )
-  source 2dup >r >r >in @ /string
+  source 2dup >r >r >in @ over min /string
   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
   2dup + r> - 1+ r> min >in ! ;
 : word   ( char -- addr )
   parse-word here place  bl here count + c!  here ;
 
 : parse    ( char -- addr len )
-  >r  source  >in @ /string  over  swap r>  scan >r
+  >r  source  >in @ over min /string  over  swap r>  scan >r
   over - dup r> IF 1+ THEN  >in +! ;
 
 \ name                                                 13feb93py
@@ -173,6 +173,12 @@ Defer source
     2dup + r> - 1+ r> min >in ! ;
 \    name count ;
 
+: name-too-short? ( c-addr u -- c-addr u )
+    dup 0= -&16 and throw ;
+
+: name-too-long? ( c-addr u -- c-addr u )
+    dup $1F u> -&19 and throw ;
+
 \ Literal                                              17dec92py
 
 : Literal  ( n -- )  state @ IF postpone lit  , THEN ;
@@ -781,7 +787,16 @@ Avariable leave-sp  leave-stack 3 cells
 : (S")     "lit count ;                                restrict
 : SLiteral postpone (S") here over char+ allot  place align ;
                                              immediate restrict
-: S"       [char] " parse  state @ IF  postpone SLiteral  THEN ;
+create s"-buffer /line chars allot
+: S" ( run-time: -- c-addr u )
+    [char] " parse
+    state @
+    IF
+	postpone SLiteral
+    ELSE
+	/line min >r s"-buffer r@ cmove
+	s"-buffer r>
+    THEN ;
                                              immediate
 : ."       state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate
@@ -827,8 +842,7 @@ defer header     ' (header) IS header
     dup c, here swap chars dup allot move ;
 
 : name,  ( "name" -- )
-    name
-    dup $1F u> -&19 and throw ( is name too long? )
+    name name-too-short? name-too-long?
     string, cfalign ;
 : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent
@@ -854,7 +868,7 @@ create nextname-buffer 32 chars allot
 
 \ the next name is given in the string
 : nextname ( c-addr u -- ) \ general
-    dup $1F u> -&19 and throw ( is name too long? )
+    name-too-long?
     nextname-buffer c! ( c-addr )
     nextname-buffer count move
     ['] nextname-header IS (header) ;
@@ -1161,7 +1175,7 @@ Defer key
 \ : bin           dup 1 chars - c@
 \                 r/o 4 chars + over - dup >r swap move r> ;
 
-: bin  1+ ;
+: bin  1 or ;
 
 create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
                            \ or not unix environments if
@@ -1201,24 +1215,47 @@ create nl$ 1 c, A c, 0 c, \ gnu includes
 
 create pathfilenamebuf 256 chars allot \ !! make this grow on demand
 
+\ : check-file-prefix  ( addr len -- addr' len' flag )
+\   dup 0=                    IF  true EXIT  THEN 
+\   over c@ '/ =              IF  true EXIT  THEN 
+\   over 2 S" ./" compare 0=  IF  true EXIT  THEN 
+\   over 3 S" ../" compare 0= IF  true EXIT  THEN
+\   over 2 S" ~/" compare 0=
+\   IF     1 /string
+\          S" HOME" getenv tuck pathfilenamebuf swap move
+\          2dup + >r pathfilenamebuf + swap move
+\          pathfilenamebuf r> true
+\   ELSE   false
+\   THEN ;
+
 : 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 "~/"?
+    \ opens a file for reading, searching in the path for it (unless
+    \ the filename contains a slash); 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
+    \ !! use file-status to determine access mode?
+    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 )
 	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
+	IF ( addr u file-id )
+	    nip nip r> rdrop 0 LEAVE
+	THEN
 	rdrop drop r> cell+ cell+
     LOOP
+\    ELSE   2dup open-file throw -rot  THEN 
     0<> -&38 and throw ( file-id u2 )
     pathfilenamebuf swap ;
 
@@ -1471,7 +1508,7 @@ Variable argc
     ?DO
 	I arg over c@ [char] - <>
 	IF
-	    included 1
+	    required 1
 	ELSE
 	    I 1+ arg  do-option
 	THEN
@@ -1493,7 +1530,7 @@ Defer 'cold ' noop IS 'cold
 	THEN
     THEN
     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
     ." Type `bye' to exit"
     loadline off quit ;