--- /dev/null
+#| -*-Scheme-*-
+
+$Id$
+
+Copyright (c) 1999 Massachusetts Institute of Technology
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+|#
+
+;;;; Test code for Boyer-Moore String Search
+
+(declare (usual-integrations))
+\f
+(define (dice-test text die-length die-skew)
+ (newline)
+ (let ((ok 0)
+ (not-ok 0))
+ (for-each
+ (lambda (entry)
+ (write-char #\+)
+ (let ((fr (string-search-forward text (car entry)))
+ (br (string-search-backward text (car entry))))
+ (if (and (eqv? (cadr entry) fr)
+ (eqv? (fix:+ (car (last-pair entry)) die-length) br))
+ (begin
+ (set! ok (fix:+ ok 1))
+ unspecific)
+ (begin
+ (set! not-ok (fix:+ not-ok 1))
+ (write-line (list (car entry) (cdr entry) fr br))))))
+ (dice-text text die-length die-skew))
+ (write-line (list 'OK= ok 'NOT-OK= not-ok))))
+
+(define (dice-text text die-length die-skew)
+ (let ((end (string-length text))
+ (table (make-string-hash-table)))
+ (define (record! s die)
+ (let ((entry
+ (or (hash-table/get table die #f)
+ (let ((entry (list 'ENTRY)))
+ (hash-table/put! table die entry)
+ entry))))
+ (set-cdr! entry (cons s (cdr entry)))))
+ (let loop ((s 0))
+ (let ((e (fix:+ s die-length)))
+ (if (fix:<= e end)
+ (begin
+ (record! s (substring text s e))
+ (let ((s (fix:+ s die-skew)))
+ (if (fix:< s end)
+ (loop s)))))))
+ (map (lambda (entry)
+ (cons (car entry)
+ (reverse! (cddr entry))))
+ (hash-table->alist table))))
+
+(define (file->string filename)
+ (call-with-input-file filename
+ (lambda (port)
+ ((port/operation port 'REST->STRING) port))))
+\f
+(define (search-speed-test text die-length die-skew procedure n-repeats)
+ (let ((entries (map car (dice-text text die-length die-skew))))
+ (show-time
+ (lambda ()
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n-repeats))
+ (do ((entries entries (cdr entries)))
+ ((null? entries))
+ (procedure (car entries) text)))))))
+
+(define (dummy-search pattern text)
+ (if (not (string? pattern))
+ (error:wrong-type-argument pattern "string" 'BM-SUBSTRING?))
+ (if (not (string? text))
+ (error:wrong-type-argument text "string" 'BM-SUBSTRING?))
+ #f)
\ No newline at end of file
--- /dev/null
+(declare (usual-integrations))
+
+(define-structure (implementation (conc-name implementation/))
+ (make #f read-only #t)
+ (insert! #f read-only #t)
+ (delete! #f read-only #t)
+ (lookup #f read-only #t)
+ (->alist #f read-only #t))
+
+(define-structure (sequence-specification
+ (conc-name sequence-specification/))
+ (length #f read-only #t)
+ (key-radix #f read-only #t)
+ (insert-fraction #f read-only #t)
+ (delete-fraction #f read-only #t))
+
+(define (run-test sequence-specification implementation)
+ (run-sequence (sequence-specification->sequence sequence-specification)
+ implementation))
+
+(define (run-sequence s implementation)
+ (let ((start-time (process-time-clock)))
+ (run-test-sequence s implementation)
+ (cons (- (process-time-clock) start-time)
+ (test-sequence-overhead s))))
+
+(define (make-sequence . arguments)
+ (sequence-specification->sequence
+ (apply make-sequence-specification arguments)))
+
+(define (sequence-specification->sequence sequence-specification)
+ (generate-test-sequence (make-random-state #t)
+ sequence-specification))
+
+(define (generate-test-sequence state sequence-specification)
+ (let ((state (make-random-state state))
+ (length (sequence-specification/length sequence-specification))
+ (key-radix (sequence-specification/key-radix sequence-specification))
+ (insert-fraction
+ (exact->inexact
+ (sequence-specification/insert-fraction sequence-specification)))
+ (delete-fraction
+ (exact->inexact
+ (sequence-specification/delete-fraction sequence-specification)))
+ (tree (make-rb-tree fix:= fix:<)))
+ (let ((delete-break (+ insert-fraction delete-fraction)))
+ (let loop ((n 0) (s '()))
+ (if (fix:= n length)
+ s
+ (loop (fix:+ n 1)
+ (cons (cons (let ((x (random 1. state)))
+ (cond ((< x insert-fraction) 'INSERT)
+ ((< x delete-break) 'DELETE)
+ (else 'LOOKUP)))
+ (let ((key (random key-radix state)))
+ (or (rb-tree/lookup tree key #f)
+ (let ((pointer (cons key '())))
+ (rb-tree/insert! tree key pointer)
+ pointer))))
+ s)))))))
+\f
+(define (run-test-sequence s implementation)
+ (let ((table ((implementation/make implementation)))
+ (insert! (implementation/insert! implementation))
+ (delete! (implementation/delete! implementation))
+ (lookup (implementation/lookup implementation)))
+ (do ((s s (cdr s)))
+ ((null? s))
+ (cond ((eq? 'INSERT (caar s))
+ (insert! table (cdar s) #f))
+ ((eq? 'DELETE (caar s))
+ (delete! table (cdar s)))
+ (else
+ (lookup table (cdar s) #f))))
+ table))
+
+(define (test-sequence-overhead s)
+ (let ((start-time (process-time-clock)))
+ (run-test-sequence s dummy-implementation)
+ (let ((end-time (process-time-clock)))
+ (- end-time start-time))))
+
+(define dummy-implementation
+ (make-implementation
+ (lambda () unspecific)
+ (lambda (table key datum) table key datum unspecific)
+ (lambda (table key) table key unspecific)
+ (lambda (table key default) table key default unspecific)
+ (lambda (table) table unspecific)))
+
+(load-option 'HASH-TABLE)
+
+(define htq
+ (make-implementation make-eq-hash-table
+ hash-table/put!
+ hash-table/remove!
+ hash-table/get
+ (lambda (table)
+ (sort (hash-table->alist table)
+ (lambda (x y) (fix:< (caar x) (caar y)))))))
+
+(define htv
+ (make-implementation make-eqv-hash-table
+ hash-table/put!
+ hash-table/remove!
+ hash-table/get
+ (lambda (table)
+ (sort (hash-table->alist table)
+ (lambda (x y) (fix:< (caar x) (caar y)))))))
+
+(define ht
+ (make-implementation make-equal-hash-table
+ hash-table/put!
+ hash-table/remove!
+ hash-table/get
+ (lambda (table)
+ (sort (hash-table->alist table)
+ (lambda (x y) (fix:< (caar x) (caar y)))))))
+
+(load-option 'RB-TREE)
+
+(define (make-pointer-tree)
+ (make-rb-tree (lambda (x y) (fix:= (car x) (car y)))
+ (lambda (x y) (fix:< (car x) (car y)))))
+
+(define rbt
+ (make-implementation make-pointer-tree
+ rb-tree/insert!
+ rb-tree/delete!
+ rb-tree/lookup
+ rb-tree->alist))
+\f
+(define (test-correctness s implementation)
+ (let ((table ((implementation/make implementation)))
+ (insert! (implementation/insert! implementation))
+ (delete! (implementation/delete! implementation))
+ (lookup (implementation/lookup implementation))
+ (tree (make-pointer-tree)))
+ (do ((s s (cdr s)))
+ ((null? s))
+ (let ((operation (caar s))
+ (key (cdar s)))
+ (cond ((eq? 'INSERT operation)
+ (rb-tree/insert! tree key #t)
+ (insert! table key #t))
+ ((eq? 'DELETE operation)
+ (rb-tree/delete! tree key)
+ (delete! table key))
+ (else
+ (let ((result (lookup table key #f)))
+ (if (not (eq? result (rb-tree/lookup tree key #f)))
+ (error "Incorrect lookup result:" result key)))))))
+ (let loop
+ ((alist ((implementation/->alist implementation) table))
+ (check (rb-tree->alist tree)))
+ (if (null? alist)
+ (if (not (null? check))
+ (error "Table has too few elements:" check))
+ (begin
+ (if (null? check)
+ (error "Table has too many elements:" alist))
+ (if (not (and (eq? (caar alist) (caar check))
+ (eq? (cdar alist) (cdar check))))
+ (error "Alist element incorrect:" (car alist) (car check)))
+ (loop (cdr alist) (cdr check)))))))
\ No newline at end of file
--- /dev/null
+(define (test-encoder n-packets packet-length text? filename
+ initialize finalize update)
+ (call-with-output-file filename
+ (lambda (port)
+ (let ((context (initialize port text?))
+ (n-packets (random n-packets)))
+ (do ((i 0 (+ i 1)))
+ ((= i n-packets))
+ (let ((packet-length (random packet-length)))
+ (write i)
+ (write-char #\space)
+ (write packet-length)
+ (write-char #\space)
+ (let ((packet
+ (if text?
+ (random-text-string packet-length)
+ (random-byte-vector packet-length))))
+ (write packet)
+ (newline)
+ (update context packet 0 packet-length))))
+ (finalize context)))))
+
+(define (random-text-string length)
+ (let ((string (make-string length))
+ (n-text (string-length text-characters)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i length))
+ (string-set! string i (string-ref text-characters (random n-text))))
+ string))
+
+(define text-characters
+ (list->string
+ (append '(#\tab #\newline)
+ (char-set-members char-set:graphic))))
+\f
+(define (test-codec n-packets packet-length text? filename
+ encode:initialize encode:finalize encode:update
+ decode:initialize decode:finalize decode:update)
+ (let ((packets (make-test-vector n-packets packet-length text?)))
+ (let ((n-packets (vector-length packets)))
+ (call-with-output-file (pathname-new-type filename "clear1")
+ (lambda (port)
+ (do ((i 0 (+ i 1)))
+ ((= i n-packets))
+ (write-string (vector-ref packets i) port))))
+ (call-with-output-file (pathname-new-type filename "encoded")
+ (lambda (port)
+ (let ((context (encode:initialize port text?)))
+ (do ((i 0 (+ i 1)))
+ ((= i n-packets))
+ (let ((packet (vector-ref packets i)))
+ (encode:update context packet 0 (string-length packet))))
+ (encode:finalize context))))))
+ (retest-decoder text? filename
+ decode:initialize decode:finalize decode:update))
+
+(define (make-test-vector n-packets packet-length text?)
+ (let ((n-packets (random n-packets)))
+ (let ((packets (make-vector n-packets)))
+ (do ((i 0 (+ i 1)))
+ ((= i n-packets))
+ (vector-set! packets i
+ (let ((packet-length (random packet-length)))
+ (if text?
+ (random-text-string packet-length)
+ (random-byte-vector packet-length)))))
+ packets)))
+
+(define (retest-codec text? filename
+ encode:initialize encode:finalize encode:update
+ decode:initialize decode:finalize decode:update)
+ (call-with-input-file (pathname-new-type filename "clear1")
+ (lambda (input-port)
+ (call-with-output-file (pathname-new-type filename "encoded")
+ (lambda (output-port)
+ (let ((context (encode:initialize output-port text?))
+ (buffer (make-string 37)))
+ (let loop ()
+ (let ((n-read (read-string! buffer input-port)))
+ (if (fix:> n-read 0)
+ (begin
+ (encode:update context buffer 0 n-read)
+ (loop)))))
+ (encode:finalize context))))))
+ (retest-decoder text? filename
+ decode:initialize decode:finalize decode:update))
+
+(define (retest-decoder text? filename
+ decode:initialize decode:finalize decode:update)
+ (let ((pn3 (pathname-new-type filename "clear2")))
+ (call-with-input-file (pathname-new-type filename "encoded")
+ (lambda (input-port)
+ (call-with-output-file pn3
+ (lambda (output-port)
+ (let ((context (decode:initialize output-port text?))
+ (buffer (make-string 41)))
+ (let loop ()
+ (let ((n-read (read-string! buffer input-port)))
+ (if (fix:> n-read 0)
+ (begin
+ (decode:update context buffer 0 n-read)
+ (loop)))))
+ (decode:finalize context))))))
+ (call-with-input-file (pathname-new-type filename "clear1")
+ (lambda (p1)
+ (call-with-input-file pn3
+ (lambda (p3)
+ (let loop ()
+ (let ((c1 (read-char p1))
+ (c3 (read-char p3)))
+ (if (eof-object? c1)
+ (if (eof-object? c3)
+ unspecific
+ (error "Output file longer."))
+ (if (eof-object? c3)
+ (error "Output file shorter.")
+ (if (char=? c1 c3)
+ (loop)
+ (error "Files don't match."))))))))))))
\ No newline at end of file
--- /dev/null
+(define (fill-file-with-random-integers n-bits-in-file
+ n-bits-per-integer
+ n-progress-dots
+ filename)
+ (if (not (= 0 (remainder n-bits-in-file n-bits-per-integer)))
+ (error:bad-range-argument n-bits-in-file
+ 'FILL-FILE-WITH-RANDOM-INTEGERS))
+ (if (not (= 0 (remainder n-bits-per-integer 8)))
+ (error:bad-range-argument n-bits-per-integer
+ 'FILL-FILE-WITH-RANDOM-INTEGERS))
+ (call-with-output-file filename
+ (lambda (port)
+ (let ((modulus (expt 2 n-bits-per-integer))
+ (j-limit (quotient n-bits-in-file n-bits-per-integer))
+ (i-limit (quotient n-bits-per-integer 8)))
+ (let ((j-dot (quotient j-limit n-progress-dots))
+ (buffer (make-string i-limit)))
+ (do ((j 0 (+ j 1)))
+ ((= j j-limit))
+ (if (= 0 (remainder j j-dot))
+ (write-char #\.))
+ (do ((i 0 (+ i 1))
+ (n (random modulus) (quotient n #x100)))
+ ((= i i-limit))
+ (vector-8b-set! buffer i (remainder n #x100)))
+ (write-string buffer port)))))))
\ No newline at end of file
--- /dev/null
+(define (test-string pattern string expected)
+ (assert-equal `(match-string ',pattern ,string)
+ (match-string pattern string)
+ expected))
+
+(define (match-string pattern string)
+ (regsexp-match-string (compile-regsexp pattern) string))
+
+(define (assert-equal expr value expected)
+ (if (not (equal? value expected))
+ (begin
+ (fluid-let ((*unparse-abbreviate-quotations?* #t))
+ (write expr))
+ (write-string " => ")
+ (write value)
+ (write-string " but expected ")
+ (write expected)
+ (newline))))
+
+(define (test-strings pattern entries)
+ (for-each (lambda (p)
+ (test-string pattern (car p) (cadr p)))
+ entries))
+
+(define (test-no-groups pattern entries)
+ (test-strings pattern
+ (map (lambda (p)
+ (list (car p)
+ (and (cadr p)
+ (list (cadr p)))))
+ entries)))
+
+(define (no-groups-tester strings)
+ (lambda (pattern indices)
+ (test-no-groups pattern
+ (map list strings indices))))
+
+(define (run-tests)
+ (test-no-groups '(any-char)
+ '(("" #f)
+ ("a" 1)
+ ("b" 1)
+ ("\n" #f)))
+
+ (test-no-groups '(* (any-char))
+ '(("" 0)
+ ("a" 1)
+ ("ab" 2)
+ ("abc" 3)
+ ("ab\n" 2)
+ ("a\nb" 1)))
+
+ (test-string '(seq "a" "b") "ab" '(2))
+
+ (let ((test (no-groups-tester '("" "a" "b" "ab" "ba" "aab"))))
+ (let ((equivalents
+ (lambda (indices . patterns)
+ (for-each (lambda (pattern)
+ (test pattern indices))
+ patterns))))
+
+ (equivalents '(0 0 0 0 0 0)
+ ""
+ '(repeat> 0 0 "a")
+ '(repeat< 0 0 "a")
+ '(seq "" ""))
+
+ (equivalents '(#f 1 #f 1 #f 1)
+ "a"
+ '(repeat> 1 1 "a")
+ '(repeat< 1 1 "a")
+ '(seq "a" "")
+ '(seq "" "a"))
+
+ (equivalents '(#f #f #f #f #f 2)
+ "aa"
+ '(repeat> 2 2 "a")
+ '(repeat< 2 2 "a")
+ '(seq "a" "a")
+ '(seq "aa" "")
+ '(seq "" "aa"))
+
+ (equivalents '(0 1 0 1 0 2)
+ '(* "a")
+ '(repeat> 0 #f "a"))
+
+ (equivalents '(0 0 0 0 0 0)
+ '(*? "a")
+ '(repeat< 0 #f "a"))
+
+ (equivalents '(#f 1 #f 1 #f 2)
+ '(+ "a")
+ '(seq "a" (* "a"))
+ '(repeat> 1 #f "a"))
+
+ (equivalents '(#f 1 #f 1 #f 1)
+ '(+? "a")
+ '(seq "a" (*? "a"))
+ '(repeat< 1 #f "a"))
+
+ (equivalents '(0 1 0 1 0 1)
+ '(? "a")
+ '(repeat> 0 1 "a"))
+
+ (equivalents '(0 0 0 0 0 0)
+ '(?? "a")
+ '(repeat< 0 1 "a"))))
+
+ (test-string '(seq (? "a") "a") "aab" '(2))
+ (test-string '(seq (? "a") "ab") "aab" '(3))
+
+ (test-string '(seq (?? "a") "a") "aab" '(1))
+ (test-string '(seq (?? "a") "ab") "aab" '(3))
+
+ (test-string '(repeat> 1 2 "a") "aab" '(2))
+ (test-string '(seq (repeat> 1 2 "a") "b") "aab" '(3))
+
+ (test-string '(repeat< 1 2 "a") "aab" '(1))
+ (test-string '(seq (repeat< 1 2 "a") "b") "aab" '(3))
+
+ (test-string '(repeat> 1 3 "a") "aaab" '(3))
+ (test-string '(seq (repeat> 1 3 "a") "b") "aaab" '(4))
+
+ (test-string '(repeat< 1 3 "a") "aaab" '(1))
+ (test-string '(seq (repeat< 1 3 "a") "b") "aaab" '(4))
+
+ (test-string '(seq (group foo (? "a")) "a") "aab" '(2 (foo 0 1)))
+ (test-string '(seq (group foo (? "a")) "ab") "aab" '(3 (foo 0 1)))
+ (test-string '(seq (group foo (? "a")) "aab") "aab" '(3 (foo 0 0)))
+
+ (test-string '(seq (group foo (?? "a")) "a") "aab" '(1 (foo 0 0)))
+ (test-string '(seq (group foo (?? "a")) "ab") "aab" '(3 (foo 0 1)))
+ (test-string '(seq (group foo (?? "a")) "aab") "aab" '(3 (foo 0 0)))
+
+ (test-string '(seq (group foo (* "a")) "b") "aab" '(3 (foo 0 2)))
+ (test-string '(seq (group foo (* "a")) "ab") "aab" '(3 (foo 0 1)))
+ (test-string '(seq (group foo (* "a")) "aab") "aab" '(3 (foo 0 0)))
+
+ (test-string '(seq (group foo (*? "a")) "b") "aab" '(3 (foo 0 2)))
+ (test-string '(seq (group foo (*? "a")) "ab") "aab" '(3 (foo 0 1)))
+ (test-string '(seq (group foo (*? "a")) "aab") "aab" '(3 (foo 0 0)))
+ )
\ No newline at end of file
--- /dev/null
+;;; xcons
+(xcons (list 1) 2)
+;Value 1: (2 1)
+
+;;; make-list
+(make-list 3)
+;Value 2: (#f #f #f)
+
+(make-list 3 5)
+;Value 3: (5 5 5)
+
+;;; list-tablulate
+(list-tabulate 5 (lambda (x) (+ x 1)))
+;Value 7: (1 2 3 4 5)
+
+(list-tabulate 5 square)
+;Value 6: (0 1 4 9 16)
+
+;;; cons*
+(cons* 'a 'b (iota 3))
+;Value 8: (a b 0 1 2)
+
+;;; list-copy
+(let* ((foo (iota 5))
+ (bar foo)
+ (baz (list-copy foo)))
+ (list (eq? foo bar)
+ (eq? foo baz)))
+;Value 9: (#t #f)
+
+;;; iota,
+(iota 5)
+;Value 10: (0 1 2 3 4)
+
+(iota 5 10)
+;Value 11: (10 11 12 13 14)
+
+(iota 5 10 2)
+;Value 12: (10 12 14 16 18)
+
+;;; iota-
+(iota- 5)
+;Value 13: (1 2 3 4 5)
+
+(iota- 5 10)
+;Value 14: (6 7 8 9 10)
+
+(iota- 5 10 2)
+;Value 15: (7 9)
+
+;;; -iota
+(-iota 5)
+;Value 16: (0 1 2 3 4)
+
+(-iota 5 10)
+;Value 17: (5 6 7 8 9)
+
+(-iota 5 10 2)
+;Value 18: (5 7 9)
+
+;;; circular-list
+(fourth (circular-list 1 2 3))
+;Value: 1
+
+;;; proper-list?
+(proper-list? (cons 1 (list 2)))
+;Value: #t
+
+(proper-list? (cons 1 2))
+;Value: #f
+
+(proper-list? (circular-list 1 2 3))
+;Value: #f
+
+;;; dotted-list?
+(dotted-list? (cons 1 (list 2)))
+;Value: #f
+
+(dotted-list? (cons 1 2))
+;Value: #t
+
+(dotted-list? (circular-list 1 2 3))
+;Value: #f
+
+;;; circular-list?
+(circular-list? (cons 1 (list 2)))
+;Value: #f
+
+(circular-list? (cons 1 2))
+;Value: #f
+
+(circular-list? (circular-list 1 2 3))
+;Value: #t
+
+;;; not-pair?
+(not-pair? 5)
+;Value: #t
+
+(not-pair? '())
+;Value: #t
+
+(not-pair? (circular-list 1 2 3))
+;Value: #f
+
+;;; list= (altered)
+(list= eq?
+ '(a b c)
+ '(a b c)
+ '(a b c))
+;Value: #t
+
+(list= eq?
+ '("a")
+ '("a"))
+;Value: #f
+
+(list= equal?
+ '("a")
+ '("a"))
+;Value: #t
+
+;;; length+
+(length (circular-list 1 2 3))
+;The object (1 2 3 1 2 3 1 2 3...), passed as an argument to length, is not a list.
+;To continue, call RESTART with an option number:
+; (RESTART 2) => Return to read-eval-print level 2.
+; (RESTART 1) => Return to read-eval-print level 1.
+
+(length+ (circular-list 1 2 3))
+;Value: #f
+
+(length+ (list 1 2 3))
+;Value: 3
+
+;;; zip
+(zip '(1 2 3) '(1 2 3))
+;Value 2: ((1 1) (2 2) (3 3))
+
+
+;;; take-right
+(take-right '(a b c d e) 2)
+;Value 5: (d e)
+
+
+;;; drop-right
+(drop-right '(a b c d e) 2)
+;Value 6: (a b c)
+
+
+;;; drop-right!
+(let ((foo '(a b c d e)))
+ (let ((bar (drop-right! foo 2)))
+ foo))
+;Value 7: (a b c)
+
+
+;;; take
+(take '(a b c d e) 2)
+;Value 8: (a b)
+
+(take '(a b c d e) -2)
+;Value 9: (d e)
+
+
+;;; drop
+(drop '(a b c d e) 2)
+;Value 15: (c d e)
+
+(drop '(a b c d e) -2)
+;Value 16: (a b c)
+
+
+;;; take!
+(let ((foo '(a b c d e)))
+ (let ((bar (take! foo 2)))
+ foo))
+;Value 10: (a b)
+
+;;; drop! (linear updates not guaranteed to modify their arguments)
+(let ((foo '(a b c d e)))
+ (let ((bar (drop! foo 2)))
+ (list foo
+ bar)))
+;Value 14: ((a b c d e) (c d e))
+
+;;; split-at
+(let ((foo '(a b c d e)))
+ (receive (x y)
+ (split-at foo 2)
+ (list x y)))
+;Value 17: ((a b) (c d e))
+
+;;; split-at!
+(let ((foo '(a b c d e)))
+ (receive (x y)
+ (split-at! foo 2)
+ (list x y foo)))
+;Value 18: ((a b) (c d e) (a b))
+
+
+;;; last
+(last '(a b c d e))
+;Value: e
+
+
+;;; unzip1-5
+(unzip1 '((a b)
+ (c d)
+ (e f)))
+;Value 19: (a c e)
+
+(receive (a b)
+ (unzip2 (list (iota 10 0)
+ (iota 10 10)
+ (iota 10 20)))
+ (list a b))
+;Value 34: ((0 10 20) (1 11 21))
+
+
+(receive (a b c)
+ (unzip3 (list (iota 10 0)
+ (iota 10 10)
+ (iota 10 20)))
+ (list a b c))
+;Value 35: ((0 10 20) (1 11 21) (2 12 22))
+
+(receive (a b c d)
+ (unzip4 (list (iota 10 0)
+ (iota 10 10)
+ (iota 10 20)))
+ (list a b c d))
+;Value 39: ((0 10 20) (1 11 21) (2 12 22) (3 13 23))
+
+(receive (a b c d e)
+ (unzip5 (list (iota 10 0)
+ (iota 10 10)
+ (iota 10 20)))
+ (list a b c d e))
+;Value 40: ((0 10 20) (1 11 21) (2 12 22) (3 13 23) (4 14 24))
+
+
+;;; append! append-reverse append-reverse! concatenate concatenate!
+(append! '(a b c)
+ '(d e f)
+ '(g h i))
+;Value 41: (a b c d e f g h i)
+
+(append-reverse '(a b c)
+ '(d e f))
+;Value 42: (c b a d e f)
+
+(append-reverse! '(a b c)
+ '(d e f))
+;Value 43: (c b a d e f)
+
+(concatenate '((a b c)
+ (d e f)
+ (g h i)))
+;Value 47: (a b c d e f g h i)
+
+(concatenate! '((a b c)
+ (d e f)
+ (g h i)))
+;Value 48: (a b c d e f g h i)
+
+
+;;; fold/map internal utilities
+(%cdrs '((a b c)
+ (d e f)
+ (g h i)))
+;Value 49: ((b c) (e f) (h i))
+
+(%cars+ '((a b c)
+ (d e f)
+ (g h i))
+ 0)
+;Value 51: (a d g 0)
+
+(receive (x y)
+ (%cars+cdrs '((a b c)
+ (d e f)
+ (g h i)))
+ (list x y))
+;Value 53: ((a d g) ((b c) (e f) (h i)))
+
+(receive (x y)
+ (%cars+cdrs '((a b c)
+ (d e f)
+ ()))
+ (list x y))
+;Value 5: (() ())
+
+
+(receive (x y)
+ (%cars+cdrs+ '((a b c)
+ (d e f)
+ (g h i))
+ 0)
+ (list x y))
+;Value 54: ((a d g 0) ((b c) (e f) (h i)))
+
+(receive (x y)
+ (%cars+cdrs+ '((a b c)
+ (d e f)
+ ())
+ 0)
+ (list x y))
+;Value 6: (() ())
+
+
+(receive (x y)
+ (%cars+cdrs/no-test '((a b c)
+ (d e f)
+ (g h i)))
+ (list x y))
+;Value 55: ((a d g) ((b c) (e f) (h i)))
+
+
+(receive (x y)
+ (%cars+cdrs/no-test '((a b c)
+ (d e f)
+ ()))
+ (list x y))
+
+;The object (), passed as the first argument to cdr, is not the correct type.
+;To continue, call RESTART with an option number:
+; (RESTART 2) => Specify an argument to use in its place.
+; (RESTART 1) => Return to read-eval-print level 1.
+
+;;; count
+(count even? (iota 10))
+;Value: 5
+
+(count (lambda (x y) (even? (+ x y)))
+ (iota 10)
+ (iota 10))
+;Value: 10
+
+;;; fold/unfold
+(unfold-right null-list? car cdr (iota 10))
+;Value 59: (9 8 7 6 5 4 3 2 1 0)
+
+(unfold null-list? car cdr (iota 10) (lambda (x) (cons 'foo x)))
+;Value 60: (0 1 2 3 4 5 6 7 8 9 foo)
+
+
+(fold cons* '() '(a b c) '(1 2 3 4 5))
+;Value 7: (c 3 b 2 a 1)
+
+
+(fold-right + 0 (iota 5 1) (iota 5 6))
+;Value: 55
+
+(fold-right cons* '() (iota 10) (iota 20))
+;Value 69: (0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9)
+
+
+(pair-fold cons* '() '(a b c) '(1 2 3 4 5))
+;Value 8: ((c) (3 4 5) (b c) (2 3 4 5) (a b c) (1 2 3 4 5))
+
+(pair-fold-right cons* '() '(a b c) '(1 2 3 4 5))
+;Value 9: ((a b c) (1 2 3 4 5) (b c) (2 3 4 5) (c) (3 4 5))
+
+(reduce + 'none (iota 10))
+;Value: 45
+
+(reduce + 'none '())
+;Value: none
+
+(reduce-right + 'none (iota 10))
+;Value: 45
+
+(reduce-right + 'none '())
+;Value: none
+
+(append-map (lambda (x) (list x (- x))) '(1 3 8))
+;Value 12: (1 -1 3 -3 8 -8)
+
+(append-map list
+ (iota 5)
+ (iota 5 5))
+;Value 15: (0 5 1 6 2 7 3 8 4 9)
+
+(append-map! (lambda (x) (list x (- x))) '(1 3 8))
+;Value 13: (1 -1 3 -3 8 -8)
+
+
+(pair-for-each write-line (iota 3))
+; (0 1 2)
+; (1 2)
+; (2)
+; ;Unspecified return value
+
+(pair-for-each (lambda (x y) (write-line (list x y)))
+ (iota 3)
+ (iota 3 3))
+; ((0 1 2) (3 4 5))
+; ((1 2) (4 5))
+; ((2) (5))
+; ;Unspecified return value
+
+(map! +
+ (iota 5)
+ (iota 10))
+;Value 16: (0 2 4 6 8)
+
+(map! +
+ (iota 10)
+ (iota 5))
+;The object (), passed as the first argument to cdr, is not the correct type.
+;To continue, call RESTART with an option number:
+; (RESTART 2) => Specify an argument to use in its place.
+; (RESTART 1) => Return to read-eval-print level 1.
+
+(filter-map (lambda (x) (and (even? x)
+ (square x)))
+ (iota 10))
+;Value 17: (0 4 16 36 64)
+
+(let ((foo '()))
+ (map-in-order (lambda (x) (set! foo (cons x foo)))
+ (iota 10))
+ foo)
+;Value 19: (9 8 7 6 5 4 3 2 1 0)
+
+
+;;; filter, remove, partition
+
+(filter even? (iota 10))
+;Value 20: (0 2 4 6 8)
+
+(filter! even? (iota 10))
+;Value 22: (0 2 4 6 8)
+
+(remove even? (iota 10))
+;Value 21: (1 3 5 7 9)
+
+(remove! even? (iota 10))
+;Value 23: (1 3 5 7 9)
+
+(receive (x y)
+ (partition even? (iota 10))
+ (list x y))
+;Value 24: ((0 2 4 6 8) (1 3 5 7 9))
+
+(receive (x y)
+ (partition! even? (iota 10))
+ (list x y))
+;Value 25: ((0 2 4 6 8) (1 3 5 7 9))
+
+
+;;; delete, assoc, member
+(delete 3 (iota 5))
+;Value 26: (0 1 2 4)
+
+(delete 3 (iota 5) eqv?)
+;Value 49: (0 1 2 4)
+
+(delete! 3 (iota 5))
+;Value 27: (0 1 2 4)
+
+(delete! 3 (iota 5) eqv?)
+;Value 50: (0 1 2 4)
+
+
+(member "b" (list "a" "b" "c"))
+;Value 29: ("b" "c")
+
+(member "b" (list "a" "b" "c") eqv?)
+;Value: #f
+
+
+(delete-duplicates '(0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9))
+;Value 52: (0 1 2 3 4 5 6 7 8 9)
+
+(delete-duplicates '(0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9) eqv?)
+;Value 53: (0 1 2 3 4 5 6 7 8 9)
+
+
+;;; alist stuff
+
+(let ((e '((a 1) (b 2) (c 3))))
+ (list (assq 'a e)
+ (assq 'b e)
+ (assq 'd e)))
+;Value 54: ((a 1) (b 2) #f)
+
+
+(assq (list 'a) '(((a)) ((b)) ((c))))
+;Value: #f
+
+(assoc (list 'a) '(((a)) ((b)) ((c))))
+;Value 55: ((a))
+
+
+(assq 5 '((2 3) (5 7) (11 13)))
+;Value 56: (5 7)
+;;; this is R5RS unspecified though
+
+(assv 5 '((2 3) (5 7) (11 13)))
+;Value 57: (5 7)
+;;; but not this
+
+
+;;; find find-tail take-while drop-while span break any every list-index
+
+
+(find even? (iota 10 5))
+;Value: 6
+
+(find-tail even? (iota 10 5))
+;Value 58: (6 7 8 9 10 11 12 13 14)
+
+(drop-while even? '(2 18 3 10 22 9))
+;Value 59: (3 10 22 9)
+
+(take-while even? '(2 18 3 10 22 9))
+;Value 60: (2 18)
+
+(receive (x y)
+ (span even? '(2 18 3 10 22 9))
+ (list x y))
+;Value 61: ((2 18) (3 10 22 9))
+
+
+(receive (x y)
+ (span! even? '(2 18 3 10 22 9))
+ (list x y))
+;Value 62: ((2 18) (3 10 22 9))
+
+
+(any even? (iota 5 1 2))
+;Value: #f
+
+(any (lambda (x y) (odd? (+ x y)))
+ (iota 10)
+ (iota 10))
+;Value: #f
+
+(every odd? (iota 5 1 2))
+;Value: #t
+
+(every (lambda (x y) (even? (+ x y)))
+ (iota 10)
+ (iota 10))
+;Value: #t
+
+(list-index odd? '(2 18 3 10 22 9))
+;Value: 2
+
+
+;;; reverse!
+
+(reverse! (iota 10))
+;Value 66: (9 8 7 6 5 4 3 2 1 0)
+
+
+;;; lset-*
+
+(lset<= eq? '(a) '(a b a) '(a b c c))
+;Value: #t
+
+(lset= eq? '(b e a) '(a e b) '(e e b a)) => #t
+;Value: #t
+
+
+(lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u)
+;Value 67: (u o i a b c d c e)
+
+
+(lset-union eq? '(a a c) '(x a x))
+;Value 68: (x a a c)
+
+
+(lset-union eq? '(a a c) '(x a x))
+;Value 69: (x a a c)
+
+
+(lset-intersection eq? '(a x y a) '(x a x z))
+;Value 70: (a x a)
+
+
+(lset-difference eq? '(a b c d e) '(a e i o u))
+;Value 71: (b c d)
+
+
+(lset-xor eq? '(a b c d e) '(a e i o u))
+;Value 72: (u o i b c d)
+
+
+(receive (x y)
+ (lset-diff+intersection eq?
+ '(a b c d)
+ '(a e)
+ '(c e))
+ (list x y))
+;Value 75: ((b d) (a c))
+
+(receive (x y)
+ (lset-diff+intersection! eq?
+ '(a b c d)
+ '(a e)
+ '(c e))
+ (list x y))
+;Value 76: ((b d) (a c))
--- /dev/null
+(define (file-stream filename)
+ (let ((port (open-input-file filename)))
+ (let loop ()
+ (let ((char (read-char port)))
+ (if (eof-object? char)
+ (begin
+ (close-port port)
+ '())
+ (cons-stream char (loop)))))))
+
+(define (run-tests filename)
+ (toggle-gc-notification!)
+ (stream-length (file-stream filename))
+ (stream-length (stream-map (lambda (x) x) (file-stream filename)))
+ (stream-for-each (lambda (x) x) (file-stream filename))
+ (toggle-gc-notification!))
+
+(run-tests "~/gunk/receiver/chip1/receiver/qrm-1.sim")
\ No newline at end of file
--- /dev/null
+(declare (usual-integrations))
+
+(define (test-noop length iterations)
+ (let ((from (make-string length))
+ (to (make-string (fix:* 2 length))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i iterations)))))
+
+(define (test-left length iterations)
+ (let ((from (make-string length))
+ (to (make-string (fix:* 2 length))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i iterations))
+ (substring-move-left! from 0 length to length))))
+
+(define (test-right length iterations)
+ (let ((from (make-string length))
+ (to (make-string (fix:* 2 length))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i iterations))
+ (substring-move-right! from 0 length to length))))
+
+(define (test-inline length iterations)
+ (let ((from (make-string length))
+ (to (make-string (fix:* 2 length))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i iterations))
+ (do ((fi 0 (fix:+ fi 1))
+ (ti length (fix:+ ti 1)))
+ ((fix:= fi length))
+ (string-set! to ti (string-ref from fi))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff