Changeset 37931 in project


Ignore:
Timestamp:
09/29/19 18:41:20 (3 weeks ago)
Author:
sjamaan
Message:

foof-loop: Update test code with latest version from darcs

Location:
release/5/foof-loop/trunk/tests
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/foof-loop/trunk/tests/run.scm

    r37924 r37931  
    55(module foof-loop-tests (vector-quick-sort! vector-exchange!)
    66
    7 (import scheme (only (chicken base) parameterize include case-sensitive) srfi-6 foof-loop test-shim)
     7(import scheme
     8        (only (chicken base) parameterize include case-sensitive)
     9        (rename (chicken random) (pseudo-random-integer random-integer))
     10        srfi-6 foof-loop test-shim)
    811
    912(define (identity-procedure x) x)
  • release/5/foof-loop/trunk/tests/test-foof-loop.scm

    r37922 r37931  
    11;;; -*- Mode: Scheme -*-
    22
    3 ;;;; Extensible Looping Macros
     3;;;; Extensible Looping Macros, version 9 (BETA)
    44;;;; Test Suite
    55
    6 ;;; This code is written by Taylor R. Campbell and placed in the Public
    7 ;;; Domain.  All warranties are disclaimed.
     6;;; Copyright (c) 2008, Taylor R. Campbell
     7;;;
     8;;; Redistribution and use in source and binary forms, with or without
     9;;; modification, are permitted provided that the following conditions
     10;;; are met:
     11;;;
     12;;; * Redistributions of source code must retain the above copyright
     13;;;   notice, this list of conditions and the following disclaimer.
     14;;;
     15;;; * Redistributions in binary form must reproduce the above copyright
     16;;;   notice, this list of conditions and the following disclaimer in
     17;;;   the documentation and/or other materials provided with the
     18;;;   distribution.
     19;;;
     20;;; * Neither the names of the authors nor the names of contributors
     21;;;   may be used to endorse or promote products derived from this
     22;;;   software without specific prior written permission.
     23;;;
     24;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
     25;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
     26;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
     27;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
     28;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
     29;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
     30;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
     31;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
     32;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
     33;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
     34;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     35
    836
    937(define-test-suite loop-tests
     
    4977          (continue (+ i 1) (+ sum i))))))
    5078
    51 (define-test-case loop-tests.trivial-named-let partition-list-by-sign ()
     79(define-test-case loop-tests.trivial-named-let partition-list-by-sign
     80    ()
    5281  (test-equal '((6 1 3) (-5 -2))
    5382    ;; R5RS, 4.2.4, p12, translated from named LET.
     
    162191(define-test-case loop-tests.in-vector linear-search ()
    163192  (test-equal 2
    164     (loop continue ((for element index (in-vector '#(FOO BAR BAZ QUUX))))
     193    (loop continue ((for element index
     194                         (in-vector '#(FOO BAR BAZ QUUX))))
    165195      (if (eq? element 'BAZ)
    166196          index
     
    178208      (vector-reverse-copy '#(A B C D E F G H I) 2 5))))
    179209
    180 (define-test-case loop-tests.in-vector accelerated-alphabetic-traversal ()
     210(define-test-case loop-tests.in-vector accelerated-alphabetic-traversal
     211    ()
    181212  (test-equal '((A 0) (B 1) (D 3) (H 7) (P 15))
    182213    ((lambda (body)
     
    224255
    225256(define-test-case loop-tests.io-loops read-expressions ()
    226   (test-equal '(FOO BAR (BAZ QUUX) #(ZOT))
     257  (test-equal '(FOO (BAR BAZ) #(QUUX))
    227258    (loop ((for expression
    228                 (in-port (open-input-string "foo bar (baz quux) #(zot)")
     259                (in-port (open-input-string "FOO (BAR BAZ) #(QUUX)")
    229260                         read))
    230261           (with expressions '() (cons expression expressions)))
     
    234265  (test-equal '(FOO BAR BAZ)
    235266    (loop ((for term
    236                 (in-port (open-input-string "foo bar baz eof quux")
     267                (in-port (open-input-string "FOO BAR BAZ EOF QUUX")
    237268                         read
    238269                         (lambda (term)
     
    375406      => j)))
    376407
    377 (define-test-case loop-tests.accumulation sum-of-squares-of-valid-numbers ()
     408(define-test-case loop-tests.accumulation
     409    sum-of-squares-of-valid-numbers
     410    ()
    378411  (test-equal 1300
    379412    (loop ((for string (in-list '("a" "12" "x" "34")))
     
    384417(define-test-case loop-tests.accumulation sum-of-valid-even-numbers ()
    385418  (test-equal 24
    386     (loop ((for string (in-list '("a" "2" "3" "6" "b" "16" "17" "x" "19")))
    387            (for sum (summing (values (string->number string))
    388                              (lambda (x) (and x (even? x)))
    389                              => (lambda (number) number))))
     419    (loop ((for string
     420                (in-list '("a" "2" "3" "6" "b" "16" "17" "x" "19")))
     421           (for sum
     422                (summing (values (string->number string))
     423                         (lambda (x) (and x (even? x)))
     424                         => (lambda (number) number))))
    390425      => sum)))
    391426
     
    409444                    (for result (listing (list a b c d))))
    410445      => result
    411       (continue (+ a 1)
    412                 (=> d (cddr d))))))
     446      (continue (+ a 1) (=> d (cddr d))))))
    413447
    414448(define-test-case loop-tests.misc vector-quick-sort ()
    415   (let ()
    416     (define (vector-copy vector)
    417       (let* ((length (vector-length vector))
    418              (vector* (make-vector length)))
    419         (loop ((for element index (in-vector vector)))
    420           (vector-set! vector* index element))
    421         vector*))
    422     (loop ((for vector (in-list '(#(A B C 8 6 5 3 1 4 0 7 2 9 D E F)
    423                                   #(A B C 2 7 4 9 3 6 8 5 0 1 D E F)
    424                                   #(A B C 0 8 9 3 5 4 6 1 7 2 D E F)
    425                                   #(A B C 7 8 3 0 2 1 4 6 9 5 D E F)
    426                                   #(A B C 9 7 4 8 3 0 1 2 5 6 D E F)
    427                                   #(A B C 1 9 2 6 4 7 3 8 0 5 D E F)))))
    428       (let ((vector (vector-copy vector)))
    429         (vector-quick-sort! vector 3 (- (vector-length vector) 3)
    430                             identity-procedure
    431                             <)
    432         (if (not (equal? vector '#(A B C 0 1 2 3 4 5 6 7 8 9 D E F)))
    433             (test-failure "Vector quick-sort yielded an unsorted vector:"
    434                           vector))))))
     449  (let* ((vector '#(A B C 0 1 2 3 4 5 6 7 8 9 D E F))
     450         (vector* (make-vector (vector-length vector))))
     451    (loop ((for element index (in-vector vector)))
     452      (vector-set! vector* index element))
     453    (let ((start 3)
     454          (end (- (vector-length vector) 3)))
     455      (loop ((for i (up-from 0 (to #x1000))))
     456        (vector-shuffle! vector* start end)
     457        (vector-quick-sort! vector* start end values <)
     458        (if (not (equal? vector* vector))
     459            (test-failure "Vector quick-sort yielded unsorted vector:"
     460                          vector*))))))
     461
     462(define (vector-shuffle! vector start end)
     463  (loop ((for i (up-from start (to end)))
     464         (for bound (up-from 1)))
     465    (vector-exchange! vector i (+ start (random-integer bound)))))
    435466
    436467(define (vector-quick-sort! vector start end key-selector key<)
    437468  (define (select-pivot vector start end)
    438     (vector-ref vector (quotient (+ start end) 2)))
     469    (vector-ref vector (+ start (quotient (- end start) 2))))
    439470  (loop sort ((start start) (end end))
    440471    (if (< 1 (- end start))
    441472        (let ((pivot (key-selector (select-pivot vector start end))))
    442473          (loop continue ((i start) (j end))
    443             (let ((i (loop scan ((for i (up-from i)))
     474            (let ((i (loop scan ((for i (up-from i (to end))))
     475                       => i
    444476                       (if (key< (key-selector (vector-ref vector i)) pivot)
    445477                           (scan)
    446478                           i)))
    447                   (j (loop scan ((for j (down-from j)))
     479                  (j (loop scan ((for j (down-from j (to start))))
     480                       => j
    448481                       (if (key< pivot (key-selector (vector-ref vector j)))
    449482                           (scan)
  • release/5/foof-loop/trunk/tests/test-shim.scm

    r37923 r37931  
    55
    66;; Minimal shim version of the foof-loop test library using the test egg as a backend.
     7
     8;; Should it be time to do a proper port, the complete original
     9;; Scheme48/MIT Scheme testing library is available at:
     10;; https://mumble.net/~campbell/darcs/trc-testing/
     11
    712;; <suite> : #(symbolic-nested-name description cases-list subsuites)
    813(define suite-nesting '())            ; ((name . ((sub-name1 . ...) (sub-name2 . ...)))
Note: See TracChangeset for help on using the changeset viewer.