; -*- Scheme -*-
;
; $Id: conc-string-test.scm,v 1.1 1998/03/16 07:58:03 foner Exp $
;
; Small set of regression tests for CONC-STRING.
;
; To run the test call the function CONC-STRING:TEST:ALL.
; If everthing works, it should return #t.
; If there are any errors, CONC-STRING:TEST:ERROR is called with the
; name of the test that failed.  The default definition of this is to
; abort (and probably invoke the debugger)

;-------------

(require 'conc-string)

;-------------

(define conc-string:test:all
  (lambda ()
    (conc-string:test:length-simple)
    (conc-string:test:ref-simple)
    (conc-string:test:error:bounds)
    (conc-string:test:->string)
    (conc-string:test:append)
    (conc-string:test:insert)
    ))

; XXX: write more test functions

;------------

(define conc-string:test:error
  (lambda (test-name)
    (error 'test-name "failed regression test")))

;------------

(define conc-string:test:eq
  (lambda (test-name test-result expected-result)
    (if (equal? test-result expected-result)
	#t
	(conc-string:test:error test-name))))

;-------------

(define conc-string:test:length-simple
  (lambda ()

    (conc-string:test:eq
     'conc-string:length-a
     (conc-string:length (conc-string:<-string "abc"))
     3)

    (conc-string:test:eq
     'conc-string:length-b
     (conc-string:length (conc-string:<-string ""))
     0)
    ))

(define conc-string:test:ref-simple
  (lambda ()
    (conc-string:test:eq
     'conc-string:ref-a
     (conc-string:ref (conc-string:<-string "abc") 0)
     #\a)
    (conc-string:test:eq
     'conc-string:ref-a
     (conc-string:ref (conc-string:<-string "abc") 1)
     #\b)
    (conc-string:test:eq
     'conc-string:ref-a
     (conc-string:ref (conc-string:<-string "abc") 2)
     #\c)
    ))
    

(define conc-string:test:error:bounds
  (lambda ()
    (let ((old-error-handler conc-string:error:bounds))
      (set! conc-string:error:bounds (lambda (str index) 42))
      (conc-string:test:eq
       'conc-string:error:bounds
       (conc-string:ref (conc-string:<-string "abc") 5)
       42)
      (set! conc-string:error:bounds old-error-handler))
    ))

(define conc-string:test:->string
  (lambda ()
    (conc-string:test:eq
     'conc-string:->string-a
     (conc-string:->string (conc-string:<-string "abc"))
     "abc")

    (conc-string:test:eq
     'conc-string:->string-b
     (conc-string:->string (conc-string:<-string ""))
     "")
    ))

(define conc-string:test:append
  (lambda ()
    (let ((s (conc-string:append:2 (conc-string:<-string "abc")
				   (conc-string:<-string "pqrst"))))
      (conc-string:test:eq
       'conc-string:append-a
       (conc-string:length s)
       8)

      (conc-string:test:eq
       'conc-string:append-b
       (conc-string:->string s)
       "abcpqrst")

      (let ((t (conc-string:append:2 (conc-string:<-string "xyz") s)))
	(conc-string:test:eq
	 'conc-string:append-c
	 (conc-string:->string t)
	 "xyzabcpqrst")))))

(define conc-string:test:insert
  (lambda ()
    (conc-string:test:eq
     'conc-string:insert-a
     (conc-string:->string
      (conc-string:insert
       (conc-string:<-string " john ")
       7
       (conc-string:<-string "stephenbevan")))
     "stephen john bevan")

    (conc-string:test:eq
     'conc-string:insert-b
     (conc-string:->string
      (conc-string:insert
       (conc-string:<-string " john ")
       7
       (conc-string:append:2
	 (conc-string:<-string "stephe")
	 (conc-string:<-string "nbevan"))))
     "stephen john bevan")
    ))
