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

Diff for /gforth/Attic/kernal.fs between versions 1.25 and 1.39

version 1.25, 1994/11/15 16:54:56 version 1.39, 1995/08/29 21:07:35
Line 66  DOES> ( n -- )  + c@ ; Line 66  DOES> ( n -- )  + c@ ;
       bl c,        bl c,
   LOOP ;    LOOP ;
   
   \ !! this is machine-dependent, but works on all but the strangest machines
   ' faligned Alias maxaligned
   ' falign Alias maxalign
   
   \ the code field is aligned if its body is maxaligned
   \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
   ' maxaligned Alias cfaligned
   ' maxalign Alias cfalign
   
 : chars ; immediate  : chars ; immediate
   
 : A!    ( addr1 addr2 -- )  dup relon ! ;  : A!    ( addr1 addr2 -- )  dup relon ! ;
Line 78  DOES> ( n -- )  + c@ ; Line 87  DOES> ( n -- )  + c@ ;
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;  : (name>)  ( nfa -- cfa )
 : name>    ( nfa -- cfa )    cell+      count  $1F and  +  cfaligned ;
   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;  : name>    ( nfa -- cfa )
       cell+
       dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
   
 : found ( nfa -- cfa n )  cell+  : found ( nfa -- cfa n )  cell+
   dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN    dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN
Line 142  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 162  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 358  Defer notfound ( c-addr count -- ) Line 375  Defer notfound ( c-addr count -- )
     IF      IF
         1 and          1 and
         IF \ not restricted to compile state?          IF \ not restricted to compile state?
             nip nip execute  EXIT              nip nip execute EXIT
         THEN          THEN
         -&14 throw          -&14 throw
     THEN      THEN
Line 693  Avariable leave-sp  leave-stack 3 cells Line 710  Avariable leave-sp  leave-stack 3 cells
     cell - dup @ swap      cell - dup @ swap
     leave-sp ! ;      leave-sp ! ;
   
 : DONE ( orig -- )  drop >r drop  : DONE ( orig -- )
     \ !! the original done had ( addr -- )      \ !! the original done had ( addr -- )
       drop >r drop
     begin      begin
         leave>          leave>
         over r@ u>=          over r@ u>=
Line 769  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
 : (        [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 802  Avariable leave-sp  leave-stack 3 cells Line 837  Avariable leave-sp  leave-stack 3 cells
 defer (header)  defer (header)
 defer header     ' (header) IS header  defer header     ' (header) IS header
   
   : string, ( c-addr u -- )
       \ puts down string as cstring
       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 ;
     dup c,  here swap chars  dup allot  move  align ;  
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent      \ !! this is f83-implementation-dependent
     align here last !  -1 A,      align here last !  -1 A,
Line 824  create nextname-buffer 32 chars allot Line 862  create nextname-buffer 32 chars allot
     \ !! f83-implementation-dependent      \ !! f83-implementation-dependent
     nextname-buffer count      nextname-buffer count
     align here last ! -1 A,      align here last ! -1 A,
     dup c,  here swap chars  dup allot  move  align      string, cfalign
     $80 flag!      $80 flag!
     input-stream ;      input-stream ;
   
 \ 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) ;
   
 : noname-header ( -- )  : noname-header ( -- )
     0 last !      0 last ! cfalign
     input-stream ;      input-stream ;
   
 : noname ( -- ) \ general  : noname ( -- ) \ general
Line 856  create nextname-buffer 32 chars allot Line 894  create nextname-buffer 32 chars allot
 Create ???  0 , 3 c, char ? c, char ? c, char ? c,  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa )  : >name ( cfa -- nfa )
  $21 cell do   $21 cell do
    dup i - count $9F and + aligned over $80 + = if     dup i - count $9F and + cfaligned over $80 + = if
      i - cell - unloop exit       i - cell - unloop exit
    then     then
  cell +loop   cell +loop
Line 902  Create ???  0 , 3 c, char ? c, char ? c, Line 940  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 965  AVariable current Line 1003  AVariable current
 \ 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 989  AVariable lookup       G forth-wordlist Line 1028  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 ;
   
 Variable warnings  G -1 warnings T !  Variable warnings  G -1 warnings T !
   
Line 1023  Variable warnings  G -1 warnings T ! Line 1062  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 1109  Defer key Line 1148  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 1136  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 1176  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 (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 ;
   
 : included ( i*x addr u -- j*x )  create included-files 0 , 0 , ( pointer to and count of included files )
   
   : included? ( c-addr u -- f )
       \ true, iff filename c-addr u is in included-files
       included-files 2@ 0
       ?do ( c-addr u addr )
           dup >r 2@ 2over compare 0=
           if
               2drop rdrop unloop
               true EXIT
           then
           r> cell+ cell+
       loop
       2drop drop false ;
   
   : add-included-file ( c-addr u -- )
       \ add name c-addr u to included-files
       included-files 2@ tuck 1+ 2* cells resize throw
       swap 2dup 1+ included-files 2!
       2* cells + 2! ;
   
   : save-string           ( addr1 u -- addr2 u )
       swap >r
       dup allocate throw
       swap 2dup r> -rot move ;
   
   : included1 ( i*x file-id c-addr u -- j*x )
       \ include the file file-id with the name given by c-addr u
     loadfilename 2@ >r >r      loadfilename 2@ >r >r
     open-path-file ( file-id c-addr2 u2 )      save-string 2dup loadfilename 2! add-included-file ( file-id )
     dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 )  
     drop loadfilename 2@ move  
     ['] include-file catch      ['] include-file catch
     \ don't free filenames; they don't take much space  
     \ and are used for debugging  
     r> r> loadfilename 2!  throw ;      r> r> loadfilename 2!  throw ;
       
   : included ( i*x addr u -- j*x )
       open-path-file included1 ;
   
   : required ( i*x addr u -- j*x )
       \ include the file with the name given by addr u, if it is not
       \ included already. Currently this works by comparing the name of
       \ the file (with path) against the names of earlier included
       \ files; however, it would probably be better to fstat the file,
       \ and compare the device and inode. The advantages would be: no
       \ problems with several paths to the same file (e.g., due to
       \ links) and we would catch files included with include-file and
       \ write a require-file.
       open-path-file 2dup included?
       if
           2drop close-file throw
       else
           included1
       then ;
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
Line 1222  create pathfilenamebuf 256 chars allot \ Line 1326  create pathfilenamebuf 256 chars allot \
 : include  ( "file" -- )  : include  ( "file" -- )
   name included ;    name included ;
   
   : require  ( "file" -- )
     name required ;
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse ( -- )  : recurse ( -- )
Line 1385  Variable argc Line 1492  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
       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
   
 : 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
Line 1418  Defer 'cold ' noop IS 'cold Line 1530  Defer 'cold ' noop IS 'cold
         THEN          THEN
     THEN      THEN
     cr      cr
     ." 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"
     quit ;      loadline off quit ;
   
 : license ( -- ) cr  : license ( -- ) cr
  ." This program is free software; you can redistribute it and/or modify" cr   ." This program is free software; you can redistribute it and/or modify" cr
Removed from v.1.25  
changed lines
  Added in v.1.39

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