1: \ defining words for words with non-default and non-immediate compilation semantics
2:
3: \ Copyright (C) 1996,1997,2000,2003 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 /does-handler + \ 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: dodoes, 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: dodoes, 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>