Annotation of gforth/intcomp.fs, revision 1.13
1.1 anton 1: \ defining words for words with non-default and non-immediate compilation semantics
2:
1.13 ! anton 3: \ Copyright (C) 1996,1997,2000,2003,2007 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>