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

version 1.14, 1994/08/19 17:47:23 version 1.16, 1994/08/31 16:37: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 729  Avariable leave-sp  leave-stack 3 cells Line 780  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@
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     1+ chars allot align ;      1+ chars allot 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 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
 0D constant #cr                \ the newline key code  0D constant #cr                \ the newline key code
 0A constant #lf  0A constant #lf
   0C constant #ff
   
 : bell  #bell emit ;  : bell  #bell emit ;
   

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


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