File:  [gforth] / gforth / locals.fs
Revision 1.4: download - view: text, annotated - select for diffs
Wed Nov 29 20:20:36 1995 UTC (28 years, 3 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, v0-3-0, v0-2-1, v0-2-0, gforth-0_1beta, HEAD
replced tester.fs and coretest.fs with the new versions from John Hayes
make mostlyclean virtualclean added
Cache-flushing now works on the Alpha (other minor changes there)
configure now uses gcc by default and passes its GCC variable to the Makefile
introduced sourcefilename and sourceline# (and used them in many places).

    1: \ Local primitives                                      17jan92py
    2: 
    3: \ Copyright (C) 1995 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: Variable loffset   0 loffset !
   22: Variable locals  here locals !  100 ( some) cells allot
   23: : local, ( offset -- )  postpone rp@ loffset @ swap -
   24:   postpone Literal postpone + ;
   25: : delocal, ( offset -- ) local, postpone rp! ;
   26: : (local  DOES>  @ local, postpone @ ;
   27: : f>r  r> rp@ 1 floats - dup rp! f! >r ;
   28: : (flocal DOES>  @ local, postpone f@ ;
   29: 
   30: : do-nothing ;
   31: : ralign  r>
   32:   BEGIN  rp@ [ 1 floats 1- ] Literal and
   33:          WHILE  [ ' do-nothing >body ] ALiteral >r
   34:   REPEAT  >r ;
   35: 
   36: : <local ( -- sys1 )  current @ @ loffset @ locals @
   37:   over 0= IF  postpone  ralign  THEN  ;                 immediate
   38: : local: ( -- )  postpone >r  last @ lastcfa @ here locals @ dp !
   39:   cell loffset +! Create  loffset @ , immediate (local
   40:   here locals !  dp !  lastcfa ! last ! ;               immediate
   41: : flocal: ( -- )  last @ lastcfa @ here locals @ dp !
   42:   BEGIN  loffset @ 0 1 floats fm/mod drop  WHILE
   43:          0 postpone Literal postpone >r  1 cells  loffset +!  REPEAT
   44:   postpone f>r  Create  loffset @ , immediate (flocal
   45:   here locals !  dp !  lastcfa ! last ! ;               immediate
   46: : local> ( sys1 -- sys2 ) ;                             immediate
   47: : local; ( sys2 -- ) locals ! dup delocal,
   48:   loffset ! current @ ! ;                               immediate
   49: : TO  >in @ ' dup @ [ ' (local >body cell+ ] ALiteral =
   50:   IF    >body @ local, postpone ! drop
   51:   ELSE  dup @ [ ' (flocal >body cell+ ] ALiteral =
   52:         IF    >body @ local, postpone f!  drop
   53:         ELSE  drop >in ! postpone to  THEN THEN ;       immediate
   54: 
   55: : DO      2 cells loffset +!  postpone DO     ; immediate restrict
   56: : ?DO     2 cells loffset +!  postpone ?DO    ; immediate restrict
   57: : FOR     2 cells loffset +!  postpone FOR    ; immediate restrict
   58: : LOOP   -2 cells loffset +!  postpone LOOP   ; immediate restrict
   59: : +LOOP  -2 cells loffset +!  postpone +LOOP  ; immediate restrict
   60: : NEXT   -2 cells loffset +!  postpone NEXT   ; immediate restrict
   61: : >R      1 cells loffset +!  postpone >R     ; immediate restrict
   62: : R>     -1 cells loffset +!  postpone R>     ; immediate restrict
   63: 
   64: \ High level locals                                    19aug93py
   65: 
   66: : { postpone <local  -1
   67:   BEGIN  >in @ name dup c@ 1 = swap 1+ c@ '| = and  UNTIL
   68:   drop >in @ >r
   69:   BEGIN  dup 0< 0= WHILE  >in ! postpone local:  REPEAT  drop
   70:   r> >in ! postpone local> ;                  immediate restrict
   71: 
   72: : F{ postpone <local  -1
   73:   BEGIN  >in @ name dup c@ 1 = swap 1+ c@ '| = and  UNTIL
   74:   drop >in @ >r
   75:   BEGIN  dup 0< 0= WHILE  >in ! postpone Flocal:  REPEAT  drop
   76:   r> >in ! postpone local> ;                  immediate restrict
   77: 
   78: ' local; alias } immediate restrict
   79: 
   80: \ ANS Locals                                           19aug93py
   81: 
   82: Create inlocal  5 cells allot  inlocal off
   83: : (local)  ( addr u -- )  inlocal @ 0=
   84:   IF  postpone <local inlocal on
   85:       inlocal 3 cells + 2!  inlocal cell+ 2! THEN
   86:   dup IF    linestart @ >r sourceline# >r loadfile @ >r
   87:             blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
   88: 
   89:             >tib +! dup #tib ! >tib @ swap move
   90:             >in off blk off loadfile off -1 linestart !
   91: 
   92:             postpone local:
   93: 
   94:             r> >in !  r> #tib !  r> >tib ! r> blk !
   95:             r> loadfile ! r> loadline ! r> linestart !
   96:       ELSE  2drop  inlocal cell+ 2@  inlocal 3 cells + 2@
   97:             postpone local>
   98:             inlocal 2 cells + 2! inlocal cell+ ! THEN ;
   99: 
  100: : ?local;  inlocal @
  101:   IF  inlocal cell+ @ inlocal 2 cells + 2@
  102:       postpone local; inlocal off  THEN ;
  103: 
  104: : ;      ?local; postpone ; ;                 immediate restrict
  105: : DOES>  ?local; postpone DOES> ;             immediate
  106: : EXIT  inlocal @ IF  0 delocal,  THEN  postpone EXIT ; immediate
  107: 
  108: : locals|
  109:   BEGIN  name dup c@ 1 = over 1+ c@ '| = and 0=  WHILE
  110:          count (local)  REPEAT  0 (local) ;   immediate restrict

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