Merge branch 'master' into refactor-contrib

contrib/10.regexp/CMakeLists.txt

@@ -1,4 +1,7 @@
 # regex
+
+set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${PROJECT_SOURCE_DIR}/contrib/10.regexp/cmake/")
+
 find_package(REGEX)
 
 if (REGEX_FOUND)

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

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)
+  )

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 *);

t/r7rs-tests.scm

@@ -36,77 +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)
 
 (test-begin "R7RS")
 
@@ -2089,12 +2026,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 +2069,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")