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

gforth: gforth/kernel/Attic/interp.fs

Diff for /gforth/kernel/Attic/interp.fs between version 1.1 and 1.7

version 1.1, Wed May 21 20:40:15 1997 UTC version 1.7, Fri Oct 24 17:13:31 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  
     ['] udp >code-address ;  
 [THEN]  
   
 doer? :douser [IF]  
 : douser: ( -- addr )   \ gforth  
     \G the code address of a @code{USER} variable  
     ['] s0 >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 u> -8 and throw
     dp +! ;      dp +! ;
 : c,    ( c -- ) \ core  : c,    ( c -- ) \ core
     here 1 chars allot c! ;      here 1 chars allot c! ;
Line 78 
Line 37 
   
 ' , alias A, ( addr -- ) \ gforth  ' , alias A, ( addr -- ) \ gforth
   
   ' NOOP ALIAS const
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 $80 constant alias-mask \ set when the word is not an alias!  $80 constant alias-mask \ set when the word is not an alias!
Line 130 
Line 91 
 : capitalize ( addr len -- addr len ) \ gforth  : capitalize ( addr len -- addr len ) \ gforth
   2dup chars chars bounds    2dup chars chars bounds
   ?DO  I c@ toupper I c! 1 chars +LOOP ;    ?DO  I c@ toupper I c! 1 chars +LOOP ;
   
   [IFUNDEF] (name) \ name might be a primitive
 : (name) ( -- c-addr count )  : (name) ( -- c-addr count )
     source 2dup >r >r >in @ /string (parse-white)      source 2dup >r >r >in @ /string (parse-white)
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
   [THEN]
   
 : name-too-short? ( c-addr u -- c-addr u )  : name-too-short? ( c-addr u -- c-addr u )
     dup 0= -&16 and throw ;      dup 0= -&16 and throw ;
Line 153 
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 183 
Line 162 
 \ number? number                                       23feb93py  \ number? number                                       23feb93py
   
 hex  hex
 Create bases   10 ,   2 ,   A , 100 ,  const Create bases   10 ,   2 ,   A , 100 ,
 \              16     2    10   character  \              16     2    10   character
 \ !! this saving and restoring base is an abomination! - anton  \ !! this saving and restoring base is an abomination! - anton
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
Line 421 
Line 400 
     \g @var{addr count} is the name of the word represented by @var{nt}.      \g @var{addr count} is the name of the word represented by @var{nt}.
     cell+ count $1F and ;      cell+ count $1F and ;
   
 Create ???  0 , 3 c, char ? c, char ? c, char ? c,  : head>string
 : >name ( cfa -- nt ) \ gforth  to-name    cell+ count $1F and ;
   
   
   const Create ???  0 , 3 c, char ? c, char ? c, char ? c,
   \ ??? is used by dovar:, must be created/:dovar
   
   : >head ( cfa -- nt ) \ gforth  to-name
  $21 cell do   $21 cell do
    dup i - count $9F and + cfaligned over alias-mask + = if     dup i - count $9F and + cfaligned over alias-mask + = if
      i - cell - unloop exit       i - cell - unloop exit
Line 430 
Line 415 
  cell +loop   cell +loop
  drop ??? ( wouldn't 0 be better? ) ;   drop ??? ( wouldn't 0 be better? ) ;
   
 \ threading                                   17mar93py  ' >head ALIAS >name
   
 : cfa,     ( code-address -- )  \ gforth        cfa-comma  : body> 0 >body - ;
     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
Line 470 
Line 444 
 : AUser ( "name" -- ) \ gforth  : AUser ( "name" -- ) \ gforth
     User ;      User ;
 [ELSE]  [ELSE]
 : User Create uallot , DOES> @ up @ + ;  : User Create cell uallot , DOES> @ up @ + ;
 : AUser User ;  : AUser User ;
 [THEN]  [THEN]
   
Line 532 
Line 506 
   
 \ Search list handling                                 23feb93py  \ Search list handling                                 23feb93py
   
 AVariable current ( -- addr ) \ gforth  
   
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     last @ ?dup ;      last @ ?dup ;
 : (reveal) ( nt wid -- )  : (reveal) ( nt wid -- )
Line 546 
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 -- )    cell% field rehash-method \ xt: ( wid -- )       \ re-initializes a "search-data" (hashtables)
     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 hash)    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 )
     ( wid>wordlist-id ) @ (f83find) ;      ( wid>wordlist-id ) @ (f83find) ;
   
   : initvoc               ( wid -- )
     dup wordlist-map @ hash-method perform ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
 Create f83search ( -- wordlist-map )  Create f83search ( -- wordlist-map )
     ' f83find A,  ' (reveal) A,  ' drop A,      ' f83find A,  ' (reveal) A,  ' drop A, ' drop A,
   
   here NIL A, G f83search T A, NIL A, NIL A,
   AValue forth-wordlist \ variable, will be redefined by search.fs
   
 Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,  AVariable lookup        forth-wordlist lookup !
 AVariable lookup       G forth-wordlist lookup T !  \ !! last is user and lookup?! jaw
 G forth-wordlist current T !  AVariable current ( -- addr ) \ gforth
   AVariable voclink       forth-wordlist wordlist-link voclink !
   lookup AValue context
   
   forth-wordlist current !
   
 \ 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 714 
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 722 
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 749 
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 766 
Line 748 
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse ( compilation -- ; run-time ?? -- ?? ) \ core  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
       \g calls the current definition.
     lastxt compile, ; immediate restrict      lastxt compile, ; immediate restrict
 ' reveal alias recursive ( -- ) \ gforth  ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
         immediate  \g makes the current definition visible, enabling it to call itself
   \g recursively.
           immediate restrict
   
 \ 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 858 
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] ]
Line 884 
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
   
 : quit ( ?? -- ?? ) \ core  : quit ( ?? -- ?? ) \ core
     r0 @ rp! handler off >tib @ >r      rp0 @ rp! handler off >tib @ >r
     BEGIN      BEGIN
         postpone [          postpone [
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
Line 905 
Line 890 
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
   
 Defer 'cold  
 \ hook (deferred word) for things to do right before interpreting the  
 \ command-line arguments  
 ' noop IS 'cold  
   
 : (bootmessage)  : (bootmessage)
     ." 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
   
   Defer 'cold
   \ hook (deferred word) for things to do right before interpreting the
   \ command-line arguments
   ' noop IS 'cold
   
   include chains.fs
   
   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
 [ has-files [IF] ]      init8 chainperform
   [ 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 943 
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@ s0 !      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 +
     [ [THEN] ]      [ [THEN] ]
 [ [THEN] ]  [ [THEN] ]
     dup >tib ! tibstack ! #tib off >in off      dup >tib ! tibstack ! #tib off >in off
     rp@ r0 !      rp@ rp0 !
 [ has-floats [IF] ]  [ has? floating [IF] ]
     fp@ f0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
     ['] cold catch DoError      ['] cold catch DoError
 [ 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.1  
changed lines
  Added in v.1.7
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help