[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.28

version 1.25, 1994/11/15 16:54:56 version 1.28, 1995/02/06 18:14:34
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 358  Defer notfound ( c-addr count -- ) Line 369  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 802  Avariable leave-sp  leave-stack 3 cells Line 813  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
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     dup c,  here swap chars  dup allot  move  align ;      string, cfalign ;
 : 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 839  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 ;
   
Line 836  create nextname-buffer 32 chars allot Line 851  create nextname-buffer 32 chars allot
     ['] 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 871  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 992  G forth-wordlist current T ! Line 1007  G forth-wordlist current T !
   dup cell+ @ @ execute ;    dup cell+ @ @ 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 1197  create pathfilenamebuf 256 chars allot \ Line 1212  create pathfilenamebuf 256 chars allot \
     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 1279  create pathfilenamebuf 256 chars allot \
 : include  ( "file" -- )  : include  ( "file" -- )
   name included ;    name included ;
   
   : require  ( "file" -- )
     name required ;
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse ( -- )  : recurse ( -- )
Line 1421  Defer 'cold ' noop IS 'cold Line 1481  Defer 'cold ' noop IS 'cold
     ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr      ." GNU Forth 0.0alpha, 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.28

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