From 0eb32de9c74515ba64d5be547ed57fe82478d87d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 8 Jul 2016 18:02:06 +0200 Subject: [PATCH] mes.c: support `.' and add let. --- GNUmakefile | 2 +- boot.mes | 125 +++++++++++++++++++++++++++++++++------------------- mes.c | 56 ++++++++++++++++++++--- mes.mes | 2 +- mes.test | 2 + scm.mes | 6 +-- 6 files changed, 138 insertions(+), 55 deletions(-) diff --git a/GNUmakefile b/GNUmakefile index 8f4c8d40..5271407c 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -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 diff --git a/boot.mes b/boot.mes index 67a71e9f..01af3303 100644 --- a/boot.mes +++ b/boot.mes @@ -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) + +'() diff --git a/mes.c b/mes.c index 69a1e402..52bcfcd1 100644 --- a/mes.c +++ b/mes.c @@ -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); } diff --git a/mes.mes b/mes.mes index 264dfc51..7b0c02a5 100644 --- a/mes.mes +++ b/mes.mes @@ -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))) diff --git a/mes.test b/mes.test index 9a417044..0bfbe294 100755 --- a/mes.test +++ b/mes.test @@ -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 diff --git a/scm.mes b/scm.mes index 2b7b2038..4115b586 100755 --- a/scm.mes +++ b/scm.mes @@ -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))