Annotation of gforth/intcomp.fs, revision 1.12

1.1       anton       1: \ defining words for words with non-default and non-immediate compilation semantics
                      2: 
1.10      anton       3: \ Copyright (C) 1996,1997,2000,2003 Free Software Foundation, Inc.
1.1       anton       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
1.12    ! anton       9: \ as published by the Free Software Foundation, either version 3
1.1       anton      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
1.12    ! anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1       anton      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" ;
1.9       anton      28: latestxt >does-code
1.1       anton      29: does> abort" compiling word without compilation semantics" ;
1.9       anton      30: latestxt >does-code
1.1       anton      31: constant no-compilation-does-code
                     32: constant no-interpretation-does-code
                     33: 
1.3       anton      34: : create-interpret/compile ( "name" -- ) \ gforth
1.1       anton      35:     0 0 interpret/compile:
1.9       anton      36:     here latestxt interpret/compile-comp !
1.2       anton      37:     no-compilation-does-code here does-code!
                     38:     [ 0 >body ] literal allot
1.9       anton      39:     here latestxt interpret/compile-int !
1.1       anton      40:     no-interpretation-does-code here does-code!
1.2       anton      41:     [ 0 >body ] literal allot ; \ restrict?
1.1       anton      42: 
                     43: : fix-does-code ( addr ret-addr -- )
1.9       anton      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
1.1       anton      48:     0= abort" not created with create-interpret/compile"
1.5       anton      49:     cell+ cell+ maxaligned /does-handler + \ to does-code
1.1       anton      50:     swap @ does-code! ;
                     51: 
1.11      anton      52: : (interpretation>1) ( addr R:retaddr -- )
                     53:     latestxt interpret/compile-int swap fix-does-code ;
1.1       anton      54: 
1.3       anton      55: : interpretation> ( compilation. -- orig colon-sys ) \ gforth
1.11      anton      56:     here 4 cells +  POSTPONE literal POSTPONE (interpretation>1) POSTPONE ahead
1.2       anton      57:     dodoes, defstart dead-code off 0 set-locals-size-list ; immediate restrict
1.1       anton      58: 
1.3       anton      59: : <interpretation ( compilation. orig colon-sys -- ) \ gforth
1.1       anton      60:     ?struc POSTPONE exit
                     61:     POSTPONE then ; immediate restrict
                     62: 
1.11      anton      63: : (compilation>1) ( addr R:retaddr -- )
                     64:     latestxt interpret/compile-comp swap fix-does-code ;
1.1       anton      65: 
1.3       anton      66: : compilation> ( compilation. -- orig colon-sys ) \ gforth
1.11      anton      67:     here 4 cells + POSTPONE literal POSTPONE (compilation>1) POSTPONE ahead
1.2       anton      68:     dodoes, defstart dead-code off 0 set-locals-size-list POSTPONE >body ; immediate restrict
1.1       anton      69: 
1.3       anton      70: comp' <interpretation drop
                     71: Alias <compilation ( compilation. orig colon-sys -- ) \ gforth
                     72: immediate restrict
1.1       anton      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>