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

Diff for /gforth/Attic/kernal.fs between versions 1.14 and 1.19

version 1.14, 1994/08/19 17:47:23 version 1.19, 1994/09/05 17:36:20
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 142  Defer source Line 158  Defer source
   dup count chars bounds    dup count 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)  ( -- addr )  bl word ;
 \ : (cname) ( -- addr )  bl word capitalize ;  : sname ( -- c-addr count )
       source 2dup >r >r >in @ /string (parse-white)
       2dup + r> - 1+ r> min >in ! ;
   \    name count ;
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
Line 203  Create bases   10 ,   2 ,   A , 100 , Line 222  Create bases   10 ,   2 ,   A , 100 ,
   REPEAT  THEN  2drop rdrop dpl off  ELSE    REPEAT  THEN  2drop rdrop dpl off  ELSE
   2drop rdrop r> IF  dnegate  THEN    2drop rdrop r> IF  dnegate  THEN
   THEN r> base ! ;    THEN r> base ! ;
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number dpl @ 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0> 0= IF
           nip
       THEN ;
 : number? ( string -- string 0 / n -1 / d 0> )  : number? ( string -- string 0 / n -1 / d 0> )
   dup count s>number dpl @ 0= IF  2drop false  EXIT  THEN      dup >r count snumber? dup if
   rot drop dpl @ dup 0> 0= IF  nip  THEN ;          rdrop
       else
           r> swap
       then ;
 : s>d ( n -- d ) dup 0< ;  : s>d ( n -- d ) dup 0< ;
 : number ( string -- d )  : number ( string -- d )
   number? ?dup 0= abort" ?"  0< IF s>d THEN ;    number? ?dup 0= abort" ?"  0< IF s>d THEN ;
Line 304  hex Line 334  hex
   
 Defer parser  Defer parser
 Defer name      ' (name) IS name  Defer name      ' (name) IS name
 Defer notfound  Defer notfound ( c-addr count -- )
   
 : no.extensions  ( string -- )  IF  -&13 bounce  THEN ;  : no.extensions  ( addr u -- )  2drop -&13 bounce ;
   
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
 : interpret  : interpret
   BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;      BEGIN
           ?stack sname dup
 \ interpreter compiler                                 30apr92py      WHILE
           parser
 : interpreter  ( name -- ) find ?dup      REPEAT
   IF  1 and  IF execute  EXIT THEN  -&14 throw  THEN      2drop ;
   number? 0= IF  notfound THEN ;  
   \ sinterpreter scompiler                                 30apr92py
   
   : sinterpreter  ( c-addr u -- ) 
       \ interpretation semantics for the name/number c-addr u
       2dup sfind dup
       IF
           1 and
           IF \ not restricted to compile state?
               nip nip execute  EXIT
           THEN
           -&14 throw
       THEN
       drop
       2dup 2>r snumber?
       IF
           2rdrop
       ELSE
           2r> notfound
       THEN ;
   
 ' interpreter  IS  parser  ' sinterpreter  IS  parser
   
 : compiler     ( name -- ) find  ?dup  : scompiler     ( c-addr u -- )
   IF  0> IF  execute EXIT THEN compile, EXIT THEN number? dup      \ compilation semantics for the name/number c-addr u
   IF  0> IF  swap postpone Literal  THEN  postpone Literal      2dup sfind dup
   ELSE  drop notfound  THEN ;      IF
           0>
           IF
               nip nip execute EXIT
           THEN
           compile, 2drop EXIT
       THEN
       drop
       2dup snumber? dup
       IF
           0>
           IF
               swap postpone Literal
           THEN
           postpone Literal
           2drop
       ELSE
           drop notfound
       THEN ;
   
 : [     ['] interpreter  IS parser state off ; immediate  : [     ['] sinterpreter  IS parser state off ; immediate
 : ]     ['] compiler     IS parser state on  ;  : ]     ['] scompiler     IS parser state on  ;
   
 \ locals stuff needed for control structures  \ locals stuff needed for control structures
   
Line 705  Avariable leave-sp  leave-stack 3 cells Line 772  Avariable leave-sp  leave-stack 3 cells
 : ."       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
 : \        source >in ! drop ;                          immediate  : \        blk @ IF  >in @ c/l / 1+ c/l * >in !  EXIT  THEN
              source >in ! drop ;                          immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
 \ 'abort thrown out!                                   11may93jaw  \ 'abort thrown out!                                   11may93jaw
