1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
\ Doers for ShBoom
\ Copyright (C) 1997,2003,2004,2007 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.
doer? :docon [IF]
: docon: ( -- addr ) \ gforth
\G the code address of a @code{CONSTANT}
['] :docon ;
[THEN]
: docol: ( -- addr ) \ gforth
\G the code address of a colon definition
0 ;
doer? :dovar [IF]
: dovar: ( -- addr ) \ gforth
\G the code address of a @code{CREATE}d word
\ in rom-applications variable might be implemented with constant
\ use really a created word!
['] :dovar ;
[THEN]
doer? :douser [IF]
: douser: ( -- addr ) \ gforth
\G the code address of a @code{USER} variable
['] :douser ;
[THEN]
doer? :dodefer [IF]
: dodefer: ( -- addr ) \ gforth
\G the code address of a @code{defer}ed word
['] :dodefer ;
[THEN]
doer? :dofield [IF]
: dofield: ( -- addr ) \ gforth
\G the code address of a @code{field}
['] :dofield ;
[THEN]
has? prims 0= [IF]
: dodoes: ( -- addr ) \ gforth
\G the code address of a @code{field}
['] :dodoes ;
[THEN]
: check-inliners ( -- code-address true | xt false )
dup @
CASE dovar: SkipInlineMark @ OF drop dovar: true EXIT ENDOF
docon: SkipInlineMark @ OF drop docon: true EXIT ENDOF
douser: SkipInlineMark @ OF drop douser: true EXIT ENDOF
ENDCASE
false ;
: call-destination
\ isolate value
dup @ $07FFFFFF and
\ do sign extention if we need to
dup $04000000 and
IF $F8000000 or THEN
\ and resolve offset
cells + ( dest ) ;
: check-calls ( dest -- code-address true | dest false )
\ if it is a call at the beginning of a definition
\ we have to check whether it is a call to a doer
dup
CASE dodoes: OF true EXIT ENDOF
dodefer: OF true EXIT ENDOF
ENDCASE
false ;
: >code-address ( cfa -- code-address )
dup c@ $F8 and $08 =
IF \ call detected, calculate destination
call-destination
check-calls
ELSE check-inliners
THEN
\ we found nothing, must be a normal colon definition
0= IF drop docol: THEN
;
: doer! ( code-address cfa -- )
here >r dp !
docol, ]comp
colon,
fini, comp[
r> dp ! ;
: code-address! ( code-address cfa -- )
over
IF doer!
ELSE -1 ABORT" Arghh!"
THEN ;
: does-code! ( code-address cfa -- )
dodoes: over doer!
cell+ ! ;
: /does-handler
0 ;
: does-handler! ( does-handler-addr -- )
drop ;
|
