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