-
Notifications
You must be signed in to change notification settings - Fork 135
/
tclconst.pir
240 lines (183 loc) · 4.49 KB
/
tclconst.pir
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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
.namespace [ "TclConst" ]
.HLL "Tcl", "tcl_group"
# return codes
.const int TCL_OK = 0
.const int TCL_ERROR = 1
.const int TCL_RETURN = 2
.const int TCL_BREAK = 3
.const int TCL_CONTINUE = 4
=head2 __class_init
Define the attributes required for the class.
=cut
.sub __class_init @LOAD
$P0 = getclass "TclString"
$P1 = subclass $P0, "TclConst"
$P0 = new Hash
$P0[ 97] = "\a"
$P0[ 98] = "\x8" # \b
$P0[102] = "\f"
$P0[110] = "\n"
$P0[114] = "\r"
$P0[116] = "\t"
$P0[118] = "\v"
store_global "_Tcl", "backslashes", $P0
$P0 = new Hash
$P0[ 48] = 0 # "0"
$P0[ 49] = 1
$P0[ 50] = 2
$P0[ 51] = 3
$P0[ 52] = 4
$P0[ 53] = 5
$P0[ 54] = 6
$P0[ 55] = 7
$P0[ 56] = 8
$P0[ 57] = 9
$P0[ 65] = 10 # "A"
$P0[ 66] = 11
$P0[ 67] = 12
$P0[ 68] = 13
$P0[ 69] = 14
$P0[ 70] = 15
$P0[ 97] = 10 # "a"
$P0[ 98] = 11
$P0[ 99] = 12
$P0[100] = 13
$P0[101] = 14
$P0[102] = 15
store_global "_Tcl", "hexadecimal", $P0
.end
.sub __clone method
.local pmc obj
$I0 = typeof self
obj = new $I0
obj = self
.return(obj)
.end
.sub __set_string_native method
.param string value
.local int value_length
value_length = length value
.local pmc backslashes, hexadecimal
find_global backslashes, "_Tcl", "backslashes"
find_global hexadecimal, "_Tcl", "hexadecimal"
.local int pos
pos = 0
loop:
pos = index value, "\\", pos
if pos == -1 goto done
$I0 = pos + 1
$I0 = ord value, $I0
if $I0 == 120 goto hex # x
if $I0 == 117 goto unicode # u
if $I0 < 48 goto simple # < 0
if $I0 <= 55 goto octal # 0..7
# > 7
simple:
$I1 = exists backslashes[$I0]
if $I1 goto special
substr value, pos, 1, ""
inc pos
goto loop
=for comment
Octal escapes consist of one, two, or three octal digits
=cut
.local int octal_value
.local int digit
.local int octal_pos
octal:
# at this point, $I0 contains the value of the first digit,
# but pos is still at the backslash.
octal_pos = pos + 1
digit = $I0 - 48 # ascii value of 0.
octal_value = digit
$I0 = octal_pos + 1
if $I0 >= value_length goto octal_only1
$I0 = ord value, $I0
if $I0 < 48 goto octal_only1 # < 0
if $I0 <= 55 goto octal2 # 0..7
# > 7
octal_only1:
$S0 = chr octal_value
substr value, pos, 2, $S0
pos += 2 # skip \ and 1 char.
goto loop
octal2:
# at this point, $I0 contains the value of the second digit,
# but octal_pos is still at the first digit.
inc octal_pos # skip first digit
digit = $I0 - 48 # ascii value of 0.
octal_value *= 8
octal_value += digit
$I0 = octal_pos + 1
if $I0 >= value_length goto octal_only2
$I0 = ord value, $I0
if $I0 < 48 goto octal_only2 # < 0
if $I0 <= 55 goto octal3 # 0..7
octal_only2:
$S0 = chr octal_value
substr value, pos, 3, $S0
pos += 3 # skip \ and 2 characters
goto loop
octal3:
# at this point, $I0 contains the value of the third digit
digit = $I0 - 48 # ascii value of 0.
octal_value *= 8
octal_value += digit
$S0 = chr octal_value
substr value, pos, 4, $S0
pos += 4 # skip \ and 3 characters
goto loop # can't have four digits, stop now.
=for comment
Hexadecimal escapes consist of an C<x>, followed by any number of hexadecimal
digits. However, only the last two are used.
=cut
.local int hex_pos, hex_digit, hex_value
hex:
# at this point, pos is set to the backslash
hex_value = 0
hex_pos = pos + 2 # skip the backslash and the x
hex_loop:
if hex_pos >= value_length goto hex_done
$I0 = ord value, hex_pos
$I1 = exists hexadecimal[$I0]
unless $I1 goto hex_done
hex_digit = hexadecimal[$I0]
band hex_value, 15 # high byte discarded
hex_value *= 16 # low byte promoted
hex_value += hex_digit # new low byte added.
inc hex_pos
goto hex_loop
hex_done:
$I0 = hex_pos - pos
if $I0 == 2 goto hex_not_really
$S0 = chr hex_value
substr value, pos, $I0, $S0
pos = hex_pos
goto loop
hex_not_really:
# This was a \x escape that had no hex value..
substr value, pos, 2, "x"
pos = hex_pos
goto loop
=for comment
Unicode escapes consist of an C<u>, followed by one to four hexadecimal digits.
=cut
unicode:
inc pos
goto loop
special:
$S0 = backslashes[$I0]
substr value, pos, 2, $S0
inc pos
goto loop
done:
$I0 = classoffset self, "TclConst"
$P0 = getattribute self, $I0
$P0 = value
.end
=head2 interpret
Get the value of the const.
=cut
.sub interpret method
.return(TCL_OK, self)
.end