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

version 1.14, 1994/08/19 17:47:23 version 1.17, 1994/08/31 19:42:48
Line 142  Defer source Line 142  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 206  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 318  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 756  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 729  Avariable leave-sp  leave-stack 3 cells Line 781  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 c@
Line 742  defer header Line 795  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 762  create nextname-buffer 32 chars allot Line 815  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 770  create nextname-buffer 32 chars allot Line 823  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 839  Create ???  0 , 3 c, char ? c, char ? c, Line 892  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 936  Variable warnings  G -1 warnings T ! Line 992  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 ;      search @ 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 1009  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
   0C constant #ff
 0D constant #cr                \ the newline key code  0D constant #cr                \ the newline key code
 0A constant #lf  0A constant #lf
   
Line 1000  Create crtlkeys Line 1064  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 1087  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 1126  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   ( -- )  r>
   r> >in !  r> #tib !  r> >tib ! r> blk !    r> >in !  r> #tib !  r> >tib !  r> blk !
   r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;    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
   loadfile @ close-file throw    pop-file  throw throw ;
   pop-file ;  
   
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x )
     loadfilename 2@ >r >r      loadfilename 2@ >r >r
Line 1116  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1185  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 ;

Removed from v.1.14  
changed lines
  Added in v.1.17


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