Diff for /gforth/Attic/kernal.fs between versions 1.18 and 1.19

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) ;

Removed from v.1.18  
changed lines
  Added in v.1.19


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