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

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

version 1.17, 1994/08/31 19:42:48 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 782  Avariable leave-sp  leave-stack 3 cells Line 792  Avariable leave-sp  leave-stack 3 cells
 \ with existing/independent defining words  \ with existing/independent defining words
   
 defer (header)  defer (header)
 defer header ' (header) IS 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 967  AVariable current Line 977  AVariable current
 Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,  Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,
   
 Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,  Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
 AVariable search       G forth-wordlist search T !  AVariable lookup       G forth-wordlist lookup T !
 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 ( @ swap ) 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 ;
Line 993  Variable warnings  G -1 warnings T ! Line 1003  Variable warnings  G -1 warnings T !
  2drop 2drop ;   2drop 2drop ;
   
 : sfind ( c-addr u -- xt n / 0 )  : sfind ( c-addr u -- xt n / 0 )
     search @ search-wordlist ;      lookup @ search-wordlist ;
   
 : find   ( addr -- cfa +-1 / string false )  : find   ( addr -- cfa +-1 / string false )
     \ !! not ANS conformant: returns +-2 for restricted words      \ !! not ANS conformant: returns +-2 for restricted words
Line 1009  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 1017  Variable warnings  G -1 warnings T ! Line 1027  Variable warnings  G -1 warnings T !
 08 constant #bs  08 constant #bs
 09 constant #tab  09 constant #tab
 7F constant #del  7F constant #del
 0C constant #ff  
 0D constant #cr                \ the newline key code  0D constant #cr                \ the newline key code
   0C constant #ff
 0A constant #lf  0A constant #lf
   
 : bell  #bell emit ;  : bell  #bell emit ;
Line 1129  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1139  create nl$ 1 c, A c, 0 c, \ gnu includes
   loadline @ >r loadfile @ >r    loadline @ >r loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;    blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;
   
 : pop-file   ( -- )  r>  : pop-file   ( throw-code -- throw-code )
     dup IF
            source >in @ loadline @ loadfilename 2@
            error-stack dup @ dup 1+
            max-errors 1- min error-stack !
            6 * cells + cell+
            5 cells bounds swap DO
                               I !
            -1 cells +LOOP
     THEN
     r>
   r> >in !  r> #tib !  r> >tib !  r> blk !    r> >in !  r> #tib !  r> >tib !  r> blk !
   r> loadfile ! r> loadline !  >r ;    r> loadfile ! r> loadline !  >r ;
   
Line 1139  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    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 1163  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 1205  Defer .status Line 1249  Defer .status
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
   
   8 Constant max-errors
   Variable error-stack  0 error-stack !
   max-errors 6 * cells allot
   \ format of one cell:
   \ source ( addr u )
   \ >in
   \ line-number
   \ Loadfilename ( addr u )
   
 : dec. ( n -- )  : dec. ( n -- )
     \ print value in decimal representation      \ print value in decimal representation
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : typewhite ( addr u -- )  : typewhite ( addr u -- )
     \ like type, but white space is printed instead of the characters      \ like type, but white space is printed instead of the characters
     0 ?do      bounds ?do
         dup i + c@ 9 = if \ check for tab          i c@ 9 = if \ check for tab
             9              9
         else          else
             bl              bl
         then          then
         emit          emit
     loop      loop
     drop ;  ;
   
 DEFER DOERROR  DEFER DOERROR
   
   : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
     cr error-stack @
     IF
        ." in file included from "
        type ." :" dec.  drop 2drop
     ELSE
        type ." :" dec.
        cr dup 2over type cr drop
        nip -trailing 1- ( line-start index2 )
        0 >r  BEGIN
                     2dup + c@ bl >  WHILE
                     r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
        ( line-start index1 )
        typewhite
        r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                     [char] ^ emit
        loop
     THEN
   ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
     LoadFile @    loadline @ IF
     IF                 source >in @ loadline @ 0 0 .error-frame
         cr loadfilename 2@ type ." :" Loadline @ dec.    THEN
     THEN    error-stack @ 0 ?DO
     cr source type cr      -1 error-stack +!
     source drop >in @ -trailing ( throw-code line-start index2 )      error-stack dup @ 6 * cells + cell+
     here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )      6 cells bounds DO
     typewhite        I @
     r> 1 max 0 ?do \ we want at least one "^", even if the length is 0      cell +LOOP
         ." ^"      .error-frame
     loop    LOOP
     dup -2 =    dup -2 =
     IF     IF 
         "error @ ?dup       "error @ ?dup
         IF       IF
             cr count type           cr count type 
         THEN       THEN
         drop       drop
     ELSE    ELSE
         .error       .error
     THEN    THEN
     normal-dp dpp ! ;    normal-dp dpp ! ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
Line 1264  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 1282  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 1318  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.17  
changed lines
  Added in v.1.20

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