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

version 1.14, 1994/08/19 17:47:23 version 1.15, 1994/08/25 15:25:28
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 839  Create ???  0 , 3 c, char ? c, char ? c, Line 890  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 990  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 1007  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
   

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


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