diff --git a/NEWS b/NEWS index 36449e0f..4b219662 100644 --- a/NEWS +++ b/NEWS @@ -18,6 +18,7 @@ The C-reader needs only support reading of words and lists block-comments are all handled by the Scheme reader later. ** Language *** Keywords are supported. +*** Cond now supports =>. * Changes in 0.3 since 0.2 ** Core *** Number-based rather than pointer-based cells. diff --git a/mes.c b/mes.c index fdb66ca5..1ca53e07 100644 --- a/mes.c +++ b/mes.c @@ -84,6 +84,7 @@ scm scm_nil = {SPECIAL, "()"}; scm scm_f = {SPECIAL, "#f"}; scm scm_t = {SPECIAL, "#t"}; scm scm_dot = {SPECIAL, "."}; +scm scm_arrow = {SPECIAL, "=>"}; scm scm_undefined = {SPECIAL, "*undefined*"}; scm scm_unspecified = {SPECIAL, "*unspecified*"}; scm scm_closure = {SPECIAL, "*closure*"}; diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index bc5c1103..1cf396a3 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -60,18 +60,20 @@ (apply f (apply cons* (cons h t))))) (define-macro (cond . clauses) - (list 'if (null? clauses) *unspecified* - (if (null? (cdr clauses)) - (list 'if (car (car clauses)) - (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses)))))) - *unspecified*) - (if (eq? (car (cadr clauses)) 'else) - (list 'if (car (car clauses)) - (list (cons 'lambda (cons '() (car clauses)))) - (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses))))))) - (list 'if (car (car clauses)) - (list (cons 'lambda (cons '() (car clauses)))) - (cons 'cond (cdr clauses))))))) + (list 'if (pair? clauses) + (list (cons + 'lambda + (cons + '(test) + (list (list 'if 'test + (if (pair? (cdar clauses)) + (if (eq? (cadar clauses) '=>) + (append2 (cddar clauses) '(test)) + (list (cons 'lambda (cons '() (car clauses))))) + (list (cons 'lambda (cons '() (car clauses))))) + (if (pair? (cdr clauses)) + (cons 'cond (cdr clauses))))))) + (car (car clauses))))) (define else #t) diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes index dddfaa79..ea854e16 100644 --- a/module/mes/read-0.mes +++ b/module/mes/read-0.mes @@ -54,19 +54,16 @@ (helper (read))) (define-macro (cond . clauses) - (list (quote if) (null? clauses) *unspecified* - (if (null? (cdr clauses)) - (list (quote if) (car (car clauses)) - (list (cons (quote lambda) (cons (list) (cons (car (car clauses)) (cdr (car clauses)))))) - *unspecified*) - (if (eq? (car (cadr clauses)) (quote else)) - (list (quote if) (car (car clauses)) - (list (cons (quote lambda) (cons (list) (car clauses)))) - (list (cons (quote lambda) (cons (list) (cons *unspecified* (cdr (cadr clauses))))))) - (list (quote if) (car (car clauses)) - (list (cons (quote lambda) (cons (list) (car clauses)))) - (cons (quote cond) (cdr clauses))))))) - + (list 'if (pair? clauses) + (list 'if (car (car clauses)) + (if (pair? (cdar clauses)) + (if (eq? (cadar clauses) '=>) + (append2 (cddar clauses) (list (caar clauses))) + (list (cons 'lambda (cons '() (car clauses))))) + (list (cons 'lambda (cons '() (car clauses))))) + (if (pair? (cdr clauses)) + (cons 'cond (cdr clauses)))))) + (define (eat-whitespace) (cond ((eq? (peek-byte) 9) (read-byte) (eat-whitespace)) @@ -130,7 +127,7 @@ (read-byte) (cons (lookup (symbol->list (quote unsyntax-splicing)) a) (cons (read-word (read-byte) w a) (list)))) - (else + (#t (cons (lookup (symbol->list (quote unsyntax)) a) (cons (read-word (read-byte) w a) (list)))))) ((eq? (peek-byte) 39) (read-byte) @@ -139,7 +136,7 @@ ((eq? (peek-byte) 96) (read-byte) (cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a) (cons (read-word (read-byte) w a) (list)))) - (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a)))) + (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a)))) ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a) (cons (read-word (read-byte) w a) (list))) (begin (unread-byte c) (lookup w a)))) @@ -153,11 +150,11 @@ (cons (lookup (symbol->list (quote unquote-splicing)) a) (cons (read-word (read-byte) w a) (list))))) - (else (cons (lookup-char c a) (cons (read-word (read-byte) w a) + (#t (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list)))))) ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list)))) ((eq? c 59) (read-line-comment c) (read-word 10 w a)) - (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a)))) + (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a)))) ((lambda (p) ;;(display (quote scheme-program=)) (display p) (newline) diff --git a/tests/base.test b/tests/base.test index 8670c370..5f23e0af 100755 --- a/tests/base.test +++ b/tests/base.test @@ -52,8 +52,14 @@ exit $? (pass-if "cond" (seq? (cond (#t)) #t)) (pass-if "cond 2" (seq? (cond (#f)) *unspecified*)) (pass-if "cond 3" (seq? (cond (#t 0)) 0)) - (pass-if "cond 3" (seq? (cond (#f 1) (#t 0)) 0))) - ) + (pass-if "cond 3" (seq? (cond (#f 1) (#t 0)) 0)) + (pass-if-equal "cond => " + 0 (let ((lst '(0 1 2))) + (define (next) + (let ((r (car lst))) + (set! lst (cdr lst)) + r)) + (cond ((next) => identity)))))) (pass-if "and" (seq? (and 1) 1)) (pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f))