Line 839  Create ???  0 , 3 c, char ? c, char ? c, Line 907  Create ???  0 , 3 c, char ? c, char ? c,
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer  : Defer ( -- )
   Create ( -- )       \ !! shouldn't it be initialized with abort or something similar?
     ['] noop A,      Header Reveal [ :dodefer ] Literal cfa,
   DOES> ( ??? )      ['] noop A, ;
     @ execute ;  \     Create ( -- ) 
   \       ['] noop A,
   \     DOES> ( ??? )
   \       @ execute ;
   
 : IS ( addr "name" -- )  : IS ( addr "name" -- )
     ' >body      ' >body
Line 911  AVariable current Line 982  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 936  Variable warnings  G -1 warnings T ! Line 1007  Variable warnings  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : find   ( addr -- cfa +-1 / string false )  dup  : sfind ( c-addr u -- xt n / 0 )
   count search @ search-wordlist  dup IF  rot drop  THEN ;      lookup @ search-wordlist ;
   
   : find   ( addr -- cfa +-1 / string false )
       \ !! not ANS conformant: returns +-2 for restricted words
       dup count sfind dup if
           rot drop
       then ;
   
 : reveal ( -- )  : reveal ( -- )
  last? if   last? if
Line 947  Variable warnings  G -1 warnings T ! Line 1024  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= no.extensions ;  : '    ( "name" -- addr )  name find 0= if drop -&13 bounce then ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell  07 constant #bell
 08 constant #bs  08 constant #bs
   09 constant #tab
 7F constant #del  7F constant #del
 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 1000  Create crtlkeys Line 1079  Create crtlkeys
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
 DEFER type      \ defer type for a output buffer or fast  Defer type      \ defer type for a output buffer or fast
                 \ screen write                  \ screen write
   
 \ : (type) ( addr len -- )  \ : (type) ( addr len -- )
 \   bounds ?DO  I c@ emit  LOOP ;  \   bounds ?DO  I c@ emit  LOOP ;
   
 ' (TYPE) IS Type  ' (type) IS Type
   
 DEFER Emit  Defer emit
   
 ' (Emit) IS Emit  ' (Emit) IS Emit
   
   Defer key
   ' (key) IS key
   
 \ : form  ( -- rows cols )  &24 &80 ;  \ : form  ( -- rows cols )  &24 &80 ;
 \ form should be implemented using TERMCAPS or CURSES  \ form should be implemented using TERMCAPS or CURSES
 \ : rows  form drop ;  \ : rows  form drop ;
Line 1020  DEFER Emit Line 1102  DEFER Emit
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag )  : refill ( -- flag )
     blk @  IF  1 blk +!  true  EXIT  THEN
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    \ dup file-position throw linestart 2!    IF    read-line throw
         read-line throw  
   ELSE  loadline @ 0< IF 2drop false EXIT THEN    ELSE  loadline @ 0< IF 2drop false EXIT THEN
         accept true          accept true
   THEN    THEN
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- )  0 loadfile ! refill drop ;  : Query  ( -- )  loadfile off  blk off  refill drop ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1059  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1141  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   ( linestart 2@ >r >r ) 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 )
   r> >in !  r> #tib !  r> >tib ! r> blk !    dup IF
   r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;           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> loadfile ! r> loadline !  >r ;
   
   : read-loop ( i*x -- j*x )
     BEGIN  refill  WHILE  interpret  REPEAT ;
   
 : include-file ( i*x fid -- j*x )  : include-file ( i*x fid -- j*x )
   push-file  loadfile !    push-file  loadfile !
   0 loadline ! blk off    0 loadline ! blk off  ['] read-loop catch
   BEGIN  refill  WHILE  interpret  REPEAT    loadfile @ close-file swap
   loadfile @ close-file throw    pop-file  throw throw ;
   pop-file ;  
   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
     \ 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! ;
Line 1116  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1234  create nl$ 1 c, A c, 0 c, \ gnu includes
   push-file  dup #tib ! >tib @ swap move    push-file  dup #tib ! >tib @ swap move
   >in off blk off loadfile off -1 loadline !    >in off blk off loadfile off -1 loadline !
   
   BEGIN  interpret  >in @ #tib @ u>= UNTIL  \  BEGIN  interpret  >in @ #tib @ u>= UNTIL
     ['] interpret catch
   pop-file ;    pop-file throw ;
   
   
 : abort -1 throw ;  : abort -1 throw ;
Line 1136  Defer .status Line 1254  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 ( line-start index2 )
        0 >r  BEGIN
                     1- 2dup + c@ bl >  WHILE
                     r> 1+ >r  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 1195  DEFER DOERROR Line 1342  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 1213  Variable argc Line 1385  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 1249  Variable argc Line 1426  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.14  
changed lines
  Added in v.1.19

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