git.m455.casa

perl-lisp

clone url: git://git.m455.casa/perl-lisp

lip.pl

1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 # i used to need to disable the deep recursion warnings before i learned about
7 # the `@_ = whatever; goto &subroutine` trick
8 # i still probably need it but whatever lol. can't figure some alternatives out
9 # no warnings 'recursion';
10
11 # utf8 it all ...at least that's what i hope i'm doing
12 use utf8;
13 use open ":std", ":encoding(UTF-8)";
14 use Scalar::Util qw(looks_like_number);
15
16 # pretty printing
17 use Data::Dumper;
18 $Data::Dumper::Terse = 1; # don't prefix things with stuff like $VAR->whatever
19 $Data::Dumper::Indent = 2; # style of output/indent/indexes/spaces
20 $Data::Dumper::Useqq = 1; # use double quotes for strings
21 $Data::Dumper::Deepcopy = 1; # don't show $VAR->[1] for deeply nested shit
22 sub pp { print(Dumper(@_)); }
23
24 use constant {
25 AST_NUMBER => 'number',
26 AST_STRING => 'string',
27 AST_KEYWORD => 'keyword',
28 AST_SYMBOL => 'symbol',
29 OK => ':ok'
30 };
31
32 my $environment = {
33 'str' => sub {
34 return lisp_string($_[0]);
35 },
36 'file->str' => sub {
37 return read_file($_[0]);
38 },
39 'function?' => sub {
40 return (ref($_[0]) eq 'HASH');
41 },
42 'list?' => sub {
43 return (ref($_[0]) eq 'ARRAY');
44 },
45 'number?' => sub { return looks_like_number($_[0]); },
46 'string?' => sub {
47 return (
48 not looks_like_number($_[0]) and
49 ref($_[0]) ne 'ARRAY'
50 );
51 },
52 'keyword?' => sub {
53 return (
54 not looks_like_number($_[0]) and
55 ref($_[0]) ne 'ARRAY' and
56 substr($_[0], 0, 1) eq ':'
57 );
58 },
59 'number-equal?' => sub {
60 return $_[0] == $_[1];
61 },
62 'string-equal?' => sub {
63 return $_[0] eq $_[1];
64 },
65 'list' => sub { return \@_; },
66 'drop-first' => sub {
67 my ($args) = @_;
68 my ($first, @rest) = @$args;
69 return \@rest;
70 },
71 'list-length' => sub {
72 return scalar(@{$_[0]});
73 },
74 'string-length' => sub {
75 return length($_[0]);
76 },
77 'string-split' => sub {
78 my ($arg, $delimiter) = @_;
79 if (not defined($delimiter)) {
80 return [split('', $arg)];
81 }
82 else {
83 return [split($delimiter, $arg)];
84 }
85 },
86 'string-join' => sub {
87 my ($arg1, $arg2) = @_;
88 return $arg1 . $arg2;
89 },
90 'list-join' => sub {
91 my ($arg1, $arg2) = @_;
92 return [@$arg1, @$arg2];
93 },
94 'list-prepend' => sub {
95 my ($arg, $list) = @_;
96 my $list_copy = [@{$list}];
97 unshift(@$list_copy, $arg);
98 return $list_copy;
99 },
100 'list-append' => sub {
101 my ($arg, $list) = @_;
102 my $list_copy = [@{$list}];
103 push(@$list_copy, $arg);
104 return $list_copy;
105 },
106 'drop-last' => sub {
107 my ($list) = @_;
108 my $list_copy = [@{$list}];
109 pop(@$list_copy);
110 return $list_copy;
111 },
112 'add' => sub { return $_[0] + $_[1]; },
113 'subtract' => sub { return $_[0] - $_[1]; },
114 'multiply' => sub { return $_[0] * $_[1]; },
115 'divide' => sub { return $_[0] / $_[1]; },
116 'remainder' => sub { return $_[0] % $_[1]; },
117 'do' => sub { return $_[-1]; },
118 };
119
120 my $std_lib = <<STRING_BLOCK;
121 not sure if i want to implement the standard lib in a string block of separate file haha
122 STRING_BLOCK
123
124 sub zip {
125 my ($parameters, $args, $acc) = @_;
126 if (scalar(@$parameters) == 0) {
127 return $acc;
128 }
129 else {
130 my ($parameters_first, @parameters_rest) = @$parameters;
131 my ($args_first, @args_rest) = @$args;
132 $acc->{$parameters_first->{'value'}} = $args_first;
133 @_ = (\@parameters_rest, \@args_rest, $acc);
134 return goto &zip;
135 }
136 }
137
138 sub get {
139 my ($scope, $key) = @_;
140 # check if in local scope
141 if (defined($scope->{$key})) {
142 return $scope->{$key};
143 }
144 # recursively check parent scope
145 elsif ($scope->{'parent_scope'}) {
146 @_ = ($scope->{'parent_scope'}, $key);
147 return goto &get;
148 }
149 else {
150 print("error: '$key' isn't defined.\n\n");
151 print("you can define a symbol using the following syntax:\n\n");
152 die("(def $key \"hello world\")\n");
153 }
154 }
155
156 sub read_file {
157 my ($file) = @_;
158
159 my $file_contents = do {
160 local $/ = undef;
161 open(my $file_handle, "<", $file) or die "can't open $file: $!";
162 # we don't need to close this $file_handle. lexical file handles close
163 # when they go out of scope
164 <$file_handle>;
165 };
166
167 return $file_contents;
168 }
169
170 sub is_space {
171 my ($char) = @_;
172 return $char =~ /\s/
173 }
174
175 sub atomize {
176 my ($str) = @_;
177
178 if (looks_like_number($str)) {
179 {
180 'type' => AST_NUMBER,
181 'value' => $str,
182 }
183 }
184 elsif (':' eq substr($str, 0, 1)) {
185 {
186 'type' => AST_KEYWORD,
187 'value' => $str,
188 }
189 }
190 else {
191 {
192 'type' => AST_SYMBOL,
193 'value' => $str,
194 }
195 }
196 }
197
198 sub unescape {
199 my ($char, @chars) = @_;
200
201 if ($char eq '"') {
202 return ("\"", \@chars);
203 }
204 elsif ($char eq 'n') {
205 return ("\n", \@chars);
206 }
207 elsif ($char eq 't') {
208 return ("\t", \@chars);
209 }
210 else {
211 print("error: '\\$char' is not a valid escape code.\n\n");
212 print("only the following escape codes are valid:\n\n");
213 print("\\\" -> for double quotation marks.\n");
214 print("\\n -> for newlines.\n");
215 die("\\t -> for tabs\n");
216 }
217 }
218
219 sub unescape_string {
220 my ($str, $acc) = @_;
221 # this is messy, but it saves me from having to split the $str argument and
222 # provide a "" every time i want to call this function
223 if (ref($str) ne 'ARRAY') { $str = [split('', $str)]; }
224 if (not defined($acc)) { $acc = "" }
225 if (scalar(@$str) == 0) {
226 return $acc;
227 }
228 else {
229 my ($char, @rest_chars) = @$str;
230 if ($char eq '\\') {
231 my ($unescaped_char, $remaining_chars) = unescape(@rest_chars);
232 $acc = $acc . $unescaped_char;
233 @_ = ($remaining_chars, $acc);
234 return goto &unescape_string;
235 }
236 else {
237 $acc = $acc . $char;
238 @_ = (\@rest_chars, $acc);
239 return goto &unescape_string;
240 }
241 }
242 }
243
244 sub ignore_line {
245 my ($char, @rest_chars) = @_;
246
247 if ($char ne "\n") {
248 @_ = @rest_chars;
249 return goto &ignore_line;
250 }
251 else {
252 return \@rest_chars;
253 }
254 }
255
256 sub build_string {
257 my ($chars, $str) = @_;
258 my ($char, @rest_chars) = @$chars;
259
260 if ($char eq '\\') {
261 my ($unescaped_char, $remaining_chars) = unescape(@rest_chars);
262 $str = $str . $unescaped_char;
263
264 @_ = ($remaining_chars, $str);
265 return goto &build_string;
266 }
267 elsif ($char ne '"') {
268 my $new_str = $str . $char;
269
270 @_ = (\@rest_chars, $new_str);
271 return goto &build_string;
272 }
273 else {
274 my $return_str = {
275 'type' => AST_STRING,
276 'value' => $str,
277 };
278 return (\@rest_chars, $return_str);
279 }
280 }
281
282 sub build_atom {
283 my ($chars, $str) = @_;
284 my ($char, @rest_chars) = @$chars;
285
286 if (not is_space($char) and
287 $char ne ')' and
288 $char ne '(' and
289 $char ne '[' and
290 $char ne ']') {
291 my $new_str = $str . $char;
292
293 @_ = (\@rest_chars, $new_str);
294 return goto &build_atom;
295 }
296 else {
297 return ($chars, atomize($str));
298 }
299 }
300
301 sub eval_args {
302 my ($expr, $acc, $current_scope) = @_;
303
304 if (scalar(@$expr) == 0) {
305 return $acc;
306 }
307 else {
308 my ($first_expr, @rest_expr) = @$expr;
309 my ($result, $new_scope) = eval_single_expr($first_expr, $current_scope);
310
311 push(@$acc, $result);
312 @_ = (\@rest_expr, $acc, $new_scope);
313 return goto &eval_args;
314 }
315 }
316
317 sub lisp_string {
318 my ($expr, $mode) = @_;
319 if (not defined($mode)) {
320 $mode = 0;
321 }
322
323 # not actually sure if i ever return an undef here to be honest
324 if (not defined($expr)) {
325 return 'undef';
326 }
327 elsif ($expr eq "") {
328 return '""';
329 }
330 # functions
331 # this turns something like HASH(0x562aaeb46cc8) into
332 # function(0x562aaeb46cc8)
333 elsif (ref($expr) eq 'HASH') {
334 return $expr =~ s/HASH/function/r;
335 }
336 # lists
337 elsif (ref($expr) eq 'ARRAY') {
338 return "[" . join(" ", map { lisp_string($_, $mode); } @$expr) . "]";
339 }
340 # strings
341 elsif (not substr($expr, 0, 1) eq ':' and
342 $expr =~ /^[\s\S]+$/ and
343 not looks_like_number($expr)) {
344 if ($mode eq 'repl-mode') {
345 # can't get my escape_string and unescape_strings to work on this,
346 # so i'll just use a bunch of these? :shrug: :
347 #$expr =~ s/"/\\"/g;
348 #$expr =~ s/\n/\\n/g;
349 #$expr =~ s/\t/\\t/g;
350 return '"' . $expr . '"';
351 }
352 else {
353 return $expr;
354 }
355 }
356 # keywords, numbers, and quoted symbols
357 else {
358 return $expr;
359 }
360 }
361
362 sub lisp_string_quote {
363 my ($expr) = @_;
364
365 if (ref($expr) eq 'ARRAY') {
366 return "[" . join(" ", map { lisp_string_quote($_); } @$expr) . "]";
367 }
368 elsif (ref($expr) eq 'HASH') {
369 my $result = $expr->{'value'};
370 if ($result eq 'list') {
371 return;
372 }
373 elsif ($expr->{'type'} eq AST_STRING) {
374 return "\"$result\"";
375 }
376 else {
377 return $result;
378 }
379 }
380 else {
381 return $expr;
382 }
383 }
384
385 # reminder: all tokens in the AST are hashes containing the type and value
386 sub eval_single_expr {
387 my ($expr, $current_scope) = @_;
388
389 # ==============
390 # = not a list =
391 # ==============
392 if (ref($expr) eq 'HASH') {
393 # ------------
394 # - constant -
395 # ------------
396 if ($expr->{'type'} eq AST_NUMBER or
397 $expr->{'type'} eq AST_KEYWORD or
398 $expr->{'type'} eq AST_STRING) {
399 return ($expr->{'value'}, $current_scope);
400 }
401 # ----------
402 # - symbol -
403 # ----------
404 elsif ($expr->{'type'} eq AST_SYMBOL) {
405 return (get($current_scope, $expr->{'value'}), $current_scope);
406 }
407 }
408
409 # =============
410 # = is a list =
411 # =============
412 # ------------
413 # - () or [] -
414 # ------------
415 elsif (scalar(@$expr) == 0) {
416 return ($expr, $current_scope);
417 }
418 # ------------------
419 # - (print <expr>) -
420 # ------------------
421 elsif (ref($expr->[0]) eq 'HASH' and $expr->[0]->{'value'} eq 'print') {
422 my (undef, $arg) = @$expr;
423 my ($arg_evaluated, undef) = eval_single_expr($arg, $current_scope);
424 #print($arg_evaluated);
425 print($arg_evaluated);
426 return (OK, $current_scope);
427 }
428 # --------------------------
429 # - (load-file <filename>) -
430 # --------------------------
431 elsif (ref($expr->[0]) eq 'HASH' and $expr->[0]->{'value'} eq 'load-file') {
432 my (undef, $filename) = @$expr;
433 my ($filename_evaluated, undef) = eval_single_expr($filename, $current_scope);
434 # NEW (mayyybe) =============
435 # my $ast = make_ast(tokenize_file($filename_evaluated), []);
436 # # ignore return value
437 # my (undef, $new_scope) = eval_all_expr($ast, [], $current_scope);
438 # return (OK, $new_scope);
439 # OLD =======================
440 # ignore return value
441 my (undef, $new_scope) = load_file($filename_evaluated, $current_scope);
442 return (OK, $new_scope);
443 }
444 # ------------------------
445 # - (def <name> <value>) -
446 # ------------------------
447 elsif (ref($expr->[0]) eq 'HASH' and $expr->[0]->{'value'} eq 'def') {
448 my (undef, $name, $definition) = @$expr;
449 my ($definition_evaluated, undef) = eval_single_expr($definition, $current_scope);
450 # create new copy of current_scope
451 my $new_scope = {%{$current_scope}};
452 $new_scope->{$name->{'value'}} = $definition_evaluated;
453 return (OK, $new_scope);
454 }
455 # -----------------------------------------------
456 # - (defn <name> [<parameters> ...] <body ...>) -
457 # -----------------------------------------------
458 elsif (ref($expr->[0]) eq 'HASH' and $expr->[0]->{'value'} eq 'defn') {
459 my (undef, $symbol, $parameters, @body) = @$expr;
460 my $def = {'type' => AST_SYMBOL, 'value' => 'def'};
461 my $fn = {'type' => AST_SYMBOL, 'value' => 'fn'};
462 @_ = ([$def, $symbol, [$fn, $parameters, @body]], $current_scope);
463 return goto &eval_single_expr;
464 }
465 # --------------------------------------
466 # - (fn [<parameters> ...] <body ...>) -
467 # --------------------------------------
468 elsif (ref($expr->[0]) eq 'HASH' and $expr->[0]->{'value'} eq 'fn') {
469 my (undef, $args, @body) = @$expr;
470 my (undef, @params) = @$args;
471 # we don't turn body into a reference here because it was already turned
472 # into a reference by the ast
473 return ({'parameters' => \@params, 'body' => \@body}, $current_scope);
474 }
475 # -----------------------------
476 # - (if <cond> <then> <else>) -
477 # -----------------------------
478 elsif (ref($expr->[0]) eq 'HASH' and $expr->[0]->{'value'} eq 'if') {
479 my (undef, $condition, $then, $otherwise) = @$expr;
480 my ($condition_evaluated, undef) = eval_single_expr($condition, $current_scope);
481
482 if ($condition_evaluated) {
483 my ($then_evaluated, undef) = eval_single_expr($then, $current_scope);
484 return($then_evaluated, $current_scope);
485 }
486 else {
487 my ($otherwise_evaluated, undef) = eval_single_expr($otherwise, $current_scope);
488 return($otherwise_evaluated, $current_scope);
489 }
490 }
491 # ---------------------
492 # - (<number> <list>) -
493 # ---------------------
494 elsif (ref($expr->[0]) eq 'HASH' and $expr->[0]->{'type'} eq AST_NUMBER) {
495 my ($func, $arg) = @$expr;
496 my $number = $func->{'value'};
497 my ($arg_evaluated, undef) = eval_single_expr($arg, $current_scope);
498
499 if (ref($arg_evaluated) eq 'ARRAY') {
500 return ($arg_evaluated->[$number], $current_scope);
501 }
502 else {
503 my $str_invalid_expr = lisp_string_quote($expr);
504 print("error: '$arg_evaluated' is not a list in the expression '$str_invalid_expr`.\n\n");
505 print("try using a list or a definition containing a list, instead of '$arg_evaluated', similar to the examples below:\n\n");
506 print("(def my-list [1 2 3])\n");
507 print("(2 my-list)\n");
508 die("(2 [3 4 5])\n");
509 }
510 }
511 # --------------------
512 # - (<function> ...) -
513 # --------------------
514 else {
515 my ($head, @tail) = @$expr;
516 my ($head_evaluated, undef) = eval_single_expr($head, $current_scope);
517 my $args_evaluated = eval_args(\@tail, [], $current_scope);
518
519 # functions
520 if (ref($head_evaluated) eq 'CODE') {
521 return ($head_evaluated->(@$args_evaluated), $current_scope);
522 }
523 # anonymous functions
524 else {
525 # handle error for invalid function
526 if (ref($head_evaluated) ne 'HASH') {
527 my $str_invalid = lisp_string_quote($head);
528 my $str_invalid_expr = lisp_string_quote($expr);
529 print("'$str_invalid' isn't a valid function in the expression '$str_invalid_expr'.\n\n");
530 print("make sure '$str_invalid' isn't a list, string, or keyword. ");
531 print("if '$str_invalid' isn't a list, string, or keyword, then make sure that you've defined it.\n\n");
532 print("examples of invalid functions:\n\n");
533 print("(:example \"hello world\")\n");
534 print("(\"example\" \"hello world\")\n");
535 die("([1 2 3] \"hello world\")\n");
536 }
537 else {
538 my $parameters = $head_evaluated->{'parameters'};
539 my $fn_scope = zip($parameters, $args_evaluated, {});
540 $fn_scope->{'parent_scope'} = $current_scope;
541 my ($fn_body_result, undef) = eval_all_expr($head_evaluated->{'body'}, [], $fn_scope);
542
543 return ($fn_body_result, $current_scope);
544
545 }
546 }
547 }
548 }
549
550 sub make_ast {
551 my ($tokens, $ast) = @_;
552
553 if (scalar(@$tokens) == 0) {
554 return $ast;
555 }
556
557 my ($tok, @rest_tokens) = @$tokens;
558
559 if ($tok eq '(') {
560 my ($remaining_tokens, $sub_list) = make_ast(\@rest_tokens, []);
561
562 push(@$ast, $sub_list);
563 @_ = ($remaining_tokens, $ast);
564 return goto &make_ast;
565 }
566 elsif ($tok eq ')') {
567 return (\@rest_tokens, $ast);
568 }
569 # turn [1 2 3] into (list 1 2 3), ["list", 1, 2, 3] in perl, under the hood
570 elsif ($tok eq '[') {
571 my @sub_ast = {
572 'type' => AST_SYMBOL,
573 'value' => 'list'
574 };
575 my ($remaining_tokens, $sub_list) = make_ast(\@rest_tokens, \@sub_ast);
576
577 push(@$ast, $sub_list);
578 @_ = ($remaining_tokens, $ast);
579 return goto &make_ast;
580 }
581 elsif ($tok eq ']') {
582 return (\@rest_tokens, $ast);
583 }
584 else {
585 push(@$ast, $tok);
586 @_ = (\@rest_tokens, $ast);
587 return goto &make_ast;
588 }
589 }
590
591 sub tokenize {
592 my ($chars, $tokens) = @_;
593
594 if (scalar(@$chars) == 0) {
595 return $tokens;
596 }
597
598 my ($char, @rest_chars) = @$chars;
599
600 if (is_space($char)) {
601 @_ = (\@rest_chars, $tokens);
602 return goto &tokenize;
603 }
604 elsif ($char eq ';') {
605 my ($remaining_chars) = ignore_line(@rest_chars);
606 @_ = ($remaining_chars, $tokens);
607 return goto &tokenize;
608 }
609 elsif ($char eq '(' or
610 $char eq ')' or
611 $char eq '[' or
612 $char eq ']') {
613 push(@$tokens, $char);
614 @_ = (\@rest_chars, $tokens);
615 return goto &tokenize;
616 }
617 elsif ($char eq '"') {
618 my ($remaining_chars, $built_string) = build_string(\@rest_chars, "");
619
620 push(@$tokens, $built_string);
621 @_ = ($remaining_chars, $tokens);
622 return goto &tokenize;
623 }
624 else {
625 my ($remaining_chars, $built_atom) = build_atom($chars, "");
626
627 push(@$tokens, $built_atom);
628 @_ = ($remaining_chars, $tokens);
629 return goto &tokenize;
630 }
631 }
632
633 sub tokenize_file {
634 my ($file) = @_;
635
636 my $file_contents = read_file($file);
637 # don't need to do this awful trick below anymore, since i made
638 # eval_all_expr, which is basically a (do ...) statement. keeping this
639 # around for now, because it was a fun memory.
640 # my @split_contents = split('', '(do' . $file_contents . ')');
641 my $tokens = tokenize([split('', $file_contents)], []);
642
643 return $tokens;
644 }
645
646 sub eval_all_expr {
647 my ($expr, $result, $current_scope) = @_;
648 if (scalar(@$expr) == 0) {
649 return ($result, $current_scope);
650 }
651 else {
652 my ($first_expr, @rest_expr) = @$expr;
653 my ($new_result, $new_scope) = eval_single_expr($first_expr, $current_scope);
654 @_ = (\@rest_expr, $new_result, $new_scope);
655 return goto &eval_all_expr;
656 }
657 }
658
659 sub load_file {
660 my ($filename, $current_scope) = @_;
661 my $ast = make_ast(tokenize_file($filename), []);
662 # returns last expression evaluated, and a scope
663 return eval_all_expr($ast, [], $current_scope);
664 }
665
666 sub repl {
667 my ($scope) = @_;
668 print("> ");
669 my $input = <STDIN>;
670
671 # handle ctrl-d/ctrl-c
672 if (not defined($input)) {
673 exit();
674 }
675 # handle space input
676 elsif ($input =~ /^[\s]+$/) {
677 goto &repl;
678 }
679
680 eval {
681 # keep make_ast in here, because it can throw errors too
682 my $ast = make_ast(tokenize([split('', $input)]), []);
683 my ($result, $new_scope) = eval_all_expr($ast, [], $scope);
684 print(lisp_string($result, 'repl-mode') . "\n");
685 @_ = ($new_scope);
686 } or do {
687 my $error= $@ || "error";
688 print($error);
689 };
690
691 goto &repl;
692 }
693
694 sub main{
695 my $environment_copy = {%{$environment}};
696 if (scalar(@ARGV) < 1) {
697 print("welcome to lip, the really shitty lisp\n");
698 return repl($environment_copy);
699 }
700 else {
701 # === normal ===================================================
702 # old =====
703 #my $ast = make_ast(tokenize_file($ARGV[0]), []);
704 #return eval_all_expr($ast, [], $environment_copy);
705 # new =====
706 # list all built-in functions, and std.lip functions
707 if ($ARGV[0] eq 'functions') {
708 my (undef, $new_scope) = load_file("std.lip", $environment_copy);
709 for (sort(keys %$new_scope)) {
710 print($_ . "\n");
711 }
712 }
713 else {
714 return load_file($ARGV[0], $environment_copy);
715 }
716 # === end normal ===================================================
717
718 # === begin random test ========================================
719 # my $ast = make_ast(tokenize_file($ARGV[0]), []);
720 # my ($result, $env) = eval_all_expr($ast, [], $environment_copy);
721 # ##pp($env);
722 # print(lisp_string($result), "\n");
723 # === end random test ==========================================
724 }
725 }
726
727 main();