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

version 1.32, 1995/03/13 09:17:31 version 1.36, 1995/04/30 23:18:23
Line 153  Defer source Line 153  Defer source
 \ word parse                                           23feb93py  \ word parse                                           23feb93py
   
 : parse-word  ( char -- addr len )  : 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    rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
   2dup + r> - 1+ r> min >in ! ;    2dup + r> - 1+ r> min >in ! ;
 : word   ( char -- addr )  : word   ( char -- addr )
   parse-word here place  bl here count + c!  here ;    parse-word here place  bl here count + c!  here ;
   
 : parse    ( char -- addr len )  : 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 +! ;    over - dup r> IF 1+ THEN  >in +! ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
Line 173  Defer source Line 173  Defer source
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    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                                              17dec92py
   
 : Literal  ( n -- )  state @ IF postpone lit  , THEN ;  : Literal  ( n -- )  state @ IF postpone lit  , THEN ;
Line 781  Avariable leave-sp  leave-stack 3 cells Line 787  Avariable leave-sp  leave-stack 3 cells
 : (S")     "lit count ;                                restrict  : (S")     "lit count ;                                restrict
 : SLiteral postpone (S") here over char+ allot  place align ;  : SLiteral postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               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                                               immediate
 : ."       state @  IF    postpone (.") ,"  align  : ."       state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      ELSE  [char] " parse type  THEN  ;  immediate
Line 794  Avariable leave-sp  leave-stack 3 cells Line 809  Avariable leave-sp  leave-stack 3 cells
     THEN      THEN
     source >in ! drop ; immediate      source >in ! drop ; immediate
   
 : G\ ( -- ) \ new backslash  : \G ( -- ) \ new backslash
     POSTPONE \ ; immediate      POSTPONE \ ; immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
Line 827  defer header     ' (header) IS header Line 842  defer header     ' (header) IS header
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : name,  ( "name" -- )  : name,  ( "name" -- )
     name      name name-too-short? name-too-long?
     dup $1F u> -&19 and throw ( is name too long? )  
     string, cfalign ;      string, cfalign ;
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent      \ !! this is f83-implementation-dependent
Line 854  create nextname-buffer 32 chars allot Line 868  create nextname-buffer 32 chars allot
   
 \ the next name is given in the string  \ the next name is given in the string
 : nextname ( c-addr u -- ) \ general  : 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 c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
     ['] nextname-header IS (header) ;      ['] nextname-header IS (header) ;
Line 1161  Defer key Line 1175  Defer key
 \ : bin           dup 1 chars - c@  \ : bin           dup 1 chars - c@
 \                 r/o 4 chars + over - dup >r swap move r> ;  \                 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  create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
                            \ or not unix environments if                             \ or not unix environments if
Line 1201  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 )
     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 )  : 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; c-addr2
     \ u2 is the full filename (valid until the next call); if the file      \ u2 is the full filename (valid until the next call); if the file
Line 1209  create pathfilenamebuf 256 chars allot \ Line 1236  create pathfilenamebuf 256 chars allot \
     \ makes little sense, as the path will usually contain dirs that      \ makes little sense, as the path will usually contain dirs that
     \ are only readable for the user      \ are only readable for the user
     \ !! check for "/", "./", "../" in original filename; check for "~/"?      \ !! check for "/", "./", "../" in original filename; check for "~/"?
     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 
     0<> -&38 and throw ( file-id u2 )      0<> -&38 and throw ( file-id u2 )
     pathfilenamebuf swap ;      pathfilenamebuf swap ;
   
Line 1464  Variable argc Line 1493  Variable argc
         r> >tib +!  2 EXIT  THEN          r> >tib +!  2 EXIT  THEN
     ." Unknown option: " type cr 2drop 1 ;      ." Unknown option: " type cr 2drop 1 ;
   
 : process-args ( -- )  >tib @ >r  : process-args ( -- )
       >tib @ >r
       true to script?
     argc @ 1      argc @ 1
     ?DO      ?DO
         I arg over c@ [char] - <>          I arg over c@ [char] - <>
         IF          IF
             true to script? included  false to script? 1              required 1
         ELSE          ELSE
             I 1+ arg  do-option              I 1+ arg  do-option
         THEN          THEN
     +LOOP      +LOOP
       false to script?
     r> >tib ! ;      r> >tib ! ;
   
 Defer 'cold ' noop IS 'cold  Defer 'cold ' noop IS 'cold

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


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