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

mes.c: support `.' and add let.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-08 18:02:06 +02:00
parent dfde662d0b
commit 0eb32de9c7
6 changed files with 138 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
GNUmakefile
View file

@ -9,7 +9,7 @@ all: mes
check: all
./mes.test
./mes.test ./mes
./mes < boot.mes
# ./mes < boot.mes
# ./mes < scm.mes
# ./mes.scm < scm.mes

125
boot.mes
View file

@ -45,6 +45,7 @@ exec ./mes "$@" < "$0"
;; (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)))))
@ -76,6 +77,9 @@ exec ./mes "$@" < "$0"
(define (evlis m a)
;;(debug "evlis m=~a a=~a\n" m a)
;; (display 'mes-evlis:)
;; (display m)
;; (newline)
(cond
((null m) '())
(#t (cons (eval (car m) a) (evlis (cdr m) a)))))
@ -119,10 +123,6 @@ exec ./mes "$@" < "$0"
;; (display 'a:)
;; (display a)
;; (newline)
;;(display 'pair?*macro*:)
;;(display (assoc '*macro* a))
;; (display (cdr (assoc '*macro* a)))
;; (newline)
(cond
((number e) e)
((eq e #t) #t)
@ -133,36 +133,13 @@ exec ./mes "$@" < "$0"
(cond
((eq (car e) 'quote) (cadr e))
((eq (car e) 'cond) (evcon (cdr e) a))
(;;#f ;; #f: no macro support
#t ;; #t: macro support
(cond
((eq (assoc '*macro* a) #f)
(display 'we-have-no-macros:)
(display e)
(newline)
(apply (car e) (evlis (cdr e) a) a)
)
((pair (assoc (car e) (cdr (assoc '*macro* a))))
;; (display 'expanz0r:)
;; (display (assoc (car e) (cdr (assoc '*macro* a))))
;; (newline)
;; (display 'running:)
;; (display (cdr (assoc (car e) (cdr (assoc '*macro* a)))))
;; (newline)
;; (display 'args:)
;; (display (cdr e))
;; (newline)
;; (display '==>args:)
;; (display (evlis (cdr e) a))
;; (newline)
(eval (apply
(cdr (assoc (car e) (cdr (assoc '*macro* a))))
(evlis (cdr e) a)
a)
a))
(#t
(apply (car e) (evlis (cdr e) a) a))))
((pair (assoc (car e) (cdr (assoc '*macro* a))))
(c:eval
(c:apply
(cdr (assoc (car e) (cdr (assoc '*macro* a))))
(cdr e)
a)
a))
(#t (apply (car e) (evlis (cdr e) a) a))))
(#t (apply (car e) (evlis (cdr e) a) a))))
@ -171,14 +148,15 @@ exec ./mes "$@" < "$0"
(readword (getchar) '() a))
(define (readword c w a)
;; (display 'readword:)
;; (display c)
;; (newline)
(display 'mes-readword:)
(display c)
(newline)
(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)))
(#t (lookup w a))))
((eq c 32) ;; \space
(readword 10 w a))
@ -199,8 +177,8 @@ exec ./mes "$@" < "$0"
(#t (readword (getchar) (append w (cons c '())) a))))
(define (readlis a)
;; (display 'readlis:)
;; (newline)
(display 'mes-readlis:)
(newline)
(cond ((eq (peekchar) 41) ;; )
(getchar)
'())
@ -255,10 +233,8 @@ exec ./mes "$@" < "$0"
;;(newline)
EOF
;; loop2 skips one read:
'this-is-skipped-scm
(display 123)
4
(newline)
@ -284,6 +260,10 @@ EOF
(cond (x x)
(#t y)))
;; EOF2
;; EOF
;; EOF2
(display 'and-0-1:)
(display (and 0 1))
(newline)
@ -298,7 +278,62 @@ EOF
(display (or #f 2))
(newline)
'()
EOF2
EOF
(define (split-params 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)
(#t (split-values (cdr bindings)
(append values (cdar bindings) '())))))
(define-macro (let1 bindings body)
(cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
(split-values bindings '())))
(let1 ((a 3)
(b 4))
((lambda ()
(display 'let-a:3-b:4)
(newline)
(display 'a:)
(display a)
(newline)
(display 'b:)
(display b)
(newline))))
(display 'let1-dun)
(newline)
(define-macro (let bindings . body)
(cons (cons 'lambda (cons (split-params bindings '()) body))
(split-values bindings '())))
(let ((p 5)
(q 6))
(display 'let-p:3-q:4)
(newline)
(display 'p:)
(display p)
(newline)
(display 'q:)
(display q)
(newline))
(display
(let ((p 5)
(q 6))
(display 'hallo)
(display p)
(display 'daar)
(display q)
(display 'dan)))
(newline)
(display 'let-dun)
(newline)
'()

56
mes.c
View file

@ -36,6 +36,8 @@
#define DEBUG 0
#define MACROS 1
#ifndef QUOTE_SUGAR
#define QUOTE_SUGAR 1
#endif
@ -64,6 +66,7 @@ typedef struct scm_t {
} scm;
scm scm_nil = {ATOM, "()"};
scm scm_dot = {ATOM, "."};
scm scm_t = {ATOM, "#t"};
scm scm_f = {ATOM, "#f"};
scm scm_lambda = {ATOM, "lambda"};
@ -71,6 +74,7 @@ scm scm_label = {ATOM, "label"};
scm scm_unspecified = {ATOM, "*unspecified*"};
scm scm_symbol_cond = {ATOM, "cond"};
scm scm_symbol_quote = {ATOM, "quote"};
scm scm_macro = {ATOM, "*macro*"};
// PRIMITIVES
@ -185,10 +189,12 @@ list (scm *x, ...)
return lst;
}
scm* make_atom (char const *);
scm *
pairlis (scm *x, scm *y, scm *a)
{
#if 0 //DEBUG
#if DEBUG
printf ("pairlis x=");
display (x);
printf (" y=");
@ -197,6 +203,8 @@ pairlis (scm *x, scm *y, scm *a)
#endif
if (x == &scm_nil)
return a;
if (atom_p (x) == &scm_t)
return cons (cons (x, y), a);
return cons (cons (car (x), car (y)),
pairlis (cdr (x), cdr (y), a));
}
@ -238,8 +246,8 @@ apply_ (scm *fn, scm *x, scm *a)
#if DEBUG
printf ("apply fn=");
display (fn);
//printf (" x=");
//display (x);
printf (" x=");
display (x);
puts ("");
#endif
if (atom_p (fn) != &scm_f)
@ -250,6 +258,7 @@ apply_ (scm *fn, scm *x, scm *a)
}
else if (car (fn) == &scm_lambda) {
scm *body = cddr (fn);
scm *ca = cadr (fn);
scm *ax = pairlis (cadr (fn), x, a);
scm *result = eval (car (body), ax);
if (cdr (body) == &scm_nil)
@ -267,6 +276,11 @@ scm *evlis (scm*, scm*);
scm *
eval_ (scm *e, scm *a)
{
#if DEBUG
printf ("eval e=");
display (e);
puts ("");
#endif
if (e->type == NUMBER)
return e;
else if (atom_p (e) == &scm_t) {
@ -281,12 +295,18 @@ eval_ (scm *e, scm *a)
return e;
else if (atom_p (car (e)) == &scm_t)
{
#if MACROS
scm *macro;
#endif // MACROS
if (car (e) == &scm_symbol_quote)
return cadr (e);
else if (car (e) == &scm_symbol_cond)
return evcon (cdr (e), a);
else
return apply (car (e), evlis (cdr (e), a), a);
#if MACROS
else if ((macro = assoc (car (e), cdr (assoc (&scm_macro, a)))) != &scm_f)
return eval (apply_ (cdr (macro), cdr (e), a), a);
#endif // MACROS
return apply (car (e), evlis (cdr (e), a), a);
}
return apply (car (e), evlis (cdr (e), a), a);
}
@ -334,6 +354,11 @@ scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon};
scm *
evlis (scm *m, scm *a)
{
#if DEBUG
printf ("evlis m=");
display (m);
puts ("");
#endif
if (m == &scm_nil)
return &scm_nil;
return cons (eval (car (m), a), evlis (cdr (m), a));
@ -586,6 +611,7 @@ readword (int c, char* w, scm *a)
{
if (c == EOF && !w) return &scm_nil;
if (c == '\n' && !w) return readword (getchar (), w, a);
if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
if (c == EOF || c == '\n') return lookup (w, a);
if (c == ' ') return readword ('\n', w, a);
if (c == '(' && !w) return readlis (a);
@ -608,6 +634,8 @@ readlis (scm *a)
int c = getchar ();
if (c == ')') return &scm_nil;
scm *w = readword (c, 0, a);
if (w == &scm_dot)
return car (readlis (a));
return cons (w, readlis (a));
}
@ -738,6 +766,7 @@ initial_environment ()
//
a = add_environment (a, "*macro*", &scm_nil);
a = add_environment (a, "*dot*", &scm_dot);
return a;
}
@ -756,9 +785,22 @@ define (scm *x, scm *a)
return define_lambda (x, a);
}
scm *
define_macro (scm *x, scm *a)
{
return cons (&scm_macro,
cons (define_lambda (x, a),
cdr (assoc (&scm_macro, a))));
}
scm *
loop (scm *r, scm *e, scm *a)
{
#if DEBUG
printf ("\nc:loop e=");
display (e);
puts ("");
#endif
if (e == &scm_nil)
return r;
else if (eq_p (e, make_atom ("EOF")) == &scm_t)
@ -772,6 +814,10 @@ loop (scm *r, scm *e, scm *a)
return loop (&scm_unspecified,
readenv (a),
cons (define (e, a), a));
else if (eq_p (car (e), make_atom ("define-macro")) == &scm_t)
return loop (&scm_unspecified,
readenv (a),
cons (define_macro (e, a), a));
return loop (eval (e, a), readenv (a), a);
}

2
mes.mes
View file

@ -47,7 +47,7 @@
((builtin fn) (call fn x))
(#t (apply (eval fn a) x a))))
;; John McCarthy LISP 1.5
((eq (car fn) 'single-line-LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a)))
((eq (car fn) 'LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a)))
((eq (car fn) 'lambda)
;; (CDDR fn) all eval
(cond ((null (cdr (cddr fn)))

2
mes.test
View file

@ -20,3 +20,5 @@ echo "((label fun\
(cond ((< 0 x) (fun (- x 1)))\
(#t '())))))\
3)" | $mes
echo "'(0 . 1)" | $mes
echo "(cdr '(0 . 1))" | $mes

6
scm.mes
View file

@ -54,9 +54,9 @@ exec ./mes "$@" < "$0"
(#t (split-values (cdr bindings)
(append values (cdar bindings) '())))))
;; (define-macro (let bindings body)
;; (cons (cons 'lambda (cons (split-params bindings '()) body))
;; (split-values bindings '())))
(define-macro (let bindings body)
(cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
(split-values bindings '())))
(display 'and-0-1:)
(display (and 0 1))