1 /* -*- C++ -*-
2 // -------------------------------------------------------------------
3 // MiniLisp - Very small lisp interpreter to demonstrate MiniExp.
4 // Copyright (c) 2005 Leon Bottou
5 //
6 // This software is subject to, and may be distributed under, the
7 // GNU General Public License, either Version 2 of the license,
8 // or (at your option) any later version. The license should have
9 // accompanied the software or you may obtain a copy of the license
10 // from the Free Software Foundation at http://www.fsf.org .
11 //
12 // This program is distributed in the hope that it will be useful,
13 // but WITHOUT ANY WARRANTY; without even the implied warranty of
14 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 // GNU General Public License for more details.
16 // -------------------------------------------------------------------
17 */
18
19 #include <stdlib.h>
20 #include <stdio.h>
21 #include <string.h>
22 #include <signal.h>
23 #include <ctype.h>
24 #include <math.h>
25
26 #include "miniexp.h"
27
28 #define CAT(a,b) __CAT(a,b)
29 #define __CAT(a,b) a ## b
30
31 miniexp_t s_quote = miniexp_symbol("quote");
32 miniexp_t s_true = miniexp_symbol("t");
33
34 /* ------------ error */
35
36 #ifdef __GNUC__
37 void error(const char *msg, miniexp_t v=0) __attribute__ ((noreturn));
38 #else
39 void error(const char *msg, miniexp_t v=0);
40 #endif
41
42 void
error(const char * msg,miniexp_t v)43 error(const char *msg, miniexp_t v)
44 {
45 if (msg)
46 printf("ERROR: %s", msg);
47 else
48 printf("BREAK");
49 if (v)
50 {
51 printf(": ");
52 miniexp_prin(v);
53 }
54 printf("\n");
55 throw 0;
56 }
57
58
59
60 /* ------------ environment */
61
62 miniexp_t
lookup(miniexp_t var,miniexp_t env)63 lookup(miniexp_t var, miniexp_t env)
64 {
65 while (miniexp_consp(env))
66 {
67 miniexp_t a = miniexp_car(env);
68 if (miniexp_car(a) == var)
69 return a;
70 env = miniexp_cdr(env);
71 }
72 return 0;
73 }
74
75 minivar_t globalenv;
76
77 void
defvar(miniexp_t s,miniexp_t w=0)78 defvar(miniexp_t s, miniexp_t w = 0)
79 {
80 minivar_t v;
81 if (! globalenv)
82 {
83 minivar_t a = miniexp_cons(s_true, s_true);
84 globalenv = miniexp_cons(a, 0);
85 }
86 if (! miniexp_symbolp(s))
87 error("defvar: not a symbol", s);
88 miniexp_t a = lookup(s, globalenv);
89 if (a && w)
90 {
91 printf("WARNING: redefining '%s\n", miniexp_to_name(s));
92 miniexp_rplacd(a, w);
93 }
94 else
95 {
96 v = miniexp_cons(s, w);
97 v = miniexp_cons(v, miniexp_cdr(globalenv));
98 miniexp_rplacd(globalenv, v);
99 }
100 }
101
102
103 /* ------------ evaluate */
104
105 static bool break_request = false;
106
107 struct callable_t : public miniobj_t
108 {
109 MINIOBJ_DECLARE(callable_t,miniobj_t,"callable");
110 virtual miniexp_t call(miniexp_t args, miniexp_t env,
111 bool apply=false) = 0;
112 };
113
114 MINIOBJ_IMPLEMENT(callable_t,miniobj_t,"callable");
115
116 miniexp_t
evaluate(miniexp_t expr,miniexp_t env)117 evaluate(miniexp_t expr, miniexp_t env)
118 {
119 if (miniexp_symbolp(expr))
120 {
121 miniexp_t a = lookup(expr,env);
122 if (! a)
123 error ("eval: undefined variable", expr);
124 return miniexp_cdr(a);
125 }
126 else if (miniexp_consp(expr))
127 {
128 miniexp_t s = miniexp_car(expr);
129 minivar_t xs = evaluate(s, env);
130 miniobj_t *obj = miniexp_to_obj(xs);
131 if (break_request)
132 error(0);
133 if (obj && obj->isa(callable_t::classname))
134 return ((callable_t*)obj)->call(miniexp_cdr(expr), env);
135 error("apply: cannot apply this object", xs);
136 }
137 else
138 return expr;
139 }
140
141 miniexp_t
evaluate_progn(miniexp_t exprs,miniexp_t env)142 evaluate_progn(miniexp_t exprs, miniexp_t env)
143 {
144 minivar_t v;
145 while (miniexp_consp(exprs))
146 {
147 v = evaluate(miniexp_car(exprs),env);
148 exprs = miniexp_cdr(exprs);
149 }
150 if (exprs)
151 v = evaluate(exprs,env);
152 return v;
153 }
154
155 miniexp_t
evaluate_list(miniexp_t l,miniexp_t env)156 evaluate_list(miniexp_t l, miniexp_t env)
157 {
158 minivar_t v;
159 minivar_t ll = 0;
160 miniexp_t lp = ll;
161 if (miniexp_consp(l))
162 {
163 v = evaluate(miniexp_car(l), env);
164 lp = ll = miniexp_cons(v, 0);
165 l = miniexp_cdr(l);
166 }
167 while (miniexp_consp(l))
168 {
169 v = evaluate(miniexp_car(l), env);
170 miniexp_rplacd(lp, miniexp_cons(v, 0));
171 lp = miniexp_cdr(lp);
172 l = miniexp_cdr(l);
173 }
174 if (l)
175 {
176 v = evaluate(l, env);
177 if (lp)
178 miniexp_rplacd(lp, v);
179 else
180 ll = v;
181 }
182 return ll;
183 }
184
185
186 /* ------------ special forms */
187
188 class specialform_t : public callable_t
189 {
190 typedef miniexp_t (*fptr_t)(miniexp_t, miniexp_t);
191 fptr_t fptr;
192 public:
193 specialform_t(const char *name, fptr_t fptr);
194 MINIOBJ_DECLARE(specialform_t,callable_t,"specialform");
195 virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);
196 };
197
198 MINIOBJ_IMPLEMENT(specialform_t,callable_t,"specialform");
199
specialform_t(const char * name,fptr_t fptr)200 specialform_t::specialform_t(const char *name, fptr_t fptr)
201 : fptr(fptr)
202 {
203 miniexp_t s = miniexp_symbol(name);
204 minivar_t v = miniexp_object(this);
205 defvar(s, v);
206 }
207
208 miniexp_t
call(miniexp_t args,miniexp_t env,bool)209 specialform_t::call(miniexp_t args, miniexp_t env, bool)
210 {
211 return (*fptr)(args, env);
212 }
213
214 #define DEFSPECIAL(s, n) \
215 miniexp_t CAT(f_,n)(miniexp_t, miniexp_t);\
216 specialform_t *CAT(p_,n) = new specialform_t(s, CAT(f_,n));\
217 miniexp_t CAT(f_,n)(miniexp_t expr, miniexp_t env)
218
219
220
221
222 /* ------------ primitives */
223
224 class primitive_t : public callable_t
225 {
226 typedef miniexp_t (*fptr_t)(int, miniexp_t*, miniexp_t);
227 fptr_t fptr;
228 const int args;
229 const int optargs;
230 public:
231 primitive_t(const char *name, fptr_t fptr, int a, int o);
232 MINIOBJ_DECLARE(primitive_t,callable_t,"primitive");
233 virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);
234 };
235
236 MINIOBJ_IMPLEMENT(primitive_t,callable_t,"primitive");
237
primitive_t(const char * n,fptr_t f,int a,int o)238 primitive_t::primitive_t(const char *n, fptr_t f, int a, int o)
239 : fptr(f), args(a), optargs(o)
240 {
241 miniexp_t s = miniexp_symbol(n);
242 minivar_t v = miniexp_object(this);
243 defvar(s, v);
244 }
245
246 miniexp_t
call(miniexp_t args,miniexp_t env,bool apply)247 primitive_t::call(miniexp_t args, miniexp_t env, bool apply)
248 {
249 int argc = miniexp_length(args);
250 if (argc < this->args)
251 error("apply(primitive): not enough arguments");
252 if (argc > this->args + this->optargs)
253 error("apply(primitive): too many arguments");
254 minivar_t xargs = apply ? args : evaluate_list(args, env);
255 miniexp_t *argv = new miniexp_t[argc];
256 miniexp_t a = xargs;
257 argc = 0;
258 while (miniexp_consp(a))
259 {
260 argv[argc++] = miniexp_car(a);
261 a = miniexp_cdr(a);
262 }
263 minivar_t v;
264 try
265 { v = (*fptr)(argc, argv, env); }
266 catch(...)
267 { delete [] argv; throw; }
268 delete [] argv;
269 return v;
270 }
271
272 #define DEFUN(s, n,a,o) \
273 miniexp_t CAT(f_,n)(int argc, miniexp_t *argv, miniexp_t env);\
274 primitive_t *CAT(p_,n) = new primitive_t(s, CAT(f_,n), a, o);\
275 miniexp_t CAT(f_,n)(int argc, miniexp_t *argv, miniexp_t env)
276
277
278 /* ------- functions */
279
280 class function_t : public callable_t
281 {
282 protected:
283 miniexp_t args;
284 miniexp_t body;
285 miniexp_t env;
286 static void check_args(miniexp_t a);
287 static void match_args(miniexp_t a, miniexp_t v, miniexp_t &env);
288 public:
289 function_t(miniexp_t, miniexp_t, miniexp_t);
290 MINIOBJ_DECLARE(function_t,callable_t,"function");
291 virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);
292 virtual void mark(minilisp_mark_t action);
293 virtual miniexp_t funcdef(miniexp_t name=0);
294 };
295
296 MINIOBJ_IMPLEMENT(function_t,callable_t,"function");
297
298 void
check_args(miniexp_t a)299 function_t::check_args(miniexp_t a)
300 {
301 again:
302 if (miniexp_symbolp(a) || !a)
303 return;
304 if (miniexp_listp(a))
305 {
306 check_args(miniexp_car(a));
307 a = miniexp_cdr(a);
308 goto again;
309 }
310 error("lambda: illegal formal arguments");
311 }
312
313 void
match_args(miniexp_t a,miniexp_t v,miniexp_t & env)314 function_t::match_args(miniexp_t a, miniexp_t v, miniexp_t &env)
315 {
316 again:
317 if (miniexp_symbolp(a))
318 {
319 minivar_t x = miniexp_cons(a,v);
320 env = miniexp_cons(x, env);
321 return;
322 }
323 if (miniexp_consp(a))
324 {
325 if (! miniexp_consp(v))
326 error("apply: not enough arguments", a);
327 match_args(miniexp_car(a), miniexp_car(v), env);
328 a = miniexp_cdr(a);
329 v = miniexp_cdr(v);
330 goto again;
331 }
332 if (v)
333 error("apply: too many arguments", v);
334 }
335
function_t(miniexp_t a,miniexp_t b,miniexp_t e)336 function_t::function_t(miniexp_t a, miniexp_t b, miniexp_t e)
337 : args(a), body(b), env(e)
338 {
339 check_args(a);
340 }
341
342 miniexp_t
call(miniexp_t args,miniexp_t env,bool apply)343 function_t::call(miniexp_t args, miniexp_t env, bool apply)
344 {
345 minivar_t xargs = apply ? args : evaluate_list(args, env);
346 minivar_t nenv = this->env;
347 match_args(this->args, xargs, nenv);
348 return evaluate_progn(body, nenv);
349 }
350
351 void
mark(minilisp_mark_t action)352 function_t::mark(minilisp_mark_t action)
353 {
354 action(&args);
355 action(&body);
356 action(&env);
357 }
358
359 miniexp_t
funcdef(miniexp_t name)360 function_t::funcdef(miniexp_t name)
361 {
362 if (name)
363 {
364 miniexp_t d = miniexp_symbol("defun");
365 miniexp_t a = miniexp_cons(name, args);
366 return miniexp_cons(d, miniexp_cons(a, body));
367 }
368 else
369 {
370 miniexp_t d = miniexp_symbol("lambda");
371 return miniexp_cons(d,miniexp_cons(args,body));
372 }
373 }
374
375
376 /* ------- macros */
377
378 class macrofunction_t : public function_t
379 {
380 public:
381 macrofunction_t(miniexp_t a, miniexp_t b, miniexp_t e);
382 MINIOBJ_DECLARE(macrofunction_t,function_t,"macrofunction");
383 virtual miniexp_t call(miniexp_t args, miniexp_t env, bool);
384 virtual miniexp_t funcdef(miniexp_t name=0);
385 };
386
387 MINIOBJ_IMPLEMENT(macrofunction_t,function_t,"macrofunction");
388
macrofunction_t(miniexp_t a,miniexp_t b,miniexp_t e)389 macrofunction_t::macrofunction_t(miniexp_t a, miniexp_t b, miniexp_t e)
390 : function_t(a,b,e)
391 {
392 }
393
394 miniexp_t
call(miniexp_t args,miniexp_t env,bool)395 macrofunction_t::call(miniexp_t args, miniexp_t env, bool)
396 {
397 minivar_t nenv = this->env;
398 match_args(this->args, args, nenv);
399 minivar_t e = evaluate_progn(body, nenv);
400 return evaluate(e, env);
401 }
402
403 miniexp_t
funcdef(miniexp_t name)404 macrofunction_t::funcdef(miniexp_t name)
405 {
406 if (name)
407 {
408 miniexp_t d = miniexp_symbol("defmacro");
409 miniexp_t a = miniexp_cons(name, args);
410 return miniexp_cons(d, miniexp_cons(a, body));
411 }
412 else
413 {
414 miniexp_t d = miniexp_symbol("mlambda");
415 return miniexp_cons(d, miniexp_cons(args, body));
416 }
417 }
418
419 /* ------------ define special forms */
420
421 DEFSPECIAL("progn",progn)
422 {
423 return evaluate_progn(expr, env);
424 }
425
426 DEFSPECIAL("list",list)
427 {
428 return evaluate_list(expr, env);
429 }
430
431 DEFSPECIAL("if",if)
432 {
433 if (evaluate(miniexp_car(expr), env))
434 return evaluate(miniexp_cadr(expr), env);
435 return evaluate_progn(miniexp_cddr(expr), env);
436 }
437
438 DEFSPECIAL("setq",setq)
439 {
440 if (miniexp_cddr(expr) || !miniexp_consp(miniexp_cdr(expr)))
441 error("setq: syntax error");
442 miniexp_t a = lookup(miniexp_car(expr),env);
443 if (! a)
444 error ("setq: undefined variable", miniexp_car(expr));
445 minivar_t v = evaluate(miniexp_cadr(expr), env);
446 miniexp_rplacd(a,v);
447 return v;
448 }
449
450 DEFSPECIAL("defvar",defvar)
451 {
452 if (miniexp_cddr(expr))
453 error("defvar: syntax error");
454 minivar_t v = evaluate(miniexp_cadr(expr), env);
455 defvar(miniexp_car(expr), v);
456 return miniexp_car(expr);
457 }
458
459 DEFSPECIAL("let",let)
460 {
461 miniexp_t v = miniexp_car(expr);
462 minivar_t nenv = env;
463 minivar_t p, w;
464 while (miniexp_consp(v))
465 {
466 miniexp_t a = miniexp_car(v);
467 v = miniexp_cdr(v);
468 if (! (miniexp_consp(a) &&
469 miniexp_symbolp(miniexp_car(a)) &&
470 !miniexp_cddr(a)))
471 error("let: syntax error");
472 w = evaluate(miniexp_cadr(a), env);
473 p = miniexp_cons(miniexp_car(a), w);
474 nenv = miniexp_cons(p, nenv);
475 }
476 return evaluate_progn(miniexp_cdr(expr), nenv);
477 }
478
479 DEFSPECIAL("letrec",letrec)
480 {
481 miniexp_t v = miniexp_car(expr);
482 minivar_t nenv = env;
483 minivar_t p, w;
484 while (miniexp_consp(v))
485 {
486 miniexp_t a = miniexp_car(v);
487 v = miniexp_cdr(v);
488 if (! (miniexp_consp(a) &&
489 miniexp_symbolp(miniexp_car(a)) &&
490 !miniexp_cddr(a)))
491 error("let: syntax error");
492 minivar_t p = miniexp_cons(miniexp_car(a), 0);
493 nenv = miniexp_cons(p, nenv);
494 }
495 v = miniexp_car(expr);
496 while (miniexp_consp(v))
497 {
498 miniexp_t a = miniexp_car(v);
499 v = miniexp_cdr(v);
500 w = evaluate(miniexp_cadr(a), nenv);
501 p = lookup(miniexp_car(a), nenv);
502 miniexp_rplacd(p,w);
503 }
504 return evaluate_progn(miniexp_cdr(expr), nenv);
505 }
506
507 DEFSPECIAL("lambda",lambda)
508 {
509 miniexp_t args = miniexp_car(expr);
510 miniexp_t body = miniexp_cdr(expr);
511 function_t *f = new function_t(args, body, env);
512 return miniexp_object(f);
513 }
514
515 DEFSPECIAL("mlambda",mlambda)
516 {
517 miniexp_t args = miniexp_car(expr);
518 miniexp_t body = miniexp_cdr(expr);
519 function_t *f = new macrofunction_t(args, body, env);
520 return miniexp_object(f);
521 }
522
523 DEFSPECIAL("quote",quote)
524 {
525 if (miniexp_cdr(expr))
526 error("quote: syntax error");
527 return miniexp_car(expr);
528 }
529
530 DEFSPECIAL("while",while)
531 {
532 if (! miniexp_consp(expr))
533 error("while: syntax error");
534 minivar_t v;
535 while (evaluate(miniexp_car(expr), env))
536 v = evaluate_progn(miniexp_cdr(expr), env);
537 return v;
538 }
539
540 /* ------------ define primitive */
541
542 DEFUN("nullp",nullp,1,0) {
543 return (!argv[0]) ? s_true : 0;
544 }
545
546 DEFUN("listp",listp,1,0) {
547 return miniexp_listp(argv[0]) ? s_true : 0;
548 }
549
550 DEFUN("consp",consp,1,0) {
551 return miniexp_consp(argv[0]) ? s_true : 0;
552 }
553
554 DEFUN("numberp",numberp,1,0) {
555 return miniexp_numberp(argv[0]) ? s_true : 0;
556 }
557
558 DEFUN("doublep",doublep,1,0) {
559 return miniexp_doublep(argv[0]) ? s_true : 0;
560 }
561
562 DEFUN("objectp",objectp,1,0) {
563 return miniexp_objectp(argv[0]) ? s_true : 0;
564 }
565
566 DEFUN("symbolp",symbolp,1,0) {
567 return miniexp_symbolp(argv[0]) ? s_true : 0;
568 }
569
570 DEFUN("stringp",stringp,1,0) {
571 return miniexp_stringp(argv[0]) ? s_true : 0;
572 }
573
574 DEFUN("classof",classof,1,0) {
575 return miniexp_classof(argv[0]);
576 }
577
578 DEFUN("car",car,1,0) {
579 return miniexp_car(argv[0]);
580 }
581
582 DEFUN("cdr",cdr,1,0) {
583 return miniexp_cdr(argv[0]);
584 }
585
586 DEFUN("caar",caar,1,0) {
587 return miniexp_caar(argv[0]);
588 }
589
590 DEFUN("cadr",cadr,1,0) {
591 return miniexp_cadr(argv[0]);
592 }
593
594 DEFUN("cdar",cdar,1,0) {
595 return miniexp_cdar(argv[0]);
596 }
597
598 DEFUN("cddr",cddr,1,0) {
599 return miniexp_cddr(argv[0]);
600 }
601
602 DEFUN("length",length,1,0) {
603 return miniexp_number(miniexp_length(argv[0]));
604 }
605
606 DEFUN("reverse",reverse,1,0) {
607 return miniexp_reverse(argv[0]);
608 }
609
610 DEFUN("cons",cons,2,0) {
611 return miniexp_cons(argv[0],argv[1]);
612 }
613
614 DEFUN("nth",nth,2,0) {
615 if (! miniexp_numberp(argv[0]))
616 error("nth: integer number expected");
617 return miniexp_nth(miniexp_to_int(argv[0]), argv[1]);
618 }
619
620 DEFUN("rplaca",rplaca,2,0) {
621 return miniexp_rplaca(argv[0],argv[1]);
622 }
623
624 DEFUN("rplacd",rplacd,2,0) {
625 return miniexp_rplacd(argv[0],argv[1]);
626 }
627
628 DEFUN("abs",abs,1,0) {
629 return miniexp_double(fabs(miniexp_to_double(argv[0])));
630 }
631
632 DEFUN("+",plus,0,9999) {
633 double s = 0;
634 for (int i=0; i<argc; i++)
635 {
636 if (!miniexp_doublep(argv[i]))
637 error("+: number expected");
638 s += miniexp_to_double(argv[i]);
639 }
640 return miniexp_double(s);
641 }
642
643 DEFUN("*",times,0,9999) {
644 double s = 1;
645 for (int i=0; i<argc; i++)
646 {
647 if (!miniexp_doublep(argv[i]))
648 error("*: number expected");
649 s *= miniexp_to_double(argv[i]);
650 }
651 return miniexp_double(s);
652 }
653
654 DEFUN("-",minus,1,9999) {
655 if (! miniexp_doublep(argv[0]))
656 error("-: number expected");
657 int i = 0;
658 double s = 0;
659 if (argc>1 && miniexp_doublep(argv[0]))
660 s = miniexp_to_double(argv[i++]);
661 while (i<argc && miniexp_doublep(argv[i]))
662 s -= miniexp_to_double(argv[i++]);
663 if (i < argc)
664 error("-: number expected", argv[i]);
665 return miniexp_double(s);
666 }
667
668 DEFUN("/",div,1,9999) {
669 if (! miniexp_doublep(argv[0]))
670 error("/: number expected");
671 int i = 0;
672 double s = 1;
673 if (argc>1 && miniexp_doublep(argv[0]))
674 s = miniexp_to_double(argv[i++]);
675 while (i<argc && miniexp_doublep(argv[i]) && miniexp_to_double(argv[i]))
676 s /= miniexp_to_double(argv[i++]);
677 if (i < argc)
678 {
679 if (miniexp_doublep(argv[i]))
680 error("/: division by zero", argv[i]);
681 else
682 error("/: number expected", argv[i]);
683 }
684 return miniexp_double(s);
685 }
686
687 DEFUN("==",equalequal,2,0) {
688 return (argv[0]==argv[1]) ? s_true : 0;
689 }
690
691 static bool
equal(miniexp_t a,miniexp_t b)692 equal(miniexp_t a, miniexp_t b)
693 {
694 if (a == b)
695 {
696 return true;
697 }
698 else if (miniexp_consp(a) && miniexp_consp(b))
699 {
700 return equal(miniexp_car(a),miniexp_car(b))
701 && equal(miniexp_cdr(a),miniexp_cdr(b));
702 }
703 else if (miniexp_doublep(a) && miniexp_doublep(b))
704 {
705 return miniexp_to_double(a) == miniexp_to_double(b);
706 }
707 else if (miniexp_stringp(a) && miniexp_stringp(b))
708 {
709 const char *sa, *sb;
710 int la = miniexp_to_lstr(a, &sa);
711 int lb = miniexp_to_lstr(b, &sb);
712 return (la == lb) && ! memcmp(sa, sb, la);
713 }
714 return false;
715 }
716
717 DEFUN("=",equal,2,0) {
718 return equal(argv[0],argv[1]) ? s_true : 0;
719 }
720
721 DEFUN("<>",notequal,2,0) {
722 return !equal(argv[0],argv[1]) ? s_true : 0;
723 }
724
725 static int
compare(miniexp_t a,miniexp_t b)726 compare(miniexp_t a, miniexp_t b)
727 {
728 if (miniexp_doublep(a) && miniexp_doublep(b))
729 {
730 double na = miniexp_to_double(a);
731 double nb = miniexp_to_double(b);
732 return (na < nb) ? -1 : (na > nb) ? +1 : 0;
733 }
734 else if (miniexp_stringp(a) && miniexp_stringp(b))
735 {
736 const char *sa, *sb;
737 int la = miniexp_to_lstr(a, &sa);
738 int lb = miniexp_to_lstr(b, &sb);
739 int r = memcmp(sa, sb, (la < lb) ? la : lb);
740 if (r == 0)
741 return (la < lb) ? -1 : (la > lb) ? +1 : 0;
742 return r;
743 }
744 else
745 error("compare: cannot rank these arguments");
746 }
747
748 DEFUN("<=",cmple,2,0) {
749 return (compare(argv[0],argv[1])<=0) ? s_true : 0;
750 }
751
752 DEFUN("<",cmplt,2,0) {
753 return (compare(argv[0],argv[1])<0) ? s_true : 0;
754 }
755
756 DEFUN(">=",cmpge,2,0) {
757 return (compare(argv[0],argv[1])>=0) ? s_true : 0;
758 }
759
760 DEFUN(">",cmpgt,2,0) {
761 return (compare(argv[0],argv[1])>0) ? s_true : 0;
762 }
763
764 DEFUN("floor",floor,1,0) {
765 if (! miniexp_doublep(argv[0]))
766 error("-: number expected");
767 return miniexp_double(floor(miniexp_to_double(argv[0])));
768 }
769
770 DEFUN("ceil",ceil,1,0) {
771 if (! miniexp_doublep(argv[0]))
772 error("-: number expected");
773 return miniexp_double(ceil(miniexp_to_double(argv[0])));
774 }
775
776 DEFUN("strlen",strlen,1,1) {
777 if (! miniexp_stringp(argv[0]))
778 error("strlen: string expected", argv[0]);
779 return miniexp_number(miniexp_to_lstr(argv[0], 0));
780 }
781
782 DEFUN("substr",substr,2,1) {
783 if (! miniexp_stringp(argv[0]))
784 error("substr: string expected", argv[0]);
785 const char *s;
786 int l = miniexp_to_lstr(argv[0], &s);
787 if (! miniexp_numberp(argv[1]))
788 error("substr: integer number expected", argv[1]);
789 int f = miniexp_to_double(argv[1]);
790 f = (l < f) ? l : (f < 0) ? l : f;
791 s += f;
792 l -= f;
793 if (argc>2)
794 {
795 if (! miniexp_numberp(argv[2]))
796 error("substr: integer number expected", argv[2]);
797 f = miniexp_to_double(argv[2]);
798 l = (f > l) ? l : (f < 0) ? 0 : f;
799 }
800 return miniexp_lstring(l,s);
801 }
802
803 DEFUN("concat",concat,0,9999) {
804 minivar_t l = 0;
805 for (int i=0; i<argc; i++)
806 if (miniexp_stringp(argv[i]))
807 l = miniexp_cons(argv[i],l);
808 else
809 error("concat: string expected", argv[i]);
810 l = miniexp_reverse(l);
811 return miniexp_concat(l);
812 }
813
814 DEFUN("prin",prin,1,9999) {
815 minivar_t v;
816 v = miniexp_prin(argv[0]);
817 for (int i=1; i<argc; i++)
818 {
819 minilisp_puts(" ");
820 v = miniexp_prin(argv[i]);
821 }
822 return v;
823 }
824
825 DEFUN("print",print,1,9999) {
826 minivar_t v;
827 v = miniexp_prin(argv[0]);
828 for (int i=1; i<argc; i++)
829 {
830 minilisp_puts(" ");
831 v = miniexp_prin(argv[i]);
832 }
833 minilisp_puts("\n");
834 return v;
835 }
836
837 DEFUN("pprint",pprint,1,1) {
838 int w = 72;
839 if (argc>1)
840 {
841 if (! miniexp_numberp(argv[1]))
842 error("pprint: second argument must be number");
843 w = miniexp_to_int(argv[1]);
844 }
845 return miniexp_pprint(argv[0], w);
846 }
847
848 DEFUN("pname",pname,1,1) {
849 int w = 0;
850 if (argc > 1)
851 {
852 if (! miniexp_numberp(argv[1]))
853 error("pprint: second argument must be number");
854 w = miniexp_to_int(argv[1]);
855 }
856 return miniexp_pname(argv[0],w);
857 }
858
859 DEFUN("gc",gc,0,0) {
860 minilisp_gc();
861 minilisp_info();
862 return 0;
863 }
864
865 DEFUN("info",info,0,0) {
866 minilisp_info();
867 return 0;
868 }
869
870 DEFUN("funcdef",funcdef,1,1) {
871 if (! miniexp_isa(argv[0], function_t::classname))
872 error("funcdef: expecting function", argv[0]);
873 if (argc>1 && ! miniexp_symbolp(argv[1]))
874 error("funcdef: expecting symbol", argv[1]);
875 function_t *f = (function_t*)miniexp_to_obj(argv[0]);
876 return f->funcdef(argc>1 ? argv[1] : 0);
877 }
878
879 DEFUN("vardef",vardef,1,0) {
880 miniexp_t a = lookup(argv[0],globalenv);
881 if (! a)
882 error("vardef: undefined global variable");
883 return miniexp_cdr(a);
884 }
885
886 DEFUN("eval",eval,1,0) {
887 return evaluate(argv[0],env);
888 }
889
890 DEFUN("apply",apply,2,0) {
891 miniobj_t *obj = miniexp_to_obj(argv[0]);
892 if (obj && obj->isa(callable_t::classname))
893 return ((callable_t*)obj)->call(argv[1], env, true);
894 error("apply: cannot apply this object", argv[0]);
895 }
896
897 DEFUN("error",error,1,1) {
898 if (!miniexp_stringp(argv[0]))
899 error("error: string expected", argv[0]);
900 error(miniexp_to_str(argv[0]), (argc>1) ? argv[1] : 0);
901 }
902
903 DEFUN("display",display,0,9999) {
904 for (int i=0; i<argc; i++)
905 {
906 minivar_t v = argv[i];
907 if (! miniexp_stringp(v))
908 v = miniexp_pname(v, 0);
909 minilisp_puts(miniexp_to_str(v));
910 }
911 return 0;
912 }
913
914 DEFUN("string->symbol",string2symbol,1,0) {
915 if (! miniexp_stringp(argv[0]))
916 error("string->symbol: string expected",argv[0]);
917 return miniexp_symbol(miniexp_to_str(argv[0]));
918 }
919
920 DEFUN("symbol->string",symbol2string,1,0) {
921 if (! miniexp_symbolp(argv[0]))
922 error("symbol->string: symbol expected",argv[0]);
923 return miniexp_string(miniexp_to_name(argv[0]));
924 }
925
926 DEFUN("printflags",printflags,1,0) {
927 if (! miniexp_numberp(argv[0]))
928 error("printflags: integer number expected");
929 minilisp_print_7bits = miniexp_to_int(argv[0]);
930 return argv[0];
931 }
932
933 /* ------------ special */
934
935 #if defined(_WIN32) || defined(__WIN64)
936 # include <process.h>
937
938 class thread_t : public miniobj_t
939 {
940 MINIOBJ_DECLARE(thread_t, miniobj_t, "thread");
941 private:
942 uintptr_t thr;
943 miniexp_t exp, env, res, run;
start(void * arg)944 static void start(void *arg) {
945 thread_t *pth = (thread_t*) arg;
946 try {
947 pth->res = evaluate(pth->exp, pth->env);
948 pth->run = miniexp_symbol("finished");
949 } catch(...) {
950 pth->run = miniexp_symbol("error");
951 } }
952 public:
thread_t(miniexp_t exp,miniexp_t env)953 thread_t(miniexp_t exp, miniexp_t env) : exp(exp), env(env), res(0), run(0) {
954 thr = _beginthread(thread_t::start, 0, (void*)this); }
mark(minilisp_mark_t action)955 void mark(minilisp_mark_t action) {
956 action(&exp); action(&env), action(&res); }
join()957 miniexp_t join() {
958 return (run) ? res : miniexp_dummy; }
status()959 miniexp_t status() { return run; }
~thread_t()960 ~thread_t() { if (!run) abort(); join(); }
961 };
962
963 MINIOBJ_IMPLEMENT(thread_t, miniobj_t, "thread");
964
965 DEFUN("thread",threadstart,1,0) {
966 return miniexp_object(new thread_t(argv[0],env));
967 }
968 DEFUN("threadp", threadtest,1,0) {
969 if (! miniexp_isa(argv[0], thread_t::classname)) return 0;
970 miniexp_t run = ((thread_t*)miniexp_to_obj(argv[0]))->status();
971 return (run) ? run : miniexp_symbol("running");
972 }
973 DEFUN("join",threadjoin,1,0) {
974 if (! miniexp_isa(argv[0], thread_t::classname))
975 error("join: thread expected");
976 return ((thread_t*)miniexp_to_obj(argv[0]))->join();
977 }
978 #endif
979
980 #ifdef HAVE_PTHREAD
981 # include <pthread.h>
982
983 class thread_t : public miniobj_t
984 {
985 MINIOBJ_DECLARE(thread_t, miniobj_t, "thread");
986 private:
987 pthread_t thr;
988 miniexp_t exp, env, res, run;
989 bool joined;
start(void * arg)990 static void* start(void *arg) {
991 thread_t *pth = (thread_t*) arg;
992 try {
993 pth->res = evaluate(pth->exp, pth->env);
994 pth->run = miniexp_symbol("finished");
995 return 0; }
996 catch(...) {
997 pth->run = miniexp_symbol("error");
998 return (void*)1; } }
999 public:
thread_t(miniexp_t exp,miniexp_t env)1000 thread_t(miniexp_t exp, miniexp_t env)
1001 : exp(exp), env(env), res(0), run(0), joined(false) {
1002 pthread_create(&this->thr, 0, thread_t::start, (void*)this); }
mark(minilisp_mark_t action)1003 void mark(minilisp_mark_t action) {
1004 action(&exp); action(&env), action(&res); }
join()1005 miniexp_t join() {
1006 if (! joined) pthread_join(thr, 0); joined=true;
1007 return (run) ? res : miniexp_dummy; }
status()1008 miniexp_t status() { return run; }
~thread_t()1009 ~thread_t() { if (!run) abort(); join(); }
1010 };
1011
1012 MINIOBJ_IMPLEMENT(thread_t, miniobj_t, "thread");
1013
1014 DEFUN("thread",threadstart,1,0) {
1015 return miniexp_object(new thread_t(argv[0],env));
1016 }
1017 DEFUN("threadp", threadtest,1,0) {
1018 if (! miniexp_isa(argv[0], thread_t::classname)) return 0;
1019 miniexp_t run = ((thread_t*)miniexp_to_obj(argv[0]))->status();
1020 return (run) ? run : miniexp_symbol("running");
1021 }
1022 DEFUN("join",threadjoin,1,0) {
1023 if (! miniexp_isa(argv[0], thread_t::classname))
1024 error("join: thread expected");
1025 return ((thread_t*)miniexp_to_obj(argv[0]))->join();
1026 }
1027
1028 #endif
1029
1030
1031 /* ------------ toplevel */
1032
1033 void
toplevel(FILE * inp,FILE * out,bool print)1034 toplevel(FILE *inp, FILE *out, bool print)
1035 {
1036 miniexp_io_t saved_io = miniexp_io;
1037 minilisp_set_output(out);
1038 minilisp_set_input(inp);
1039 for(;;)
1040 {
1041 minivar_t s = miniexp_read();
1042 if (s == miniexp_dummy)
1043 {
1044 if (feof(inp)) break;
1045 printf("ERROR: while parsing\n");
1046 break;
1047 }
1048 try
1049 {
1050 break_request = false;
1051 minivar_t v = evaluate(s, globalenv);
1052 if (print)
1053 {
1054 printf("= ");
1055 miniexp_print(v);
1056 }
1057 }
1058 catch(...)
1059 {
1060 }
1061 }
1062 miniexp_io = saved_io;
1063 }
1064
1065 miniexp_t
parse_comment(void)1066 parse_comment(void)
1067 {
1068 int c = minilisp_getc();
1069 while (c != EOF && c != '\n')
1070 c = minilisp_getc();
1071 return miniexp_nil;
1072 }
1073
1074 miniexp_t
parse_quote(void)1075 parse_quote(void)
1076 {
1077 minivar_t l = miniexp_read();
1078 if (l == miniexp_dummy)
1079 return miniexp_dummy;
1080 l = miniexp_cons(s_quote, miniexp_cons(l, miniexp_nil));
1081 return miniexp_cons(l,miniexp_nil);
1082 }
1083
1084 static void
sighandler(int signo)1085 sighandler(int signo)
1086 {
1087 break_request = true;
1088 signal(signo, sighandler);
1089 }
1090
1091 DEFUN("load",xload,1,0) {
1092 if (! miniexp_stringp(argv[0]))
1093 error("load: string expected");
1094 FILE *f = fopen(miniexp_to_str(argv[0]), "r");
1095 if (! f)
1096 error("load: cannot open file");
1097 toplevel(f, stdout, false);
1098 fclose(f);
1099 return miniexp_nil;
1100 }
1101
1102
1103 /* ------------ toplevel */
1104
1105 int
main()1106 main()
1107 {
1108 #ifdef DEBUG
1109 minilisp_debug(1);
1110 #endif
1111 minilisp_macrochar_parser[(int)';'] = parse_comment;
1112 minilisp_macrochar_parser[(int)'\''] = parse_quote;
1113 FILE *f = fopen("minilisp.in","r");
1114 if (f) {
1115 toplevel(f, stdout, false);
1116 fclose(f);
1117 } else
1118 printf("WARNING: cannot find 'minilisp.in'\n");
1119 signal(SIGINT, sighandler);
1120 while (! feof(stdin))
1121 toplevel(stdin, stdout, true);
1122 break_request = true;
1123 minilisp_finish();
1124 return 0;
1125 }
1126