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

Diff for /gforth/Attic/kernal.fs between versions 1.18 and 1.20

version 1.18, 1994/09/02 15:23:36 version 1.20, 1994/09/12 19:00:32
Line 110  Defer source Line 110  Defer source
   
 \ (word)                                               22feb93py  \ (word)                                               22feb93py
   
 : scan   ( addr1 n1 char -- addr2 n2 )  >r  : scan   ( addr1 n1 char -- addr2 n2 )
   BEGIN  dup  WHILE  over c@ r@ <>  WHILE  1 /string      \ skip all characters not equal to char
   REPEAT  THEN  rdrop ;      >r
 : skip   ( addr1 n1 char -- addr2 n2 )  >r      BEGIN
   BEGIN  dup  WHILE  over c@ r@  =  WHILE  1 /string          dup
   REPEAT  THEN  rdrop ;      WHILE
           over c@ r@ <>
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   : skip   ( addr1 n1 char -- addr2 n2 )
       \ skip all characters equal to char
       >r
       BEGIN
           dup
       WHILE
           over c@ r@  =
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   
 : (word) ( addr1 n1 char -- addr2 n2 )  : (word) ( addr1 n1 char -- addr2 n2 )
   dup >r skip 2dup r> scan  nip - ;    dup >r skip 2dup r> scan  nip - ;
Line 138  Defer source Line 154  Defer source
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
 : capitalize ( addr -- addr )  : capitalize ( addr len -- addr len )
   dup count chars bounds    2dup chars chars bounds
   ?DO  I c@ toupper I c! 1 chars +LOOP ;    ?DO  I c@ toupper I c! 1 chars +LOOP ;
 : (name)  ( -- addr )  bl word ;  : (name) ( -- c-addr count )
 : sname ( -- c-addr count )  
     source 2dup >r >r >in @ /string (parse-white)      source 2dup >r >r >in @ /string (parse-white)
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
Line 160  Defer source Line 175  Defer source
   
 : (compile) ( -- )  r> dup cell+ >r @ A, ;  : (compile) ( -- )  r> dup cell+ >r @ A, ;
 : postpone ( "name" -- )  : postpone ( "name" -- )
   name find dup 0= abort" Can't compile "    name sfind dup 0= abort" Can't compile "
   0> IF  A,  ELSE  postpone (compile) A,  THEN ;    0> IF  A,  ELSE  postpone (compile) A,  THEN ;
                                              immediate restrict                                               immediate restrict
   
Line 326  Defer notfound ( c-addr count -- ) Line 341  Defer notfound ( c-addr count -- )
   
 : interpret  : interpret
     BEGIN      BEGIN
         ?stack sname dup          ?stack name dup
     WHILE      WHILE
         parser          parser
     REPEAT      REPEAT
     2drop ;      2drop ;
   
 \ sinterpreter scompiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : sinterpreter  ( c-addr u -- )   : interpreter  ( c-addr u -- ) 
     \ interpretation semantics for the name/number c-addr u      \ interpretation semantics for the name/number c-addr u
     2dup sfind dup      2dup sfind dup
     IF      IF
Line 352  Defer notfound ( c-addr count -- ) Line 367  Defer notfound ( c-addr count -- )
         2r> notfound          2r> notfound
     THEN ;      THEN ;
   
 ' sinterpreter  IS  parser  ' interpreter  IS  parser
   
 : scompiler     ( c-addr u -- )  : compiler     ( c-addr u -- )
     \ compilation semantics for the name/number c-addr u      \ compilation semantics for the name/number c-addr u
     2dup sfind dup      2dup sfind dup
     IF      IF
