* http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
*/
+#define STRING_MAX 2048
#define _GNU_SOURCE
#include <assert.h>
#include <ctype.h>
{
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);
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));
}
}
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);
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) {
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);
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
}
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;
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;
}
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
scm *
string (scm *x/*...*/)
{
- char buf[256] = "";
+ char buf[STRING_MAX] = "";
char *p = buf;
while (x != &scm_nil)
{
scm *
string_append (scm *x/*...*/)
{
- char buf[256] = "";
+ char buf[STRING_MAX] = "";
while (x != &scm_nil)
{
scm *
list_to_string (scm *x)
{
- char buf[256] = "";
+ char buf[STRING_MAX] = "";
char *p = buf;
while (x != &scm_nil)
{
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);
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);
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);
}
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)
{
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;
}
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') {
scm *
readstring ()
{
- char buf[256];
+ char buf[STRING_MAX];
char *p = buf;
int c = getchar ();
while (true) {
}
scm *
-readenv (scm *a)
+read_env (scm *a)
{
return readword (getchar (), 0, a);
}
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
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);
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
#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;
}
--- /dev/null
+;;; -*-scheme-*-
+
+(define welcome
+ "Mes 0.0
+Copyright (C) 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+
+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 <http://www.gnu.org/licenses/gpl.html>, 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 <http://www.gnu.org/licenses/>.
+")
+
+(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)
+()
projects / mes.git / commitdiff