diff --git a/mes.c b/mes.c index 3c65c81f..50b5cd25 100644 --- a/mes.c +++ b/mes.c @@ -92,6 +92,7 @@ scm scm_symbol_quote = {SYMBOL, "quote"}; #if QUASIQUOTE scm scm_symbol_quasiquote = {SYMBOL, "quasiquote"}; scm scm_symbol_unquote = {SYMBOL, "unquote"}; +scm scm_symbol_unquote_splicing = {SYMBOL, "unquote-splicing"}; #endif #if MACROS scm scm_macro = {SYMBOL, "*macro*"}; @@ -200,6 +201,12 @@ quote (scm *x) } #if QUASIQUOTE +scm * +quasiquote (scm *x) +{ + return cons (&scm_symbol_quasiquote, x); +} + scm * unquote (scm *x) { @@ -207,9 +214,9 @@ unquote (scm *x) } scm * -quasiquote (scm *x) +unquote_splicing (scm *x) { - return cons (&scm_symbol_quasiquote, x); + return cons (&scm_symbol_unquote_splicing, x); } #endif @@ -674,9 +681,11 @@ lookup (char *x, scm *a) #if QUASIQUOTE if (*x == '`') return &scm_symbol_quasiquote; - if (*x == ',') return &scm_symbol_unquote; - if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote; + if (*x == ',' && *(x+1) == '@') return &scm_symbol_unquote_splicing; + if (*x == ',') return &scm_symbol_unquote; if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote; + if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote; + if (!strcmp (x, scm_symbol_unquote_splicing.name)) return &scm_symbol_unquote_splicing; #endif return make_symbol (x); @@ -798,6 +807,10 @@ display_helper (scm *x, bool cont, char *sep, bool quote) printf (","); return display_helper (car (cdr (x)), cont, "", true); } + if (car (x) == &scm_unquote_splicing) { + printf (",@"); + return display_helper (car (cdr (x)), cont, "", true); + } #endif #endif if (!cont) printf ("("); @@ -885,6 +898,9 @@ readword (int c, char* w, scm *a) if (c == '(') {ungetchar (c); return lookup (w, a);} if (c == ')' && !w) {ungetchar (c); return &scm_nil;} if (c == ')') {ungetchar (c); return lookup (w, a);} + if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (",@", a), + cons (readword (getchar (), w, a), + &scm_nil));} if ((c == '\'' #if QUASIQUOTE || c == '`' @@ -976,7 +992,15 @@ readlist (scm *a) scm * readenv (scm *a) { +#if DEBUG + scm *e = readword (getchar (), 0, a); + printf ("readenv: "); + display (e); + puts (""); + return e; +#else return readword (getchar (), 0, a); +#endif } // Extras to make interesting program @@ -1086,15 +1110,17 @@ eval_quasiquote (scm *e, scm *a) #endif if (e == &scm_nil) return e; else if (atom_p (e) == &scm_t) return e; + else if (eq_p (car (e), &scm_symbol_quote) == &scm_t) + return e; + else if (eq_p (car (e), &scm_symbol_quasiquote) == &scm_t) + return cons (e, eval_quasiquote (cdr (e), a)); + else if (eq_p (car (e), &scm_symbol_unquote) == &scm_t) + return eval (cadr (e), a); else if (atom_p (car (e)) == &scm_t) return cons (car (e), eval_quasiquote (cdr (e), a)); - else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t) - return cons (eval (cadar (e), a), &scm_nil); - else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t) - return cons (cadar (e), &scm_nil); - else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t) - return cdar (e); - return cons (car (e), eval_quasiquote (cdr (e), a)); + else if (eq_p (caar (e), &scm_symbol_unquote_splicing) == &scm_t) + return append2 (eval_ (cadar (e), a), eval_quasiquote (cdr (e), a)); + return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a)); } #endif diff --git a/scm.mes b/scm.mes index 3a3ee57b..37bee77c 100755 --- a/scm.mes +++ b/scm.mes @@ -21,6 +21,16 @@ ;; The Maxwell Equations of Software -- John McCarthy page 13 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf +(define (list . rest) rest) + +(define-macro (begin . rest) + `((lambda () ,@rest))) + +(define (vector . rest) (list->vector rest)) + +(define (apply f args) + (c:eval (cons f args) (current-module))) + (define (defined? x) (assq x (current-module))) @@ -29,8 +39,6 @@ ((pair? p) (eq? (car p) 'lambda)) (#t #f))) -(define (list . rest) rest) -(define (vector . rest) (list->vector rest)) (define assv assq) (define (memq x lst) (cond ((null? lst) #f) @@ -39,10 +47,10 @@ (define memv memq) (define-macro (or x y) - (list 'cond (list x x) (list #t y))) + `(cond (,x ,x) (#t ,y))) (define-macro (and x y) - (list 'cond (list x y) (list #t #f))) + `(cond (,x ,y) (#t #f))) (define (split-params bindings params) (cond ((null? bindings) params) @@ -80,19 +88,14 @@ (cond (x #f) (#t #t))) -(define-macro (if expr then else) - (list 'cond - (list expr then) - (list #t else))) +(define-macro (if expr then . else) + `(cond + (,expr ,then) + (#t (cond (,(pair? else) ((lambda () ,@else))))))) -;;TODO -(define-macro (iif expr then . else) - (list 'cond - (list expr then) - (list #t - (list 'cond - (list (list 'pair? else) (list 'car else)) - (list #t '*unspecified*))))) +(define-macro (when expr . body) + `(if ,expr + ((lambda () ,@body)))) (define (unspecified-bindings bindings params) (cond ((null? bindings) params) @@ -111,8 +114,3 @@ (append (letrec-setters bindings '()) body))) ) -(define (begin . rest) - (let () rest)) - -(define (apply f args) - (c:eval (cons f args) (current-module))) diff --git a/syntax.mes b/syntax.mes index 699efb7f..ee037ec8 100644 --- a/syntax.mes +++ b/syntax.mes @@ -1,18 +1,18 @@ -(display "define-syntax...") +;; (display "define-syntax...") -(define-macro define-syntax - (lambda (form expander) - (expander `(define-macro ,(cadr form) - (let ((transformer ,(caddr form))) - (lambda (form expander) - (expander (transformer form - (lambda (x) x) - eq?) - expander)))) - expander))) +;; (define-macro define-syntax +;; (lambda (form expander) +;; (expander `(define-macro ,(cadr form) +;; (let ((transformer ,(caddr form))) +;; (lambda (form expander) +;; (expander (transformer form +;; (lambda (x) x) +;; eq?) +;; expander)))) +;; expander))) -(newline) +;; (newline) (display "define-syntax when...") @@ -27,68 +27,29 @@ ;; (begin ,exp . ,rest))) -(define-macro (when clause . rest) - (cond - ((not (eq? clause #f)) (cons 'let (cons '() rest))))) - -(define-macro (ifwhen clause . rest) - (if (not (eq? clause #f)) (cons 'let (cons '() rest)))) - -(define-macro my-when - (lambda (test . branch) - (list 'if test (cons 'begin branch)))) - -;; (define-macro (q-when test . branch) -;; `(if ,test -;; (begin ,@branch))) - -;; (define-macro (when clause exp . rest) -;; (display "all=") -;; (display (cons exp rest)) -;; (newline) -;; `(if ,clause -;; (begin ,(cons exp rest)))) - ;; (define-macro (when clause . rest) -;; (cond -;; ((not (eq? clause #f)) (cons 'let (cons '() rest))))) +;; (list 'cond (list clause (list 'let '() rest)))) + + +(define-macro (when expr . body) + `(if ,expr + ((lambda () ,@body)) + 'bah)) (newline) -(ifwhen #t +(when #t (display "true") (newline)) -(ifwhen #f - (display "false") +(when #t + (display "q-when") (newline) '()) -(my-when #t - (display "my-when") - (newline) - '()) - - -;; (q-when #t -;; (display "q-when") -;; (newline) -;; '()) - - (define *gensym* 0) (define (gensym) (set! *gensym* (+ *gensym* 1)) (string->symbol (string-append "g" (number->string *gensym*)))) -(define-macro bla (gensym)) - -(display bla) (newline) -(display bla) (newline) -(display bla) (newline) - (newline) -'() - -;;EOF -EOF2 diff --git a/test.mes b/test.mes index 2f6f7a34..8b1bf304 100644 --- a/test.mes +++ b/test.mes @@ -137,7 +137,7 @@ (display (= 3 '3)) (newline) -(display (if #t 'true 'FIXME)) +(display (if #t 'true)) (newline) (display (if (eq? 0 '0) 'true 'false)) (newline) @@ -280,4 +280,29 @@ (display (gensym)) (newline) +(display "unquote:") +(display `,(list 1 2 3 4)) +(newline) + +(display `('boo ,@'(bah baz) 1 2)) +(newline) + +(display "splice:") +(display `(1 ,@(list 2 3) 4)) +(newline) + +(define s-r '(2 3)) +(display "splice:") +(display `(1 ,@s-r 4)) +(newline) + +(display "when:") +(when #t + (display "true") + (newline)) + +(when #f + (display "must not see") + (newline)) + '()