artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

snarf scm functions and environment.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-09 23:12:25 +02:00
parent f89507414e
commit 72d96eb485
6 changed files with 141 additions and 241 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -4,3 +4,4 @@
*~ *~
/boot.mes /boot.mes
/mes /mes
/mes.h

17
GNUmakefile
View file

@ -6,6 +6,23 @@ default: all
all: mes boot.mes 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 check: all
./mes.test ./mes.test
./mes.test ./mes ./mes.test ./mes

180
mes.c
View file

@ -28,7 +28,6 @@
#define _GNU_SOURCE #define _GNU_SOURCE
#include <assert.h> #include <assert.h>
#include <ctype.h> #include <ctype.h>
#include <stdarg.h>
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
#include <stdlib.h> #include <stdlib.h>
@ -66,6 +65,11 @@ typedef struct scm_t {
}; };
} scm; } scm;
#define MES 1
#include "mes.h"
scm *display_helper (scm*, bool, char*, bool);
scm scm_nil = {ATOM, "()"}; scm scm_nil = {ATOM, "()"};
scm scm_dot = {ATOM, "."}; scm scm_dot = {ATOM, "."};
scm scm_t = {ATOM, "#t"}; scm scm_t = {ATOM, "#t"};
@ -91,7 +95,6 @@ atom_p (scm *x)
{ {
return x->type == PAIR ? &scm_f : &scm_t; return x->type == PAIR ? &scm_f : &scm_t;
} }
scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom_p};
scm * scm *
car (scm *x) car (scm *x)
@ -148,26 +151,23 @@ scm *eval (scm*, scm*);
scm *display (scm*); scm *display (scm*);
scm scm_quote;
scm * scm *
quote (scm *x) quote (scm *x)
{ {
return cons (&scm_quote, x); return cons (&scm_symbol_quote, x);
} }
#if QUASIQUOTE #if QUASIQUOTE
scm scm_unquote;
scm * scm *
unquote (scm *x) unquote (scm *x)
{ {
return cons (&scm_unquote, x); return cons (&scm_symbol_unquote, x);
} }
scm scm_quasiquote;
scm * scm *
quasiquote (scm *x) quasiquote (scm *x)
{ {
return cons (&scm_quasiquote, x); return cons (&scm_symbol_quasiquote, x);
} }
scm *eval_quasiquote (scm *, scm *); scm *eval_quasiquote (scm *, scm *);
@ -175,8 +175,6 @@ scm *eval_quasiquote (scm *, scm *);
#endif #endif
//Library functions //Library functions
scm scm_read;
// Derived, non-primitives // Derived, non-primitives
scm *caar (scm *x) {return car (car (x));} 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 *cadar (scm *x) {return car (cdr (car (x)));}
scm *cddar (scm *x) {return cdr (cdr (car (x)));} scm *cddar (scm *x) {return cdr (cdr (car (x)));}
scm *cdddr (scm *x) {return cdr (cdr (cdr (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 *); scm* make_atom (char const *);
@ -235,7 +207,6 @@ pairlis (scm *x, scm *y, scm *a)
return cons (cons (car (x), car (y)), return cons (cons (car (x), car (y)),
pairlis (cdr (x), cdr (y), a)); pairlis (cdr (x), cdr (y), a));
} }
scm scm_pairlis = {FUNCTION3, .name="pairlis", .function3 = &pairlis};
scm * scm *
assoc (scm *x, scm *a) assoc (scm *x, scm *a)
@ -250,7 +221,6 @@ assoc (scm *x, scm *a)
return car (a); return car (a);
return assoc (x, cdr (a)); return assoc (x, cdr (a));
} }
scm scm_assoc = {FUNCTION2, .name="assoc", .function2 = &assoc};
scm *apply (scm*, scm*, scm*); scm *apply (scm*, scm*, scm*);
scm *eval_ (scm*, scm*); scm *eval_ (scm*, scm*);
@ -395,8 +365,6 @@ evcon (scm *c, scm *a)
return evcon_ (c, a); return evcon_ (c, a);
} }
scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon};
scm * scm *
evlis (scm *m, scm *a) evlis (scm *m, scm *a)
{ {
@ -410,29 +378,6 @@ evlis (scm *m, scm *a)
scm *e = eval (car (m), a); scm *e = eval (car (m), a);
return cons (e, evlis (cdr (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 = &quote};
#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 //Helpers
@ -445,26 +390,18 @@ builtin_p (scm *x)
|| x->type == FUNCTION3) || x->type == FUNCTION3)
? &scm_t : &scm_f; ? &scm_t : &scm_f;
} }
scm scm_builtin_p = {FUNCTION1, .name="builtin", .function1 = &builtin_p};
scm * scm *
number_p (scm *x) number_p (scm *x)
{ {
return x->type == NUMBER ? &scm_t : &scm_f; 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 * scm *
display (scm *x) display (scm *x)
{ {
return display_helper (x, false, "", false); 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 * scm *
call (scm *fn, scm *x) call (scm *fn, scm *x)
@ -498,8 +435,6 @@ append (scm *x, scm *y)
assert (x->type == PAIR); assert (x->type == PAIR);
return cons (car (x), append (cdr (x), y)); return cons (car (x), append (cdr (x), y));
} }
scm scm_append = {FUNCTION2, .name="append", .function2 = &append};
scm * scm *
make_atom (char const *s) make_atom (char const *s)
@ -572,7 +507,6 @@ builtin_lookup (scm *l, scm *a)
{ {
return lookup (list2str (l), a); return lookup (list2str (l), a);
} }
scm scm_lookup = {FUNCTION2, .name="lookup", .function2 = &builtin_lookup};
scm * scm *
cossa (scm *x, scm *a) cossa (scm *x, scm *a)
@ -589,7 +523,6 @@ newline ()
puts (""); puts ("");
return &scm_unspecified; return &scm_unspecified;
} }
scm scm_newline = {FUNCTION0, .name="newline", .function0 = &newline};
scm * scm *
display_helper (scm *x, bool cont, char *sep, bool quote) 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 // READ
int int
ungetchar (int c) ungetchar (int c) //int
{ {
return ungetc (c, stdin); return ungetc (c, stdin);
} }
int int
peekchar () peekchar () //int
{ {
int c = getchar (); int c = getchar ();
ungetchar (c); ungetchar (c);
@ -652,23 +585,20 @@ builtin_getchar ()
{ {
return make_number (getchar ()); return make_number (getchar ());
} }
scm scm_getchar = {FUNCTION0, .name="getchar", .function0 = &builtin_getchar};
scm* scm*
builtin_peekchar () builtin_peekchar ()
{ {
return make_number (peekchar ()); return make_number (peekchar ());
} }
scm scm_peekchar = {FUNCTION0, .name="peekchar", .function0 = &builtin_peekchar};
scm* scm*
builtin_ungetchar (scm* c) builtin_ungetchar (scm *c)
{ {
assert (c->type == NUMBER); assert (c->type == NUMBER);
ungetchar (c->value); ungetchar (c->value);
return c; return c;
} }
scm scm_ungetchar = {FUNCTION1, .name="ungetchar", .function1 = &builtin_ungetchar};
int int
readcomment (int c) readcomment (int c)
@ -740,7 +670,6 @@ readenv (scm *a)
{ {
return readword (getchar (), 0, a); return readword (getchar (), 0, a);
} }
scm scm_readenv = {FUNCTION1, .name="readenv", .function1 = &readenv};
// Extras to make interesting program // Extras to make interesting program
@ -750,8 +679,6 @@ hello_world ()
puts ("c: hello world"); puts ("c: hello world");
return &scm_unspecified; return &scm_unspecified;
} }
scm scm_hello_world = {FUNCTION0, .name="hello-world", .function0 = &hello_world};
scm * scm *
less_p (scm *a, scm *b) less_p (scm *a, scm *b)
@ -783,9 +710,6 @@ minus (scm *a, scm *b)
return r; return r;
} }
scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p};
scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus};
#if QUASIQUOTE #if QUASIQUOTE
scm * scm *
eval_quasiquote (scm *e, scm *a) eval_quasiquote (scm *e, scm *a)
@ -813,17 +737,16 @@ eval_quasiquote (scm *e, scm *a)
return cdar (e); return cdar (e);
return cons (car (e), eval_quasiquote (cdr (e), a)); return cons (car (e), eval_quasiquote (cdr (e), a));
} }
scm scm_eval_quasiquote = {FUNCTION2, .name="c:eval-quasiquote", .function2 = &eval_quasiquote};
#endif #endif
scm * 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); return cons (cons (make_atom (name), x), a);
} }
scm * scm *
initial_environment () mes_environment ()
{ {
scm *a = &scm_nil; scm *a = &scm_nil;
@ -831,77 +754,20 @@ initial_environment ()
a = add_environment (a, "#t", &scm_t); a = add_environment (a, "#t", &scm_t);
a = add_environment (a, "#f", &scm_f); a = add_environment (a, "#f", &scm_f);
a = add_environment (a, "*unspecified*", &scm_unspecified); a = add_environment (a, "*unspecified*", &scm_unspecified);
a = add_environment (a, "label", &scm_label); a = add_environment (a, "label", &scm_label);
a = add_environment (a, "lambda", &scm_lambda); 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, "*macro*", &scm_nil);
a = add_environment (a, "*dot*", &scm_dot); a = add_environment (a, "*dot*", &scm_dot);
a = add_environment (a, "current-module", &scm_symbol_current_module); 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; return a;
} }
@ -966,14 +832,14 @@ loop (scm *r, scm *e, scm *a)
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
scm *a = initial_environment (); scm *a = mes_environment ();
display (loop (&scm_unspecified, readenv (a), a)); display (loop (&scm_unspecified, readenv (a), a));
newline (); newline ();
return 0; return 0;
} }
scm * scm *
apply (scm* fn, scm *x, scm *a) apply (scm *fn, scm *x, scm *a)
{ {
#if DEBUG #if DEBUG
printf ("\nc:apply fn="); printf ("\nc:apply fn=");

106
mes.mes
View file

@ -36,8 +36,8 @@
;; (define (pairlis x y a) ;; (define (pairlis x y a)
;; ;;(debug "pairlis x=~a y=~a a=~a\n" x y a) ;; ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
;; (cond ;; (cond
;; ((null x) a) ;; ((null? x) a)
;; ((atom x) (cons (cons x y) a)) ;; ((atom? x) (cons (cons x y) a))
;; (#t (cons (cons (car x) (car y)) ;; (#t (cons (cons (car x) (car y))
;; (pairlis (cdr x) (cdr y) a))))) ;; (pairlis (cdr x) (cdr y) a)))))
@ -45,8 +45,8 @@
;; ;;(stderr "assoc x=~a\n" x) ;; ;;(stderr "assoc x=~a\n" x)
;; ;;(debug "assoc x=~a a=~a\n" x a) ;; ;;(debug "assoc x=~a a=~a\n" x a)
;; (cond ;; (cond
;; ((null a) #f) ;; ((null? a) #f)
;; ((eq (caar a) x) (car a)) ;; ((eq? (caar a) x) (car a))
;; (#t (assoc x (cdr a))))) ;; (#t (assoc x (cdr a)))))
;; ;; Page 13 ;; ;; Page 13
@ -60,7 +60,7 @@
;; single-statement cond ;; single-statement cond
;; ((eval (caar c) a) (eval (cadar c) a)) ;; ((eval (caar c) a) (eval (cadar c) a))
((eval (caar 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) (#t (eval (cadar c) a)
(evcon (evcon
(cons (cons #t (cddar c)) '()) (cons (cons #t (cddar c)) '())
@ -73,7 +73,7 @@
;; (display m) ;; (display m)
;; (newline) ;; (newline)
(cond (cond
((null m) '()) ((null? m) '())
(#t (cons (eval (car m) a) (evlis (cdr m) a))))) (#t (cons (eval (car m) a) (evlis (cdr m) a)))))
@ -84,33 +84,33 @@
;; (display fn) ;; (display fn)
;; (newline) ;; (newline)
;; (display 'builtin:) ;; (display 'builtin:)
;; (display (builtin fn)) ;; (display (builtin? fn))
;; (newline) ;; (newline)
;; (display 'x:) ;; (display 'x:)
;; (display x) ;; (display x)
;; (newline) ;; (newline)
(cond (cond
((atom fn) ((atom? fn)
(cond (cond
((eq fn 'current-module) ;; FIXME ((eq? fn 'current-module) ;; FIXME
(c:apply current-module '() a)) (c:apply current-module '() a))
((builtin fn) ((builtin? fn)
(call fn x)) (call fn x))
(#t (apply (eval fn a) x a)))) (#t (apply (eval fn a) x a))))
((eq (car fn) 'lambda) ((eq? (car fn) 'lambda)
(cond ((null (cdr (cddr fn))) (cond ((null? (cdr (cddr fn)))
(eval (caddr fn) (pairlis (cadr fn) x a))) (eval (caddr fn) (pairlis (cadr fn) x a)))
(#t (#t
(eval (caddr fn) (pairlis (cadr fn) x a)) (eval (caddr fn) (pairlis (cadr fn) x a))
(apply (cons (car fn) (cons (cadr fn) (cdddr fn))) (apply (cons (car fn) (cons (cadr fn) (cdddr fn)))
x x
(pairlis (cadr fn) x a))))) (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))))) (caddr fn)) a)))))
(define (eval e a) (define (eval e a)
;;(debug "eval e=~a a=~a\n" 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 'mes-eval:)
;; (display e) ;; (display e)
;; (newline) ;; (newline)
@ -118,19 +118,19 @@
;; (display a) ;; (display a)
;; (newline) ;; (newline)
(cond (cond
((number e) e) ((number? e) e)
((eq e #t) #t) ((eq? e #t) #t)
((eq e #f) #f) ((eq? e #f) #f)
((atom e) (cdr (assoc e a))) ((atom? e) (cdr (assoc e a)))
((builtin e) e) ((builtin? e) e)
((atom (car e)) ((atom? (car e))
(cond (cond
((eq (car e) 'quote) (cadr e)) ((eq? (car e) 'quote) (cadr e))
((eq (car e) 'lambda) e) ((eq? (car e) 'lambda) e)
((eq (car e) 'unquote) (eval (cadr e) a)) ((eq? (car e) 'unquote) (eval (cadr e) a))
((eq (car e) 'quasiquote) (eval-quasiquote (cadr e) a)) ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) a))
((eq (car e) 'cond) (evcon (cdr e) a)) ((eq? (car e) 'cond) (evcon (cdr e) a))
((pair (assoc (car e) (cdr (assoc '*macro* a)))) ((pair? (assoc (car e) (cdr (assoc '*macro* a))))
(c:eval (c:eval
(c:apply (c:apply
(cdr (assoc (car e) (cdr (assoc '*macro* a)))) (cdr (assoc (car e) (cdr (assoc '*macro* a))))
@ -144,12 +144,12 @@
;; (display 'mes-eval-quasiquote:) ;; (display 'mes-eval-quasiquote:)
;; (display e) ;; (display e)
;; (newline) ;; (newline)
(cond ((null e) e) (cond ((null? e) e)
((atom e) e) ((atom? e) e)
((atom (car e)) (cons (car e) (eval-quasiquote (cdr e) a))) ((atom? (car e)) (cons (car e) (eval-quasiquote (cdr e) a)))
((eq (caar e) 'unquote) (cons (eval (cadar e) a) '())) ((eq? (caar e) 'unquote) (cons (eval (cadar e) a) '()))
((eq (caar e) 'quote) (cons (cadar e) '())) ((eq? (caar e) 'quote) (cons (cadar e) '()))
((eq (caar e) 'quasiquote) (cons (cadar e) '())) ((eq? (caar e) 'quasiquote) (cons (cadar e) '()))
(#t (cons (car e) (eval-quasiquote (cdr e) a))))) (#t (cons (car e) (eval-quasiquote (cdr e) a)))))
;; readenv et al works, but slows down dramatically ;; readenv et al works, but slows down dramatically
@ -160,31 +160,31 @@
;; (display 'mes-readword:) ;; (display 'mes-readword:)
;; (display c) ;; (display c)
;; (newline) ;; (newline)
(cond ((eq c -1) ;; eof (cond ((eq? c -1) ;; eof
(cond ((eq w '()) '()) (cond ((eq? w '()) '())
(#t (lookup w a)))) (#t (lookup w a))))
((eq c 10) ;; \n ((eq? c 10) ;; \n
(cond ((eq w '()) (readword (getchar) w a)) (cond ((eq? w '()) (readword (getchar) w a))
;; DOT ((eq w '(*dot*)) (car (readword (getchar) '() a))) ;; DOT ((eq? w '(*dot*)) (car (readword (getchar) '() a)))
(#t (lookup w a)))) (#t (lookup w a))))
((eq c 32) ;; \space ((eq? c 32) ;; \space
(readword 10 w a)) (readword 10 w a))
((eq c 40) ;; ( ((eq? c 40) ;; (
(cond ((eq w '()) (readlis a)) (cond ((eq? w '()) (readlis a))
(#t (ungetchar c) (lookup w a)))) (#t (ungetchar c) (lookup w a))))
((eq c 41) ;; ) ((eq? c 41) ;; )
(cond ((eq w '()) (ungetchar c) w) (cond ((eq? w '()) (ungetchar c) w)
(#t (ungetchar c) (lookup w a)))) (#t (ungetchar c) (lookup w a))))
((eq c 39) ;; ' ((eq? c 39) ;; '
(cond ((eq w '()) (cond ((eq? w '())
(cons (lookup (cons c '()) a) (cons (lookup (cons c '()) a)
(cons (readword (getchar) w a) '()))) (cons (readword (getchar) w a) '())))
(#t (ungetchar c) (lookup w a)))) (#t (ungetchar c) (lookup w a))))
((eq c 59) ;; ; ((eq? c 59) ;; ;
(readcomment c) (readcomment c)
(readword 10 w a)) (readword 10 w a))
((eq c 35) ;; # ((eq? c 35) ;; #
(cond ((eq (peekchar) 33) ;; ! (cond ((eq? (peekchar) 33) ;; !
(getchar) (getchar)
(readblock (getchar)) (readblock (getchar))
(readword 10 w a)) (readword 10 w a))
@ -195,27 +195,27 @@
;; (display 'mes-readblock:) ;; (display 'mes-readblock:)
;; (display c) ;; (display c)
;; (newline) ;; (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)))))
(#t (readblock (getchar))))) (#t (readblock (getchar)))))
(define (eat-whitespace) (define (eat-whitespace)
(cond ((eq (peekchar) 10) (getchar) (eat-whitespace)) (cond ((eq? (peekchar) 10) (getchar) (eat-whitespace))
((eq (peekchar) 32) (getchar) (eat-whitespace)) ((eq? (peekchar) 32) (getchar) (eat-whitespace))
((eq (peekchar) 35) (getchar) (eat-whitespace)) ((eq? (peekchar) 35) (getchar) (eat-whitespace))
(#t #t))) (#t #t)))
(define (readlis a) (define (readlis a)
;; (display 'mes-readlis:) ;; (display 'mes-readlis:)
;; (newline) ;; (newline)
(eat-whitespace) (eat-whitespace)
(cond ((eq (peekchar) 41) ;; ) (cond ((eq? (peekchar) 41) ;; )
(getchar) (getchar)
'()) '())
;; TODO *dot* ;; TODO *dot*
(#t (cons (readword (getchar) '() a) (readlis a))))) (#t (cons (readword (getchar) '() a) (readlis a)))))
(define (readcomment c) (define (readcomment c)
(cond ((eq c 10) ;; \n (cond ((eq? c 10) ;; \n
c) c)
(#t (readcomment (getchar))))) (#t (readcomment (getchar)))))

54
mes.scm
View file

@ -81,7 +81,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
;;(define debug stderr) ;;(define debug stderr)
;; TODO ;; TODO
(define (atom x) (define (atom? x)
(cond (cond
((guile:pair? x) #f) ((guile:pair? x) #f)
((guile:null? x) #f) ((guile:null? x) #f)
@ -91,17 +91,33 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
(define car guile:car) (define car guile:car)
(define cdr guile:cdr) (define cdr guile:cdr)
(define cons guile:cons) (define cons guile:cons)
(define eq guile:eq?) (define eq? guile:eq?)
(define null guile:null?) (define null? guile:null?)
(define pair guile:pair?) (define pair? guile:pair?)
(define builtin guile:procedure?) (define builtin? guile:procedure?)
(define number guile:number?) (define number? guile:number?)
(define call guile:apply) (define call guile:apply)
(include "mes.mes") (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) (define (append x y)
(cond ((null x) y) (cond ((null? x) y)
(#t (cons (car x) (append (cdr x) y))))) (#t (cons (car x) (append (cdr x) y)))))
(define (eval-environment e a) (define (eval-environment e a)
@ -123,15 +139,15 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
(*unspecified* . ,*unspecified*) (*unspecified* . ,*unspecified*)
(atom . ,atom) (atom? . ,atom?)
(car . ,car) (car . ,car)
(cdr . ,cdr) (cdr . ,cdr)
(cons . ,cons) (cons . ,cons)
(cond . ,evcon) (cond . ,evcon)
(eq . ,eq) (eq? . ,eq?)
(null . ,null) (null? . ,null?)
(pair . ,guile:pair?) (pair? . ,guile:pair?)
;;(quote . ,quote) ;;(quote . ,quote)
(evlis . ,evlis) (evlis . ,evlis)
@ -146,8 +162,8 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
(display . ,guile:display) (display . ,guile:display)
(newline . ,guile:newline) (newline . ,guile:newline)
(builtin . ,builtin) (builtin? . ,builtin?)
(number . ,number) (number? . ,number?)
(call . ,call) (call . ,call)
(< . ,guile:<) (< . ,guile:<)
@ -177,7 +193,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
(cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x))))) (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))
(define (mes-define x a) (define (mes-define x a)
(if (atom (cadr x)) (if (atom? (cadr x))
(cons (cadr x) (eval (caddr x) a)) (cons (cadr x) (eval (caddr x) a))
(mes-define-lambda x a))) (mes-define-lambda x a)))
@ -187,15 +203,15 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
(cdr (assoc '*macro* a))))) (cdr (assoc '*macro* a)))))
(define (loop r e a) (define (loop r e a)
(cond ((null e) r) (cond ((null? e) r)
((eq e 'exit) ((eq? e 'exit)
(apply (cdr (assoc 'loop a)) (apply (cdr (assoc 'loop a))
(cons *unspecified* (cons #t (cons a '()))) (cons *unspecified* (cons #t (cons a '())))
a)) a))
((atom e) (loop (eval e a) (readenv a) a)) ((atom? e) (loop (eval e a) (readenv a) a))
((eq (car e) 'define) ((eq? (car e) 'define)
(loop *unspecified* (readenv a) (cons (mes-define e a) a))) (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))) (loop *unspecified* (readenv a) (cons (mes-define-macro e a) a)))
(#t (loop (eval e a) (readenv a) a)))) (#t (loop (eval e a) (readenv a) a))))

24
scm.mes
View file

@ -24,7 +24,7 @@
(define (list . rest) rest) (define (list . rest) rest)
(define (scm-define x a) (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))))))) (#t (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))))
(define (scm-define-macro x a) (define (scm-define-macro x a)
@ -38,15 +38,15 @@
;; (display 'e:) ;; (display 'e:)
;; (display e) ;; (display e)
;; (newline) ;; (newline)
(cond ((null e) r) (cond ((null? e) r)
((eq e 'EOF2) ((eq? e 'EOF2)
(display 'loop2-exiting...) (display 'loop2-exiting...)
(newline)) (newline))
((atom e) ((atom? e)
(loop2 (eval e a) (readenv a) a)) (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))) (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))) (loop2 *unspecified* (readenv a) (cons (scm-define-macro e a) a)))
(#t (loop2 (eval e a) (readenv a) a)) (#t (loop2 (eval e a) (readenv a) a))
@ -68,12 +68,12 @@ EOF
(#t y))) (#t y)))
(define (split-params bindings params) (define (split-params bindings params)
(cond ((null bindings) params) (cond ((null? bindings) params)
(#t (split-params (cdr bindings) (#t (split-params (cdr bindings)
(append params (cons (caar bindings) '())))))) (append params (cons (caar bindings) '()))))))
(define (split-values bindings values) (define (split-values bindings values)
(cond ((null bindings) values) (cond ((null? bindings) values)
(#t (split-values (cdr bindings) (#t (split-values (cdr bindings)
(append values (cdar bindings) '()))))) (append values (cdar bindings) '())))))
@ -82,7 +82,7 @@ EOF
(split-values bindings '()))) (split-values bindings '())))
(define (expand-let* bindings body) (define (expand-let* bindings body)
(cond ((null bindings) (cond ((null? bindings)
(cons (cons 'lambda (cons '() body)) '())) (cons (cons 'lambda (cons '() body)) '()))
(#t (#t
(cons (cons
@ -94,7 +94,7 @@ EOF
(expand-let* bindings body)) (expand-let* bindings body))
(define (map f l . r) (define (map f l . r)
(cond ((null l) '()) (cond ((null? l) '())
((null r) (cons (f (car l)) (map f (cdr l)))) ((null? r) (cons (f (car l)) (map f (cdr l))))
((null (cdr r)) ((null? (cdr r))
(cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))) (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))