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

gforth: gforth/kernel/Attic/interp.fs

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

version 1.2, Fri Jun 6 17:28:15 1997 UTC version 1.3, Sun Jul 6 15:56:16 1997 UTC
Line 13 
Line 13 
 doer? :dovar [IF]  doer? :dovar [IF]
 : dovar: ( -- addr )    \ gforth  : dovar: ( -- addr )    \ gforth
     \G the code address of a @code{CREATE}d word      \G the code address of a @code{CREATE}d word
     ['] udp >code-address ;      \ in rom-applications variable might be implemented with constant
       \ use really a created word!
       ['] ??? >code-address ;
 [THEN]  [THEN]
   
 doer? :douser [IF]  doer? :douser [IF]
 : douser: ( -- addr )   \ gforth  : douser: ( -- addr )   \ gforth
     \G the code address of a @code{USER} variable      \G the code address of a @code{USER} variable
     ['] s0 >code-address ;      ['] sp0 >code-address ;
 [THEN]  [THEN]
   
 doer? :dodefer [IF]  doer? :dodefer [IF]
Line 79 
Line 81 
   
 ' , 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 131 
Line 135 
 : 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 184 
Line 191 
 \ 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 422 
Line 429 
     \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 431 
Line 444 
  cell +loop   cell +loop
  drop ??? ( wouldn't 0 be better? ) ;   drop ??? ( wouldn't 0 be better? ) ;
   
   ' >head ALIAS >name
   
   : body> 0 >body - ;
   
 \ threading                                   17mar93py  \ threading                                   17mar93py
   
 : cfa,     ( code-address -- )  \ gforth        cfa-comma  : cfa,     ( code-address -- )  \ gforth        cfa-comma
Line 471 
Line 488 
 : 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 533 
Line 550 
   
 \ 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 549 
Line 564 
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- nt )    1 cells: field find-method   \ xt: ( c_addr u wid -- nt )
   1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field    1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )    \ re-initializes a "search-data" (hashtables)
     1 cells: field hash-method   \ xt: ( wid -- )    \ initializes ""
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct
   
Line 557 
Line 573 
   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation    1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
   1 cells: field wordlist-map \ pointer to a wordlist-map-struct    1 cells: field wordlist-map \ pointer to a wordlist-map-struct
   1 cells: field wordlist-link \ link field to other wordlists    1 cells: field wordlist-link \ link field to other wordlists
   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    1 cells: 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
   
Line 894 
Line 920 
 ' (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 909 
Line 935 
 \ : 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
Line 926 
Line 947 
   
 ' (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-files [IF] ]
     pathstring 2@ fpath only-path      pathstring 2@ fpath only-path
     init-included-files      init-included-files
 [ [THEN] ]  [ [THEN] ]
     'cold      'cold
       init8 chainperform
 [ has-files [IF] ]  [ has-files [IF] ]
     ['] process-args catch ?dup      ['] process-args catch ?dup
     IF      IF
Line 953 
Line 984 
 [ has-files [IF] ]  [ has-files [IF] ]
     argc ! argv ! pathstring 2!      argc ! argv ! pathstring 2!
 [ [THEN] ]  [ [THEN] ]
     sp@ s0 !      sp@ sp0 !
 [ has-locals [IF] ]  [ has-locals [IF] ]
     lp@ forthstart 7 cells + @ -      lp@ forthstart 7 cells + @ -
 [ [ELSE] ]  [ [ELSE] ]
Line 964 
Line 995 
     [ [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-floats [IF] ]
     fp@ f0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
     ['] cold catch DoError      ['] cold catch DoError
 [ has-os [IF] ]  [ has-os [IF] ]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help