scheme48/ps-compiler/prescheme/test/string.scm

; Part of Scheme 48 1.9.  See file COPYING for notices and license.

; Authors: Richard Kelsey



(define (xwrite-string string out)
  (let ((len (string-length string)))
    (do ((i 0 (+ i 1)))
	((>= i len))
      (write-char (string-ref string (- len (+ i 1))) out))
    (newline out)))

(define (write-string string out)
  (let ((len (string-length string)))
    (do ((i 0 (+ i 1)))
	((>= i len))
      (write-char (string-ref string i) out))
    (newline out)))

(define a-string "Hello sailor...")

(define (test)
  (let* ((in (current-input-port))
	 (out (current-output-port))
	 (len (ashr (read-number in) 2))
	 (string (make-string len)))
    (let loop ((i 0))
      (if (< i len)
	  (ps-read-char in
	    (lambda (ch)
	      (string-set! string i ch)
	      (loop (+ i 1)))
	    (lambda ()
	      (unassigned)))))
    (write-string string out)
    (xwrite-string string out)
    (deallocate string)
    (write-string a-string out)
    (xwrite-string a-string out)))

(define (read-number port)
  (let loop ((r 0))
    (ps-read-char port
      (lambda (ch)
	(cond ((digit? ch)
	       (loop (+ (- (char->ascii ch) (char->ascii #\0))
			(* r 10))))
	      (else r)))
      (lambda () 0))))

(define (digit? ch)
  (let ((ch (char->ascii ch)))
    (and (>= ch (char->ascii #\0))
	 (<= ch (char->ascii #\9)))))