From 5a9b1a1eead4c125445bba1c67b5fa4774e63945 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 31 Aug 2011 18:08:04 -0400 Subject: [PATCH] adding chars --- .../runtime-src/baselib-primitives.js | 19 ++ lang/check-expect/check-expect.rkt | 229 ++++++++++++++++++ lang/kernel.rkt | 4 +- tests/more-tests/chars.expected | 12 + tests/more-tests/chars.rkt | 15 ++ tests/run-more-tests.rkt | 1 + 6 files changed, 278 insertions(+), 2 deletions(-) create mode 100644 lang/check-expect/check-expect.rkt create mode 100644 tests/more-tests/chars.expected create mode 100644 tests/more-tests/chars.rkt diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 3171162..d68dc7a 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/js-assembler/runtime-src/baselib-primitives.js @@ -1039,6 +1039,25 @@ }); + installPrimitiveProcedure( + 'char-upcase', + 1, + function(MACHINE) { + var ch = checkChar(MACHINE, 'char=?', 0).val; + return baselib.chars.makeChar(ch.toUpperCase()); + }); + + installPrimitiveProcedure( + 'char-downcase', + 1, + function(MACHINE) { + var ch = checkChar(MACHINE, 'char=?', 0).val; + return baselib.chars.makeChar(ch.toLowerCase()); + }); + + + + installPrimitiveProcedure( 'box', diff --git a/lang/check-expect/check-expect.rkt b/lang/check-expect/check-expect.rkt new file mode 100644 index 0000000..911cc1e --- /dev/null +++ b/lang/check-expect/check-expect.rkt @@ -0,0 +1,229 @@ +#lang s-exp "../kernel.rkt" + +(require (for-syntax racket/base)) + +(provide check-expect + check-within + ;check-error + run-tests) + +(define *tests* '()) + + +(define-for-syntax (syntax-location-values stx) + (list (syntax-source stx) ;; can be path or symbol + (syntax-position stx) + (syntax-line stx) + (syntax-column stx) + (syntax-span stx))) + + +(define-for-syntax (check-at-toplevel! who stx) + (unless (eq? (syntax-local-context) 'module) + (raise-syntax-error #f + (format "~a: found a test that is not at the top level." + who) + stx))) + + +(define-syntax (check-expect stx) + (syntax-case stx () + [(_ test expected) + (begin + (check-at-toplevel! 'check-expect stx) + (with-syntax ([stx stx] + [(id offset line column span) + (syntax-location-values stx)]) + #'(accumulate-test! + (lambda () + (check-expect* 'stx + (make-location 'id offset line column span) + (lambda () test) + (lambda () expected))))))])) + +;; (define-syntax (check-within stx) +;; (syntax-case stx () +;; [(_ test expected delta) +;; (begin +;; (check-at-toplevel! 'check-within stx) +;; (with-syntax ([stx stx] +;; [(id offset line column span) +;; (syntax-location-values stx)]) +;; #'(accumulate-test! +;; (lambda () +;; (check-within* 'stx +;; (make-location 'id offset line column span) +;; (lambda () test) +;; (lambda () expected) +;; (lambda () delta))))))])) + +;; (define-syntax (check-error stx) +;; (syntax-case stx () +;; [(_ test expected-msg) +;; (begin +;; (check-at-toplevel! 'check-error stx) +;; (with-syntax ([stx stx] +;; [(id offset line column span) +;; (syntax-location-values stx)]) +;; #'(accumulate-test! +;; (lambda () +;; (check-error* 'stx +;; (make-location 'id offset line column span) +;; (lambda () test) +;; (lambda () expected-msg))))))])) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (check-expect* test-datum a-loc test-thunk expected-thunk) +; (with-handlers ([void +; (lambda (exn) +; (printf "check-expect: ~s" +; (exn-message exn)) +; (newline) +; (display-location test-datum a-loc) +; #f)]) + (let ([expected-value (expected-thunk)] + [test-value (test-thunk)]) + (cond + [(equal? test-value expected-value) + #t] + [else + (printf "check-expect: actual value ~s differs from ~s, the expected value\n" test-value expected-value) + ;(newline) + ;(display-location test-datum a-loc) + #f]))) + + +;; (define (check-within* test-datum a-loc test-thunk expected-thunk delta-thunk) +;; ;(with-handlers ([void +;; ; (lambda (exn) +;; ; (printf "check-within: ~s" +;; ; (exn-message exn)) +;; ; (newline) +;; ; (display-location test-datum a-loc) +;; ; #f)]) +;; (let ([expected-value (expected-thunk)] +;; [test-value (test-thunk)] +;; [delta-value (delta-thunk)]) +;; (cond +;; [(not (real? delta-value)) +;; (printf "check-within requires an inexact number for the range. ~s is not inexact.\n" delta-value) +;; ;;(display-location test-datum a-loc) +;; #f] +;; [(equal~? test-value expected-value delta-value) +;; #t] +;; [else +;; (printf "check-within: actual value ~s differs from ~s, the expected value.\n" test-value expected-value) +;; ;;(display-location test-datum a-loc) +;; #f]))) + + + +;; (define (check-error* test-datum a-loc test-thunk expected-message-thunk) +;; (with-handlers ([void +;; (lambda (exn) +;; (printf "check-error: ~s" +;; (exn-message exn)) +;; (newline) +;; (display-location test-datum a-loc) +;; #f)]) +;; (let ([expected-message (expected-message-thunk)]) +;; (with-handlers +;; ([unexpected-no-error? +;; (lambda (une) +;; (printf "check-error expected the error ~s, but got ~s instead.\n" +;; expected-message +;; (unexpected-no-error-result une)) +;; (display-location test-datum a-loc) +;; #f)] +;; [exn:fail? +;; (lambda (exn) +;; (cond [(string=? (exn-message exn) expected-message) +;; #t] +;; [else +;; (printf "check-error: expected the error ~s, but got ~s instead.\n" +;; expected-message +;; (exn-message exn)) +;; (display-location test-datum a-loc) +;; #f]))]) +;; (let ([result (test-thunk)]) +;; (raise (make-unexpected-no-error result))))))) + + + + + + + +;; a test is a thunk of type: (-> boolean) +;; where it returns true if the test was successful, +;; false otherwise. + +;; accumulate-test! +(define (accumulate-test! a-test) + (set! *tests* (cons a-test *tests*))) + + +;; test-suffixed: number -> string +(define (test-suffixed n) + (case n + [(0) "zero tests"] + [(1) "one test"] + [else (format "~a tests" n)])) + + +;; capitalize: string -> string +(define (capitalize s) + (cond [(> (string-length s) 0) + (string-append (string (char-upcase (string-ref s 0))) + (substring s 1))] + [else + s])) + + +;; run-tests: -> void +(define (run-tests) + (when (> (length *tests*) 0) + ;; Run through the tests + (printf "Running tests...\n") + (let loop ([tests-passed 0] + [tests-failed 0] + [tests (reverse *tests*)]) + (cond + [(empty? tests) + ;; Report test results + (cond [(= tests-passed (length *tests*)) + (display (case (length *tests*) + [(1) "The test passed!"] + [(2) "Both tests passed!"] + [else + (format "All ~a tests passed!" + (length *tests*))])) + (newline)] + [else + (printf "Ran ~a.\n" + (test-suffixed (length *tests*))) + (printf "~a passed.\n" + (capitalize (test-suffixed tests-passed))) + (printf "~a failed.\n" + (capitalize (test-suffixed tests-failed)))]) + (set! *tests* '())] + [else + (let* ([test-thunk (first tests)] + [test-result (test-thunk)]) + (cond + [test-result + (loop (add1 tests-passed) + tests-failed + (rest tests))] + [else + (loop tests-passed + (add1 tests-failed) + (rest tests))]))])))) + + + +(define-struct unexpected-no-error (result)) + diff --git a/lang/kernel.rkt b/lang/kernel.rkt index d0c90e5..e052d4e 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -429,8 +429,8 @@ char=? ;; char-lower-case? ;; char->integer ;; integer->char -;; char-upcase -;; char-downcase + char-upcase + char-downcase ;; call-with-current-continuation diff --git a/tests/more-tests/chars.expected b/tests/more-tests/chars.expected new file mode 100644 index 0000000..5ae9959 --- /dev/null +++ b/tests/more-tests/chars.expected @@ -0,0 +1,12 @@ +#\A +#\B +#\C +#\A +#\B +#\C +#\a +#\b +#\c +#\a +#\b +#\c diff --git a/tests/more-tests/chars.rkt b/tests/more-tests/chars.rkt new file mode 100644 index 0000000..375f5b2 --- /dev/null +++ b/tests/more-tests/chars.rkt @@ -0,0 +1,15 @@ +#lang planet dyoo/whalesong/base + +(char-upcase #\a) +(char-upcase #\b) +(char-upcase #\c) +(char-upcase #\A) +(char-upcase #\B) +(char-upcase #\C) + +(char-downcase #\a) +(char-downcase #\b) +(char-downcase #\c) +(char-downcase #\A) +(char-downcase #\B) +(char-downcase #\C) diff --git a/tests/run-more-tests.rkt b/tests/run-more-tests.rkt index 9f9cb33..05e0949 100644 --- a/tests/run-more-tests.rkt +++ b/tests/run-more-tests.rkt @@ -8,6 +8,7 @@ (test "more-tests/booleans.rkt") (test "more-tests/string-tests.rkt") +(test "more-tests/chars.rkt") (test "more-tests/numbers.rkt") (test "more-tests/hello.rkt") (test "more-tests/sharing.rkt")