[gforth] / gforth / glocals.fs  

gforth: gforth/glocals.fs

Diff for /gforth/glocals.fs between version 1.13 and 1.14

version 1.13, Sat Oct 7 17:38:15 1995 UTC version 1.14, Mon Oct 16 18:33:10 1995 UTC
Line 61 
Line 61 
 \ Currently locals may only be  \ Currently locals may only be
 \ defined at the outer level and TO is not supported.  \ defined at the outer level and TO is not supported.
   
 include search-order.fs  require search-order.fs
 include float.fs  require float.fs
   
 : compile-@local ( n -- ) \ new compile-fetch-local  : compile-@local ( n -- ) \ gforth compile-fetch-local
  case   case
     0       of postpone @local0 endof      0       of postpone @local0 endof
     1 cells of postpone @local1 endof      1 cells of postpone @local1 endof
Line 73 
Line 73 
    ( otherwise ) dup postpone @local# ,     ( otherwise ) dup postpone @local# ,
  endcase ;   endcase ;
   
 : compile-f@local ( n -- ) \ new compile-f-fetch-local  : compile-f@local ( n -- ) \ gforth compile-f-fetch-local
  case   case
     0        of postpone f@local0 endof      0        of postpone f@local0 endof
     1 floats of postpone f@local1 endof      1 floats of postpone f@local1 endof
Line 153 
Line 153 
 vocabulary locals-types \ this contains all the type specifyers, -- and }  vocabulary locals-types \ this contains all the type specifyers, -- and }
 locals-types definitions  locals-types definitions
   
 : W:  : W: ( "name" -- a-addr xt ) \ gforth w-colon
     create-local ( "name" -- a-addr xt )      create-local
         \ xt produces the appropriate locals pushing code when executed          \ xt produces the appropriate locals pushing code when executed
         ['] compile-pushlocal-w          ['] compile-pushlocal-w
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         \ compiles a local variable access          \ compiles a local variable access
         @ lp-offset compile-@local ;          @ lp-offset compile-@local ;
   
 : W^  : W^ ( "name" -- a-addr xt ) \ gforth w-caret
     create-local ( "name" -- a-addr xt )      create-local
         ['] compile-pushlocal-w          ['] compile-pushlocal-w
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         postpone laddr# @ lp-offset, ;          postpone laddr# @ lp-offset, ;
   
 : F:  : F: ( "name" -- a-addr xt ) \ gforth f-colon
     create-local ( "name" -- a-addr xt )      create-local
         ['] compile-pushlocal-f          ['] compile-pushlocal-f
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         @ lp-offset compile-f@local ;          @ lp-offset compile-f@local ;
   
 : F^  : F^ ( "name" -- a-addr xt ) \ gforth f-caret
     create-local ( "name" -- a-addr xt )      create-local
         ['] compile-pushlocal-f          ['] compile-pushlocal-f
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         postpone laddr# @ lp-offset, ;          postpone laddr# @ lp-offset, ;
   
 : D:  : D: ( "name" -- a-addr xt ) \ gforth d-colon
     create-local ( "name" -- a-addr xt )      create-local
         ['] compile-pushlocal-d          ['] compile-pushlocal-d
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         postpone laddr# @ lp-offset, postpone 2@ ;          postpone laddr# @ lp-offset, postpone 2@ ;
   
 : D^  : D^ ( "name" -- a-addr xt ) \ gforth d-caret
     create-local ( "name" -- a-addr xt )      create-local
         ['] compile-pushlocal-d          ['] compile-pushlocal-d
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         postpone laddr# @ lp-offset, ;          postpone laddr# @ lp-offset, ;
   
 : C:  : C: ( "name" -- a-addr xt ) \ gforth c-colon
     create-local ( "name" -- a-addr xt )      create-local
         ['] compile-pushlocal-c          ['] compile-pushlocal-c
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         postpone laddr# @ lp-offset, postpone c@ ;          postpone laddr# @ lp-offset, postpone c@ ;
   
 : C^  : C^ ( "name" -- a-addr xt ) \ gforth c-caret
     create-local ( "name" -- a-addr xt )      create-local
         ['] compile-pushlocal-c          ['] compile-pushlocal-c
     does> ( Compilation: -- ) ( Run-time: -- w )      does> ( Compilation: -- ) ( Run-time: -- w )
         postpone laddr# @ lp-offset, ;          postpone laddr# @ lp-offset, ;
Line 238 
Line 238 
 variable old-dpp  variable old-dpp
   
 \ and now, finally, the user interface words  \ and now, finally, the user interface words
 : { ( -- addr wid 0 )  : { ( -- addr wid 0 ) \ gforth open-brace
     dp old-dpp !      dp old-dpp !
     locals-dp dpp !      locals-dp dpp !
     also new-locals      also new-locals
Line 248 
Line 248 
   
 locals-types definitions  locals-types definitions
   
 : } ( addr wid 0 a-addr1 xt1 ... -- )  : } ( addr wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
     \ ends locals definitions      \ ends locals definitions
     ] old-dpp @ dpp !      ] old-dpp @ dpp !
     begin      begin
Line 262 
Line 262 
     previous previous      previous previous
     locals-list TO locals-wordlist ;      locals-list TO locals-wordlist ;
   
 : -- ( addr wid 0 ... -- )  : -- ( addr wid 0 ... -- ) \ gforth dash-dash
     }      }
     [char] } parse 2drop ;      [char] } parse 2drop ;
   
Line 373 
Line 373 
   
 \ explicit scoping  \ explicit scoping
   
 : scope ( -- scope )  : scope ( compilation  -- scope ; run-time  -- ) \ gforth
  cs-push-part scopestart ; immediate   cs-push-part scopestart ; immediate
   
 : endscope ( scope -- )  : endscope ( compilation scope -- ; run-time  -- ) \ gforth
  scope?   scope?
  drop   drop
  locals-list @ common-list   locals-list @ common-list
Line 449 
Line 449 
   
 \ And here's finally the ANS standard stuff  \ And here's finally the ANS standard stuff
   
 : (local) ( addr u -- )  : (local) ( addr u -- ) \ local paren-local-paren
     \ a little space-inefficient, but well deserved ;-)      \ a little space-inefficient, but well deserved ;-)
     \ In exchange, there are no restrictions whatsoever on using (local)      \ In exchange, there are no restrictions whatsoever on using (local)
     \ as long as you use it in a definition      \ as long as you use it in a definition
Line 481 
Line 481 
     then ;      then ;
   
 \ !! untested  \ !! untested
 : TO ( c|w|d|r "name" -- )  : TO ( c|w|d|r "name" -- ) \ core-ext,local
 \ !! state smart  \ !! state smart
  0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }   0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
  ' dup >definer   ' dup >definer
Line 510 
Line 510 
  endif ; immediate   endif ; immediate
   
 : locals|  : locals|
       \ don't use 'locals|'! use '{'! A portable and free '{'
       \ implementation is anslocals.fs
     BEGIN      BEGIN
         name 2dup s" |" compare 0<>          name 2dup s" |" compare 0<>
     WHILE      WHILE

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help