Diff for /gforth/Attic/kernal.fs between versions 1.61 and 1.62

version 1.61, 1996/08/21 14:58:42 version 1.62, 1996/08/26 10:07:20
Line 517  Defer interpreter-notfound ( c-addr coun Line 517  Defer interpreter-notfound ( c-addr coun
   
 : compile-only-error ( ... -- )  : compile-only-error ( ... -- )
     -&14 throw ;      -&14 throw ;
 Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt?  
 ' compile-only-error IS interpret-special  
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
Line 605  variable backedge-locals Line 603  variable backedge-locals
     0 backedge-locals ! ; immediate      0 backedge-locals ! ; immediate
   
 : ASSUME-LIVE ( orig -- orig ) \ gforth  : ASSUME-LIVE ( orig -- orig ) \ gforth
     \ used immediateliy before a BEGIN that is not reachable from      \ used immediatly before a BEGIN that is not reachable from
     \ above.  causes the BEGIN to assume that the same locals are live      \ above.  causes the BEGIN to assume that the same locals are live
     \ as at the orig point      \ as at the orig point
     dup orig?      dup orig?
Line 962  Avariable leave-sp  leave-stack 3 cells Line 960  Avariable leave-sp  leave-stack 3 cells
 : ," ( "string"<"> -- ) [char] " parse  : ," ( "string"<"> -- ) [char] " parse
   here over char+ allot  place align ;    here over char+ allot  place align ;
 : "lit ( -- addr )  : "lit ( -- addr )
   r> r> dup count + aligned >r swap >r ;               restrict    r> r> dup count + aligned >r swap >r ;
 : (.")     "lit count type ;                           restrict  : (.")     "lit count type ;
 : (S")     "lit count ;                                restrict  : (S")     "lit count ;
 : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string  : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
     postpone (S") here over char+ allot  place align ;      postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
Line 1205  G forth-wordlist current T ! Line 1203  G forth-wordlist current T !
   
 ( struct )  ( struct )
 0 >body cell  0 >body cell
   1 cells: field special-interpretation    1 cells: field interpret/compile-int
   1 cells: field special-compilation    1 cells: field interpret/compile-comp
 end-struct special-struct  end-struct interpret/compile-struct
   
 : interpret/compile? ( xt -- flag )  : interpret/compile? ( xt -- flag )
     >does-code ['] S" >does-code = ;      >does-code ['] S" >does-code = ;
   
   : (cfa>int) ( cfa -- xt )
       dup interpret/compile?
       if
           interpret/compile-int @
       then ;
   
 : (x>int) ( cfa b -- xt )  : (x>int) ( cfa b -- xt )
     \ get interpretation semantics of name      \ get interpretation semantics of name
     restrict-mask and      restrict-mask and
     if      if
         drop ['] compile-only-error          drop ['] compile-only-error
     else      else
         dup interpret/compile?          (cfa>int)
         if  
             special-interpretation @  
         then  
     then ;      then ;
   
 : name>int ( nfa -- xt ) \ gforth  : name>int ( nfa -- xt ) \ gforth
     (name>x) (x>int) ;      (name>x) (x>int) ;
   
   : name?int ( nfa -- xt ) \ gforth
       \ like name>int, but throws an error if compile-only
       (name>x) restrict-mask and
       if
           compile-only-error \ does not return
       then
       (cfa>int) ;
   
 : name>comp ( nfa -- w xt ) \ gforth  : name>comp ( nfa -- w xt ) \ gforth
     \ get compilation semantics of name      \ get compilation semantics of name
     (name>x) >r dup interpret/compile?      (name>x) >r dup interpret/compile?
     if      if
         special-compilation @          interpret/compile-comp @
     then      then
     r> immediate-mask and if      r> immediate-mask and if
         ['] execute          ['] execute
Line 1246  end-struct special-struct Line 1255  end-struct special-struct
     \ true becomes 1, false -1      \ true becomes 1, false -1
     0= 2* 1+ ;      0= 2* 1+ ;
   
   : (name>intn) ( nfa -- xt +-1 )
       (name>x) tuck (x>int) ( b xt )
       swap immediate-mask and flag-sign ;
   
 : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search  : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
    \ xt is the interpretation semantics      \ xt is the interpretation semantics
     (search-wordlist) dup if      (search-wordlist) dup if
         (name>x) tuck (x>int) ( b xt )          (name>intn)
         swap immediate-mask and flag-sign  
     then ;      then ;
   
 : find-name ( c-addr u -- nfa/0 )  : find-name ( c-addr u -- nfa/0 )
Line 1261  end-struct special-struct Line 1273  end-struct special-struct
     if ( nfa )      if ( nfa )
         state @          state @
         if          if
             name>comp ['] execute =              name>comp ['] execute = flag-sign
         else          else
             (name>x) tuck (x>int)              (name>intn)
             swap immediate-mask and  
         then          then
         flag-sign  
     then ;      then ;
   
 : find ( c-addr -- xt +-1 / c-addr 0 ) \ core  : find ( c-addr -- xt +-1 / c-addr 0 ) \ core
Line 1285  end-struct special-struct Line 1295  end-struct special-struct
     (') postpone ALiteral ; immediate restrict      (') postpone ALiteral ; immediate restrict
   
 : '    ( "name" -- xt ) \ core  tick  : '    ( "name" -- xt ) \ core  tick
     (') name>int ;      (') name?int ;
 : [']  ( compilation "name" -- ; run-time -- xt ) \ core        bracket-tick  : [']  ( compilation "name" -- ; run-time -- xt ) \ core        bracket-tick
     ' postpone ALiteral ; immediate restrict      ' postpone ALiteral ; immediate restrict
   

Removed from v.1.61  
changed lines
  Added in v.1.62


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