From 720eb94395bc6b3ef94d815a37b360b5f2bb0dd5 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Sun, 20 Jul 2014 17:24:03 +0900 Subject: [PATCH 1/3] separate (picrin test) and import some test macros from chibi scheme --- piclib/CMakeLists.txt | 1 + piclib/picrin/test.scm | 103 +++++++++++++++++++++++++++++++++++++++++ t/r7rs-tests.scm | 102 +--------------------------------------- 3 files changed, 106 insertions(+), 100 deletions(-) create mode 100644 piclib/picrin/test.scm diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 50b59f9b..9d81aae3 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -3,6 +3,7 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/prelude.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm diff --git a/piclib/picrin/test.scm b/piclib/picrin/test.scm new file mode 100644 index 00000000..f786ba58 --- /dev/null +++ b/piclib/picrin/test.scm @@ -0,0 +1,103 @@ +(define-library (picrin test) + (import (scheme base) + (scheme write) + (scheme read) + (scheme process-context)) + (define test-counter 0) + (define counter 0) + (define failure-counter 0) + + (define fails '()) + + (define (print-statistics) + (newline) + (display "Test Result: ") + (write (- counter failure-counter)) + (display " / ") + (write counter) + (display " (") + (write (* (/ (- counter failure-counter) counter) 100)) + (display "%)") + (display " [PASS/TOTAL]") + (display "") + (newline) + (for-each + (lambda (fail) + (display fail)) + fails)) + + (define (test-begin . o) + (set! test-counter (+ test-counter 1))) + + (define (test-end . o) + (set! test-counter (- test-counter 1)) + (if (= test-counter 0) + (print-statistics))) + + (define-syntax test + (syntax-rules () + ((test expected expr) + (let ((res expr)) + (display "case ") + (write counter) + (cond + ((equal? res expected) + (display " PASS: ") + (write 'expr) + (display " equals ") + (write expected) + (display "") + (newline) + ) + ((not (equal? res expected)) + (set! failure-counter (+ failure-counter 1)) + (let ((out (open-output-string))) + (display " FAIL: " out) + (write 'expr out) + (newline out) + (display " expected " out) + (write expected out) + (display " but got " out) + (write res out) + (display "" out) + (newline out) + (let ((str (get-output-string out))) + (set! fails (cons str fails)) + (display str))))) + (set! counter (+ counter 1)))))) + + (define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name (call-with-values (lambda () expect) (lambda results results)) + (call-with-values (lambda () expr) (lambda results results)))))) + + + (define (test-failure-count) + (length fails)) + + (define (test-exit) + (exit (zero? (test-failure-count)))) + + (define-syntax test-syntax-error + (syntax-rules () + ((_) (syntax-error "invalid use of test-syntax-error")))) + + (define-syntax test-numeric-syntax + (syntax-rules () + ((test-numeric-syntax str expect strs ...) + (let* ((z (read (open-input-string str))) + (out (open-output-string)) + (z-str (begin (write z out) (get-output-string out)))) + (test expect (values z)) + (test #t (and (member z-str '(str strs ...)) #t)))))) + + ;; (define (test-read-error str) + ;; (test-assert + ;; (guard (exn (else #t)) + ;; (read (open-input-string str)) + ;; #f))) + (export test test-begin test-end test-values test-exit test-syntax-error test-numeric-syntax) + ) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index c0877161..0282062c 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -36,75 +36,14 @@ (scheme write) ; (scheme eval) (scheme process-context) - (scheme case-lambda)) + (scheme case-lambda) + (picrin test)) ;; R7RS test suite. Covers all procedures and syntax in the small ;; language except `delete-file'. Currently assumes full-unicode ;; support, the full numeric tower and all standard libraries ;; provided. -(define test-counter 0) -(define counter 0) -(define failure-counter 0) - -(define fails '()) - -(define (print-statistics) - (newline) - (display "Test Result: ") - (write (- counter failure-counter)) - (display " / ") - (write counter) - (display " (") - (write (* (/ (- counter failure-counter) counter) 100)) - (display "%)") - (display " [PASS/TOTAL]") - (display "") - (newline) - (for-each - (lambda (fail) - (display fail)) - fails)) - -(define (test-begin . o) - (set! test-counter (+ test-counter 1))) - -(define (test-end . o) - (set! test-counter (- test-counter 1)) - (if (= test-counter 0) - (print-statistics))) - -(define-syntax test - (syntax-rules () - ((test expected expr) - (let ((res expr)) - (display "case ") - (write counter) - (cond - ((equal? res expected) - (display " PASS: ") - (write 'expr) - (display " equals ") - (write expected) - (display "") - (newline) - ) - ((not (equal? res expected)) - (set! failure-counter (+ failure-counter 1)) - (let ((out (open-output-string))) - (display " FAIL: " out) - (write 'expr out) - (newline out) - (display " expected " out) - (write expected out) - (display " but got " out) - (write res out) - (display "" out) - (newline out) - (let ((str (get-output-string out))) - (set! fails (cons str fails)) - (display str))))) - (set! counter (+ counter 1)))))) (newline) @@ -2089,12 +2028,6 @@ (test '(a . c) (read (open-input-string "(a . #;b c)"))) (test '(a . b) (read (open-input-string "(a . b #;c)"))) -;; (define (test-read-error str) -;; (test-assert -;; (guard (exn (else #t)) -;; (read (open-input-string str)) -;; #f))) - ;; (test-read-error "(#;a . b)") ;; (test-read-error "(a . #;b)") ;; (test-read-error "(a #;. b)") @@ -2138,37 +2071,6 @@ (test-begin "Numeric syntax") -;; Numeric syntax adapted from Peter Bex's tests. -;; -;; These are updated to R7RS, using string ports instead of -;; string->number, and "error" tests removed because implementations -;; are free to provide their own numeric extensions. Currently all -;; tests are run by default - need to cond-expand and test for -;; infinities and -0.0. - -(define-syntax test-numeric-syntax - (syntax-rules () - ((test-numeric-syntax str expect strs ...) - (let* ((z (read (open-input-string str))) - (out (open-output-string)) - (z-str (begin (write z out) (get-output-string out)))) - (test expect (values z)) - (test #t (and (member z-str '(str strs ...)) #t)))))) - -;; Each test is of the form: -;; -;; (test-numeric-syntax input-str expected-value expected-write-values ...) -;; -;; where the input should be eqv? to the expected-value, and the -;; written output the same as any of the expected-write-values. The -;; form -;; -;; (test-numeric-syntax input-str expected-value) -;; -;; is a shorthand for -;; -;; (test-numeric-syntax input-str expected-value (input-str)) - ;; Simple (test-numeric-syntax "1" 1) ;; (test-numeric-syntax "+1" 1 "1") From 28894dd07a23bb6446d3f12f0afc336bf2a5da21 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Sun, 20 Jul 2014 21:19:12 +0900 Subject: [PATCH 2/3] remove useless newline --- t/r7rs-tests.scm | 2 -- 1 file changed, 2 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 0282062c..1cf0cb0a 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -45,8 +45,6 @@ ;; provided. -(newline) - (test-begin "R7RS") (test-begin "4.1 Primitive expression types") From 12fb80b857b4f4201f3724613b10ad9bcd80288a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 21 Jul 2014 16:32:51 +0900 Subject: [PATCH 3/3] allow multiple identifier aliasing --- src/macro.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/macro.c b/src/macro.c index 7711a860..597eb57f 100644 --- a/src/macro.c +++ b/src/macro.c @@ -35,12 +35,7 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren { xh_entry *e; - if (! pic_interned_p(pic, sym)) { - if (rename != NULL) { - *rename = sym; - } - return true; - } + UNUSED(pic); if ((e = xh_get_int(&senv->map, sym)) == NULL) { return false; @@ -87,7 +82,12 @@ make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) break; senv = senv->up; } - return pic_gensym(pic, sym); + if (! pic_interned_p(pic, sym)) { + return sym; + } + else { + return pic_gensym(pic, sym); + } } static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);