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

version 1.29, 1995/02/09 17:49:57 version 1.40, 1995/09/06 21:00:21
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 340  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 781  Avariable leave-sp  leave-stack 3 cells Line 789  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 844  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 870  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 918  Create ???  0 , 3 c, char ? c, char ? c, Line 942  Create ???  0 , 3 c, char ? c, char ? c,
 : 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
Line 968  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
   
 \ 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: ( -- )
     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 1030  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 1064  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 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 1125  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 1152  Defer key Line 1178  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 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 )
   \   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 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 1446  Variable argc Line 1495  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 1522  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.40


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