Diff for /gforth/Attic/kernal.fs between versions 1.29 and 1.41

version 1.29, 1995/02/09 17:49:57 version 1.41, 1995/10/07 17:38:16
Line 31 Line 31
   
 HEX  HEX
   
   \ labels for some code addresses
   
   : docon: ( -- addr )    \ gforth
       \ the code address of a @code{CONSTANT}
       ['] bl >code-address ;
   
   : docol: ( -- addr )    \ gforth
       \ the code address of a colon definition
       ['] docon: >code-address ;
   
   : dovar: ( -- addr )    \ gforth
       \ the code address of a @code{CREATE}d word
       ['] udp >code-address ;
   
   : douser: ( -- addr )   \ gforth
       \ the code address of a @code{USER} variable
       ['] s0 >code-address ;
   
   : dodefer: ( -- addr )  \ gforth
       \ the code address of a @code{defer}ed word
       ['] source >code-address ;
   
   : dofield: ( -- addr )  \ gforth
       \ the code address of a @code{field}
       ['] reveal-method >code-address ;
   
 \ Bit string manipulation                              06oct92py  \ Bit string manipulation                              06oct92py
   
 Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 115  DOES> ( n -- )  + c@ ; Line 141  DOES> ( n -- )  + c@ ;
 \ input stream primitives                              23feb93py  \ input stream primitives                              23feb93py
   
 : tib   >tib @ ;  : tib   >tib @ ;
 Defer source  Defer source \ used by dodefer:, must be defer
 : (source) ( -- addr count ) tib #tib @ ;  : (source) ( -- addr count ) tib #tib @ ;
 ' (source) IS source  ' (source) IS source
   
Line 153  Defer source Line 179  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 199  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 340  hex Line 372  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 728  Avariable leave-sp  leave-stack 3 cells Line 762  Avariable leave-sp  leave-stack 3 cells
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     ( 0 0 0 >leave ) ; immediate restrict      ( 0 0 0 >leave ) ; immediate restrict
   
 : ?DO ( -- do-sys )  : ?do-like ( -- do-sys )
     ( 0 0 0 >leave )      ( 0 0 0 >leave )
     POSTPONE (?do)  
     >mark >leave      >mark >leave
     POSTPONE begin drop do-dest ; immediate restrict      POSTPONE begin drop do-dest ;
   
   : ?DO ( -- do-sys )     \ core-ext      question-do
       POSTPONE (?do) ?do-like ; immediate restrict
   
   : +DO ( -- do-sys )     \ gforth        plus-do
       POSTPONE (+do) ?do-like ; immediate restrict
   
   : U+DO ( -- do-sys )    \ gforth        u-plus-do
       POSTPONE (u+do) ?do-like ; immediate restrict
   
   : -DO ( -- do-sys )     \ gforth        minus-do
       POSTPONE (-do) ?do-like ; immediate restrict
   
   : U-DO ( -- do-sys )    \ gforth        u-minus-do
       POSTPONE (u-do) ?do-like ; immediate restrict
   
 : FOR ( -- do-sys )  : FOR ( -- do-sys )
     POSTPONE (for)      POSTPONE (for)
Line 745  Avariable leave-sp  leave-stack 3 cells Line 793  Avariable leave-sp  leave-stack 3 cells
     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?      >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
     until-like  POSTPONE done  POSTPONE unloop ;      until-like  POSTPONE done  POSTPONE unloop ;
   
 : LOOP ( do-sys -- )  : LOOP ( do-sys -- )    \ core
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict   ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
 : +LOOP ( do-sys -- )  : +LOOP ( do-sys -- )   \ core  plus-loop
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict   ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
   
   \ !! should the compiler warn about +DO..-LOOP?
   : -LOOP ( do-sys -- )   \ gforth        minus-loop
    ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
   
 \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"  \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
 \ will iterate as often as "high low ?DO inc S+LOOP". For positive  \ will iterate as often as "high low ?DO inc S+LOOP". For positive
 \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for  \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
 \ negative increments.  \ negative increments.
 : S+LOOP ( do-sys -- )  : S+LOOP ( do-sys -- )  \ gforth        s-plus-loop
  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict   ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
   
 : NEXT ( do-sys -- )  : NEXT ( do-sys -- )
Line 781  Avariable leave-sp  leave-stack 3 cells Line 833  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
 : (        [char] ) parse 2drop ;                       immediate  : (        [char] ) parse 2drop ;                       immediate
 : \        blk @ IF  >in @ c/l / 1+ c/l * >in !  EXIT  THEN  : \ ( -- ) \ core-ext backslash
            source >in ! drop ;                          immediate      blk @
       IF
           >in @ c/l / 1+ c/l * >in !
           EXIT
       THEN
       source >in ! drop ; immediate
   
   : \G ( -- ) \ new backslash
       POSTPONE \ ; immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
 \ 'abort thrown out!                                   11may93jaw  \ 'abort thrown out!                                   11may93jaw
Line 819  defer header     ' (header) IS header Line 888  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 846  create nextname-buffer 32 chars allot Line 914  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 878  Create ???  0 , 3 c, char ? c, char ? c, Line 946  Create ???  0 , 3 c, char ? c, char ? c,
  cell +loop   cell +loop
  drop ??? ( wouldn't 0 be better? ) ;   drop ??? ( wouldn't 0 be better? ) ;
   
 \ indirect threading                                   17mar93py  \ threading                                   17mar93py
   
 : cfa,     ( code-address -- )  : cfa,     ( code-address -- )  \ gforth
     here lastcfa !      here
     here  0 A, 0 ,  code-address! ;      dup lastcfa !
 : compile, ( xt -- )            A, ;      0 A, 0 ,  code-address! ;
 : !does    ( addr -- )          lastcfa @ does-code! ;  : compile, ( xt -- ) \ core-ext
 : (;code)  ( R: addr -- )       r> /does-handler + !does ;      A, ;
   : !does    ( addr -- )          lastxt does-code! ;
   : (does>)  ( R: addr -- )       r> /does-handler + !does ;
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    here /does-handler allot does-handler! ;
   
 \ direct threading is implementation dependent  : Create    Header reveal dovar: cfa, ;
   
 : Create    Header reveal [ :dovar ] Literal cfa, ;  
   
 \ DOES>                                                17mar93py  \ DOES>                                                17mar93py
   
 : DOES>  ( compilation: -- )  : DOES>  ( compilation: -- ) \ core
     state @      state @
     IF      IF
         ;-hook postpone (;code) dodoes,          ;-hook postpone (does>) ?struc dodoes,
     ELSE      ELSE
         dodoes, here !does 0 ]          align dodoes, here !does ]
     THEN       THEN 
     :-hook ; immediate      defstart :-hook ; immediate
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
Line 914  Create ???  0 , 3 c, char ? c, char ? c, Line 982  Create ???  0 , 3 c, char ? c, char ? c,
 : User      Variable ;  : User      Variable ;
 : AUser     AVariable ;  : AUser     AVariable ;
   
 : (Constant)  Header reveal [ :docon ] Literal cfa, ;  : (Constant)  Header reveal docon: cfa, ;
 : Constant  (Constant) , ;  : Constant  (Constant) , ;
 : AConstant (Constant) A, ;  : AConstant (Constant) A, ;
   
 : 2CONSTANT  : 2Constant
     create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     does> ( -- w1 w2 )      DOES> ( -- w1 w2 )
         2@ ;          2@ ;
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer ( -- )  : Defer ( -- )
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal [ :dodefer ] Literal cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
 \     Create ( -- )   \     Create ( -- ) 
 \       ['] noop A,  \       ['] noop A,
Line 954  Create ???  0 , 3 c, char ? c, char ? c, Line 1022  Create ???  0 , 3 c, char ? c, char ? c,
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
 : : ( -- colon-sys )  Header [ :docol ] Literal cfa, defstart ] :-hook ;  : : ( -- colon-sys )  Header docol: cfa, defstart ] :-hook ;
 : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;  : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;
   immediate restrict    immediate restrict
   
 : :noname ( -- xt colon-sys )  : :noname ( -- xt colon-sys )
     0 last !      0 last !
     here [ :docol ] Literal cfa, 0 ] :-hook ;      here docol: cfa, 0 ] :-hook ;
   
 \ Search list handling                                 23feb93py  \ Search list handling                                 23feb93py
   
