Annotation of gforth/locals.fs, revision 1.2

1.1       pazsan      1: \ Local primitives                                      17jan92py
                      2: 
                      3: Variable loffset   0 loffset !
                      4: Variable locals  here locals !  100 ( some) cells allot
                      5: : local, ( offset -- )  postpone rp@ loffset @ swap -
                      6:   postpone Literal postpone + ;
                      7: : delocal, ( offset -- ) local, postpone rp! ;
                      8: : (local  DOES>  @ local, postpone @ ;
1.2     ! pazsan      9: : f>r  r> rp@ 1 floats - dup rp! f! >r ;
        !            10: : (flocal DOES>  @ local, postpone f@ ;
1.1       pazsan     11: 
1.2     ! pazsan     12: : do-nothing ;
        !            13: : ralign  r>
        !            14:   BEGIN  rp@ [ 1 floats 1- ] Literal and
        !            15:          WHILE  [ ' do-nothing >body ] ALiteral >r
        !            16:   REPEAT  >r ;
        !            17: 
        !            18: : <local ( -- sys1 )  current @ @ loffset @ locals @
        !            19:   over 0= IF  postpone  ralign  THEN  ;                 immediate
1.1       pazsan     20: : local: ( -- )  postpone >r  last @ lastcfa @ here locals @ dp !
                     21:   cell loffset +! Create  loffset @ , immediate (local
                     22:   here locals !  dp !  lastcfa ! last ! ;               immediate
1.2     ! pazsan     23: : flocal: ( -- )  last @ lastcfa @ here locals @ dp !
        !            24:   BEGIN  loffset @ 0 1 floats fm/mod drop  WHILE
        !            25:          0 postpone Literal postpone >r  1 cells  loffset +!  REPEAT
        !            26:   postpone f>r  Create  loffset @ , immediate (flocal
        !            27:   here locals !  dp !  lastcfa ! last ! ;               immediate
1.1       pazsan     28: : local> ( sys1 -- sys2 ) ;                             immediate
                     29: : local; ( sys2 -- ) locals ! dup delocal,
                     30:   loffset ! current @ ! ;                               immediate
                     31: : TO  >in @ ' dup @ [ ' (local >body cell+ ] ALiteral =
                     32:   IF    >body @ local, postpone ! drop
1.2     ! pazsan     33:   ELSE  dup @ [ ' (flocal >body cell+ ] ALiteral =
        !            34:         IF    >body @ local, postpone f!  drop
        !            35:         ELSE  drop >in ! postpone to  THEN THEN ;       immediate
1.1       pazsan     36: 
                     37: : DO      2 cells loffset +!  postpone DO     ; immediate restrict
                     38: : ?DO     2 cells loffset +!  postpone ?DO    ; immediate restrict
                     39: : FOR     2 cells loffset +!  postpone FOR    ; immediate restrict
                     40: : LOOP   -2 cells loffset +!  postpone LOOP   ; immediate restrict
                     41: : +LOOP  -2 cells loffset +!  postpone +LOOP  ; immediate restrict
                     42: : NEXT   -2 cells loffset +!  postpone NEXT   ; immediate restrict
                     43: : >R      1 cells loffset +!  postpone >R     ; immediate restrict
                     44: : R>     -1 cells loffset +!  postpone R>     ; immediate restrict
                     45: 
                     46: \ High level locals                                    19aug93py
                     47: 
                     48: : { postpone <local  -1
                     49:   BEGIN  >in @ name dup c@ 1 = swap 1+ c@ '| = and  UNTIL
                     50:   drop >in @ >r
                     51:   BEGIN  dup 0< 0= WHILE  >in ! postpone local:  REPEAT  drop
                     52:   r> >in ! postpone local> ;                  immediate restrict
                     53: 
1.2     ! pazsan     54: : F{ postpone <local  -1
        !            55:   BEGIN  >in @ name dup c@ 1 = swap 1+ c@ '| = and  UNTIL
        !            56:   drop >in @ >r
        !            57:   BEGIN  dup 0< 0= WHILE  >in ! postpone Flocal:  REPEAT  drop
        !            58:   r> >in ! postpone local> ;                  immediate restrict
        !            59: 
1.1       pazsan     60: ' local; alias } immediate restrict
                     61: 
                     62: \ ANS Locals                                           19aug93py
                     63: 
                     64: Create inlocal  5 cells allot  inlocal off
                     65: : (local)  ( addr u -- )  inlocal @ 0=
                     66:   IF  postpone <local inlocal on
                     67:       inlocal 3 cells + 2!  inlocal cell+ 2! THEN
                     68:   dup IF    linestart @ >r loadline @ >r loadfile @ >r
                     69:             blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
                     70: 
                     71:             >tib +! dup #tib ! >tib @ swap move
                     72:             >in off blk off loadfile off -1 linestart !
                     73: 
                     74:             postpone local:
                     75: 
                     76:             r> >in !  r> #tib !  r> >tib ! r> blk !
                     77:             r> loadfile ! r> loadline ! r> linestart !
                     78:       ELSE  2drop  inlocal cell+ 2@  inlocal 3 cells + 2@
                     79:             postpone local>
                     80:             inlocal 2 cells + 2! inlocal cell+ ! THEN ;
                     81: 
                     82: : ?local;  inlocal @
                     83:   IF  inlocal cell+ @ inlocal 2 cells + 2@
                     84:       postpone local; inlocal off  THEN ;
                     85: 
                     86: : ;      ?local; postpone ; ;                 immediate restrict
                     87: : DOES>  ?local; postpone DOES> ;             immediate
1.2     ! pazsan     88: : EXIT  inlocal @ IF  0 delocal,  THEN  postpone EXIT ; immediate
1.1       pazsan     89: 
                     90: : locals|
                     91:   BEGIN  name dup c@ 1 = over 1+ c@ '| = and 0=  WHILE
                     92:          count (local)  REPEAT  0 (local) ;   immediate restrict

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