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

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

version 1.23, 1994/11/11 16:10:12 version 1.29, 1995/02/09 17:49:57
Line 1 Line 1
 \ KERNAL.FS    ANS figFORTH kernal                     17dec92py  \ KERNAL.FS    GNU FORTH kernal                        17dec92py
 \ $ID:  \ $ID:
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  \ Copyright 1992 by the ANSI figForth Development Group
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 693  Avariable leave-sp  leave-stack 3 cells Line 704  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 802  Avariable leave-sp  leave-stack 3 cells Line 814  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 840  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 852  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 872  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 1008  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 1213  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 1280  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 1446  Variable argc
     2drop      2drop
     here r> tuck - 2 cells / ;      here r> tuck - 2 cells / ;
   
 : ">tib  ( addr len -- )  dup #tib ! >in off tib swap move ;  
   
 : do-option ( addr1 len1 addr2 len2 -- n )  2swap  : do-option ( addr1 len1 addr2 len2 -- n )  2swap
   2dup s" -e"        compare  0= >r    2dup s" -e"        compare  0= >r
   2dup s" -evaluate" compare  0= r> or    2dup s" -evaluate" compare  0= r> or
   IF  2drop ">tib interpret  2 EXIT  THEN    IF  2drop dup >r ['] evaluate catch
         ?dup IF  dup >r DoError r> negate (bye)  THEN
         r> >tib +!  2 EXIT  THEN
   ." Unknown option: " type cr 2drop 1 ;    ." Unknown option: " type cr 2drop 1 ;
   
 : process-args ( -- )  : process-args ( -- )  >tib @ >r
     argc @ 1      argc @ 1
     ?DO      ?DO
         I arg over c@ [char] - <>          I arg over c@ [char] - <>
Line 1402  Variable argc Line 1463  Variable argc
         ELSE          ELSE
             I 1+ arg  do-option              I 1+ arg  do-option
         THEN          THEN
     +LOOP ;      +LOOP
       r> >tib ! ;
   
   Defer 'cold ' noop IS 'cold
   
 : cold ( -- )  : cold ( -- )
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
       'cold
     argc @ 1 >      argc @ 1 >
     IF      IF
         ['] process-args catch ?dup          ['] process-args catch ?dup
Line 1417  Variable argc Line 1482  Variable argc
     ." 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
Line 1436  Variable argc Line 1501  Variable argc
   
 : boot ( path **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! cstring>sstring pathstring 2!  main-task up!    argc ! argv ! cstring>sstring pathstring 2!  main-task up!
   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;    sp@ dup s0 ! $10 + >tib ! #tib off >in off
     rp@ r0 !  fp@ f0 !  cold ;
   
 : bye  script? 0= IF  cr  THEN  0 (bye) ;  : bye  script? 0= IF  cr  THEN  0 (bye) ;
   
Removed from v.1.23  
changed lines
  Added in v.1.29

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