Line 968  AVariable current Line 1036  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
   
 \ word list structure:  \ word list structure:
 \ struct  
 \   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )  struct
 \   1 cells: field reveal-method \ xt: ( -- )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
 \   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field
     1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 \ end-struct wordlist-map-struct  end-struct wordlist-map-struct
   
 \ struct  struct
 \   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation    1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
 \   1 cells: field wordlist-map \ pointer to a wordlist-map-struct    1 cells: field wordlist-map \ pointer to a wordlist-map-struct
 \   1 cells: field wordlist-link \ link field to other wordlists    1 cells: field wordlist-link \ link field to other wordlists
 \   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 \ end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;  : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
   
Line 1005  AVariable lookup       G forth-wordlist Line 1074  AVariable lookup       G forth-wordlist
 G forth-wordlist current T !  G forth-wordlist current T !
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup cell+ @ @ execute ;    dup wordlist-map @ find-method @ execute ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 )  : search-wordlist  ( addr count wid -- 0 / xt +-1 )
     (search-wordlist) dup  IF  found  THEN ;      (search-wordlist) dup  IF  found  THEN ;
Line 1039  Variable warnings  G -1 warnings T ! Line 1108  Variable warnings  G -1 warnings T !
  last? if   last? if
    name>string current @ check-shadow     name>string current @ check-shadow
  then   then
  current @ cell+ @ cell+ @ execute ;   current @ wordlist-map @ reveal-method @ execute ;
   
 : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;  : rehash  ( wid -- )  dup wordlist-map @ rehash-method @ execute ;
   
 : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;  : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
