From 2715e241e5e233358a4e73ceca5664d2aa9c04c8 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 16 Oct 2016 09:44:52 +0200 Subject: [PATCH] Add REPL. * mes.c (expand_macro_env, force_output): New function. Use STRING_MAX for string buffers throughout. (eval_env, eval_begin_env): Rename from eval, eval_begin. Update callers. * repl.mes: New file. * base.mes (list?): Move from scm.mes. * scm.mes (eval, apply, primitive-eval, expand-macro): New function. * GNUmakefile: New repl target. --- GNUmakefile | 3 ++ base.mes | 4 ++ mes.c | 112 ++++++++++++++++++++++-------------------- repl.mes | 139 ++++++++++++++++++++++++++++++++++++++++++++++++++++ scm.mes | 11 +++-- 5 files changed, 213 insertions(+), 56 deletions(-) create mode 100644 repl.mes diff --git a/GNUmakefile b/GNUmakefile index 45c6cac7..6647f290 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -54,6 +54,9 @@ else @echo skipping slooowwww syntax tests endif +repl: + cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-syntax.mes lib/srfi/srfi-0.scm lib/match.scm repl.mes /dev/stdin | ./mes + guile-check: guile -s <(cat base.mes lib/test.mes test/base.test) guile -s <(cat base.mes lib/test.mes test/closure.test) diff --git a/base.mes b/base.mes index 345ee4cc..c2755e67 100644 --- a/base.mes +++ b/base.mes @@ -68,6 +68,10 @@ (define-macro (let bindings . rest) (cons* 'simple-let bindings rest)) +(define (list? x) + (or (null? x) + (and (pair? x) (list? (cdr x))))) + (define (procedure? p) (cond ((builtin? p) #t) ((and (pair? p) (eq? (car p) 'lambda))) diff --git a/mes.c b/mes.c index a15933fe..c063201c 100644 --- a/mes.c +++ b/mes.c @@ -25,6 +25,7 @@ * http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf */ +#define STRING_MAX 2048 #define _GNU_SOURCE #include #include @@ -320,13 +321,13 @@ evcon (scm *c, scm *a) // internal { if (c == &scm_nil) return &scm_unspecified; scm *clause = car (c); - scm *expr = eval (car (clause), a); + scm *expr = eval_env (car (clause), a); if (expr != &scm_f) { if (cdr (clause) == &scm_nil) return expr; if (cddr (clause) == &scm_nil) - return eval (cadr (clause), a); - eval (cadr (clause), a); + return eval_env (cadr (clause), a); + eval_env (cadr (clause), a); return evcon (cons (cons (&scm_t, cddr (clause)), &scm_nil), a); } return evcon (cdr (c), a); @@ -337,8 +338,8 @@ scm * evlis (scm *m, scm *a) { if (m == &scm_nil) return &scm_nil; - if (m->type != PAIR) return eval (m, a); - scm *e = eval (car (m), a); + if (m->type != PAIR) return eval_env (m, a); + scm *e = eval_env (car (m), a); return cons (e, evlis (cdr (m), a)); } @@ -358,7 +359,7 @@ apply_env (scm *fn, scm *x, scm *a) } else if (fn->car == &symbol_lambda) { scm *p = pairlis (cadr (fn), x, a); - return eval (cons (&symbol_begin, cddr (fn)), cons (cons (&symbol_closure, p), p)); + return eval_env (cons (&symbol_begin, cddr (fn)), cons (cons (&symbol_closure, p), p)); } else if (fn->car == &symbol_closure) { scm *args = caddr (fn); @@ -366,30 +367,25 @@ apply_env (scm *fn, scm *x, scm *a) a = cdadr (fn); a = cdr (a); scm *p = pairlis (args, x, a); - return eval (cons (&symbol_begin, body), cons (cons (&symbol_closure, p), p)); + return eval_env (cons (&symbol_begin, body), cons (cons (&symbol_closure, p), p)); } else if ((macro = lookup_macro (car (fn), a)) != &scm_f) { - scm *r = apply_env (eval (macro, a), cdr (fn), a); - scm *e = eval (r, a); + scm *r = apply_env (eval_env (macro, a), cdr (fn), a); + scm *e = eval_env (r, a); return apply_env (e, x, a); } - scm *efn = eval (fn, a); + scm *efn = eval_env (fn, a); if (efn->type == NUMBER || efn == &scm_f || efn == &scm_t) assert (!"apply bool"); return apply_env (efn, x, a); } scm * -apply (scm *f, scm *x) +eval_env (scm *e, scm *a) { - return apply_env (f, x, &scm_nil); -} - -scm * -eval (scm *e, scm *a) -{ - scm *macro; if (internal_symbol_p (e) == &scm_t) return e; - //if (internal_primitive_p (e) == &scm_t) return e; + + e = expand_macro_env (e, a); + if (e->type == SYMBOL) { scm *y = assq (e, a); if (y == &scm_f) { @@ -405,18 +401,11 @@ eval (scm *e, scm *a) if (e->car == &symbol_quote) return cadr (e); if (e->car == &symbol_begin) - return eval_begin (e, a); + return eval_begin_env (e, a); if (e->car == &symbol_lambda) return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a)); if (e->car == &symbol_closure) return e; -#if SC_EXPAND - if ((macro = assq (&symbol_sc_expand, a)) != &scm_f) - if (cdr (macro) != &scm_f) - return eval (apply_env (cdr (macro), e, a), a); -#endif // SC_EXPAND - if ((macro = lookup_macro (car (e), a)) != &scm_f) - return eval (apply_env (macro, cdr (e), a), a); #if COND if (e->car == &symbol_cond) return evcon (e->cdr, a); @@ -428,10 +417,10 @@ eval (scm *e, scm *a) if (e->car == &symbol_define_macro) return define (e, a); if (e->car == &symbol_set_x) - return set_env_x (cadr (e), eval (caddr (e), a), a); + return set_env_x (cadr (e), eval_env (caddr (e), a), a); #if BUILTIN_QUASIQUOTE if (e->car == &symbol_unquote) - return eval (cadr (e), a); + return eval_env (cadr (e), a); if (e->car == &symbol_quasiquote) return eval_quasiquote (cadr (e), add_unquoters (a)); #endif //BUILTIN_QUASIQUOTE @@ -440,11 +429,21 @@ eval (scm *e, scm *a) } scm * -eval_begin (scm *e, scm *a) +expand_macro_env (scm *e, scm *a) +{ + scm *macro; + if (e->type == PAIR + && (macro = lookup_macro (e->car, a)) != &scm_f) + return expand_macro_env (apply_env (macro, e->cdr, a), a); + return e; +} + +scm * +eval_begin_env (scm *e, scm *a) { scm *r = &scm_unspecified; while (e != &scm_nil) { - r = eval (e->car, a); + r = eval_env (e->car, a); e = e->cdr; } return r; @@ -453,10 +452,10 @@ eval_begin (scm *e, scm *a) scm * if_env (scm *e, scm *a) { - if (eval (car (e), a) != &scm_f) - return eval (cadr (e), a); + if (eval_env (car (e), a) != &scm_f) + return eval_env (cadr (e), a); if (cddr (e) != &scm_nil) - return eval (caddr (e), a); + return eval_env (caddr (e), a); return &scm_unspecified; } @@ -467,10 +466,10 @@ eval_quasiquote (scm *e, scm *a) if (e == &scm_nil) return e; else if (atom_p (e) == &scm_t) return e; else if (eq_p (car (e), &symbol_unquote) == &scm_t) - return eval (cadr (e), a); + return eval_env (cadr (e), a); else if (e->type == PAIR && e->car->type == PAIR && eq_p (caar (e), &symbol_unquote_splicing) == &scm_t) - return append2 (eval (cadar (e), a), eval_quasiquote (cdr (e), a)); + return append2 (eval_env (cadar (e), a), eval_quasiquote (cdr (e), a)); return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a)); } #endif // BUILTIN_QUASIQUOTE @@ -710,7 +709,7 @@ make_vector (int n) scm * string (scm *x/*...*/) { - char buf[256] = ""; + char buf[STRING_MAX] = ""; char *p = buf; while (x != &scm_nil) { @@ -725,7 +724,7 @@ string (scm *x/*...*/) scm * string_append (scm *x/*...*/) { - char buf[256] = ""; + char buf[STRING_MAX] = ""; while (x != &scm_nil) { @@ -740,7 +739,7 @@ string_append (scm *x/*...*/) scm * list_to_string (scm *x) { - char buf[256] = ""; + char buf[STRING_MAX] = ""; char *p = buf; while (x != &scm_nil) { @@ -782,7 +781,7 @@ substring (scm *x/*...*/) assert (x->cdr->cdr->car->value <= end); end = x->cdr->cdr->car->value; } - char buf[256]; + char buf[STRING_MAX]; strncpy (buf, s+start, end - start); buf[end-start] = 0; return make_string (buf); @@ -901,7 +900,7 @@ lookup_char (int c, scm *a) char const * list2str (scm *l) // char* { - static char buf[256]; + static char buf[STRING_MAX]; char *p = buf; while (l != &scm_nil) { scm *c = car (l); @@ -945,7 +944,7 @@ scm* number_to_string (scm *x) { assert (x->type == NUMBER); - char buf[256]; + char buf[STRING_MAX]; sprintf (buf,"%d", x->value); return make_string (buf); } @@ -990,6 +989,15 @@ newline (scm *p/*...*/) return &scm_unspecified; } +scm * +force_output (scm *p/*...*/) +{ + int fd = 1; + if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value; + FILE *f = fd == 1 ? stdout : stderr; + fflush (f); +} + scm * display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote) { @@ -1153,7 +1161,7 @@ readword (int c, char *w, scm *a) if (c == '#' && !w && peek_char () == '(') {getchar (); return list_to_vector (readlist (a));} if (c == '#' && peek_char () == '(') {ungetchar (c); return lookup (w, a);} if (c == '#' && peek_char () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);} - char buf[256] = {0}; + char buf[STRING_MAX] = {0}; char ch = c; char *p = w ? w + strlen (w) : buf; *p = ch; @@ -1193,7 +1201,7 @@ read_character () } else if (c >= 'a' && c <= 'z' && peek_char () >= 'a' && peek_char () <= 'z') { - char buf[256]; + char buf[STRING_MAX]; char *p = buf; *p++ = c; while (peek_char () >= 'a' && peek_char () <= 'z') { @@ -1219,7 +1227,7 @@ read_character () scm * readstring () { - char buf[256]; + char buf[STRING_MAX]; char *p = buf; int c = getchar (); while (true) { @@ -1256,7 +1264,7 @@ readlist (scm *a) } scm * -readenv (scm *a) +read_env (scm *a) { return readword (getchar (), 0, a); } @@ -1407,8 +1415,8 @@ add_environment (scm *a, char const *name, scm *x) scm * mes_primitives () // internal { - primitives = cons (&scm_eval, primitives); - primitives = cons (&scm_apply, primitives); + primitives = cons (&scm_eval_env, primitives); + primitives = cons (&scm_apply_env, primitives); #if 0 //COND primitives = cons (&scm_evcon, primitives); #endif @@ -1494,11 +1502,11 @@ define (scm *x, scm *a) scm *e; scm *name = cadr (x); if (name->type != PAIR) - e = eval (caddr (x), cons (cons (cadr (x), cadr (x)), a)); + e = eval_env (caddr (x), cons (cons (cadr (x), cadr (x)), a)); else { name = car (name); scm *p = pairlis (cadr (x), cadr (x), a); - e = eval (make_lambda (cdadr (x), cddr (x)), p); + e = eval_env (make_lambda (cdadr (x), cddr (x)), p); } if (eq_p (car (x), &symbol_define_macro) == &scm_t) e = make_macro (e, name->name); @@ -1529,7 +1537,7 @@ scm * read_file (scm *e, scm *a) { if (e == &scm_nil) return e; - return cons (e, read_file (readenv (a), a)); + return cons (e, read_file (read_env (a), a)); } int @@ -1539,7 +1547,7 @@ main (int argc, char *argv[]) #if STATIC_PRIMITIVES mes_primitives (); #endif - display_ (stderr, eval (cons (&symbol_begin, read_file (readenv (a), a)), a)); + display_ (stderr, eval_env (cons (&symbol_begin, read_file (read_env (a), a)), a)); fputs ("", stderr); return 0; } diff --git a/repl.mes b/repl.mes new file mode 100644 index 00000000..ee4bd817 --- /dev/null +++ b/repl.mes @@ -0,0 +1,139 @@ +;;; -*-scheme-*- + +(define welcome + "Mes 0.0 +Copyright (C) 2016 Jan Nieuwenhuizen + +Mes comes with ABSOLUTELY NO WARRANTY; for details type `,show w'. +This program is free software, and you are welcome to redistribute it +under certain conditions; type `,show c' for details. + +Enter `,help' for help. +") + +(define warranty +"Mes is distributed WITHOUT ANY WARRANTY. The following +sections from the GNU General Public License, version 3, should +make that clear. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + +See , for more details. +") + +(define copying +"Mes is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3 of the License, or (at +your option) any later version. + +Mes is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with Mes. If not, see . +") + +(define help-commands + "Help Commands: + + ,expand SEXP - Expand SEXP + ,help - Show this help + ,show TOPIC - Show info on TOPIC [c, w] +") + +(define show-commands + "Show commands: + + ,show c - Show details on licensing; GNU GPLv3+ + ,show w - Show details on the lack of warranty +") + +(define (repl) + (let ((count 0) + (print-sexp? #t)) + + (define (expand) + (let ((sexp (read-env (current-module)))) + (when #t print-sexp? + (display "[sexp=") + (display sexp) + (display "]") + (newline)) + (display (expand-macro sexp)) + (newline))) + (define (help) (display help-commands)) + (define (show) + (define topic-alist `((#\newline . ,show-commands) + (#\c . ,copying) + (#\w . ,warranty))) + (let ((topic (read-char))) + (display (assoc-ref topic-alist topic)))) + (define (meta command) + (let ((command-alist `((expand . ,expand) + (help . ,help) + (show . ,show)))) + ((or (assoc-ref command-alist command) + (lambda () #f))))) + + (display welcome) + (let loop ((a (current-module))) + (display "mes> ") + (force-output) + (let ((sexp (read-env a))) + (when (not (eq? sexp '())) + (when print-sexp? + (display "[sexp=") + (display sexp) + (display "]") + (newline)) + (if (and (pair? sexp) (eq? (car sexp) (string->symbol "unquote"))) + (begin + (meta (cadr sexp)) + (loop a)) + (let ((e (eval-env sexp a))) + (display "NOT UNQUOTE") + (display (car sexp)) + (newline) + (if (eq? e *unspecified*) (loop a) + (let ((id (string->symbol (string-append "$" (number->string count))))) + (set! count (+ count 1)) + (display id) + (display " = ") + (display e) + (newline) + (loop (acons id e a))))))))))) +(repl) +() diff --git a/scm.mes b/scm.mes index de6990b6..358caee0 100755 --- a/scm.mes +++ b/scm.mes @@ -21,6 +21,10 @@ (define (cadddr x) (car (cdddr x))) (define (list . rest) rest) +(define eval eval-env) +(define (apply f x) (apply-env f x (current-module))) +(define (primitive-eval e) (eval-env e (current-module))) +(define (expand-macro e) (expand-macro-env e (current-module))) (define-macro (case val . args) (if (null? args) @@ -64,6 +68,9 @@ (define (make-vector n . x) (list->vector (apply make-list (cons n x)))) +(define (acons key value alist) + (cons (cons key value) alist)) + (define (assq-set! alist key val) (let ((entry (assq key alist))) (cond (entry (set-cdr! entry val) @@ -140,10 +147,6 @@ (z (if (< x y) x y))) (apply min (cons z (cdr rest)))))) -(define (list? x) - (or (null? x) - (and (pair? x) (list? (cdr x))))) - (define gensym (let ((counter 0)) (lambda (. rest)