--- gforth/Attic/kernal.fs	1995/03/14 19:01:43	1.33
+++ gforth/Attic/kernal.fs	1995/09/06 21:00:21	1.40
@@ -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 ;
@@ -340,7 +346,9 @@ hex
 
 \ ?stack                                               23feb93py
 
-: ?stack ( ?? -- ?? )  sp@ s0 @ > IF  -4 throw  THEN ;
+: ?stack ( ?? -- ?? )
+    sp@ s0 @ > IF    -4 throw  THEN
+    fp@ f0 @ > IF  -&45 throw  THEN  ;
 \ ?stack should be code -- it touches an empty stack!
 
 \ interpret                                            10mar92py
@@ -781,7 +789,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 +844,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 +870,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) ;
@@ -976,15 +992,15 @@ AVariable current
 
 : last?   ( -- false / nfa nfa )    last @ ?dup ;
 : (reveal) ( -- )
-  last?
-  IF
-      dup @ 0<
-      IF
-	current @ @ over ! current @ !
-      ELSE
-	drop
-      THEN
-  THEN ;
+    last?
+    IF
+	dup @ 0<
+	IF
+	    current @ @ over ! current @ !
+	ELSE
+	    drop
+	THEN
+    THEN ;
 
 \ object oriented search list                          17mar93py
 
@@ -1082,9 +1098,10 @@ Variable warnings  G -1 warnings T !
 : (ret)  type-rest drop true space ;
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;
 : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
+: eof  2 pick 0=  IF  bye  ELSE  (ret)  THEN ;
 
 Create ctrlkeys
-  ] false false back  false  false false forw  false
+  ] false false back  false  eof   false forw  false
     ?del  false (ret) false  false (ret) false false
     false false false false  false false false false
     false false false false  false false false false [
@@ -1134,7 +1151,7 @@ Defer key
 \ Query                                                07apr93py
 
 : refill ( -- flag )
-  blk @  IF  1 blk +!  true  EXIT  THEN
+  blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line
   loadfile @ ?dup
   IF    read-line throw
@@ -1161,7 +1178,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 +1218,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 ;
 
@@ -1297,7 +1337,7 @@ create included-files 0 , 0 , ( pointer
 : recurse ( -- )
     lastxt compile, ; immediate restrict
 : recursive ( -- )
-    reveal ; immediate
+    reveal last off ; immediate
 
 \ */MOD */                                              17may93jaw
 
@@ -1464,14 +1504,16 @@ Variable argc
 	r> >tib +!  2 EXIT  THEN
     ." Unknown option: " type cr 2drop 1 ;
 
-: process-args ( -- )  >tib @ >r
+: process-args ( -- )
+    >tib @ >r
     argc @ 1
     ?DO
 	I arg over c@ [char] - <>
 	IF
-	    true to script? included  false to script? 1
+	    required 1
 	ELSE
-	    I 1+ arg  do-option
+	    I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
+	    do-option
 	THEN
     +LOOP
     r> >tib ! ;
@@ -1484,13 +1526,15 @@ Defer 'cold ' noop IS 'cold
     'cold
     argc @ 1 >
     IF
+	true to script?
 	['] process-args catch ?dup
 	IF
 	    dup >r DoError cr r> negate (bye)
 	THEN
+	cr
     THEN
-    cr
-    ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr
+    false to script?
+    ." 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 ;