git @ Cat's Eye Technologies Muriel / d805643
Initial import of muriel.pl version 1.0 revision 2001.0323 sources. catseye 10 years ago
5 changed file(s) with 460 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
0 A:"Arthur \"two-sheds\" Jackson\n";
1 .A;
2 .|A;
3 .||A
0 b:99;
1 A:$b+" bottle"+(%"s",0,1-(b=1))+" of beer";
2 .A+" on the wall,\n"+A+",\nTake one down, pass it around,\n";
3 b:b-1;
4 .$b+" bottle"+(%"s",0,1-(b=1))+" of beer on the wall.\n\n";
5 Q:";\nA:$b+\" bottle\"+(%\"s\",0,1-(b=1))+\" of beer\";\n.A+\" on the wall,\\n\"+A+\",\\nTake one down, pass it around,\\n\";\nb:b-1;\n.$b+\" bottle\"+(%\"s\",0,1-(b=1))+\" of beer on the wall.\\n\\n\";\nQ:\"";
6 R:"\";\nZ:\"b:\"+$b+Q+|Q+\"\\\";\\nR:\\\"\"+|R+R;\n@%Z,0,(b>0)*&Z";
7 Z:"b:"+$b+Q+|Q+"\";\nR:\""+|R+R;
8 @%Z,0,(b>0)*&Z
0 ."Hello, world!\n"
0 Copyright (c)2001, Cat's Eye Technologies.
1 All rights reserved.
2
3 Redistribution and use in source and binary forms, with or without
4 modification, are permitted provided that the following conditions
5 are met:
6
7 Redistributions of source code must retain the above copyright
8 notice, this list of conditions and the following disclaimer.
9
10 Redistributions in binary form must reproduce the above copyright
11 notice, this list of conditions and the following disclaimer in
12 the documentation and/or other materials provided with the
13 distribution.
14
15 Neither the name of Cat's Eye Technologies nor the names of its
16 contributors may be used to endorse or promote products derived
17 from this software without specific prior written permission.
18
19 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
20 CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
21 INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
22 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
23 DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE
24 LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
25 OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
27 OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
28 ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
29 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
30 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31 POSSIBILITY OF SUCH DAMAGE.
0 #!/usr/local/bin/perl -w
1
2 # muriel.pl - Cat's Eye Technologies' Muriel Interpreter
3 # An interpreter for Matthew Wescott's Muriel language
4 # (see http://demo.raww.net/muriel/ for more information)
5 # v2001.03.23 Chris Pressey, Cat's Eye Technologies
6
7 # Copyright (c)2001, Cat's Eye Technologies.
8 # All rights reserved.
9 #
10 # Redistribution and use in source and binary forms, with or without
11 # modification, are permitted provided that the following conditions
12 # are met:
13 #
14 # Redistributions of source code must retain the above copyright
15 # notice, this list of conditions and the following disclaimer.
16 #
17 # Redistributions in binary form must reproduce the above copyright
18 # notice, this list of conditions and the following disclaimer in
19 # the documentation and/or other materials provided with the
20 # distribution.
21 #
22 # Neither the name of Cat's Eye Technologies nor the names of its
23 # contributors may be used to endorse or promote products derived
24 # from this software without specific prior written permission.
25 #
26 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
27 # CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
28 # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
29 # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
30 # DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE
31 # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
32 # OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
33 # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
34 # OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
35 # ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
36 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
37 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
38 # POSSIBILITY OF SUCH DAMAGE.
39
40 # USAGE: [perl] muriel[.pl] program.mur
41
42 ### BEGIN muriel.pl ###
43
44 ### QUOTIFIER ###
45
46 sub unquotify
47 {
48 my $x = shift;
49 my $a; my $b = ''; my $i;
50 while(length($x)>0)
51 {
52 $a = substr($x, 0, 1);
53 if ($a eq '\\')
54 {
55 $x = substr($x, 1);
56 $a = substr($x, 0, 1);
57 if ($a eq 'n')
58 {
59 $b .= "\n";
60 }
61 else
62 {
63 $b .= $a;
64 }
65 $x = substr($x, 1);
66 } else
67 {
68 $b .= $a;
69 $x = substr($x, 1);
70 }
71 }
72 return $b;
73 }
74
75 sub quotify
76 {
77 my $x = shift;
78 my $a; my $b = ''; my $i;
79 while(length($x)>0)
80 {
81 $a = substr($x, 0, 1);
82 if ($a eq "\n" or $a eq "\r")
83 {
84 $b .= "\\n";
85 }
86 elsif ($a eq "\"")
87 {
88 $b .= "\\\"";
89 }
90 elsif ($a eq "\\")
91 {
92 $b .= "\\\\";
93 }
94 else
95 {
96 $b .= $a;
97 }
98 $x = substr($x, 1);
99 }
100 return $b;
101 }
102
103 ### SCANNER ###
104
105 $program = '';
106 $token = '';
107 sub scan
108 {
109 if ($program =~ /^\s+/)
110 {
111 $program = $';
112 goto &scan;
113 }
114 if ($program =~ /^(\d+)/)
115 {
116 $token = $1;
117 $program = $';
118 }
119 elsif ($program =~ /^([A-Za-z])/)
120 {
121 $token = $1;
122 $program = $';
123 }
124 elsif ($program =~ /^(\".*?[^\\]\")/ or $program =~ /^(\"\")/)
125 {
126 $token = $1;
127 $program = $';
128 $token = unquotify($token);
129 }
130 elsif ($program =~ /^(.)/)
131 {
132 $token = $1;
133 $program = $';
134 }
135 else
136 {
137 # end of program
138 $token = '';
139 $program = '';
140 }
141 # print "Scanned: $token\n";
142 }
143
144 sub expect
145 {
146 my $expected = shift;
147 if ($token eq $expected)
148 {
149 scan();
150 } else
151 {
152 error("Expected '$expected' not '$token'");
153 }
154 }
155
156 sub error
157 {
158 my $msg = shift;
159 print STDERR "*** ERROR: muriel: $msg\n";
160 }
161
162 ### PARSER ###
163
164 # Program ::= Instruction [";" Instruction].
165 sub program
166 {
167 instruction();
168 while($token eq ';')
169 {
170 scan();
171 instruction();
172 }
173 # print "end program on $token\n";
174 }
175
176 # Instruction ::= NumVarName ":" NumExpr
177 # | StrVarName ":" StrExpr
178 # | "." StrExpr
179 # | "@" StrExpr.
180 sub instruction
181 {
182 if ($token eq '.')
183 {
184 scan();
185 my $q = strexpr();
186 print STDOUT $q;
187 }
188 elsif ($token eq '@')
189 {
190 scan();
191 # print "token: $token\n";
192 my $q = strexpr();
193 my $key;
194 foreach $key (keys %var)
195 {
196 # print "=== $key === $var{$key}\n";
197 }
198 # print "<-- Executing $q -->\n\n"; <STDIN>;
199 $program = $q;
200 %var = ();
201 scan();
202 goto &program;
203 }
204 elsif ($token =~ /^[A-Z]$/)
205 {
206 my $t = $token;
207 scan();
208 expect(':');
209 $var{$t} = strexpr();
210 }
211 elsif ($token =~ /^[a-z]$/)
212 {
213 my $t = $token;
214 scan();
215 expect(':');
216 $var{$t} = numexpr();
217 }
218 elsif ($token eq '')
219 {
220 # end
221 } else
222 {
223 error("Unknown token '$token'");
224 }
225 }
226
227 # NumExpr ::= NumTerm {"=" NumTerm | ">" NumTerm}.
228 sub numexpr
229 {
230 my $q = numterm();
231 while($token eq "=" or $token eq ">")
232 {
233 my $t = $token;
234 scan();
235 my $r = numterm();
236 my $b = $q;
237 if ($t eq '=') { $q = ($q == $r) || 0; }
238 if ($t eq '>') { $q = ($q > $r) || 0; }
239 # print "compare: $b $t $r -> $q\n";
240 }
241 return $q;
242 }
243
244 # NumTerm ::= NumFactor {"+" NumFactor | "-" NumFactor}.
245 sub numterm
246 {
247 my $q = numfactor();
248 while($token eq "+" or $token eq "-")
249 {
250 my $t = $token;
251 scan();
252 my $r = numfactor();
253 if ($t eq '+') { $q += $r; }
254 if ($t eq '-') { $q -= $r; }
255 }
256 return $q;
257 }
258
259 # NumFactor ::= NumPrimitive {"*" NumPrimitive}.
260 sub numfactor
261 {
262 my $q = numprimitive();
263 while($token eq "*")
264 {
265 scan();
266 $q *= numprimitive();
267 # print "multiplication result: $q\n";
268 }
269 return $q;
270 }
271
272 # NumPrimitive ::= NumLiteral
273 # | NumVarName
274 # | "#" StrPrimitive
275 # | "&" StrPrimitive
276 # | "-" NumPrimitive
277 # | "(" NumExpr ")".
278 sub numprimitive
279 {
280 if ($token eq '#')
281 {
282 scan();
283 return 0+strprimitive();
284 }
285 elsif ($token eq '&')
286 {
287 scan();
288 my $q = length(strprimitive());
289 # print "length: $q\n";
290 return $q;
291 }
292 elsif ($token eq '-')
293 {
294 scan();
295 return -1 * numprimitive();
296 }
297 elsif ($token eq '(')
298 {
299 scan();
300 my $q = numexpr();
301 expect(')');
302 return $q;
303 }
304 elsif ($token =~ /^(\d+)$/)
305 {
306 my $q = 0+$1;
307 scan();
308 return $q;
309 }
310 elsif ($token =~ /^([a-z])$/)
311 {
312 my $q = $var{$1};
313 # print "GET $1:$q\n";
314 scan();
315 return $q;
316 }
317 else
318 {
319 error("Illegal numeric '$token'");
320 return 0;
321 }
322 }
323
324 # StrExpr ::= StrPrimitive {"+" StrPrimitive}.
325 sub strexpr
326 {
327 my $q = strprimitive();
328 while($token eq '+')
329 {
330 scan();
331 $q .= strprimitive();
332 }
333 # print "strexpr: <<$q>>\n";
334 return $q;
335 }
336
337 # StrPrimitive ::= StrLiteral
338 # | StrVarName
339 # | "$" NumPrimitive
340 # | "%" StrPrimitive "," NumExpr "," NumExpr
341 # | "|" StrPrimitive
342 # | "~"
343 # | "(" StrExpr ")".
344 sub strprimitive
345 {
346 if ($token eq '$')
347 {
348 scan();
349 return "" . numprimitive();
350 }
351 elsif ($token eq '%')
352 {
353 scan();
354 my $q = strprimitive();
355 expect(',');
356 my $a = numexpr();
357 expect(',');
358 my $b = numexpr();
359 my $r = substr($q, $a, $b-$a);
360 $r = '' if $b <= $a;
361 # print "substr: <<$a,$b=$r>>\n";
362 return $r;
363 }
364 elsif ($token eq '|')
365 {
366 scan();
367 my $q = quotify(strprimitive());
368 return $q;
369 }
370 elsif ($token eq '~')
371 {
372 scan();
373 my $q = <STDIN>;
374 chomp $q;
375 return $q;
376 }
377 elsif ($token eq '(')
378 {
379 scan();
380 my $q = strexpr();
381 expect(')');
382 return $q;
383 }
384 elsif ($token =~ /^\"(.*?)\"$/s)
385 {
386 my $q = "" . $1;
387 scan();
388 return $q;
389 }
390 elsif ($token =~ /^([A-Z])$/)
391 {
392 my $q = $var{$1};
393 # print "GET $1:$q\n";
394 scan();
395 return $q;
396 }
397 else
398 {
399 error("Illegal string '$token'");
400 return "";
401 }
402 }
403
404 ### MAIN ###
405
406 $| = 1;
407 open FILE, "<$ARGV[0]";
408 $program = join('', <FILE>);
409 close FILE;
410 scan();
411 program();
412
413 ### END of muriel.pl ###