[BACK]Return to kernal.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

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

version 1.36, 1995/04/30 23:18:23 version 1.40, 1995/09/06 21:00:21
Line 346  hex Line 346  hex
   
 \ ?stack                                               23feb93py  \ ?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!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
Line 990  AVariable current Line 992  AVariable current
   
 : last?   ( -- false / nfa nfa )    last @ ?dup ;  : last?   ( -- false / nfa nfa )    last @ ?dup ;
 : (reveal) ( -- )  : (reveal) ( -- )
   last?      last?
   IF      IF
       dup @ 0<          dup @ 0<
       IF          IF
         current @ @ over ! current @ !              current @ @ over ! current @ !
       ELSE          ELSE
         drop              drop
       THEN          THEN
   THEN ;      THEN ;
   
 \ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py
   
Line 1096  Variable warnings  G -1 warnings T ! Line 1098  Variable warnings  G -1 warnings T !
 : (ret)  type-rest drop true space ;  : (ret)  type-rest drop true space ;
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;  : 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 ;  : 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  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      ?del  false (ret) false  false (ret) false false
     false false false false  false false false false      false false false false  false false false false
     false false false false  false false false false [      false false false false  false false false false [
Line 1148  Defer key Line 1151  Defer key
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag )  : refill ( -- flag )
   blk @  IF  1 blk +!  true  EXIT  THEN    blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    read-line throw    IF    read-line throw
Line 1215  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1218  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 1326  create included-files 0 , 0 , ( pointer Line 1337  create included-files 0 , 0 , ( pointer
 : recurse ( -- )  : recurse ( -- )
     lastxt compile, ; immediate restrict      lastxt compile, ; immediate restrict
 : recursive ( -- )  : recursive ( -- )
     reveal ; immediate      reveal last off ; immediate
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw
   
Line 1495  Variable argc Line 1506  Variable argc
   
 : process-args ( -- )  : process-args ( -- )
     >tib @ >r      >tib @ >r
     true to script?  
     argc @ 1      argc @ 1
     ?DO      ?DO
         I arg over c@ [char] - <>          I arg over c@ [char] - <>
         IF          IF
             required 1              required 1
         ELSE          ELSE
             I 1+ arg  do-option              I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
               do-option
         THEN          THEN
     +LOOP      +LOOP
     false to script?  
     r> >tib ! ;      r> >tib ! ;
   
 Defer 'cold ' noop IS 'cold  Defer 'cold ' noop IS 'cold
Line 1516  Defer 'cold ' noop IS 'cold Line 1526  Defer 'cold ' noop IS 'cold
     'cold      'cold
     argc @ 1 >      argc @ 1 >
     IF      IF
           true to script?
         ['] process-args catch ?dup          ['] process-args catch ?dup
         IF          IF
             dup >r DoError cr r> negate (bye)              dup >r DoError cr r> negate (bye)
         THEN          THEN
           cr
     THEN      THEN
     cr      false to script?
     ." 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.40

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