Line 1073  Variable warnings  G -1 warnings T ! Line 1142  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 1125  Defer key Line 1195  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 1152  Defer key Line 1222  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 1192  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1262  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 (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
       \ !! 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      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 1288  create included-files 0 , 0 , ( pointer Line 1381  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 1446  Variable argc Line 1539  Variable argc
     2drop      2drop
     here r> tuck - 2 cells / ;      here r> tuck - 2 cells / ;
   
 : do-option ( addr1 len1 addr2 len2 -- n )  2swap  : do-option ( addr1 len1 addr2 len2 -- n )
   2dup s" -e"        compare  0= >r      2swap
   2dup s" -evaluate" compare  0= r> or      2dup s" -e"         compare  0= >r
   IF  2drop dup >r ['] evaluate catch      2dup s" --evaluate" compare  0= r> or
       ?dup IF  dup >r DoError r> negate (bye)  THEN      IF  2drop dup >r ['] evaluate catch
       r> >tib +!  2 EXIT  THEN          ?dup IF  dup >r DoError r> negate (bye)  THEN
   ." Unknown option: " type cr 2drop 1 ;          r> >tib +!  2 EXIT  THEN
       ." Unknown option: " type cr 2drop 1 ;
   
 : process-args ( -- )  >tib @ >r  : process-args ( -- )
       >tib @ >r
     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+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
               do-option
         THEN          THEN
     +LOOP      +LOOP
     r> >tib ! ;      r> >tib ! ;
Line 1470  Defer 'cold ' noop IS 'cold Line 1566  Defer 'cold ' noop IS 'cold
   
 : cold ( -- )  : cold ( -- )
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
       0 0 included-files 2!
     '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.29  
changed lines
  Added in v.1.41


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