Line 377  Defer notfound ( c-addr count -- ) Line 392  Defer notfound ( c-addr count -- )
         drop notfound          drop notfound
     THEN ;      THEN ;
   
 : [     ['] sinterpreter  IS parser state off ; immediate  : [     ['] interpreter  IS parser state off ; immediate
 : ]     ['] scompiler     IS parser state on  ;  : ]     ['] compiler     IS parser state on  ;
   
 \ locals stuff needed for control structures  \ locals stuff needed for control structures
   
 : compile-lp+! ( n -- )  : compile-lp+! ( n -- )
     dup negate locals-size +!      dup negate locals-size +!
     0 over = if      0 over = if
     else -4 over = if postpone -4lp+!      else -1 cells  over = if postpone lp-
     else  8 over = if postpone  8lp+!      else  1 floats over = if postpone lp+
     else 16 over = if postpone 16lp+!      else  2 floats over = if postpone lp+2
     else postpone lp+!# dup ,      else postpone lp+!# dup ,
     then then then then drop ;      then then then then drop ;
   
Line 545  variable dead-code \ true if normal code Line 560  variable dead-code \ true if normal code
   
 : THEN ( orig -- )  : THEN ( orig -- )
     dup orig?      dup orig?
     dead-code @      dead-orig =
     if      if
         dead-orig =          >resolve drop
         if  
             >resolve drop  
         else  
             >resolve set-locals-size-list dead-code off  
         then  
     else      else
         dead-orig =          dead-code @
         if          if
             >resolve drop              >resolve set-locals-size-list dead-code off
         else \ both live          else \ both live
             over list-size adjust-locals-size              over list-size adjust-locals-size
             >resolve              >resolve
Line 781  Avariable leave-sp  leave-stack 3 cells Line 791  Avariable leave-sp  leave-stack 3 cells
 \ information through global variables), but they are useful for dealing  \ information through global variables), but they are useful for dealing
 \ with existing/independent defining words  \ with existing/independent defining words
   
 defer header  defer (header)
   defer header     ' (header) IS header
   
 : name,  ( "name" -- )  : name,  ( "name" -- )
     name c@      name
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     1+ chars allot align ;      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 794  defer header Line 805  defer header
   
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;  \ switches back to getting the name from the input stream ;
     ['] input-stream-header IS header ;      ['] input-stream-header IS (header) ;
   
 ' input-stream-header IS header  ' input-stream-header IS (header)
   
 \ !! make that a 2variable  \ !! make that a 2variable
 create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot
Line 814  create nextname-buffer 32 chars allot Line 825  create nextname-buffer 32 chars allot
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is 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 !
Line 822  create nextname-buffer 32 chars allot Line 833  create nextname-buffer 32 chars allot
   
 : noname ( -- ) \ general  : noname ( -- ) \ general
 \ the next defined word remains anonymous. The xt of that word is given by lastxt  \ the next defined word remains anonymous. The xt of that word is given by lastxt
     ['] noname-header IS header ;      ['] noname-header IS (header) ;
   
 : lastxt ( -- xt ) \ general  : lastxt ( -- xt ) \ general
 \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname  \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
Line 1008  Variable warnings  G -1 warnings T ! Line 1019  Variable warnings  G -1 warnings T !
   
 : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;  : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;
   
 : '    ( "name" -- addr )  name find 0= if drop -&13 bounce then ;  : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
