File:  [gforth] / gforth / intcomp.fs
Revision 1.15: download - view: text, annotated - select for diffs
Fri Dec 31 18:09:02 2010 UTC (13 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright years

    1: \ defining words for words with non-default and non-immediate compilation semantics
    2: 
    3: \ Copyright (C) 1996,1997,2000,2003,2007,2010 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 3
   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, see http://www.gnu.org/licenses/.
   19: 
   20: \ used like
   21: \ : <name> create-interpret/compile ...
   22: \     interpretation> ... <interpretation
   23: \     compilation> ... <compilation ;
   24: 
   25: 
   26: noname create
   27: does> abort" interpreting word without interpretation semantics" ;
   28: latestxt >does-code
   29: does> abort" compiling word without compilation semantics" ;
   30: latestxt >does-code
   31: constant no-compilation-does-code
   32: constant no-interpretation-does-code
   33: 
   34: : create-interpret/compile ( "name" -- ) \ gforth
   35:     0 0 interpret/compile:
   36:     here latestxt interpret/compile-comp !
   37:     no-compilation-does-code here does-code!
   38:     [ 0 >body ] literal allot
   39:     here latestxt interpret/compile-int !
   40:     no-interpretation-does-code here does-code!
   41:     [ 0 >body ] literal allot ; \ restrict?
   42: 
   43: : fix-does-code ( addr ret-addr -- )
   44:     latestxt [ interpret/compile-struct %size ] literal + >r
   45:     latestxt interpret/compile?
   46:     latestxt interpret/compile-int @ r@ >body = and
   47:     latestxt interpret/compile-comp @ r> = and
   48:     0= abort" not created with create-interpret/compile"
   49:     cell+ cell+ maxaligned \ to does-code
   50:     swap @ does-code! ;
   51: 
   52: : (interpretation>1) ( addr R:retaddr -- )
   53:     latestxt interpret/compile-int swap fix-does-code ;
   54: 
   55: : interpretation> ( compilation. -- orig colon-sys ) \ gforth
   56:     here 4 cells +  POSTPONE literal POSTPONE (interpretation>1) POSTPONE ahead
   57:     defstart dead-code off 0 set-locals-size-list ; immediate restrict
   58: 
   59: : <interpretation ( compilation. orig colon-sys -- ) \ gforth
   60:     ?struc POSTPONE exit
   61:     POSTPONE then ; immediate restrict
   62: 
   63: : (compilation>1) ( addr R:retaddr -- )
   64:     latestxt interpret/compile-comp swap fix-does-code ;
   65: 
   66: : compilation> ( compilation. -- orig colon-sys ) \ gforth
   67:     here 4 cells + POSTPONE literal POSTPONE (compilation>1) POSTPONE ahead
   68:     defstart dead-code off 0 set-locals-size-list POSTPONE >body ; immediate restrict
   69: 
   70: comp' <interpretation drop
   71: Alias <compilation ( compilation. orig colon-sys -- ) \ gforth
   72: immediate restrict
   73: 
   74: \ example
   75: \ : constant ( n "name" -- )
   76: \     create-interpret/compile
   77: \     ,
   78: \ interpretation>
   79: \     @
   80: \ <interpretation
   81: \ compilation>
   82: \     @ postpone literal
   83: \ <compilation ;
   84: 
   85: \ 5 constant five
   86: 
   87: \ cr
   88: \ five . cr
   89: \ : fuenf five ;
   90: \ see fuenf cr

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