|
996
|
1 package Language::INTERCAL::ByteCode;
|
|
|
2
|
|
|
3 # Definitions of bytecode symbols etc
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13
|
|
|
14 use strict;
|
|
|
15 use vars qw($VERSION $PERVERSION);
|
|
|
16 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/ByteCode.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
17
|
|
|
18 use Carp;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
21 use Language::INTERCAL::Numbers '1.-94.-2';
|
|
|
22 use Language::INTERCAL::DoubleOhSeven '1.-94.-2';
|
|
|
23 use Language::INTERCAL::SharkFin '1.-94.-2';
|
|
|
24 use Language::INTERCAL::Arrays '1.-94.-2';
|
|
|
25 use Language::INTERCAL::Whirlpool '1.-94.-2';
|
|
|
26 use Language::INTERCAL::CrawlingHorror '1.-94.-2';
|
|
|
27 use Language::INTERCAL::GenericIO '1.-94.-2',
|
|
|
28 qw($stdwrite $stdread $stdsplat $devnull);
|
|
|
29
|
|
|
30 use constant BYTE_SIZE => 8; # number of bits per byte (must be == 8)
|
|
|
31 use constant NUM_OPCODES => 0x80; # number of virtual opcodes
|
|
|
32 use constant OPCODE_RANGE => 1 << BYTE_SIZE;
|
|
|
33 use constant BC_MASK => OPCODE_RANGE - 1;
|
|
|
34 use constant BIGNUM_SHIFT => BYTE_SIZE - 1;
|
|
|
35 use constant BIGNUM_RANGE => 1 << BIGNUM_SHIFT;
|
|
|
36 use constant BIGNUM_MASK => (BIGNUM_RANGE - 1) << 1;
|
|
|
37 use constant BYTE_SHIFT => OPCODE_RANGE - NUM_OPCODES;
|
|
|
38
|
|
|
39 use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
|
|
|
40 @EXPORT_OK = qw(
|
|
|
41 bytecode bytedecode bc_list BC BCget bc_bytype bc_match BC_MASK
|
|
|
42 BC_constants is_constant is_multibyte bc_xtype bc_skip bc_forall
|
|
|
43 BC_ABG BC_ABL BC_AWC BC_BAW BC_BBT BC_BSW BC_BUG BC_BUT BC_BWC BC_CFG
|
|
|
44 BC_CFL BC_CHO BC_CON BC_CRE BC_CSE BC_CWB BC_DES BC_DOS BC_DSX BC_EBC
|
|
|
45 BC_ECB BC_ENR BC_ENS BC_FIN BC_FLA BC_FOR BC_FRE BC_FRZ BC_GRA BC_GUP
|
|
|
46 BC_HSN BC_HYB BC_IGN BC_INT BC_LAB BC_LEA BC_MKG BC_MSP BC_MUL BC_NOT
|
|
|
47 BC_NUM BC_NXG BC_NXL BC_NXT BC_OPT BC_OSN BC_OVM BC_OVR BC_OWN BC_QUA
|
|
|
48 BC_REG BC_REL BC_REM BC_RES BC_RET BC_RIN BC_ROM BC_ROR BC_ROU BC_RSE
|
|
|
49 BC_SEL BC_SHF BC_SMU BC_SPL BC_SPO BC_STA BC_STE BC_STO BC_STR BC_STS
|
|
|
50 BC_STU BC_SUB BC_SWA BC_SWB BC_SYS BC_TAI BC_TSP BC_TYP BC_UDV BC_UNE
|
|
|
51 BC_UNS BC_USG BC_WHP BC_WIN
|
|
|
52 reg_list reg_name reg_create reg_codetype reg_decode
|
|
|
53 reg_code
|
|
|
54 );
|
|
|
55
|
|
|
56 %EXPORT_TAGS = (
|
|
|
57 BC => [qw(
|
|
|
58 BC BCget BC_MASK bytecode bytedecode
|
|
|
59 BC_ABG BC_ABL BC_AWC BC_BAW BC_BBT BC_BSW BC_BUG BC_BUT BC_BWC
|
|
|
60 BC_CFG BC_CFL BC_CHO BC_CON BC_CRE BC_CSE BC_CWB BC_DES BC_DOS
|
|
|
61 BC_DSX BC_EBC BC_ECB BC_ENR BC_ENS BC_FIN BC_FLA BC_FOR BC_FRE
|
|
|
62 BC_FRZ BC_GRA BC_GUP BC_HSN BC_HYB BC_IGN BC_INT BC_LAB BC_LEA
|
|
|
63 BC_MKG BC_MSP BC_MUL BC_NOT BC_NUM BC_NXG BC_NXL BC_NXT BC_OPT
|
|
|
64 BC_OSN BC_OVM BC_OVR BC_OWN BC_QUA BC_REG BC_REL BC_REM BC_RES
|
|
|
65 BC_RET BC_RIN BC_ROM BC_ROR BC_ROU BC_RSE BC_SEL BC_SHF BC_SMU
|
|
|
66 BC_SPL BC_SPO BC_STA BC_STE BC_STO BC_STR BC_STS BC_STU BC_SUB
|
|
|
67 BC_SWA BC_SWB BC_SYS BC_TAI BC_TSP BC_TYP BC_UDV BC_UNE BC_UNS
|
|
|
68 BC_USG BC_WHP BC_WIN
|
|
|
69 )],
|
|
|
70 );
|
|
|
71
|
|
|
72 my %bytecodes = (
|
|
|
73 ABG => ['ABstain from Gerund', 'S', '15', 'C(O)', 0, 0],
|
|
|
74 ABL => ['ABstain from Label', 'S', '14', 'E', 0, 0],
|
|
|
75 AWC => ['unary Add Without Carry', 'E', '102', 'E', 0, 1],
|
|
|
76 BAW => ['binary Add Without Carry', 'E', '103', 'EE', 0, 1],
|
|
|
77 BBT => ['binary BUT', 'E', '99', '#EE', 0, 1],
|
|
|
78 BSW => ['binary Subtract Without Borrow', 'E', '101', 'EE', 0, 1],
|
|
|
79 BUG => ['compiler BUG', 'S', '38', '#', 0, 0],
|
|
|
80 BUT => ['unary BUT', 'E', '98', '#E', 0, 1],
|
|
|
81 BWC => ['loop: Body While Condition', 'S', '26', 'SS', 0, 0],
|
|
|
82 CFG => ['Come From Gerund', 'S', '23', 'C(O)', 0, 0],
|
|
|
83 CFL => ['Come From Label', 'S', '22', 'E', 0, 0],
|
|
|
84 CHO => ['Crawling HOrror', 'R', '71', 'E', 0, 1],
|
|
|
85 CON => ['CONvert', 'S', '36', 'OO', 0, 0],
|
|
|
86 CRE => ['CREate', 'S', '2', 'EVC(<)C(>)', 0, 0],
|
|
|
87 CSE => ['CaSE', 'S', '47', 'EC(ES)', 0, 0],
|
|
|
88 CWB => ['loop: Condition While Body', 'S', '25', 'SS', 0, 0],
|
|
|
89 DES => ['DEStroy', 'S', '3', 'EVC(<)', 0, 0],
|
|
|
90 DOS => ['Double-Oh-Seven', 'R', '69', 'E', 0, 1],
|
|
|
91 DSX => ['Double-oh-Seven eXecution', 'S', '5', 'ES', 0, 0],
|
|
|
92 EBC => ['Event: Body while Condition', 'S', '40', 'ES', 0, 0],
|
|
|
93 ECB => ['Event: Condition while Body', 'S', '41', 'ES', 0, 0],
|
|
|
94 ENR => ['ENRol', 'S', '30', 'C(E)R', 0, 0],
|
|
|
95 ENS => ['ENSlave', 'S', '27', 'RR', 0, 0],
|
|
|
96 FIN => ['FINish lecture', 'S', '32', '', 0, 0],
|
|
|
97 FLA => ['set object FLAg', 'S', '63', '', 0, 0],
|
|
|
98 FOR => ['FORget', 'S', '9', 'E', 0, 0],
|
|
|
99 FRE => ['FREe', 'S', '28', 'RR', 0, 0],
|
|
|
100 FRZ => ['FReeZe', 'S', '42', '', 0, 0],
|
|
|
101 GRA => ['GRAduate', 'S', '33', 'R', 0, 0],
|
|
|
102 GUP => ['Give UP', 'S', '18', '', 0, 0],
|
|
|
103 HSN => ['Half Spot Number', '#', '126', 'N', 1, 1],
|
|
|
104 HYB => ['HYBrid', 'R', '67', 'E', 0, 1],
|
|
|
105 IGN => ['IGNore', 'S', '12', 'C(R)', 0, 0],
|
|
|
106 INT => ['INTerleave', 'E', '105', 'EE', 0, 1],
|
|
|
107 LAB => ['LABel', 'S', '21', 'ES', 0, 0],
|
|
|
108 LEA => ['LEArns', 'S', '31', 'ER', 0, 0],
|
|
|
109 MKG => ['MaKe Gerund', 'S', '61', 'EE', 0, 0],
|
|
|
110 MSP => ['Make SPlat', 'S', '4', 'EC(V)', 0, 0],
|
|
|
111 MUL => ['MULtiple number', 'E', '96', 'C(E)', 0, 0],
|
|
|
112 NOT => ['NOT', 'S', '6', 'S', 0, 0],
|
|
|
113 NUM => ['NUMber', 'E', '106', 'R', 0, 1],
|
|
|
114 NXG => ['Next From Gerund', 'S', '35', 'C(O)', 0, 0],
|
|
|
115 NXL => ['Next From Label', 'S', '34', 'E', 0, 0],
|
|
|
116 NXT => ['NeXT', 'S', '7', 'E', 0, 0],
|
|
|
117 OPT => ['OPTimise', 'S', '39', 'C([)C(])', 0, 0],
|
|
|
118 OSN => ['One Spot Number', '#', '127', 'NN', 1, 1],
|
|
|
119 OVM => ['OVerload Many', 'E', '107', 'EE', 0, 1],
|
|
|
120 OVR => ['OVerload Register', 'R', '80', 'ER', 0, 1],
|
|
|
121 OWN => ['OWNer', 'R', '82', 'ER', 0, 1],
|
|
|
122 QUA => ['QUAntum statement', 'S', '24', 'S', 0, 0],
|
|
|
123 REG => ['REinstate from Gerund', 'S', '17', 'C(O)', 0, 0],
|
|
|
124 REL => ['REinstate from Label', 'S', '16', 'E', 0, 0],
|
|
|
125 REM => ['REMember', 'S', '13', 'C(R)', 0, 0],
|
|
|
126 RES => ['RESume', 'S', '8', 'E', 0, 0],
|
|
|
127 RET => ['RETrieve', 'S', '11', 'C(R)', 0, 0],
|
|
|
128 RIN => ['Reverse INterleave', 'E', '112', 'EE', 0, 1],
|
|
|
129 ROM => ['Remove Overload Many', 'E', '108', 'E', 0, 1],
|
|
|
130 ROR => ['Remove Overload Register', 'R', '81', 'R', 0, 1],
|
|
|
131 ROU => ['Read OUt', 'S', '20', 'C(E)', 0, 0],
|
|
|
132 RSE => ['Reverse SElect', 'E', '111', 'EE', 0, 1],
|
|
|
133 SEL => ['SELect', 'E', '104', 'EE', 0, 1],
|
|
|
134 SHF => ['SHark Fin', 'R', '70', 'E', 0, 1],
|
|
|
135 SMU => ['SMUggle', 'S', '46', 'C(E)C(E)C(R)', 0, 0],
|
|
|
136 SPL => ['SPLat', 'E', '109', '', 0, 1],
|
|
|
137 SPO => ['SPOt', 'R', '64', 'E', 0, 1],
|
|
|
138 STA => ['STAsh', 'S', '10', 'C(R)', 0, 0],
|
|
|
139 STE => ['STEal', 'S', '45', 'C(E)C(E)C(R)', 0, 0],
|
|
|
140 STO => ['STOre', 'S', '1', 'EA', 0, 0],
|
|
|
141 STR => ['STRing', 'E', '97', 'C(N)', 0, 0],
|
|
|
142 STS => ['STArt of STAtement', 'S', '0', '###C(#)S', 0, 0],
|
|
|
143 STU => ['STUdy', 'S', '29', 'EER', 0, 0],
|
|
|
144 SUB => ['SUBscript', 'R', '83', 'ER', 0, 1],
|
|
|
145 SWA => ['SWAp', 'S', '37', 'OO', 0, 0],
|
|
|
146 SWB => ['unary Subtract Without Borrow', 'E', '100', 'E', 0, 1],
|
|
|
147 SYS => ['SYStem call', 'S', '43', 'EC(S)', 0, 0],
|
|
|
148 TAI => ['TAIl', 'R', '66', 'E', 0, 1],
|
|
|
149 TSP => ['Two SPot', 'R', '65', 'E', 0, 1],
|
|
|
150 TYP => ['TYPe', 'R', '79', 'RE', 0, 1],
|
|
|
151 UDV => ['Unary DiVide', 'E', '110', 'E', 0, 1],
|
|
|
152 UNE => ['UNdocumented Expression', 'E', '113', 'EEC(E)', 0, 0],
|
|
|
153 UNS => ['UNdocumented Statement', 'S', '44', 'EEC(E)', 0, 0],
|
|
|
154 USG => ['USe Gerund', 'S', '62', 'E', 0, 0],
|
|
|
155 WHP => ['WHirlPool', 'R', '68', 'E', 0, 1],
|
|
|
156 WIN => ['Write IN', 'S', '19', 'C(A)', 0, 0],
|
|
|
157 );
|
|
|
158
|
|
|
159 my %bytedecode = (
|
|
|
160 0 => 'STS',
|
|
|
161 1 => 'STO',
|
|
|
162 2 => 'CRE',
|
|
|
163 3 => 'DES',
|
|
|
164 4 => 'MSP',
|
|
|
165 5 => 'DSX',
|
|
|
166 6 => 'NOT',
|
|
|
167 7 => 'NXT',
|
|
|
168 8 => 'RES',
|
|
|
169 9 => 'FOR',
|
|
|
170 10 => 'STA',
|
|
|
171 11 => 'RET',
|
|
|
172 12 => 'IGN',
|
|
|
173 13 => 'REM',
|
|
|
174 14 => 'ABL',
|
|
|
175 15 => 'ABG',
|
|
|
176 16 => 'REL',
|
|
|
177 17 => 'REG',
|
|
|
178 18 => 'GUP',
|
|
|
179 19 => 'WIN',
|
|
|
180 20 => 'ROU',
|
|
|
181 21 => 'LAB',
|
|
|
182 22 => 'CFL',
|
|
|
183 23 => 'CFG',
|
|
|
184 24 => 'QUA',
|
|
|
185 25 => 'CWB',
|
|
|
186 26 => 'BWC',
|
|
|
187 27 => 'ENS',
|
|
|
188 28 => 'FRE',
|
|
|
189 29 => 'STU',
|
|
|
190 30 => 'ENR',
|
|
|
191 31 => 'LEA',
|
|
|
192 32 => 'FIN',
|
|
|
193 33 => 'GRA',
|
|
|
194 34 => 'NXL',
|
|
|
195 35 => 'NXG',
|
|
|
196 36 => 'CON',
|
|
|
197 37 => 'SWA',
|
|
|
198 38 => 'BUG',
|
|
|
199 39 => 'OPT',
|
|
|
200 40 => 'EBC',
|
|
|
201 41 => 'ECB',
|
|
|
202 42 => 'FRZ',
|
|
|
203 43 => 'SYS',
|
|
|
204 44 => 'UNS',
|
|
|
205 45 => 'STE',
|
|
|
206 46 => 'SMU',
|
|
|
207 47 => 'CSE',
|
|
|
208 61 => 'MKG',
|
|
|
209 62 => 'USG',
|
|
|
210 63 => 'FLA',
|
|
|
211 64 => 'SPO',
|
|
|
212 65 => 'TSP',
|
|
|
213 66 => 'TAI',
|
|
|
214 67 => 'HYB',
|
|
|
215 68 => 'WHP',
|
|
|
216 69 => 'DOS',
|
|
|
217 70 => 'SHF',
|
|
|
218 71 => 'CHO',
|
|
|
219 79 => 'TYP',
|
|
|
220 80 => 'OVR',
|
|
|
221 81 => 'ROR',
|
|
|
222 82 => 'OWN',
|
|
|
223 83 => 'SUB',
|
|
|
224 96 => 'MUL',
|
|
|
225 97 => 'STR',
|
|
|
226 98 => 'BUT',
|
|
|
227 99 => 'BBT',
|
|
|
228 100 => 'SWB',
|
|
|
229 101 => 'BSW',
|
|
|
230 102 => 'AWC',
|
|
|
231 103 => 'BAW',
|
|
|
232 104 => 'SEL',
|
|
|
233 105 => 'INT',
|
|
|
234 106 => 'NUM',
|
|
|
235 107 => 'OVM',
|
|
|
236 108 => 'ROM',
|
|
|
237 109 => 'SPL',
|
|
|
238 110 => 'UDV',
|
|
|
239 111 => 'RSE',
|
|
|
240 112 => 'RIN',
|
|
|
241 113 => 'UNE',
|
|
|
242 126 => 'HSN',
|
|
|
243 127 => 'OSN',
|
|
|
244 );
|
|
|
245
|
|
|
246 my @bc_list = qw(
|
|
|
247 ABG ABL AWC BAW BBT BSW BUG BUT BWC CFG CFL CHO CON CRE CSE CWB DES DOS
|
|
|
248 DSX EBC ECB ENR ENS FIN FLA FOR FRE FRZ GRA GUP HSN HYB IGN INT LAB LEA
|
|
|
249 MKG MSP MUL NOT NUM NXG NXL NXT OPT OSN OVM OVR OWN QUA REG REL REM RES
|
|
|
250 RET RIN ROM ROR ROU RSE SEL SHF SMU SPL SPO STA STE STO STR STS STU SUB
|
|
|
251 SWA SWB SYS TAI TSP TYP UDV UNE UNS USG WHP WIN
|
|
|
252 );
|
|
|
253
|
|
|
254 sub BC_ABG () { 15; }
|
|
|
255 sub BC_ABL () { 14; }
|
|
|
256 sub BC_AWC () { 102; }
|
|
|
257 sub BC_BAW () { 103; }
|
|
|
258 sub BC_BBT () { 99; }
|
|
|
259 sub BC_BSW () { 101; }
|
|
|
260 sub BC_BUG () { 38; }
|
|
|
261 sub BC_BUT () { 98; }
|
|
|
262 sub BC_BWC () { 26; }
|
|
|
263 sub BC_CFG () { 23; }
|
|
|
264 sub BC_CFL () { 22; }
|
|
|
265 sub BC_CHO () { 71; }
|
|
|
266 sub BC_CON () { 36; }
|
|
|
267 sub BC_CRE () { 2; }
|
|
|
268 sub BC_CSE () { 47; }
|
|
|
269 sub BC_CWB () { 25; }
|
|
|
270 sub BC_DES () { 3; }
|
|
|
271 sub BC_DOS () { 69; }
|
|
|
272 sub BC_DSX () { 5; }
|
|
|
273 sub BC_EBC () { 40; }
|
|
|
274 sub BC_ECB () { 41; }
|
|
|
275 sub BC_ENR () { 30; }
|
|
|
276 sub BC_ENS () { 27; }
|
|
|
277 sub BC_FIN () { 32; }
|
|
|
278 sub BC_FLA () { 63; }
|
|
|
279 sub BC_FOR () { 9; }
|
|
|
280 sub BC_FRE () { 28; }
|
|
|
281 sub BC_FRZ () { 42; }
|
|
|
282 sub BC_GRA () { 33; }
|
|
|
283 sub BC_GUP () { 18; }
|
|
|
284 sub BC_HSN () { 126; }
|
|
|
285 sub BC_HYB () { 67; }
|
|
|
286 sub BC_IGN () { 12; }
|
|
|
287 sub BC_INT () { 105; }
|
|
|
288 sub BC_LAB () { 21; }
|
|
|
289 sub BC_LEA () { 31; }
|
|
|
290 sub BC_MKG () { 61; }
|
|
|
291 sub BC_MSP () { 4; }
|
|
|
292 sub BC_MUL () { 96; }
|
|
|
293 sub BC_NOT () { 6; }
|
|
|
294 sub BC_NUM () { 106; }
|
|
|
295 sub BC_NXG () { 35; }
|
|
|
296 sub BC_NXL () { 34; }
|
|
|
297 sub BC_NXT () { 7; }
|
|
|
298 sub BC_OPT () { 39; }
|
|
|
299 sub BC_OSN () { 127; }
|
|
|
300 sub BC_OVM () { 107; }
|
|
|
301 sub BC_OVR () { 80; }
|
|
|
302 sub BC_OWN () { 82; }
|
|
|
303 sub BC_QUA () { 24; }
|
|
|
304 sub BC_REG () { 17; }
|
|
|
305 sub BC_REL () { 16; }
|
|
|
306 sub BC_REM () { 13; }
|
|
|
307 sub BC_RES () { 8; }
|
|
|
308 sub BC_RET () { 11; }
|
|
|
309 sub BC_RIN () { 112; }
|
|
|
310 sub BC_ROM () { 108; }
|
|
|
311 sub BC_ROR () { 81; }
|
|
|
312 sub BC_ROU () { 20; }
|
|
|
313 sub BC_RSE () { 111; }
|
|
|
314 sub BC_SEL () { 104; }
|
|
|
315 sub BC_SHF () { 70; }
|
|
|
316 sub BC_SMU () { 46; }
|
|
|
317 sub BC_SPL () { 109; }
|
|
|
318 sub BC_SPO () { 64; }
|
|
|
319 sub BC_STA () { 10; }
|
|
|
320 sub BC_STE () { 45; }
|
|
|
321 sub BC_STO () { 1; }
|
|
|
322 sub BC_STR () { 97; }
|
|
|
323 sub BC_STS () { 0; }
|
|
|
324 sub BC_STU () { 29; }
|
|
|
325 sub BC_SUB () { 83; }
|
|
|
326 sub BC_SWA () { 37; }
|
|
|
327 sub BC_SWB () { 100; }
|
|
|
328 sub BC_SYS () { 43; }
|
|
|
329 sub BC_TAI () { 66; }
|
|
|
330 sub BC_TSP () { 65; }
|
|
|
331 sub BC_TYP () { 79; }
|
|
|
332 sub BC_UDV () { 110; }
|
|
|
333 sub BC_UNE () { 113; }
|
|
|
334 sub BC_UNS () { 44; }
|
|
|
335 sub BC_USG () { 62; }
|
|
|
336 sub BC_WHP () { 68; }
|
|
|
337 sub BC_WIN () { 19; }
|
|
|
338
|
|
|
339 my @reg_list = qw(
|
|
|
340 AR AV AW BA CF CR CW DM ES EV FS IO IS JS OR ORFH OS OSFH OWFH PS RM RT
|
|
|
341 SNFH SP SS TH TM TRFH WT
|
|
|
342 );
|
|
|
343
|
|
|
344 my %reg_list = (
|
|
|
345 AR => ['spot', 0, BC_DOS, '%', 10],
|
|
|
346 AW => ['spot', 0, BC_DOS, '%', 11],
|
|
|
347 BA => ['base', 2, BC_DOS, '%', 4],
|
|
|
348 CF => ['comefrom', 0, BC_DOS, '%', 5],
|
|
|
349 CR => ['charset', 0, BC_DOS, '%', 6],
|
|
|
350 CW => ['charset', 0, BC_DOS, '%', 7],
|
|
|
351 DM => ['zeroone', 0, BC_DOS, '%', 18],
|
|
|
352 ES => ['symbol', 'CALC_EXPR', BC_DOS, '%', 16],
|
|
|
353 FS => ['symbol', 'CALC_FULL', BC_DOS, '%', 15],
|
|
|
354 IO => ['iotype', 0, BC_DOS, '%', 3],
|
|
|
355 IS => ['symbol', 0, BC_DOS, '%', 17],
|
|
|
356 JS => ['symbol', 'END_JUNK', BC_DOS, '%', 12],
|
|
|
357 OS => ['spot', 0, BC_DOS, '%', 8],
|
|
|
358 PS => ['symbol', 'PROGRAM', BC_DOS, '%', 14],
|
|
|
359 RM => ['zeroone', 0, BC_DOS, '%', 21],
|
|
|
360 RT => ['roman', 0, BC_DOS, '%', 2],
|
|
|
361 SP => ['splat', 1000, BC_DOS, '%', 19],
|
|
|
362 SS => ['symbol', 'SPACE', BC_DOS, '%', 13],
|
|
|
363 TH => ['zeroone', 0, BC_DOS, '%', 20],
|
|
|
364 TM => ['zeroone', 0, BC_DOS, '%', 9],
|
|
|
365 WT => ['zeroone', 0, BC_DOS, '%', 1],
|
|
|
366 AV => ['vector', [], BC_SHF, '^', 1],
|
|
|
367 EV => ['vector', [], BC_SHF, '^', 2],
|
|
|
368 OR => ['whirlpool', undef, BC_WHP, '@', 0],
|
|
|
369 ORFH => ['whirlpool', $stdread, BC_WHP, '@', 2],
|
|
|
370 OSFH => ['whirlpool', $stdsplat, BC_WHP, '@', 3],
|
|
|
371 OWFH => ['whirlpool', $stdwrite, BC_WHP, '@', 1],
|
|
|
372 SNFH => ['whirlpool', $devnull, BC_WHP, '@', 7],
|
|
|
373 TRFH => ['whirlpool', $stdsplat, BC_WHP, '@', 9],
|
|
|
374 );
|
|
|
375
|
|
|
376 my %reg_names = (
|
|
|
377 '%1' => 'WT',
|
|
|
378 '%2' => 'RT',
|
|
|
379 '%3' => 'IO',
|
|
|
380 '%4' => 'BA',
|
|
|
381 '%5' => 'CF',
|
|
|
382 '%6' => 'CR',
|
|
|
383 '%7' => 'CW',
|
|
|
384 '%8' => 'OS',
|
|
|
385 '%9' => 'TM',
|
|
|
386 '%10' => 'AR',
|
|
|
387 '%11' => 'AW',
|
|
|
388 '%12' => 'JS',
|
|
|
389 '%13' => 'SS',
|
|
|
390 '%14' => 'PS',
|
|
|
391 '%15' => 'FS',
|
|
|
392 '%16' => 'ES',
|
|
|
393 '%17' => 'IS',
|
|
|
394 '%18' => 'DM',
|
|
|
395 '%19' => 'SP',
|
|
|
396 '%20' => 'TH',
|
|
|
397 '%21' => 'RM',
|
|
|
398 '^1' => 'AV',
|
|
|
399 '^2' => 'EV',
|
|
|
400 '@0' => 'OR',
|
|
|
401 '@1' => 'OWFH',
|
|
|
402 '@2' => 'ORFH',
|
|
|
403 '@3' => 'OSFH',
|
|
|
404 '@7' => 'SNFH',
|
|
|
405 '@9' => 'TRFH',
|
|
|
406 );
|
|
|
407
|
|
|
408 my %mulmap = map { ( $_ => 1 ) } BC_MUL, BC_STR;
|
|
|
409
|
|
|
410 sub bc_list () {
|
|
|
411 @bc_list;
|
|
|
412 }
|
|
|
413
|
|
|
414 sub BC {
|
|
|
415 @_ == 1 || croak "Usage: BC(value)";
|
|
|
416 my ($val) = @_;
|
|
|
417 croak "Invalid undefined value" unless defined $val;
|
|
|
418 my $orig = $val;
|
|
|
419 $val < BYTE_SHIFT
|
|
|
420 and return ($val + NUM_OPCODES);
|
|
|
421 $val < OPCODE_RANGE
|
|
|
422 and return (BC_HSN, $val);
|
|
|
423 my $div = int($val / OPCODE_RANGE);
|
|
|
424 $div < OPCODE_RANGE
|
|
|
425 and return (BC_OSN, $div, $val % OPCODE_RANGE);
|
|
|
426 croak "Invalid value $orig: does not fit in one spot";
|
|
|
427 }
|
|
|
428
|
|
|
429 sub bytecode ($) {
|
|
|
430 my ($name) = @_;
|
|
|
431 $name =~ /^\d+$/ && $name < BYTE_SHIFT ? ($name + NUM_OPCODES)
|
|
|
432 : $bytecodes{$name}[2];
|
|
|
433 }
|
|
|
434
|
|
|
435 sub bytedecode ($) {
|
|
|
436 my ($b) = @_;
|
|
|
437 if ($b >= NUM_OPCODES) {
|
|
|
438 my $n = $b - NUM_OPCODES;
|
|
|
439 return () if $n >= BYTE_SHIFT;
|
|
|
440 return "#$n" unless wantarray;
|
|
|
441 return ("#$n", 'Constant', '#', $b, '', 1, 1);
|
|
|
442 } else {
|
|
|
443 return () unless exists $bytedecode{$b};
|
|
|
444 return $bytedecode{$b} unless wantarray;
|
|
|
445 return ($bytedecode{$b}, @{$bytecodes{$bytedecode{$b}}});
|
|
|
446 }
|
|
|
447 }
|
|
|
448
|
|
|
449 sub BCget {
|
|
|
450 @_ == 3 or croak "Usage: BCget(CODE, \\POSITION, END)";
|
|
|
451 my ($code, $cp, $ep) = @_;
|
|
|
452 $$cp >= $ep and faint(SP_INVALID, "end of code", "BCget");
|
|
|
453 my $byte = ord(substr($code, $$cp, 1));
|
|
|
454 $$cp++;
|
|
|
455 if ($byte >= NUM_OPCODES) {
|
|
|
456 return $byte - NUM_OPCODES;
|
|
|
457 }
|
|
|
458 if ($byte == BC_HSN) {
|
|
|
459 $$cp >= $ep and faint(SP_INVALID, "end of code", "BCget/HSN");
|
|
|
460 return ord(substr($code, $$cp++, 1));
|
|
|
461 }
|
|
|
462 if ($byte == BC_OSN) {
|
|
|
463 $$cp + 1 >= $ep and faint(SP_INVALID, "end of code", "BCget/OSN");
|
|
|
464 my $nx = unpack('n', substr($code, $$cp, 2));
|
|
|
465 $$cp += 2;
|
|
|
466 return $nx;
|
|
|
467 }
|
|
|
468 faint(SP_INVALID, sprintf("0x%02x", $byte), "BCget")
|
|
|
469 }
|
|
|
470
|
|
|
471 sub BC_constants () {
|
|
|
472 (NUM_OPCODES..BC_MASK);
|
|
|
473 }
|
|
|
474
|
|
|
475 sub is_constant ($) {
|
|
|
476 my ($byte) = @_;
|
|
|
477 return 1 if $byte >= NUM_OPCODES ||
|
|
|
478 $byte == BC_HSN ||
|
|
|
479 $byte == BC_OSN;
|
|
|
480 return 0;
|
|
|
481 }
|
|
|
482
|
|
|
483 sub is_multibyte ($) {
|
|
|
484 my ($byte) = @_;
|
|
|
485 return 1 if $byte == BC_HSN;
|
|
|
486 return 2 if $byte == BC_OSN;
|
|
|
487 0;
|
|
|
488 }
|
|
|
489
|
|
|
490 sub bc_bytype {
|
|
|
491 @_ or croak "Usage: bc_bytype(TYPES)";
|
|
|
492 my %types = ();
|
|
|
493 for my $type (@_) {
|
|
|
494 if ($type eq 'R' || $type eq 'S') {
|
|
|
495 $types{$type} = 0;
|
|
|
496 next;
|
|
|
497 }
|
|
|
498 if ($type =~ /^[CEP<>L\[\]]$/) {
|
|
|
499 $types{E} = $types{R} = $types{'#'} = 0;
|
|
|
500 next;
|
|
|
501 }
|
|
|
502 if ($type eq 'V') {
|
|
|
503 $types{R} = $types{V} = 0;
|
|
|
504 next;
|
|
|
505 }
|
|
|
506 if ($type eq 'O') {
|
|
|
507 $types{S} = 0;
|
|
|
508 next;
|
|
|
509 }
|
|
|
510 }
|
|
|
511 my %values = exists $types{V} ? %mulmap : ();
|
|
|
512 map {
|
|
|
513 my ($desc, $type, $value, $args, $function) = @{$bytecodes{$_}};
|
|
|
514 if (exists $types{$type} || exists $values{$value}) {
|
|
|
515 $value;
|
|
|
516 } else {
|
|
|
517 ();
|
|
|
518 }
|
|
|
519 } keys %bytecodes;
|
|
|
520 }
|
|
|
521
|
|
|
522 sub bc_match {
|
|
|
523 @_ >= 2 && @_ <= 4
|
|
|
524 or croak "Usage: bc_match(PATTERN, CODE [,START [,END]])";
|
|
|
525 my ($pattern, $code, $start, $end) = @_;
|
|
|
526 $start ||= 0;
|
|
|
527 $end = length($code) if not defined $end;
|
|
|
528 _match($pattern, $code, $start, $end, undef);
|
|
|
529 }
|
|
|
530
|
|
|
531 sub bc_skip {
|
|
|
532 @_ >= 1 && @_ <= 3
|
|
|
533 or croak "Usage: bc_skip(CODE [,START [,END]])";
|
|
|
534 my ($code, $start, $end) = @_;
|
|
|
535 $start ||= 0;
|
|
|
536 $end = length($code) if not defined $end;
|
|
|
537 return undef if $start >= $end || $start < 0;
|
|
|
538 my $byte = ord(substr($code, $start, 1));
|
|
|
539 return 1 if $byte >= NUM_OPCODES;
|
|
|
540 return undef if ! exists $bytedecode{$byte};
|
|
|
541 my $name = $bytedecode{$byte};
|
|
|
542 my $pattern = $bytecodes{$name}[1];
|
|
|
543 _match($pattern, $code, $start, $end, undef);
|
|
|
544 }
|
|
|
545
|
|
|
546 sub bc_forall {
|
|
|
547 @_ == 5
|
|
|
548 or croak "Usage: bc_forall(PATTERN, CODE, START, END, CLOSURE)";
|
|
|
549 my ($pattern, $code, $start, $end, $closure) = @_;
|
|
|
550 $start ||= 0;
|
|
|
551 $end = length($code) if not defined $end;
|
|
|
552 return undef if $start >= $end || $start < 0;
|
|
|
553 my $np = '';
|
|
|
554 while ($pattern =~ s/^(.*?)C\(/(/) {
|
|
|
555 my $a = $1;
|
|
|
556 $a =~ s/(.)/$1\x01/g;
|
|
|
557 $np .= $a . 'C';
|
|
|
558 $np .= '(' . _args('forall', \$pattern) . ')';
|
|
|
559 $np .= "\01";
|
|
|
560 }
|
|
|
561 $pattern =~ s/(.)/$1\x01/g;
|
|
|
562 $pattern = "\x01" if $pattern eq '';
|
|
|
563 $np .= $pattern;
|
|
|
564 _match($np, $code, $start, $end, $closure);
|
|
|
565 }
|
|
|
566
|
|
|
567 sub bc_xtype {
|
|
|
568 @_ == 1 or croak "Usage: bc_xtype(\\PATTERN)";
|
|
|
569 my ($pattern) = @_;
|
|
|
570 _args('xtype', $pattern);
|
|
|
571 }
|
|
|
572
|
|
|
573 my %typemap = (
|
|
|
574 'S' => { 'S' => 0 },
|
|
|
575 'O' => { 'S' => 0 },
|
|
|
576 'E' => { 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
577 'A' => { 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
578 'R' => { 'R' => 0 },
|
|
|
579 'V' => { 'R' => 0, 'V' => 0 },
|
|
|
580 '#' => { '#' => 0 },
|
|
|
581 'C' => { '#' => 0 },
|
|
|
582 'Z' => { 'S' => 0, 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
583 '*' => { 'S' => 0, 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
584 );
|
|
|
585
|
|
|
586 sub _args {
|
|
|
587 my ($name, $pattern) = @_;
|
|
|
588 faint(SP_BCMATCH, $name, 'Missing (') if $$pattern !~ s/^\(//;
|
|
|
589 my $count = 1;
|
|
|
590 my $result = '';
|
|
|
591 while ($count > 0) {
|
|
|
592 $$pattern =~ s/^([^\(\)]*)([\(\)])//
|
|
|
593 or faint(SP_BCMATCH, $name, 'Missing )');
|
|
|
594 $count++ if $2 eq '(';
|
|
|
595 $count-- if $2 eq ')';
|
|
|
596 $result .= $1 . ($count ? $2 : '');
|
|
|
597 }
|
|
|
598 $result;
|
|
|
599 }
|
|
|
600
|
|
|
601 sub _match {
|
|
|
602 my ($pattern, $code, $sc, $ep, $closure) = @_;
|
|
|
603 my $osc = $sc;
|
|
|
604 MATCH: while ($pattern ne '') {
|
|
|
605 my $e = substr($pattern, 0, 1, '');
|
|
|
606 if ($e eq "\x00") {
|
|
|
607 $closure->(undef, '>') if $closure;
|
|
|
608 next MATCH;
|
|
|
609 }
|
|
|
610 if ($e eq "\x01") {
|
|
|
611 $closure->($sc, undef) if $closure;
|
|
|
612 next MATCH;
|
|
|
613 }
|
|
|
614 faint(SP_INVALID, 'end of code', '_match') if $sc >= $ep;
|
|
|
615 my $v = ord(substr($code, $sc, 1));
|
|
|
616 if (exists $typemap{$e}) {
|
|
|
617 # check next opcode is correct type
|
|
|
618 my ($op, $desc, $type, $value, $args, $const) = bytedecode($v);
|
|
|
619 faint(SP_INVALID, $v, "_match: $e")
|
|
|
620 unless defined $type;
|
|
|
621 faint(SP_INVALID, $type, "_match: $e")
|
|
|
622 unless exists $typemap{$e}{$type} ||
|
|
|
623 (exists $mulmap{$v} && exists $typemap{$e}{V});
|
|
|
624 if ($e eq 'O' && $const) {
|
|
|
625 BCget($code, \$sc, $ep);
|
|
|
626 } elsif ($type eq '#' && $e ne '*') {
|
|
|
627 my $num = BCget($code, \$sc, $ep);
|
|
|
628 $closure->($v, "#$num") if $closure;
|
|
|
629 if ($e eq 'C') {
|
|
|
630 $args = _args('count', \$pattern) x $num;
|
|
|
631 $args .= "\x00";
|
|
|
632 $closure->(undef, '<') if $closure;
|
|
|
633 } else {
|
|
|
634 $args = '';
|
|
|
635 }
|
|
|
636 } else {
|
|
|
637 $sc++;
|
|
|
638 $args = '' if $e eq 'O' || $e eq '*';
|
|
|
639 $closure->($v, $op) if $closure;
|
|
|
640 }
|
|
|
641 $pattern = $args . $pattern;
|
|
|
642 next MATCH;
|
|
|
643 } elsif ($e eq 'N') {
|
|
|
644 # any nonzero number
|
|
|
645 return undef if $v == 0;
|
|
|
646 $closure->($v, "N$v") if $closure;
|
|
|
647 $sc++;
|
|
|
648 } elsif ($e eq '<') {
|
|
|
649 # left grammar element
|
|
|
650 my $count = BCget($code, \$sc, $ep);
|
|
|
651 my $num = BCget($code, \$sc, $ep);
|
|
|
652 if ($num == 0) {
|
|
|
653 $closure->(undef, '?<') if $closure;
|
|
|
654 } elsif ($num == 1 || $num == 2) {
|
|
|
655 $closure->(undef, ',<') if $closure;
|
|
|
656 } else {
|
|
|
657 $closure->(undef, ',!<') if $closure;
|
|
|
658 }
|
|
|
659 if ($count && $closure) {
|
|
|
660 $closure->(undef, $count == 65535 ? '*' : $count);
|
|
|
661 }
|
|
|
662 $pattern = "E\x00" . $pattern;
|
|
|
663 next MATCH;
|
|
|
664 } elsif ($e eq '>') {
|
|
|
665 # right grammar element
|
|
|
666 my $num = BCget($code, \$sc, $ep);
|
|
|
667 if ($num == 0 || $num == 6) {
|
|
|
668 my $count = BCget($code, \$sc, $ep);
|
|
|
669 if ($count && $closure) {
|
|
|
670 $closure->(undef, $count);
|
|
|
671 }
|
|
|
672 $closure->($v, $num ? '!<' : '?<') if $closure;
|
|
|
673 $pattern = "E\x00" . $pattern;
|
|
|
674 next MATCH;
|
|
|
675 }
|
|
|
676 if ($num == 1 || $num == 2) {
|
|
|
677 $closure->($v, ',<') if $closure;
|
|
|
678 my $count = BCget($code, \$sc, $ep);
|
|
|
679 if ($count && $closure) {
|
|
|
680 $closure->(undef, $count);
|
|
|
681 }
|
|
|
682 $pattern = "E\x00" . $pattern;
|
|
|
683 next MATCH;
|
|
|
684 }
|
|
|
685 if ($num == 3 || $num == 7) {
|
|
|
686 $closure->($v, ',!<') if $closure;
|
|
|
687 my $count = BCget($code, \$sc, $ep);
|
|
|
688 if ($count && $closure) {
|
|
|
689 $closure->(undef, $count);
|
|
|
690 }
|
|
|
691 $pattern = "E\x00" . $pattern;
|
|
|
692 next MATCH;
|
|
|
693 }
|
|
|
694 if ($num == 4) {
|
|
|
695 $num = BCget($code, \$sc, $ep);
|
|
|
696 my $se = $sc + $num;
|
|
|
697 $se <= $ep
|
|
|
698 or faint(SP_INVALID, '???', '_match: >');
|
|
|
699 if ($closure) {
|
|
|
700 $closure->(undef, '=<');
|
|
|
701 while ($sc < $se) {
|
|
|
702 $sc += _match('*', $code, $sc, $se, $closure);
|
|
|
703 }
|
|
|
704 $closure->(undef, '>');
|
|
|
705 } else {
|
|
|
706 $sc = $se;
|
|
|
707 }
|
|
|
708 next MATCH;
|
|
|
709 }
|
|
|
710 if ($num == 15) {
|
|
|
711 $closure->($v, '*') if $closure;
|
|
|
712 next MATCH;
|
|
|
713 }
|
|
|
714 faint(SP_INVALID, $num, "_match: >");
|
|
|
715 } elsif ($e eq '[') {
|
|
|
716 # XXX left optimise element
|
|
|
717 faint(SP_TODO, 'match on [');
|
|
|
718 } elsif ($e eq ']') {
|
|
|
719 # XXX right optimise element
|
|
|
720 faint(SP_TODO, 'match on ]');
|
|
|
721 } else {
|
|
|
722 faint(SP_BCMATCH, 'type', $e);
|
|
|
723 }
|
|
|
724 }
|
|
|
725 $sc - $osc;
|
|
|
726 }
|
|
|
727
|
|
|
728 sub reg_list () {
|
|
|
729 @reg_list;
|
|
|
730 }
|
|
|
731
|
|
|
732 sub reg_create {
|
|
|
733 @_ == 2 || @_ == 3
|
|
|
734 or croak "Usage: reg_create(REGISTER, OBJECT [, VALUE])";
|
|
|
735 my ($rn, $object, @value) = @_;
|
|
|
736 $rn = $reg_names{$rn} if exists $reg_names{$rn};
|
|
|
737 if (exists $reg_list{$rn}) {
|
|
|
738 @value = $reg_list{$rn}[1] if ! @value;
|
|
|
739 my $rt = $reg_list{$rn}[3];
|
|
|
740 my $dt = $reg_list{$rn}[0];
|
|
|
741 return Language::INTERCAL::DoubleOhSeven->new($dt, $object, @value)
|
|
|
742 if $rt eq '%';
|
|
|
743 return Language::INTERCAL::SharkFin->new($dt, $object, @value)
|
|
|
744 if $rt eq '^';
|
|
|
745 return Language::INTERCAL::Whirlpool->new(@value)
|
|
|
746 if $rt eq '@';
|
|
|
747 }
|
|
|
748 $rn =~ /^\./
|
|
|
749 and return Language::INTERCAL::Numbers::Spot->new(@value || 0);
|
|
|
750 $rn =~ /^:/
|
|
|
751 and return Language::INTERCAL::Numbers::Twospot->new(@value || 0);
|
|
|
752 $rn =~ /^,/
|
|
|
753 and return Language::INTERCAL::Arrays::Tail->new(@value || []);
|
|
|
754 $rn =~ /^;/
|
|
|
755 and return Language::INTERCAL::Arrays::Hybrid->new(@value || []);
|
|
|
756 $rn =~ /^\@/
|
|
|
757 and return Language::INTERCAL::Whirlpool->new();
|
|
|
758 $rn =~ /^\_[12]$/
|
|
|
759 and return Language::INTERCAL::CrawlingHorror->new();
|
|
|
760 faint(SP_SPECIAL, $rn);
|
|
|
761 }
|
|
|
762
|
|
|
763 sub reg_codetype {
|
|
|
764 @_ == 1 or croak "Usage: reg_codetype(REGISTER)";
|
|
|
765 my ($rn) = @_;
|
|
|
766 exists $reg_list{$rn} and return $reg_list{$rn}[0];
|
|
|
767 if (exists $reg_names{$rn}) {
|
|
|
768 $rn = $reg_names{$rn};
|
|
|
769 return $reg_list{$rn}[0];
|
|
|
770 }
|
|
|
771 $rn =~ /^\./ and return 'spot';
|
|
|
772 $rn =~ /^:/ and return 'twospot';
|
|
|
773 $rn =~ /^,/ and return 'tail';
|
|
|
774 $rn =~ /^;/ and return 'hybrid';
|
|
|
775 $rn =~ /^\@/ and return 'whirlpool';
|
|
|
776 faint(SP_SPECIAL, $rn);
|
|
|
777 }
|
|
|
778
|
|
|
779 sub reg_name {
|
|
|
780 @_ == 1 or croak "Usage: reg_name(REGISTER)";
|
|
|
781 my ($rn) = @_;
|
|
|
782 exists $reg_list{$rn}
|
|
|
783 and return $reg_list{$rn}[3] . $reg_list{$rn}[4];
|
|
|
784 if (exists $reg_names{$rn}) {
|
|
|
785 $rn = $reg_names{$rn};
|
|
|
786 return $reg_list{$rn}[3] . $reg_list{$rn}[4];
|
|
|
787 }
|
|
|
788 $rn =~ /^([%^\@])(.*)$/ && exists $reg_list{$2} && $reg_list{$2}[3] eq $1
|
|
|
789 and return $reg_list{$2}[3] . $reg_list{$2}[4];
|
|
|
790 $rn =~ s/^([\.:,;\@^%])0*(\d+)$/$1$2/ and return $rn;
|
|
|
791 undef;
|
|
|
792 }
|
|
|
793
|
|
|
794 sub reg_code {
|
|
|
795 @_ == 1 or croak "Usage: reg_code(REGISTER)";
|
|
|
796 my ($rn) = @_;
|
|
|
797 exists $reg_list{$rn}
|
|
|
798 and return ($reg_list{$rn}[2], BC($reg_list{$rn}[4]));
|
|
|
799 if (exists $reg_names{$rn}) {
|
|
|
800 $rn = $reg_names{$rn};
|
|
|
801 return ($reg_list{$rn}[2], BC($reg_list{$rn}[4]));
|
|
|
802 }
|
|
|
803 $rn =~ /^([%^\@])(.*)$/ && exists $reg_list{$2} && $reg_list{$2}[3] eq $1
|
|
|
804 and return ($reg_list{$2}[2], BC($reg_list{$2}[4]));
|
|
|
805 $rn =~ /^\.(\d+)$/ and return (BC_SPO, BC($1));
|
|
|
806 $rn =~ /^:(\d+)$/ and return (BC_TSP, BC($1));
|
|
|
807 $rn =~ /^,(\d+)$/ and return (BC_TAI, BC($1));
|
|
|
808 $rn =~ /^;(\d+)$/ and return (BC_HYB, BC($1));
|
|
|
809 $rn =~ /^\@(\d+)$/ and return (BC_WHP, BC($1));
|
|
|
810 $rn =~ /^\%(\d+)$/ and return (BC_DOS, BC($1));
|
|
|
811 $rn =~ /^\^(\d+)$/ and return (BC_SHF, BC($1));
|
|
|
812 undef;
|
|
|
813 }
|
|
|
814
|
|
|
815 sub reg_decode {
|
|
|
816 @_ == 1 or croak "Usage: reg_name(REGISTER)";
|
|
|
817 my ($rn) = @_;
|
|
|
818 return $rn if $rn =~ /^[.,:;\@_]/;
|
|
|
819 if ($rn =~ /^[%^]\d+$/) {
|
|
|
820 return undef unless exists $reg_names{$rn};
|
|
|
821 $rn = $reg_names{$rn};
|
|
|
822 } elsif ($rn =~ s/^([%^])//) {
|
|
|
823 return undef unless exists $reg_list{$rn};
|
|
|
824 return undef if $1 ne $reg_list{$rn}[3];
|
|
|
825 } else {
|
|
|
826 return undef unless exists $reg_list{$rn};
|
|
|
827 }
|
|
|
828 $reg_list{$rn}[3] . $rn;
|
|
|
829 }
|
|
|
830
|
|
|
831 1;
|
|
|
832
|
|
|
833 __END__
|
|
|
834
|
|
|
835 =pod
|
|
|
836
|
|
|
837 =head1 TITLE
|
|
|
838
|
|
|
839 Language::INTERCAL::Bytecode - intermediate language
|
|
|
840
|
|
|
841 =head1 DESCRIPTION
|
|
|
842
|
|
|
843 The CLC-INTERCAL compiler works by producing bytecode from the
|
|
|
844 program source; this bytecode can be interpreted to execute the
|
|
|
845 program immediately; alternatively, a backend can produce something
|
|
|
846 else from the bytecode, for example C or Perl source code which can
|
|
|
847 then be compiled to your computer's native object format.
|
|
|
848
|
|
|
849 The compiler itself is just some more bytecode. Thus, to produce the
|
|
|
850 compiler you need a compiler compiler, and to produce that you need
|
|
|
851 a compiler compiler compiler; to produce the latter you would need
|
|
|
852 a compiler compiler compiler compiler, and so on to infinity. To
|
|
|
853 simplify the programmer's life (eh?), the compiler compiler is able
|
|
|
854 to compile itself, and is therefore identical to the compiler compiler
|
|
|
855 compiler (etcetera).
|
|
|
856
|
|
|
857 The programmer can start the process because a pre-compiled compiler
|
|
|
858 compiler, in the form of bytecode, is provided with the CLC-INTERCAL
|
|
|
859 distribution; this compiler compiler then is able to compile all
|
|
|
860 other compilers, as well as to rebuild itself if need be.
|
|
|
861
|
|
|
862 See the online manual or the HTML documentation included with the
|
|
|
863 distribution for more information about this.
|
|
|
864
|
|
|
865 =head1 SEE ALSO
|
|
|
866
|
|
|
867 A qualified psychiatrist
|
|
|
868
|
|
|
869 =head1 AUTHOR
|
|
|
870
|
|
|
871 Claudio Calvelli - intercal (whirlpool) sdf.lonestar.org
|
|
|
872 (Please include the word INTERLEAVING in the subject when emailing that
|
|
|
873 address, or the email may be ignored)
|
|
|
874
|