Line 1148  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1159  create nl$ 1 c, A c, 0 c, \ gnu includes
 : include-file ( i*x fid -- j*x )  : include-file ( i*x fid -- j*x )
   push-file  loadfile !    push-file  loadfile !
   0 loadline ! blk off  ['] read-loop catch    0 loadline ! blk off  ['] read-loop catch
   loadfile @ close-file swap    loadfile @ close-file swap 2dup or
   pop-file  throw throw ;    pop-file  drop throw throw ;
   
   create pathfilenamebuf 256 chars allot \ !! make this grow on demand
   
   : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )
       \ opens a file for reading, searching in the path for it; c-addr2
       \ u2 is the full filename (valid until the next call); if the file
       \ is not found (or in case of other errors for each try), -38
       \ (non-existant file) is thrown. Opening for other access modes
       \ makes little sense, as the path will usually contain dirs that
       \ are only readable for the user
       \ !! check for "/", "./", "../" in original filename; check for "~/"?
       pathdirs 2@ 0
       ?DO ( c-addr1 u1 dirnamep )
           dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
           2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
           pathfilenamebuf over r> + dup >r r/o open-file 0=
           if ( addr u file-id )
               nip nip r> rdrop 0 leave
           then
           rdrop drop r> cell+ cell+
       LOOP
       0<> -&38 and throw ( file-id u2 )
       pathfilenamebuf swap ;
   
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x )
     loadfilename 2@ >r >r      loadfilename 2@ >r >r
     dup allocate throw over loadfilename 2!      open-path-file ( file-id c-addr2 u2 )
     over loadfilename 2@ move      dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 )
     r/o open-file throw include-file      drop loadfilename 2@ move
       ['] include-file catch
     \ don't free filenames; they don't take much space      \ don't free filenames; they don't take much space
     \ and are used for debugging      \ and are used for debugging
     r> r> loadfilename 2! ;      r> r> loadfilename 2!  throw ;
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
Line 1172  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1207  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
 : include  ( "file" -- )  : include  ( "file" -- )
   bl word count included ;    name included ;
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
Line 1249  DEFER DOERROR Line 1284  DEFER DOERROR
   ELSE    ELSE
      type ." :" dec.       type ." :" dec.
      cr dup 2over type cr drop       cr dup 2over type cr drop
      nip -trailing ( line-start index2 )       nip -trailing 1- ( line-start index2 )
      0 >r  BEGIN       0 >r  BEGIN
                   1- 2dup + c@ bl >  WHILE                    2dup + c@ bl >  WHILE
                   r> 1+ >r  dup 0<  UNTIL  THEN  1+                    r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
      ( line-start index1 )       ( line-start index1 )
      typewhite       typewhite
      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0       r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
Line 1302  DEFER DOERROR Line 1337  DEFER DOERROR
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
   
 : >len  ( cstring -- addr n )  100 0 scan 0 swap 100 - /string ;  : cstring>sstring  ( cstring -- addr n )  -1 0 scan 0 swap 1+ /string ;
 : arg ( n -- addr count )  cells argv @ + @ >len ;  : arg ( n -- addr count )  cells argv @ + @ cstring>sstring ;
 : #!       postpone \ ;  immediate  : #!       postpone \ ;  immediate
   
 Variable env  Create pathstring 2 cells allot \ string
   Create pathdirs   2 cells allot \ dir string array, pointer and count
 Variable argv  Variable argv
 Variable argc  Variable argc
   
 0 Value script? ( -- flag )  0 Value script? ( -- flag )
   
   : process-path ( addr1 u1 -- addr2 u2 )
       \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
       here >r
       BEGIN
           over >r [char] : scan
           over r> tuck - ( rest-str this-str )
           dup
           IF
               2dup 1- chars + c@ [char] / <>
               IF
                   2dup chars + [char] / swap c!
                   1+
               THEN
               2,
           ELSE
               2drop
           THEN
           dup
       WHILE
           1 /string
       REPEAT
       2drop
       here r> tuck - 2 cells / ;
   
 : ">tib  ( addr len -- )  dup #tib ! >in off tib swap move ;  : ">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
Line 1320  Variable argc Line 1380  Variable argc
   IF  2drop ">tib interpret  2 EXIT  THEN    IF  2drop ">tib interpret  2 EXIT  THEN
   ." Unknown option: " type cr 2drop 1 ;    ." Unknown option: " type cr 2drop 1 ;
   
 : process-args ( -- )  argc @ 1  : process-args ( -- )
   ?DO  I arg over c@ [char] - <>      argc @ 1
        IF    true to script? included  false to script? 1      ?DO
        ELSE  I 1+ arg  do-option          I arg over c@ [char] - <>
        THEN          IF
   +LOOP ;              true to script? included  false to script? 1
           ELSE
               I 1+ arg  do-option
           THEN
       +LOOP ;
   
 : cold ( -- )    : cold ( -- )
       pathstring 2@ process-path pathdirs 2!
     argc @ 1 >      argc @ 1 >
     IF      IF
         ['] process-args catch ?dup          ['] process-args catch ?dup
Line 1356  Variable argc Line 1421  Variable argc
  ." along with this program; if not, write to the Free Software" cr   ." along with this program; if not, write to the Free Software" cr
  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;   ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
 : boot ( **env **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! env !  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 ! 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.18  
changed lines
  Added in v.1.20

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