snarf scm functions and environment.
This commit is contained in:
Jan Nieuwenhuizen
parent
f89507414e
commit
72d96eb485
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -4,3 +4,4 @@
|
|||
*~
|
||||
/boot.mes
|
||||
/mes
|
||||
/mes.h
|
||||
|
|
|
|||
17
GNUmakefile
17
GNUmakefile
|
|
@ -6,6 +6,23 @@ default: all
|
|||
|
||||
all: mes boot.mes
|
||||
|
||||
#mes.o: mes.c mes.h
|
||||
mes: mes.c mes.h
|
||||
|
||||
mes.h: mes.c GNUmakefile
|
||||
# $(info FUNCTIONS:$(FUNCTIONS))
|
||||
( echo '#if MES'; echo '#if MES' 1>&2;\
|
||||
grep -E '^(scm [*])*[a-z_]+ \(.*\)( {|$$)' $< | grep -Ev '\(.*(char |bool |int )' | sed -e 's,^scm [*],,' | sort |\
|
||||
while read f; do\
|
||||
fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\
|
||||
name=$$(echo $$fun | sed -e 's,^scm [\*],,' | grep -o '^[^ ]*');\
|
||||
scm_name=$$(echo $$name | sed -e 's,_p$$,?,' -e 's,^builtin_,,' -re 's,(.*)_$$,c:\1,' | sed -e 's,^less?$$,<,' -e 's,^minus$$,-,' -e 's,_,-,g');\
|
||||
args=$$(echo $$fun | grep -o 'scm [\*]' | wc -l);\
|
||||
echo "scm *$$fun;";\
|
||||
echo "scm scm_$$name = {FUNCTION$$args, .name=\"$$scm_name\", .function$$args=&$$name};";\
|
||||
echo "a = add_environment (a, \"$$scm_name\", &scm_$$name);" 1>&2;\
|
||||
done; echo '#endif'; echo '#endif' 1>&2) > $@ 2>environment.i
|
||||
|
||||
check: all
|
||||
./mes.test
|
||||
./mes.test ./mes
|
||||
|
|
|
|||
180
mes.c
180
mes.c
|
|
@ -28,7 +28,6 @@
|
|||
#define _GNU_SOURCE
|
||||
#include <assert.h>
|
||||
#include <ctype.h>
|
||||
#include <stdarg.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <stdlib.h>
|
||||
|
|
@ -66,6 +65,11 @@ typedef struct scm_t {
|
|||
};
|
||||
} scm;
|
||||
|
||||
#define MES 1
|
||||
#include "mes.h"
|
||||
|
||||
scm *display_helper (scm*, bool, char*, bool);
|
||||
|
||||
scm scm_nil = {ATOM, "()"};
|
||||
scm scm_dot = {ATOM, "."};
|
||||
scm scm_t = {ATOM, "#t"};
|
||||
|
|
@ -91,7 +95,6 @@ atom_p (scm *x)
|
|||
{
|
||||
return x->type == PAIR ? &scm_f : &scm_t;
|
||||
}
|
||||
scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom_p};
|
||||
|
||||
scm *
|
||||
car (scm *x)
|
||||
|
|
@ -148,26 +151,23 @@ scm *eval (scm*, scm*);
|
|||
|
||||
scm *display (scm*);
|
||||
|
||||
scm scm_quote;
|
||||
scm *
|
||||
quote (scm *x)
|
||||
{
|
||||
return cons (&scm_quote, x);
|
||||
return cons (&scm_symbol_quote, x);
|
||||
}
|
||||
|
||||
#if QUASIQUOTE
|
||||
scm scm_unquote;
|
||||
scm *
|
||||
unquote (scm *x)
|
||||
{
|
||||
return cons (&scm_unquote, x);
|
||||
return cons (&scm_symbol_unquote, x);
|
||||
}
|
||||
|
||||
scm scm_quasiquote;
|
||||
scm *
|
||||
quasiquote (scm *x)
|
||||
{
|
||||
return cons (&scm_quasiquote, x);
|
||||
return cons (&scm_symbol_quasiquote, x);
|
||||
}
|
||||
|
||||
scm *eval_quasiquote (scm *, scm *);
|
||||
|
|
@ -175,8 +175,6 @@ scm *eval_quasiquote (scm *, scm *);
|
|||
#endif
|
||||
|
||||
//Library functions
|
||||
scm scm_read;
|
||||
|
||||
|
||||
// Derived, non-primitives
|
||||
scm *caar (scm *x) {return car (car (x));}
|
||||
|
|
@ -189,32 +187,6 @@ scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
|
|||
scm *cadar (scm *x) {return car (cdr (car (x)));}
|
||||
scm *cddar (scm *x) {return cdr (cdr (car (x)));}
|
||||
scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
|
||||
scm scm_caar = {FUNCTION1, .name="caar ", .function1 = &caar };
|
||||
scm scm_cadr = {FUNCTION1, .name="cadr ", .function1 = &cadr };
|
||||
scm scm_cdar = {FUNCTION1, .name="cdar ", .function1 = &cdar };
|
||||
scm scm_cddr = {FUNCTION1, .name="cddr ", .function1 = &cddr };
|
||||
scm scm_caadr = {FUNCTION1, .name="caadr", .function1 = &caadr};
|
||||
scm scm_caddr = {FUNCTION1, .name="caddr", .function1 = &caddr};
|
||||
scm scm_cdadr = {FUNCTION1, .name="cdadr", .function1 = &cdadr};
|
||||
scm scm_cadar = {FUNCTION1, .name="cadar", .function1 = &cadar};
|
||||
scm scm_cddar = {FUNCTION1, .name="cddar", .function1 = &cddar};
|
||||
scm scm_cdddr = {FUNCTION1, .name="cdddr", .function1 = &cdddr};
|
||||
|
||||
scm *
|
||||
list (scm *x, ...)
|
||||
{
|
||||
va_list args;
|
||||
scm *lst = &scm_nil;
|
||||
|
||||
va_start (args, x);
|
||||
while (x != &scm_unspecified)
|
||||
{
|
||||
lst = cons (x, lst);
|
||||
x = va_arg (args, scm*);
|
||||
}
|
||||
va_end (args);
|
||||
return lst;
|
||||
}
|
||||
|
||||
scm* make_atom (char const *);
|
||||
|
||||
|
|
@ -235,7 +207,6 @@ pairlis (scm *x, scm *y, scm *a)
|
|||
return cons (cons (car (x), car (y)),
|
||||
pairlis (cdr (x), cdr (y), a));
|
||||
}
|
||||
scm scm_pairlis = {FUNCTION3, .name="pairlis", .function3 = &pairlis};
|
||||
|
||||
scm *
|
||||
assoc (scm *x, scm *a)
|
||||
|
|
@ -250,7 +221,6 @@ assoc (scm *x, scm *a)
|
|||
return car (a);
|
||||
return assoc (x, cdr (a));
|
||||
}
|
||||
scm scm_assoc = {FUNCTION2, .name="assoc", .function2 = &assoc};
|
||||
|
||||
scm *apply (scm*, scm*, scm*);
|
||||
scm *eval_ (scm*, scm*);
|
||||
|
|
@ -395,8 +365,6 @@ evcon (scm *c, scm *a)
|
|||
return evcon_ (c, a);
|
||||
}
|
||||
|
||||
scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon};
|
||||
|
||||
scm *
|
||||
evlis (scm *m, scm *a)
|
||||
{
|
||||
|
|
@ -410,29 +378,6 @@ evlis (scm *m, scm *a)
|
|||
scm *e = eval (car (m), a);
|
||||
return cons (e, evlis (cdr (m), a));
|
||||
}
|
||||
scm scm_evlis = {FUNCTION2, .name="evlis", .function2 = &evlis};
|
||||
|
||||
|
||||
//Primitives
|
||||
scm scm_car = {FUNCTION1, "car", .function1 = &car};
|
||||
scm scm_cdr = {FUNCTION1, "cdr", .function1 = &cdr};
|
||||
scm scm_cons = {FUNCTION2, "cons", .function2 = &cons};
|
||||
scm scm_cond = {FUNCTION2, "cond", .function2 = &evcon};
|
||||
scm scm_eq_p = {FUNCTION2, "eq", .function2 = &eq_p};
|
||||
scm scm_null_p = {FUNCTION1, "null", .function1 = &null_p};
|
||||
scm scm_pair_p = {FUNCTION1, "pair", .function1 = &pair_p};
|
||||
scm scm_quote = {FUNCTION1, "quote", .function1 = "e};
|
||||
|
||||
#if QUASIQUOTE
|
||||
scm scm_unquote = {FUNCTION1, "unquote", .function1 = &unquote};
|
||||
scm scm_quasiquote = {FUNCTION1, "quasiquote", .function1 = &quasiquote};
|
||||
#endif
|
||||
|
||||
scm scm_eval = {FUNCTION2, .name="eval", .function2 = &eval};
|
||||
scm scm_apply = {FUNCTION3, .name="apply", .function3 = &apply};
|
||||
|
||||
scm scm_apply_ = {FUNCTION3, .name="c:apply", .function3 = &apply_};
|
||||
scm scm_eval_ = {FUNCTION2, .name="c:eval", .function2 = &eval_};
|
||||
|
||||
//Helpers
|
||||
|
||||
|
|
@ -445,26 +390,18 @@ builtin_p (scm *x)
|
|||
|| x->type == FUNCTION3)
|
||||
? &scm_t : &scm_f;
|
||||
}
|
||||
scm scm_builtin_p = {FUNCTION1, .name="builtin", .function1 = &builtin_p};
|
||||
|
||||
scm *
|
||||
number_p (scm *x)
|
||||
{
|
||||
return x->type == NUMBER ? &scm_t : &scm_f;
|
||||
}
|
||||
scm scm_number_p = {FUNCTION1, .name="number", .function1 = &number_p};
|
||||
|
||||
scm *display_helper (scm*, bool, char*, bool);
|
||||
|
||||
scm *
|
||||
display (scm *x)
|
||||
{
|
||||
return display_helper (x, false, "", false);
|
||||
}
|
||||
scm scm_display = {FUNCTION1, .name="display", .function1 = &display};
|
||||
|
||||
scm *call (scm*, scm*);
|
||||
scm scm_call = {FUNCTION2, .name="call", .function2 = &call};
|
||||
|
||||
scm *
|
||||
call (scm *fn, scm *x)
|
||||
|
|
@ -498,8 +435,6 @@ append (scm *x, scm *y)
|
|||
assert (x->type == PAIR);
|
||||
return cons (car (x), append (cdr (x), y));
|
||||
}
|
||||
scm scm_append = {FUNCTION2, .name="append", .function2 = &append};
|
||||
|
||||
|
||||
scm *
|
||||
make_atom (char const *s)
|
||||
|
|
@ -572,7 +507,6 @@ builtin_lookup (scm *l, scm *a)
|
|||
{
|
||||
return lookup (list2str (l), a);
|
||||
}
|
||||
scm scm_lookup = {FUNCTION2, .name="lookup", .function2 = &builtin_lookup};
|
||||
|
||||
scm *
|
||||
cossa (scm *x, scm *a)
|
||||
|
|
@ -589,7 +523,6 @@ newline ()
|
|||
puts ("");
|
||||
return &scm_unspecified;
|
||||
}
|
||||
scm scm_newline = {FUNCTION0, .name="newline", .function0 = &newline};
|
||||
|
||||
scm *
|
||||
display_helper (scm *x, bool cont, char *sep, bool quote)
|
||||
|
|
@ -634,13 +567,13 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
|
|||
// READ
|
||||
|
||||
int
|
||||
ungetchar (int c)
|
||||
ungetchar (int c) //int
|
||||
{
|
||||
return ungetc (c, stdin);
|
||||
}
|
||||
|
||||
int
|
||||
peekchar ()
|
||||
peekchar () //int
|
||||
{
|
||||
int c = getchar ();
|
||||
ungetchar (c);
|
||||
|
|
@ -652,23 +585,20 @@ builtin_getchar ()
|
|||
{
|
||||
return make_number (getchar ());
|
||||
}
|
||||
scm scm_getchar = {FUNCTION0, .name="getchar", .function0 = &builtin_getchar};
|
||||
|
||||
scm*
|
||||
builtin_peekchar ()
|
||||
{
|
||||
return make_number (peekchar ());
|
||||
}
|
||||
scm scm_peekchar = {FUNCTION0, .name="peekchar", .function0 = &builtin_peekchar};
|
||||
|
||||
scm*
|
||||
builtin_ungetchar (scm* c)
|
||||
builtin_ungetchar (scm *c)
|
||||
{
|
||||
assert (c->type == NUMBER);
|
||||
ungetchar (c->value);
|
||||
return c;
|
||||
}
|
||||
scm scm_ungetchar = {FUNCTION1, .name="ungetchar", .function1 = &builtin_ungetchar};
|
||||
|
||||
int
|
||||
readcomment (int c)
|
||||
|
|
@ -740,7 +670,6 @@ readenv (scm *a)
|
|||
{
|
||||
return readword (getchar (), 0, a);
|
||||
}
|
||||
scm scm_readenv = {FUNCTION1, .name="readenv", .function1 = &readenv};
|
||||
|
||||
// Extras to make interesting program
|
||||
|
||||
|
|
@ -750,8 +679,6 @@ hello_world ()
|
|||
puts ("c: hello world");
|
||||
return &scm_unspecified;
|
||||
}
|
||||
scm scm_hello_world = {FUNCTION0, .name="hello-world", .function0 = &hello_world};
|
||||
|
||||
|
||||
scm *
|
||||
less_p (scm *a, scm *b)
|
||||
|
|
@ -783,9 +710,6 @@ minus (scm *a, scm *b)
|
|||
return r;
|
||||
}
|
||||
|
||||
scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p};
|
||||
scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus};
|
||||
|
||||
#if QUASIQUOTE
|
||||
scm *
|
||||
eval_quasiquote (scm *e, scm *a)
|
||||
|
|
@ -813,17 +737,16 @@ eval_quasiquote (scm *e, scm *a)
|
|||
return cdar (e);
|
||||
return cons (car (e), eval_quasiquote (cdr (e), a));
|
||||
}
|
||||
scm scm_eval_quasiquote = {FUNCTION2, .name="c:eval-quasiquote", .function2 = &eval_quasiquote};
|
||||
#endif
|
||||
|
||||
scm *
|
||||
add_environment (scm *a, char *name, scm* x)
|
||||
add_environment (scm *a, char *name, scm *x)
|
||||
{
|
||||
return cons (cons (make_atom (name), x), a);
|
||||
}
|
||||
|
||||
scm *
|
||||
initial_environment ()
|
||||
mes_environment ()
|
||||
{
|
||||
scm *a = &scm_nil;
|
||||
|
||||
|
|
@ -831,76 +754,19 @@ initial_environment ()
|
|||
a = add_environment (a, "#t", &scm_t);
|
||||
a = add_environment (a, "#f", &scm_f);
|
||||
a = add_environment (a, "*unspecified*", &scm_unspecified);
|
||||
|
||||
a = add_environment (a, "label", &scm_label);
|
||||
a = add_environment (a, "lambda", &scm_lambda);
|
||||
|
||||
a = add_environment (a, "atom", &scm_atom);
|
||||
a = add_environment (a, "car", &scm_car);
|
||||
a = add_environment (a, "cdr", &scm_cdr);
|
||||
a = add_environment (a, "cons", &scm_cons);
|
||||
a = add_environment (a, "cond", &scm_cond);
|
||||
a = add_environment (a, "eq", &scm_eq_p);
|
||||
|
||||
a = add_environment (a, "null", &scm_null_p);
|
||||
a = add_environment (a, "pair", &scm_pair_p);
|
||||
a = add_environment (a, "quote", &scm_quote);
|
||||
a = add_environment (a, "'", &scm_quote);
|
||||
|
||||
#if QUASIQUOTE
|
||||
a = add_environment (a, "quasiquote", &scm_quasiquote);
|
||||
a = add_environment (a, "unquote", &scm_unquote);
|
||||
a = add_environment (a, ",", &scm_unquote);
|
||||
a = add_environment (a, "`", &scm_quasiquote);
|
||||
a = add_environment (a, "eval-quasiquote", &scm_eval_quasiquote);
|
||||
#endif
|
||||
|
||||
a = add_environment (a, "evlis", &scm_evlis);
|
||||
a = add_environment (a, "evcon", &scm_evcon);
|
||||
a = add_environment (a, "pairlis", &scm_pairlis);
|
||||
a = add_environment (a, "assoc", &scm_assoc);
|
||||
|
||||
a = add_environment (a, "c:eval", &scm_eval_);
|
||||
a = add_environment (a, "c:apply", &scm_apply_);
|
||||
a = add_environment (a, "eval", &scm_eval);
|
||||
a = add_environment (a, "apply", &scm_apply);
|
||||
|
||||
a = add_environment (a, "getchar", &scm_getchar);
|
||||
a = add_environment (a, "peekchar", &scm_peekchar);
|
||||
a = add_environment (a, "ungetchar", &scm_ungetchar);
|
||||
a = add_environment (a, "lookup", &scm_lookup);
|
||||
|
||||
a = add_environment (a, "readenv", &scm_readenv);
|
||||
a = add_environment (a, "display", &scm_display);
|
||||
a = add_environment (a, "newline", &scm_newline);
|
||||
|
||||
a = add_environment (a, "builtin", &scm_builtin_p);
|
||||
a = add_environment (a, "number", &scm_number_p);
|
||||
a = add_environment (a, "call", &scm_call);
|
||||
|
||||
|
||||
a = add_environment (a, "hello-world", &scm_hello_world);
|
||||
a = add_environment (a, "<", &scm_less_p);
|
||||
a = add_environment (a, "-", &scm_minus);
|
||||
|
||||
// DERIVED
|
||||
a = add_environment (a, "caar", &scm_caar);
|
||||
a = add_environment (a, "cadr", &scm_cadr);
|
||||
a = add_environment (a, "cdar", &scm_cdar);
|
||||
a = add_environment (a, "cddr", &scm_cddr);
|
||||
a = add_environment (a, "caadr", &scm_caadr);
|
||||
a = add_environment (a, "caddr", &scm_caddr);
|
||||
a = add_environment (a, "cdadr", &scm_cdadr);
|
||||
a = add_environment (a, "cadar", &scm_cadar);
|
||||
a = add_environment (a, "cddar", &scm_cddar);
|
||||
a = add_environment (a, "cdddr", &scm_cdddr);
|
||||
|
||||
a = add_environment (a, "append", &scm_append);
|
||||
|
||||
//
|
||||
a = add_environment (a, "*macro*", &scm_nil);
|
||||
a = add_environment (a, "*dot*", &scm_dot);
|
||||
a = add_environment (a, "current-module", &scm_symbol_current_module);
|
||||
|
||||
a = add_environment (a, "'", &scm_quote);
|
||||
#if QUASIQUOTE
|
||||
a = add_environment (a, ",", &scm_unquote);
|
||||
a = add_environment (a, "`", &scm_quasiquote);
|
||||
#endif
|
||||
|
||||
#include "environment.i"
|
||||
|
||||
return a;
|
||||
}
|
||||
|
|
@ -966,14 +832,14 @@ loop (scm *r, scm *e, scm *a)
|
|||
int
|
||||
main (int argc, char *argv[])
|
||||
{
|
||||
scm *a = initial_environment ();
|
||||
scm *a = mes_environment ();
|
||||
display (loop (&scm_unspecified, readenv (a), a));
|
||||
newline ();
|
||||
return 0;
|
||||
}
|
||||
|
||||
scm *
|
||||
apply (scm* fn, scm *x, scm *a)
|
||||
apply (scm *fn, scm *x, scm *a)
|
||||
{
|
||||
#if DEBUG
|
||||
printf ("\nc:apply fn=");
|
||||
|
|
|
|||
106
mes.mes
106
mes.mes
|
|
@ -36,8 +36,8 @@
|
|||
;; (define (pairlis x y a)
|
||||
;; ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
|
||||
;; (cond
|
||||
;; ((null x) a)
|
||||
;; ((atom x) (cons (cons x y) a))
|
||||
;; ((null? x) a)
|
||||
;; ((atom? x) (cons (cons x y) a))
|
||||
;; (#t (cons (cons (car x) (car y))
|
||||
;; (pairlis (cdr x) (cdr y) a)))))
|
||||
|
||||
|
|
@ -45,8 +45,8 @@
|
|||
;; ;;(stderr "assoc x=~a\n" x)
|
||||
;; ;;(debug "assoc x=~a a=~a\n" x a)
|
||||
;; (cond
|
||||
;; ((null a) #f)
|
||||
;; ((eq (caar a) x) (car a))
|
||||
;; ((null? a) #f)
|
||||
;; ((eq? (caar a) x) (car a))
|
||||
;; (#t (assoc x (cdr a)))))
|
||||
|
||||
;; ;; Page 13
|
||||
|
|
@ -60,7 +60,7 @@
|
|||
;; single-statement cond
|
||||
;; ((eval (caar c) a) (eval (cadar c) a))
|
||||
((eval (caar c) a)
|
||||
(cond ((null (cddar c)) (eval (cadar c) a))
|
||||
(cond ((null? (cddar c)) (eval (cadar c) a))
|
||||
(#t (eval (cadar c) a)
|
||||
(evcon
|
||||
(cons (cons #t (cddar c)) '())
|
||||
|
|
@ -73,7 +73,7 @@
|
|||
;; (display m)
|
||||
;; (newline)
|
||||
(cond
|
||||
((null m) '())
|
||||
((null? m) '())
|
||||
(#t (cons (eval (car m) a) (evlis (cdr m) a)))))
|
||||
|
||||
|
||||
|
|
@ -84,33 +84,33 @@
|
|||
;; (display fn)
|
||||
;; (newline)
|
||||
;; (display 'builtin:)
|
||||
;; (display (builtin fn))
|
||||
;; (display (builtin? fn))
|
||||
;; (newline)
|
||||
;; (display 'x:)
|
||||
;; (display x)
|
||||
;; (newline)
|
||||
(cond
|
||||
((atom fn)
|
||||
((atom? fn)
|
||||
(cond
|
||||
((eq fn 'current-module) ;; FIXME
|
||||
((eq? fn 'current-module) ;; FIXME
|
||||
(c:apply current-module '() a))
|
||||
((builtin fn)
|
||||
((builtin? fn)
|
||||
(call fn x))
|
||||
(#t (apply (eval fn a) x a))))
|
||||
((eq (car fn) 'lambda)
|
||||
(cond ((null (cdr (cddr fn)))
|
||||
((eq? (car fn) 'lambda)
|
||||
(cond ((null? (cdr (cddr fn)))
|
||||
(eval (caddr fn) (pairlis (cadr fn) x a)))
|
||||
(#t
|
||||
(eval (caddr fn) (pairlis (cadr fn) x a))
|
||||
(apply (cons (car fn) (cons (cadr fn) (cdddr fn)))
|
||||
x
|
||||
(pairlis (cadr fn) x a)))))
|
||||
((eq (car fn) 'label) (apply (caddr fn) x (cons (cons (cadr fn)
|
||||
((eq? (car fn) 'label) (apply (caddr fn) x (cons (cons (cadr fn)
|
||||
(caddr fn)) a)))))
|
||||
|
||||
(define (eval e a)
|
||||
;;(debug "eval e=~a a=~a\n" e a)
|
||||
;;(debug "eval (atom ~a)=~a\n" e (atom e))
|
||||
;;(debug "eval (atom? ~a)=~a\n" e (atom? e))
|
||||
;; (display 'mes-eval:)
|
||||
;; (display e)
|
||||
;; (newline)
|
||||
|
|
@ -118,19 +118,19 @@
|
|||
;; (display a)
|
||||
;; (newline)
|
||||
(cond
|
||||
((number e) e)
|
||||
((eq e #t) #t)
|
||||
((eq e #f) #f)
|
||||
((atom e) (cdr (assoc e a)))
|
||||
((builtin e) e)
|
||||
((atom (car e))
|
||||
((number? e) e)
|
||||
((eq? e #t) #t)
|
||||
((eq? e #f) #f)
|
||||
((atom? e) (cdr (assoc e a)))
|
||||
((builtin? e) e)
|
||||
((atom? (car e))
|
||||
(cond
|
||||
((eq (car e) 'quote) (cadr e))
|
||||
((eq (car e) 'lambda) e)
|
||||
((eq (car e) 'unquote) (eval (cadr e) a))
|
||||
((eq (car e) 'quasiquote) (eval-quasiquote (cadr e) a))
|
||||
((eq (car e) 'cond) (evcon (cdr e) a))
|
||||
((pair (assoc (car e) (cdr (assoc '*macro* a))))
|
||||
((eq? (car e) 'quote) (cadr e))
|
||||
((eq? (car e) 'lambda) e)
|
||||
((eq? (car e) 'unquote) (eval (cadr e) a))
|
||||
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) a))
|
||||
((eq? (car e) 'cond) (evcon (cdr e) a))
|
||||
((pair? (assoc (car e) (cdr (assoc '*macro* a))))
|
||||
(c:eval
|
||||
(c:apply
|
||||
(cdr (assoc (car e) (cdr (assoc '*macro* a))))
|
||||
|
|
@ -144,12 +144,12 @@
|
|||
;; (display 'mes-eval-quasiquote:)
|
||||
;; (display e)
|
||||
;; (newline)
|
||||
(cond ((null e) e)
|
||||
((atom e) e)
|
||||
((atom (car e)) (cons (car e) (eval-quasiquote (cdr e) a)))
|
||||
((eq (caar e) 'unquote) (cons (eval (cadar e) a) '()))
|
||||
((eq (caar e) 'quote) (cons (cadar e) '()))
|
||||
((eq (caar e) 'quasiquote) (cons (cadar e) '()))
|
||||
(cond ((null? e) e)
|
||||
((atom? e) e)
|
||||
((atom? (car e)) (cons (car e) (eval-quasiquote (cdr e) a)))
|
||||
((eq? (caar e) 'unquote) (cons (eval (cadar e) a) '()))
|
||||
((eq? (caar e) 'quote) (cons (cadar e) '()))
|
||||
((eq? (caar e) 'quasiquote) (cons (cadar e) '()))
|
||||
(#t (cons (car e) (eval-quasiquote (cdr e) a)))))
|
||||
|
||||
;; readenv et al works, but slows down dramatically
|
||||
|
|
@ -160,31 +160,31 @@
|
|||
;; (display 'mes-readword:)
|
||||
;; (display c)
|
||||
;; (newline)
|
||||
(cond ((eq c -1) ;; eof
|
||||
(cond ((eq w '()) '())
|
||||
(cond ((eq? c -1) ;; eof
|
||||
(cond ((eq? w '()) '())
|
||||
(#t (lookup w a))))
|
||||
((eq c 10) ;; \n
|
||||
(cond ((eq w '()) (readword (getchar) w a))
|
||||
;; DOT ((eq w '(*dot*)) (car (readword (getchar) '() a)))
|
||||
((eq? c 10) ;; \n
|
||||
(cond ((eq? w '()) (readword (getchar) w a))
|
||||
;; DOT ((eq? w '(*dot*)) (car (readword (getchar) '() a)))
|
||||
(#t (lookup w a))))
|
||||
((eq c 32) ;; \space
|
||||
((eq? c 32) ;; \space
|
||||
(readword 10 w a))
|
||||
((eq c 40) ;; (
|
||||
(cond ((eq w '()) (readlis a))
|
||||
((eq? c 40) ;; (
|
||||
(cond ((eq? w '()) (readlis a))
|
||||
(#t (ungetchar c) (lookup w a))))
|
||||
((eq c 41) ;; )
|
||||
(cond ((eq w '()) (ungetchar c) w)
|
||||
((eq? c 41) ;; )
|
||||
(cond ((eq? w '()) (ungetchar c) w)
|
||||
(#t (ungetchar c) (lookup w a))))
|
||||
((eq c 39) ;; '
|
||||
(cond ((eq w '())
|
||||
((eq? c 39) ;; '
|
||||
(cond ((eq? w '())
|
||||
(cons (lookup (cons c '()) a)
|
||||
(cons (readword (getchar) w a) '())))
|
||||
(#t (ungetchar c) (lookup w a))))
|
||||
((eq c 59) ;; ;
|
||||
((eq? c 59) ;; ;
|
||||
(readcomment c)
|
||||
(readword 10 w a))
|
||||
((eq c 35) ;; #
|
||||
(cond ((eq (peekchar) 33) ;; !
|
||||
((eq? c 35) ;; #
|
||||
(cond ((eq? (peekchar) 33) ;; !
|
||||
(getchar)
|
||||
(readblock (getchar))
|
||||
(readword 10 w a))
|
||||
|
|
@ -195,27 +195,27 @@
|
|||
;; (display 'mes-readblock:)
|
||||
;; (display c)
|
||||
;; (newline)
|
||||
(cond ((eq c 33) (cond ((eq (peekchar) 35) (getchar))
|
||||
(cond ((eq? c 33) (cond ((eq? (peekchar) 35) (getchar))
|
||||
(#t (readblock (getchar)))))
|
||||
(#t (readblock (getchar)))))
|
||||
|
||||
(define (eat-whitespace)
|
||||
(cond ((eq (peekchar) 10) (getchar) (eat-whitespace))
|
||||
((eq (peekchar) 32) (getchar) (eat-whitespace))
|
||||
((eq (peekchar) 35) (getchar) (eat-whitespace))
|
||||
(cond ((eq? (peekchar) 10) (getchar) (eat-whitespace))
|
||||
((eq? (peekchar) 32) (getchar) (eat-whitespace))
|
||||
((eq? (peekchar) 35) (getchar) (eat-whitespace))
|
||||
(#t #t)))
|
||||
|
||||
(define (readlis a)
|
||||
;; (display 'mes-readlis:)
|
||||
;; (newline)
|
||||
(eat-whitespace)
|
||||
(cond ((eq (peekchar) 41) ;; )
|
||||
(cond ((eq? (peekchar) 41) ;; )
|
||||
(getchar)
|
||||
'())
|
||||
;; TODO *dot*
|
||||
(#t (cons (readword (getchar) '() a) (readlis a)))))
|
||||
|
||||
(define (readcomment c)
|
||||
(cond ((eq c 10) ;; \n
|
||||
(cond ((eq? c 10) ;; \n
|
||||
c)
|
||||
(#t (readcomment (getchar)))))
|
||||
|
|
|
|||
54
mes.scm
54
mes.scm
|
|
@ -81,7 +81,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|||
;;(define debug stderr)
|
||||
|
||||
;; TODO
|
||||
(define (atom x)
|
||||
(define (atom? x)
|
||||
(cond
|
||||
((guile:pair? x) #f)
|
||||
((guile:null? x) #f)
|
||||
|
|
@ -91,17 +91,33 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|||
(define car guile:car)
|
||||
(define cdr guile:cdr)
|
||||
(define cons guile:cons)
|
||||
(define eq guile:eq?)
|
||||
(define null guile:null?)
|
||||
(define pair guile:pair?)
|
||||
(define builtin guile:procedure?)
|
||||
(define number guile:number?)
|
||||
(define eq? guile:eq?)
|
||||
(define null? guile:null?)
|
||||
(define pair? guile:pair?)
|
||||
(define builtin? guile:procedure?)
|
||||
(define number? guile:number?)
|
||||
(define call guile:apply)
|
||||
|
||||
(include "mes.mes")
|
||||
|
||||
(define (pairlis x y a)
|
||||
;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
|
||||
(cond
|
||||
((null? x) a)
|
||||
((atom? x) (cons (cons x y) a))
|
||||
(#t (cons (cons (car x) (car y))
|
||||
(pairlis (cdr x) (cdr y) a)))))
|
||||
|
||||
(define (assoc x a)
|
||||
;;(stderr "assoc x=~a\n" x)
|
||||
;;(debug "assoc x=~a a=~a\n" x a)
|
||||
(cond
|
||||
((null? a) #f)
|
||||
((eq? (caar a) x) (car a))
|
||||
(#t (assoc x (cdr a)))))
|
||||
|
||||
(define (append x y)
|
||||
(cond ((null x) y)
|
||||
(cond ((null? x) y)
|
||||
(#t (cons (car x) (append (cdr x) y)))))
|
||||
|
||||
(define (eval-environment e a)
|
||||
|
|
@ -123,15 +139,15 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|||
|
||||
(*unspecified* . ,*unspecified*)
|
||||
|
||||
(atom . ,atom)
|
||||
(atom? . ,atom?)
|
||||
(car . ,car)
|
||||
(cdr . ,cdr)
|
||||
(cons . ,cons)
|
||||
(cond . ,evcon)
|
||||
(eq . ,eq)
|
||||
(eq? . ,eq?)
|
||||
|
||||
(null . ,null)
|
||||
(pair . ,guile:pair?)
|
||||
(null? . ,null?)
|
||||
(pair? . ,guile:pair?)
|
||||
;;(quote . ,quote)
|
||||
|
||||
(evlis . ,evlis)
|
||||
|
|
@ -146,8 +162,8 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|||
(display . ,guile:display)
|
||||
(newline . ,guile:newline)
|
||||
|
||||
(builtin . ,builtin)
|
||||
(number . ,number)
|
||||
(builtin? . ,builtin?)
|
||||
(number? . ,number?)
|
||||
(call . ,call)
|
||||
|
||||
(< . ,guile:<)
|
||||
|
|
@ -177,7 +193,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|||
(cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))
|
||||
|
||||
(define (mes-define x a)
|
||||
(if (atom (cadr x))
|
||||
(if (atom? (cadr x))
|
||||
(cons (cadr x) (eval (caddr x) a))
|
||||
(mes-define-lambda x a)))
|
||||
|
||||
|
|
@ -187,15 +203,15 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|||
(cdr (assoc '*macro* a)))))
|
||||
|
||||
(define (loop r e a)
|
||||
(cond ((null e) r)
|
||||
((eq e 'exit)
|
||||
(cond ((null? e) r)
|
||||
((eq? e 'exit)
|
||||
(apply (cdr (assoc 'loop a))
|
||||
(cons *unspecified* (cons #t (cons a '())))
|
||||
a))
|
||||
((atom e) (loop (eval e a) (readenv a) a))
|
||||
((eq (car e) 'define)
|
||||
((atom? e) (loop (eval e a) (readenv a) a))
|
||||
((eq? (car e) 'define)
|
||||
(loop *unspecified* (readenv a) (cons (mes-define e a) a)))
|
||||
((eq (car e) 'define-macro)
|
||||
((eq? (car e) 'define-macro)
|
||||
(loop *unspecified* (readenv a) (cons (mes-define-macro e a) a)))
|
||||
(#t (loop (eval e a) (readenv a) a))))
|
||||
|
||||
|
|
|
|||
24
scm.mes
24
scm.mes
|
|
@ -24,7 +24,7 @@
|
|||
(define (list . rest) rest)
|
||||
|
||||
(define (scm-define x a)
|
||||
(cond ((atom (cadr x)) (cons (cadr x) (eval (caddr x) a)))
|
||||
(cond ((atom? (cadr x)) (cons (cadr x) (eval (caddr x) a)))
|
||||
(#t (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))))
|
||||
|
||||
(define (scm-define-macro x a)
|
||||
|
|
@ -38,15 +38,15 @@
|
|||
;; (display 'e:)
|
||||
;; (display e)
|
||||
;; (newline)
|
||||
(cond ((null e) r)
|
||||
((eq e 'EOF2)
|
||||
(cond ((null? e) r)
|
||||
((eq? e 'EOF2)
|
||||
(display 'loop2-exiting...)
|
||||
(newline))
|
||||
((atom e)
|
||||
((atom? e)
|
||||
(loop2 (eval e a) (readenv a) a))
|
||||
((eq (car e) 'define)
|
||||
((eq? (car e) 'define)
|
||||
(loop2 *unspecified* (readenv a) (cons (scm-define e a) a)))
|
||||
((eq (car e) 'define-macro)
|
||||
((eq? (car e) 'define-macro)
|
||||
(loop2 *unspecified* (readenv a) (cons (scm-define-macro e a) a)))
|
||||
|
||||
(#t (loop2 (eval e a) (readenv a) a))
|
||||
|
|
@ -68,12 +68,12 @@ EOF
|
|||
(#t y)))
|
||||
|
||||
(define (split-params bindings params)
|
||||
(cond ((null bindings) params)
|
||||
(cond ((null? bindings) params)
|
||||
(#t (split-params (cdr bindings)
|
||||
(append params (cons (caar bindings) '()))))))
|
||||
|
||||
(define (split-values bindings values)
|
||||
(cond ((null bindings) values)
|
||||
(cond ((null? bindings) values)
|
||||
(#t (split-values (cdr bindings)
|
||||
(append values (cdar bindings) '())))))
|
||||
|
||||
|
|
@ -82,7 +82,7 @@ EOF
|
|||
(split-values bindings '())))
|
||||
|
||||
(define (expand-let* bindings body)
|
||||
(cond ((null bindings)
|
||||
(cond ((null? bindings)
|
||||
(cons (cons 'lambda (cons '() body)) '()))
|
||||
(#t
|
||||
(cons
|
||||
|
|
@ -94,7 +94,7 @@ EOF
|
|||
(expand-let* bindings body))
|
||||
|
||||
(define (map f l . r)
|
||||
(cond ((null l) '())
|
||||
((null r) (cons (f (car l)) (map f (cdr l))))
|
||||
((null (cdr r))
|
||||
(cond ((null? l) '())
|
||||
((null? r) (cons (f (car l)) (map f (cdr l))))
|
||||
((null? (cdr r))
|
||||
(cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue