[gforth] / gforth / kernel / Attic / interp.fs  

gforth: gforth/kernel/Attic/interp.fs

Diff for /gforth/kernel/Attic/interp.fs between version 1.3 and 1.8

version 1.3, Sun Jul 6 15:56:16 1997 UTC version 1.8, Mon Dec 1 21:15:23 1997 UTC
Line 1 
Line 1 
 \ definitions needed for interpreter / compiler only  \ definitions needed for interpreter / compiler only
   
 doer? :docon [IF]  
 : docon: ( -- addr )    \ gforth  
     \G the code address of a @code{CONSTANT}  
     ['] bl >code-address ;  
 [THEN]  
   
 : docol: ( -- addr )    \ gforth  
     \G the code address of a colon definition  
     ['] docol: >code-address ;  
   
 doer? :dovar [IF]  
 : dovar: ( -- addr )    \ gforth  
     \G the code address of a @code{CREATE}d word  
     \ in rom-applications variable might be implemented with constant  
     \ use really a created word!  
     ['] ??? >code-address ;  
 [THEN]  
   
 doer? :douser [IF]  
 : douser: ( -- addr )   \ gforth  
     \G the code address of a @code{USER} variable  
     ['] sp0 >code-address ;  
 [THEN]  
   
 doer? :dodefer [IF]  
 : dodefer: ( -- addr )  \ gforth  
     \G the code address of a @code{defer}ed word  
     ['] source >code-address ;  
 [THEN]  
   
 doer? :dofield [IF]  
 : dofield: ( -- addr )  \ gforth  
     \G the code address of a @code{field}  
     ['] reveal-method >code-address ;  
 [THEN]  
   
 .( test1 )  
 has-prims 0= [IF]  
 : dodoes: ( -- addr )   \ gforth  
     \G the code address of a @code{field}  
     ['] spaces >code-address ;  
 .( test2 )  
 [THEN]  
   
 \ here allot , c, A,                                   17dec92py  \ here allot , c, A,                                   17dec92py
   
 : allot ( n -- ) \ core  : allot ( n -- ) \ core
     dup unused > -8 and throw      dup unused u> -8 and throw
     dp +! ;      dp +! ;
 : c,    ( c -- ) \ core  : c,    ( c -- ) \ core
     here 1 chars allot c! ;      here 1 chars allot c! ;
Line 161 
Line 117 
 : [char] ( compilation 'char' -- ; run-time -- n )  : [char] ( compilation 'char' -- ; run-time -- n )
     char postpone Literal ; immediate restrict      char postpone Literal ; immediate restrict
   
   \ threading                                   17mar93py
   
   : cfa,     ( code-address -- )  \ gforth        cfa-comma
       here
       dup lastcfa !
       0 A, 0 ,  code-address! ;
   : compile, ( xt -- )    \ core-ext      compile-comma
       A, ;
   : !does    ( addr -- ) \ gforth store-does
       lastxt does-code! ;
   : (does>)  ( R: addr -- )
       r> cfaligned /does-handler + !does ;
   : dodoes,  ( -- )
     cfalign here /does-handler allot does-handler! ;
   
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
Line 448 
Line 419 
   
 : body> 0 >body - ;  : body> 0 >body - ;
   
 \ threading                                   17mar93py  
   
 : cfa,     ( code-address -- )  \ gforth        cfa-comma  
     here  
     dup lastcfa !  
     0 A, 0 ,  code-address! ;  
 : compile, ( xt -- )    \ core-ext      compile-comma  
     A, ;  
 : !does    ( addr -- ) \ gforth store-does  
     lastxt does-code! ;  
 : (does>)  ( R: addr -- )  
     r> cfaligned /does-handler + !does ;  
 : dodoes,  ( -- )  
   cfalign here /does-handler allot does-handler! ;  
   
 doer? :dovar [IF]  doer? :dovar [IF]
 : Create ( "name" -- ) \ core  : Create ( "name" -- ) \ core
     Header reveal dovar: cfa, ;      Header reveal dovar: cfa, ;
Line 562 
Line 518 
 \ word list structure:  \ word list structure:
   
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- nt )    cell% field find-method   \ xt: ( c_addr u wid -- nt )
   1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field    cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    \ re-initializes a "search-data" (hashtables)    cell% field rehash-method \ xt: ( wid -- )       \ re-initializes a "search-data" (hashtables)
   1 cells: field hash-method   \ xt: ( wid -- )    \ initializes ""    cell% field hash-method   \ xt: ( wid -- )    \ initializes ""
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct
   
 struct  struct
   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation    cell% field wordlist-id \ not the same as wid; representation depends on implementation
   1 cells: field wordlist-map \ pointer to a wordlist-map-struct    cell% field wordlist-map \ pointer to a wordlist-map-struct
   1 cells: field wordlist-link \ link field to other wordlists    cell% field wordlist-link \ link field to other wordlists
   1 cells: field wordlist-extend \ points to wordlist extensions (eg hashtables)    cell% field wordlist-extend \ points to wordlist extensions (eg hashtables)
 end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nt / false )  : f83find      ( addr len wordlist -- nt / false )
Line 599 
Line 555 
   
 \ higher level parts of find  \ higher level parts of find
   
 ( struct )  struct
 0 >body cell      >body
   1 cells: field interpret/compile-int      cell% field interpret/compile-int
   1 cells: field interpret/compile-comp      cell% field interpret/compile-comp
 end-struct interpret/compile-struct  end-struct interpret/compile-struct
   
 : interpret/compile? ( xt -- flag )  
     >does-code ['] S" >does-code = ;  
   
 : (cfa>int) ( cfa -- xt )  : (cfa>int) ( cfa -- xt )
     dup interpret/compile?      dup interpret/compile?
     if      if
Line 741 
Line 694 
             dup ( name>link ) @ 1 xor           ( nt wid )              dup ( name>link ) @ 1 xor           ( nt wid )
             2dup >r name>string r> check-shadow ( nt wid )              2dup >r name>string r> check-shadow ( nt wid )
             dup wordlist-map @ reveal-method perform              dup wordlist-map @ reveal-method perform
           else
               drop
         then          then
     then ;      then ;
   
Line 749 
Line 704 
   
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 has-files 0= [IF]  has? file 0= [IF]
 : sourceline# ( -- n )  loadline @ ;  : sourceline# ( -- n )  loadline @ ;
 [THEN]  [THEN]
   
 : refill ( -- flag ) \ core-ext,block-ext,file-ext  : refill ( -- flag ) \ core-ext,block-ext,file-ext
   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN    blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line    tib /line
 [ has-files [IF] ]  [ has? file [IF] ]
   loadfile @ ?dup    loadfile @ ?dup
   IF    read-line throw    IF    read-line throw
   ELSE    ELSE
 [ [THEN] ]  [ [THEN] ]
       sourceline# 0< IF 2drop false EXIT THEN        sourceline# 0< IF 2drop false EXIT THEN
       accept true        accept true
 [ has-files [IF] ]  [ has? file [IF] ]
   THEN    THEN
 [ [THEN] ]  [ [THEN] ]
   1 loadline +!    1 loadline +!
Line 776 
Line 731 
   
 \ save-mem extend-mem  \ save-mem extend-mem
   
 has-os [IF]  has? os [IF]
 : save-mem      ( addr1 u -- addr2 u ) \ gforth  : save-mem      ( addr1 u -- addr2 u ) \ gforth
     \g copy a memory block into a newly allocated region in the heap      \g copy a memory block into a newly allocated region in the heap
     swap >r      swap >r
Line 802 
Line 757 
   
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 has-files 0= [IF]  has? file 0= [IF]
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r    sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r
   >tib @ tibstack @ = IF  r@ tibstack +!  THEN    >tib @ tibstack @ = IF  r@ tibstack +!  THEN
Line 888 
Line 843 
 ;  ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
   [ has-os [IF] ]    [ has? os [IF] ]
       outfile-id dup flush-file drop >r        outfile-id dup flush-file drop >r
       stderr to outfile-id        stderr to outfile-id
   [ [THEN] ]    [ [THEN] ]
   sourceline# IF    sourceline# 0> IF
                source >in @ sourceline# 0 0 .error-frame                 source >in @ sourceline# 0 0 .error-frame
   THEN    THEN
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
Line 914 
Line 869 
      .error       .error
   THEN    THEN
   normal-dp dpp !    normal-dp dpp !
   [ has-os [IF] ] r> to outfile-id [ [THEN] ]    [ has? os [IF] ] r> to outfile-id [ [THEN] ]
   ;    ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
Line 939 
Line 894 
     ." GForth " version-string type      ." GForth " version-string type
     ." , Copyright (C) 1994-1997 Free Software Foundation, Inc." cr      ." , Copyright (C) 1994-1997 Free Software Foundation, Inc." cr
     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"      ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
 [ has-os [IF] ]  [ has? os [IF] ]
      cr ." Type `bye' to exit"       cr ." Type `bye' to exit"
 [ [THEN] ] ;  [ [THEN] ] ;
   
 defer bootmessage  defer bootmessage
   defer process-args
   
 ' (bootmessage) IS bootmessage  ' (bootmessage) IS bootmessage
   
Line 957 
Line 913 
 Variable init8  Variable init8
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
 [ has-files [IF] ]  [ has? file [IF] ]
     pathstring 2@ fpath only-path      pathstring 2@ fpath only-path
     init-included-files      init-included-files
 [ [THEN] ]  [ [THEN] ]
     'cold      'cold
     init8 chainperform      init8 chainperform
 [ has-files [IF] ]  [ has? file [IF] ]
     ['] process-args catch ?dup      ['] process-args catch ?dup
     IF      IF
       dup >r DoError cr r> negate (bye)        dup >r DoError cr r> negate (bye)
Line 978 
Line 934 
   
 : boot ( path **argv argc -- )  : boot ( path **argv argc -- )
     main-task up!      main-task up!
 [ has-os [IF] ]  [ has? os [IF] ]
     stdout TO outfile-id      stdout TO outfile-id
 [ [THEN] ]  [ [THEN] ]
 [ has-files [IF] ]  [ has? file [IF] ]
     argc ! argv ! pathstring 2!      argc ! argv ! pathstring 2!
 [ [THEN] ]  [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
 [ has-locals [IF] ]  [ has? glocals [IF] ]
     lp@ forthstart 7 cells + @ -      lp@ forthstart 7 cells + @ -
 [ [ELSE] ]  [ [ELSE] ]
     [ has-os [IF] ]      [ has? os [IF] ]
     sp@ $1040 +      sp@ $1040 +
     [ [ELSE] ]      [ [ELSE] ]
     sp@ $40 +      sp@ $40 +
Line 996 
Line 952 
 [ [THEN] ]  [ [THEN] ]
     dup >tib ! tibstack ! #tib off >in off      dup >tib ! tibstack ! #tib off >in off
     rp@ rp0 !      rp@ rp0 !
 [ has-floats [IF] ]  [ has? floating [IF] ]
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
     ['] cold catch DoError      ['] cold catch DoError cr
 [ has-os [IF] ]  [ has? os [IF] ]
     bye      bye
 [ [THEN] ]  [ [THEN] ]
 ;  ;
   
 has-os [IF]  has? os [IF]
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
 [ has-files [IF] ]  [ has? file [IF] ]
     script? 0= IF  cr  THEN      script? 0= IF  cr  THEN
 [ [ELSE] ]  [ [ELSE] ]
     cr      cr

Generate output suitable for use with a patch program
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.8
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help