;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

;; "_standard.scm"


(##include "header.scm")

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

; IEEE Scheme procedures:

(define (not x) (touch-vars (x) (##not x)))

(define (boolean? x) (touch-vars (x) (or (##eq? x #t) (##eq? x #f))))

(define (eqv? x y) (touch-vars (x y) (##eqv? x y)))

(define (eq? x y) (touch-vars (x y) (##eq? x y)))

(define (equal? x y) (##equal? x y (if-touches #t #f)))

(define (pair? x) (touch-vars (x) (##pair? x)))

(define (cons x y) (##cons x y))

(define (car x) (touch-vars (x) (check-pair x (car x) (##car x))))

(define (cdr x) (touch-vars (x) (check-pair x (cdr x) (##cdr x))))

(define (set-car! x y)
  (touch-vars (x) (check-pair x (set-car! x y) (##set-car! x y))))

(define (set-cdr! x y)
  (touch-vars (x) (check-pair x (set-cdr! x y) (##set-cdr! x y))))

(##define-macro (define-c...r name pattern)

  (define (gen name pattern)
    `(CHECK-PAIR Y (,name X)
       ,(if (<= pattern 3)
          (if (= pattern 3) '(##CDR Y) '(##CAR Y))
          `(LET ((Y ,(if (odd? pattern) '(##CDR Y) '(##CAR Y))))
             (TOUCH-VARS (Y)
               ,(gen name (quotient pattern 2)))))))

  `(DEFINE (,name X)
     (TOUCH-VARS (X)
       (LET ((Y X))
         ,(gen name pattern)))))

(define-c...r caar 4)
(define-c...r cadr 5)
(define-c...r cdar 6)
(define-c...r cddr 7)
(define-c...r caaar 8)
(define-c...r caadr 9)
(define-c...r cadar 10)
(define-c...r caddr 11)
(define-c...r cdaar 12)
(define-c...r cdadr 13)
(define-c...r cddar 14)
(define-c...r cdddr 15)
(define-c...r caaaar 16)
(define-c...r caaadr 17)
(define-c...r caadar 18)
(define-c...r caaddr 19)
(define-c...r cadaar 20)
(define-c...r cadadr 21)
(define-c...r caddar 22)
(define-c...r cadddr 23)
(define-c...r cdaaar 24)
(define-c...r cdaadr 25)
(define-c...r cdadar 26)
(define-c...r cdaddr 27)
(define-c...r cddaar 28)
(define-c...r cddadr 29)
(define-c...r cdddar 30)
(define-c...r cddddr 31)

(define (null? x) (touch-vars (x) (##null? x)))

(define (list? x)
  (let loop ((l1 x) (l2 x))
    (touch-vars (l1)
      (if (##not (##pair? l1))
        (##null? l1)
        (let ((l1 (##cdr l1)))
          (touch-vars (l1 l2)
            (cond ((##eq? l1 l2)
                   #f)
                  ((##pair? l1)
                   (loop (##cdr l1) (##cdr l2)))
                  (else
                   (##null? l1)))))))))

(define (list . l) l)

(define (length l)
  (let loop ((l l) (n 0))
    (touch-vars (l)
      (if (##pair? l)
        (loop (##cdr l) (##fixnum.+ n 1))
        n))))

(define (append . l)

  (define (append1 l)
    (if (##pair? (##cdr l))
      (append2 (##car l) (append1 (##cdr l)))
      (##car l)))

  (define (append2 l1 l2)
    (touch-vars (l1)
      (if (##pair? l1)
        (let ((result (##cons (##car l1) '())))
          (##set-cdr!
            (let loop ((end result) (l1 (##cdr l1)))
              (touch-vars (l1)
                (if (##pair? l1)
                  (let ((tail (##cons (##car l1) '())))
                    (##set-cdr! end tail)
                    (loop tail (##cdr l1)))
                  end)))
            l2)
          result)
        l2)))

  (if (##pair? l)
    (append1 l)
    '()))

(define (reverse l)
  (let loop ((l l) (x '()))
    (touch-vars (l)
      (if (##pair? l)
        (loop (##cdr l) (##cons (##car l) x))
        x))))

(define (list-ref l k)
  (touch-vars (k)
    (check-exact-int-non-neg k (list-ref l k)
      (let loop ((x l) (i k))
        (touch-vars (x)
          (check-pair x (list-ref l k)
            (if (##fixnum.< 0 i)
              (loop (##cdr x) (##fixnum.- i 1))
              (##car x))))))))

(define (memq x l)
  (touch-vars (x)
    (let loop ((l l))
      (touch-vars (l)
        (if (##pair? l)
          (let ((y (##car l)))
            (touch-vars (y)
              (if (##eq? x y)
                l
                (loop (##cdr l)))))
          #f)))))

(define (memv x l)
  (touch-vars (x)
    (let loop ((l l))
      (touch-vars (l)
        (if (##pair? l)
          (let ((y (##car l)))
            (touch-vars (y)
              (if (##eqv? x y)
                l
                (loop (##cdr l)))))
          #f)))))

(define (member x l)
  (let loop ((l l))
    (touch-vars (l)
      (if (##pair? l)
        (let ((y (##car l)))
          (if (##equal? x y (if-touches #t #f))
            l
            (loop (##cdr l))))
        #f))))

(define (assq x l)
  (touch-vars (x l)
    (let loop ((y l))
      (if (##pair? y)
        (let ((couple (##car y)))
          (touch-vars (couple)
            (check-pair couple (assq x l)
              (let ((z (##car couple)))
                (touch-vars (z)
                  (if (##eq? x z)
                    couple
                    (let ((y (##cdr y)))
                      (touch-vars (y)
                        (loop y)))))))))
        #f))))

(define (assv x l)
  (touch-vars (x l)
    (let loop ((y l))
      (if (##pair? y)
        (let ((couple (##car y)))
          (touch-vars (couple)
            (check-pair couple (assv x l)
              (let ((z (##car couple)))
                (touch-vars (z)
                  (if (##eqv? x z)
                    couple
                    (let ((y (##cdr y)))
                      (touch-vars (y)
                        (loop y)))))))))
        #f))))

(define (assoc x l)
  (touch-vars (l)
    (let loop ((y l))
      (if (##pair? y)
        (let ((couple (##car y)))
          (touch-vars (couple)
            (check-pair couple (assoc x l)
              (let ((z (##car couple)))
                (if (##equal? x z (if-touches #t #f))
                  couple
                  (let ((y (##cdr y)))
                    (touch-vars (y)
                      (loop y))))))))
        #f))))

(define (symbol? x) (touch-vars (x) (##symbol? x)))

(define (symbol->string sym)
  (touch-vars (sym)
    (check-symbol sym (symbol->string sym)
      (##symbol->string sym))))

(define (string->symbol str)
  (touch-vars (str)
    (check-string str (string->symbol str)
      (##string->symbol str))))

(define (number? x)   (touch-vars (x) (##complex? x)))
(define (complex? x)  (touch-vars (x) (##complex? x)))
(define (real? x)     (touch-vars (x) (##real? x)))
(define (rational? x) (touch-vars (x) (##rational? x)))
(define (integer? x)  (touch-vars (x) (##integer? x)))

(define (exact? x)   (touch-vars (x) (##exact? x)))
(define (inexact? x) (touch-vars (x) (##not (##exact? x))))

(define-nary0-boolean (=  x y) (##= x y) no-check touch-vars)
(define-nary0-boolean (<  x y) (##< x y) no-check touch-vars)
(define-nary0-boolean (>  x y) (##< y x) no-check touch-vars)
(define-nary0-boolean (<= x y) (##not (##< y x)) no-check touch-vars)
(define-nary0-boolean (>= x y) (##not (##< x y)) no-check touch-vars)

(define (zero? x)     (touch-vars (x) (##zero? x)))
(define (positive? x) (touch-vars (x) (##positive? x)))
(define (negative? x) (touch-vars (x) (##negative? x)))
(define (odd? x)      (touch-vars (x) (##odd? x)))
(define (even? x)     (touch-vars (x) (##not (##odd? x))))

(define-nary1 (max x y) x (##max x y) touch-vars)
(define-nary1 (min x y) x (##min x y) touch-vars)

(define-nary0 (+ x y) 0 x (##+ x y) touch-vars)
(define-nary0 (* x y) 1 x (##* x y) touch-vars)
(define-nary1 (- x y) (##- 0 x) (##- x y) touch-vars)
(define-nary1 (/ x y) (##/ 1 x) (##/ x y) touch-vars)

(define (abs x) (touch-vars (x) (##abs x)))

(define (quotient x y)  (touch-vars (x y) (##quotient x y)))
(define (remainder x y) (touch-vars (x y) (##remainder x y)))
(define (modulo x y)    (touch-vars (x y) (##modulo x y)))

(define-nary0 (gcd x y) 0 x (##gcd x y) touch-vars)
(define-nary0 (lcm x y) 1 x (##lcm x y) touch-vars)

(define (numerator x)   (touch-vars (x) (##numerator x)))
(define (denominator x) (touch-vars (x) (##denominator x)))

(define (floor x)    (touch-vars (x) (##floor x)))
(define (ceiling x)  (touch-vars (x) (##ceiling x)))
(define (truncate x) (touch-vars (x) (##truncate x)))
(define (round x)    (touch-vars (x) (##round x)))

(define (rationalize x y) (touch-vars (x y) (##rationalize x y)))

(define (exp x)  (touch-vars (x) (##exp x)))
(define (log x)  (touch-vars (x) (##log x)))
(define (sin x)  (touch-vars (x) (##sin x)))
(define (cos x)  (touch-vars (x) (##cos x)))
(define (tan x)  (touch-vars (x) (##tan x)))
(define (asin x) (touch-vars (x) (##asin x)))
(define (acos x) (touch-vars (x) (##acos x)))

(define (atan x (y))
  (touch-vars (x)
    (if (##unassigned? y)
      (##atan x)
      (touch-vars (y)
        (##atan2 x y)))))

(define (sqrt x) (touch-vars (x) (##sqrt x)))

(define (expt x y) (touch-vars (x y) (##expt x y)))

(define (make-rectangular x y)
  (touch-vars (x y) (##make-rectangular x y)))

(define (make-polar x y) (touch-vars (x y) (##make-polar x y)))
(define (real-part x)    (touch-vars (x) (##real-part x)))
(define (imag-part x)    (touch-vars (x) (##imag-part x)))
(define (magnitude x)    (touch-vars (x) (##magnitude x)))
(define (angle x)        (touch-vars (x) (##angle x)))

(define (exact->inexact x)
  (touch-vars (x) (##exact->inexact x)))

(define (inexact->exact x)
  (touch-vars (x) (##inexact->exact x)))

(define (number->string n (r))
  (touch-vars (n)
    (if (##unassigned? r)
      (##number->string n 10)
      (touch-vars (r)
        (##number->string n r)))))

(define (string->number s (r))
  (touch-vars (s)
    (if (##unassigned? r)
      (check-string s (string->number s)
        (##string->number s 10))
      (touch-vars (r)
        (check-string s (string->number s r)
          (##string->number s r))))))

(define (char? x) (touch-vars (x) (##char? x)))

(define-nary0-boolean (char=? x y)
  (##char=? x y) check-char touch-vars)

(define-nary0-boolean (char<? x y)
  (##char<? x y) check-char touch-vars)

(define-nary0-boolean (char>? x y)
  (##char<? y x) check-char touch-vars)

(define-nary0-boolean (char<=? x y)
  (##not (##char<? y x)) check-char touch-vars)

(define-nary0-boolean (char>=? x y)
  (##not (##char<? x y)) check-char touch-vars)

(define-nary0-boolean (char-ci=? x y)
  (##char-ci=? x y) check-char touch-vars)

(define-nary0-boolean (char-ci<? x y)
  (##char-ci<? x y) check-char touch-vars)

(define-nary0-boolean (char-ci>? x y)
  (##char-ci<? y x) check-char touch-vars)

(define-nary0-boolean (char-ci<=? x y)
  (##not (##char-ci<? y x)) check-char touch-vars)

(define-nary0-boolean (char-ci>=? x y)
  (##not (##char-ci<? x y)) check-char touch-vars)

(define (char-alphabetic? c)
  (touch-vars (c)
    (check-char c (char-alphabetic? c)
      (##char-alphabetic? c))))

(define (char-numeric? c)
  (touch-vars (c)
    (check-char c (char-numeric? c)
      (##char-numeric? c))))

(define (char-whitespace? c)
  (touch-vars (c)
    (check-char c (char-whitespace? c)
      (##char-whitespace? c))))

(define (char-upper-case? c)
  (touch-vars (c)
    (check-char c (char-upper-case? c)
      (##char-upper-case? c))))

(define (char-lower-case? c)
  (touch-vars (c)
    (check-char c (char-lower-case? c)
      (##char-lower-case? c))))

(define (char->integer c)
  (touch-vars (c)
    (check-char c (char->integer c)
      (##char->integer c))))

(define (integer->char n)
  (touch-vars (n)
    (check-exact-int-range n 0 (char-range) (integer->char n)
      (##integer->char n))))

(define (char-upcase c)
  (touch-vars (c)
    (check-char c (char-upcase c)
      (##char-upcase c))))

(define (char-downcase c)
  (touch-vars (c)
    (check-char c (char-downcase c)
      (##char-downcase c))))

(define (string? x) (touch-vars (x) (##string? x)))

(define (make-string x (y))
  (touch-vars (x)
    (if (##unassigned? y)
      (check-exact-int-non-neg x (make-string x)
        (##make-string x #\space))
      (touch-vars (y)
        (check-exact-int-non-neg x (make-string x y)
          (check-char y (make-string x y)
            (##make-string x y)))))))

(define (string . l)
  (let* ((n (##length l))
         (str (##make-string n #\space)))
    (let loop ((x l) (i 0))
      (if (##pair? x)
        (let ((c (##car x)))
          (check-char c (string . l)
            (begin
              (##string-set! str i c)
              (loop (##cdr x) (##fixnum.+ i 1)))))
        str))))

(define (string-length x)
  (touch-vars (x)
    (check-string x (string-length x)
      (##string-length x))))

(define (string-ref x y)
  (touch-vars (x y)
    (check-string x (string-ref x y)
      (check-exact-int-range y 0 (##string-length x) (string-ref x y)
        (##string-ref x y)))))

(define (string-set! x y z)
  (touch-vars (x y z)
    (check-string x (string-set! x y z)
      (check-exact-int-range y 0 (##string-length x) (string-set! x y z)
        (check-char z (string-set! x y z)
          (##string-set! x y z))))))

(define-nary0-boolean (string=? x y)
  (##string=? x y) check-string touch-vars)

(define-nary0-boolean (string<? x y)
  (##string<? x y) check-string touch-vars)

(define-nary0-boolean (string>? x y)
  (##string<? y x) check-string touch-vars)

(define-nary0-boolean (string<=? x y)
  (##not (##string<? y x)) check-string touch-vars)

(define-nary0-boolean (string>=? x y)
  (##not (##string<? x y)) check-string touch-vars)

(define-nary0-boolean (string-ci=? x y)
  (##string-ci=? x y) check-string touch-vars)

(define-nary0-boolean (string-ci<? x y)
  (##string-ci<? x y) check-string touch-vars)

(define-nary0-boolean (string-ci>? x y)
  (##string-ci<? y x) check-string touch-vars)

(define-nary0-boolean (string-ci<=? x y)
  (##not (##string-ci<? y x)) check-string touch-vars)

(define-nary0-boolean (string-ci>=? x y)
  (##not (##string-ci<? x y)) check-string touch-vars)

(define (substring x y z)
  (touch-vars (x y z)
    (check-string x (substring x y z)
      (check-exact-int-range-incl y 0 (##string-length x) (substring x y z)
        (check-exact-int-range-incl z y (##string-length x) (substring x y z)
          (##substring x y z))))))

(define (string-append . l)
  (let loop1 ((n 0) (x l) (y '()))
    (if (##pair? x)
      (let ((s (##car x)))
        (touch-vars (s)
          (check-string s (string-append . l)
            (loop1 (##fixnum.+ n (##string-length s)) (##cdr x) (##cons s y)))))
      (let ((result (##make-string n #\space)))
        (let loop2 ((k (##fixnum.- n 1)) (y y))
          (if (##pair? y)
            (let ((s (##car y)))
              (let loop3 ((i k) (j (##fixnum.- (##string-length s) 1)))
                (if (##not (##fixnum.< j 0))
                  (begin
                    (##string-set! result i (##string-ref s j))
                    (loop3 (##fixnum.- i 1) (##fixnum.- j 1)))
                  (loop2 i (##cdr y)))))
            result))))))

(define (vector? x) (touch-vars (x) (##vector? x)))

(define (make-vector x (y))
  (touch-vars (x)
    (if (##unassigned? y)
      (check-exact-int-non-neg x (make-vector x)
        (##make-vector x #f))
      (touch-vars (y)
        (check-exact-int-non-neg x (make-vector x y)
          (##make-vector x y))))))

(define (vector . l)
  (let* ((n (##length l))
         (vect (##make-vector n #f)))
    (let loop ((x l) (i 0))
      (if (##pair? x)
        (begin
          (##vector-set! vect i (##car x))
          (loop (##cdr x) (##fixnum.+ i 1)))
        vect))))

(define (vector-length x)
  (touch-vars (x)
    (check-vector x (vector-length x)
      (##vector-length x))))

(define (vector-ref x y)
  (touch-vars (x y)
    (check-vector x (vector-ref x y)
      (check-exact-int-range y 0 (##vector-length x) (vector-ref x y)
        (##vector-ref x y)))))

(define (vector-set! x y z)
  (touch-vars (x y)
    (check-vector x (vector-set! x y z)
      (check-exact-int-range y 0 (##vector-length x) (vector-set! x y z)
        (##vector-set! x y z)))))

(define (procedure? x) (touch-vars (x) (##procedure? x)))

(define (apply p x . l)

  (define (arg-list prev rest)
    (if (##pair? rest)
      (##cons prev (arg-list (##car rest) (##cdr rest)))
      (if-touches
        (let loop ((l prev))
          (touch-vars (l)
            (if (##pair? l)
              (##cons (##car l) (loop (##cdr l)))
              '())))
        prev)))

  (touch-vars (p)
    (check-procedure p (apply p x . l)
      (##apply p (arg-list x l)))))

(define (map p l1 . l2)
  (touch-vars (p)
    (check-procedure p (map p l1 . l2)
      (if (##null? l2)

        (touch-vars (l1)
          (if (##pair? l1)

            (let ((result (##cons (p (##car l1)) '())))
              (let loop1 ((end result) (x (##cdr l1)))
                (touch-vars (x)
                  (if (##pair? x)
                    (let ((tail (##cons (p (##car x)) '())))
                      (##set-cdr! end tail)
                      (loop1 tail (##cdr x))))))
              result)

            '()))

        (let ((reversed-lists (##reverse (##cons l1 l2))))

          (define (end-of-lists l result)
            (if (##eq? l reversed-lists)
              (let loop ((l l))
                (if (##pair? l)
                  (let ((head (##car l)))
                    (touch-vars (head)
                      (if (##pair? head)
                        (trap-list-lengths (map p l1 . l2))
                        (loop (##cdr l)))))
                  result))
              (trap-list-lengths (map p l1 . l2))))

          (let loop2 ((l reversed-lists) (args '()))
            (if (##pair? l)

              (let ((head (##car l)))
                (touch-vars (head)
                  (if (##pair? head)
                    (begin
                      (##set-car! l (##cdr head))
                      (loop2 (##cdr l) (##cons (##car head) args)))
                    (if-checks (end-of-lists l '()) '()))))

              (let ((result (##cons (##apply p args) '())))
                (let loop3 ((end result))
                  (let loop4 ((l reversed-lists) (args '()))
                    (if (##pair? l)

                      (let ((head (##car l)))
                        (touch-vars (head)
                          (if (##pair? head)
                            (begin
                              (##set-car! l (##cdr head))
                              (loop4 (##cdr l) (##cons (##car head) args)))
                            (if-checks (end-of-lists l result) result))))

                      (let ((tail (##cons (##apply p args) '())))
                        (##set-cdr! end tail)
                        (loop3 tail)))))))))))))

(define (for-each p l1 . l2)
  (touch-vars (p)
    (check-procedure p (for-each p l1 . l2)
      (if (##null? l2)

        (let loop1 ((x l1))
          (touch-vars (x)
            (if (##pair? x)
              (begin
                (p (##car x))
                (loop1 (##cdr x))))))

        (let ((reversed-lists (##reverse (##cons l1 l2))))

          (define (end-of-lists l)
            (if (##eq? l reversed-lists)
              (let loop ((l l))
                (if (##pair? l)
                  (let ((head (##car l)))
                    (touch-vars (head)
                      (if (##pair? head)
                        (trap-list-lengths (for-each p l1 . l2))
                        (loop (##cdr l)))))
                  ##undef-object))
              (trap-list-lengths (for-each p l1 . l2))))

          (let loop2 ()
            (let loop3 ((l reversed-lists) (args '()))
              (if (##pair? l)

                (let ((head (##car l)))
                  (touch-vars (head)
                    (if (##pair? head)
                      (begin
                        (##set-car! l (##cdr head))
                        (loop3 (##cdr l) (##cons (##car head) args)))
                      (if-checks (end-of-lists l) ##undef-object))))

                (begin
                  (##apply p args)
                  (loop2))))))))))

(define (call-with-current-continuation p)
  (touch-vars (p)
    (check-procedure p (call-with-current-continuation p)
      (##call-with-current-continuation p))))

(define (call-with-input-file s p)
  (touch-vars (s p)
    (check-string s (call-with-input-file s p)
      (check-procedure p (call-with-input-file s p)
        (let ((port (##open-input-file s)))
          (if port
            (let ((result (p port)))
              (##close-port port)
              result)
            (trap-open-file (call-with-input-file s p))))))))

(define (call-with-output-file s p)
  (touch-vars (s p)
    (check-string s (call-with-output-file s p)
      (check-procedure p (call-with-output-file s p)
        (let ((port (##open-output-file s)))
          (if port
            (let ((result (p port)))
              (##close-port port)
              result)
            (trap-open-file (call-with-output-file s p))))))))

(define (input-port? x)
  (touch-vars (x)
    (##input-port? x)))

(define (output-port? x)
  (touch-vars (x)
    (##output-port? x)))

(define (current-input-port)
  (##current-input-port))

(define (current-output-port)
  (##current-output-port))

(define (open-input-file s)
  (touch-vars (s)
    (check-string s (open-input-file s)
      (let ((port (##open-input-file s)))
        (if port
          port
          (trap-open-file (open-input-file s)))))))

(define (open-output-file s)
  (touch-vars (s)
    (check-string s (open-output-file s)
      (let ((port (##open-output-file s)))
        (if port
          port
          (trap-open-file (open-output-file s)))))))

(define (close-input-port p)
  (touch-vars (p)
    (check-input-port p (close-input-port p)
      (##close-port p))))

(define (close-output-port p)
  (touch-vars (p)
    (check-output-port p (close-output-port p)
      (##close-port p))))

(define (eof-object? x)
  (touch-vars (x)
    (##eof-object? x)))

(define (read (p))
  (if (##unassigned? p)
    (let ((port (##current-input-port)))
      (check-open-port port (read)
        (##read port)))
    (touch-vars (p)
      (check-input-port p (read p)
        (check-open-port p (read p)
          (##read p))))))

(define (read-char (p))
  (if (##unassigned? p)
    (let ((port (##current-input-port)))
      (check-open-port port (read-char)
        (##read-char port)))
    (touch-vars (p)
      (check-input-port p (read-char p)
        (check-open-port p (read-char p)
          (##read-char p))))))

(define (peek-char (p))
  (if (##unassigned? p)
    (let ((port (##current-input-port)))
      (check-open-port port (peek-char)
        (##peek-char port)))
    (touch-vars (p)
      (check-input-port p (peek-char p)
        (check-open-port p (peek-char p)
          (##peek-char p))))))
  
(define (write obj (p))
  (if (##unassigned? p)
    (let ((port (##current-output-port)))
      (check-open-port port (write obj)
        (##write obj port (if-touches #t #f))))
    (touch-vars (p)
      (check-output-port p (write obj p)
        (check-open-port p (write obj p)
          (##write obj p (if-touches #t #f)))))))

(define (display obj (p))
  (if (##unassigned? p)
    (let ((port (##current-output-port)))
      (check-open-port port (display obj)
        (##display obj port (if-touches #t #f))))
    (touch-vars (p)
      (check-output-port p (display obj p)
        (check-open-port p (display obj p)
          (##display obj p (if-touches #t #f)))))))

(define (newline (p))
  (if (##unassigned? p)
    (let ((port (##current-output-port)))
      (check-open-port port (newline)
        (##newline port)))
    (touch-vars (p)
      (check-output-port p (newline p)
        (check-open-port p (newline p)
          (##newline p))))))

(define (write-char c (p))
  (touch-vars (c)
    (if (##unassigned? p)
      (check-char c (write-char c)
        (let ((port (##current-output-port)))
          (check-open-port port (write-char c)
            (##write-char c port))))
      (touch-vars (p)
        (check-char c (write-char c p)
          (check-output-port p (write-char c p)
            (check-open-port p (write-char c p)
              (##write-char c p))))))))

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

; R4RS Scheme procedures:

(define (list-tail l k)
  (touch-vars (k)
    (check-exact-int-non-neg k (list-tail l k)
      (let loop ((x l) (i k))
        (if (##fixnum.< 0 i)
          (touch-vars (x)
            (check-pair x (list-tail l k)
              (loop (##cdr x) (##fixnum.- i 1))))
          x)))))

(define (string->list str)
  (touch-vars (str)
    (check-string str (string->list str)
      (let loop ((l '()) (i (##fixnum.- (##string-length str) 1)))
        (if (##fixnum.< i 0)
          l
          (loop (##cons (##string-ref str i) l) (##fixnum.- i 1)))))))

(define (list->string l)
  (let loop1 ((x l) (n 0))
    (touch-vars (x)
      (if (##pair? x)
        (loop1 (##cdr x) (##fixnum.+ n 1))
        (let ((str (##make-string n #\space)))
          (let loop2 ((x l) (i 0))
            (touch-vars (x)
              (if (##pair? x)
                (let ((c (##car x)))
                  (check-char c (list->string l)
                    (begin
                      (##string-set! str i c)
                      (loop2 (##cdr x) (##fixnum.+ i 1)))))
                str))))))))

(define (string-copy str)
  (touch-vars (str)
    (check-string str (string-copy str)
      (let* ((n (##string-length str))
             (result (##make-string n #\space)))
        (let loop ((i (##fixnum.- n 1)))
          (if (##fixnum.< i 0)
            result
            (begin
              (##string-set! result i (##string-ref str i))
              (loop (##fixnum.- i 1)))))))))

(define (string-fill! str c)
  (touch-vars (str c)
    (check-string str (string-fill str c)
      (check-char c (string-fill str c)
        (let ((n (##string-length str)))
          (let loop ((i (##fixnum.- n 1)))
            (if (##fixnum.< i 0)
              ##undef-object
              (begin
                (##string-set! str i c)
                (loop (##fixnum.- i 1))))))))))

(define (vector->list vect)
  (touch-vars (vect)
    (check-vector vect (vector->list vect)
      (let loop ((l '()) (i (##fixnum.- (##vector-length vect) 1)))
        (if (##fixnum.< i 0)
          l
          (loop (##cons (##vector-ref vect i) l) (##fixnum.- i 1)))))))

(define (list->vector l)
  (let loop1 ((x l) (n 0))
    (touch-vars (x)
      (if (##pair? x)
        (loop1 (##cdr x) (##fixnum.+ n 1))
        (let ((vect (##make-vector n #f)))
          (let loop2 ((x l) (i 0))
            (touch-vars (x)
              (if (##pair? x)
                (begin
                  (##vector-set! vect i (##car x))
                  (loop2 (##cdr x) (##fixnum.+ i 1)))
                vect))))))))

(define (vector-fill! vect x)
  (touch-vars (vect x)
    (check-vector vect (vector-fill vect x)
      (let ((n (##vector-length vect)))
        (let loop ((i (##fixnum.- n 1)))
          (if (##fixnum.< i 0)
            ##undef-object
            (begin
              (##vector-set! vect i x)
              (loop (##fixnum.- i 1)))))))))

(define (force x)
  (##touch x))

(define (with-input-from-file s thunk)
  (touch-vars (s thunk)
    (check-string s (with-input-from-file s thunk)
      (check-procedure thunk (with-input-from-file s thunk)
        (let ((port (##open-input-file s)))
          (if port
            (let ((result (##dynamic-bind (##list (##cons '##CURRENT-INPUT-PORT port)) thunk)))
              (##close-port port)
              result)
            (trap-open-file (with-input-from-file s thunk))))))))

(define (with-output-to-file s thunk)
  (touch-vars (s thunk)
    (check-string s (with-output-to-file s thunk)
      (check-procedure thunk (with-output-to-file s thunk)
        (let ((port (##open-output-file s)))
          (if port
            (let ((result (##dynamic-bind (##list (##cons '##CURRENT-OUTPUT-PORT port)) thunk)))
              (##close-port port)
              result)
            (trap-open-file (with-output-to-file s thunk))))))))

(define (char-ready? (p))
  (if (##unassigned? p)
    (let ((port (##current-input-port)))
      (check-open-port port (char-ready?)
        (##char-ready? port)))
    (touch-vars (p)
      (check-input-port p (char-ready? p)
        (check-open-port p (char-ready? p)
          (##char-ready? p))))))

(define (load s (trace?))
  (touch-vars (s)
    (check-string s (load s)
      (if (or (##unassigned? trace?) (##not trace?))
        (##load s #f)
        (##load s ##stdout)))))

(define (transcript-on s)
  (touch-vars (s)
    (check-string s (transcript-on s)
      (let ((port (##open-output-file s)))
        (if port
          (begin
            (##transcript-on port)
            s)
          (trap-open-file (transcript-on s)))))))

(define (transcript-off)
  (if ##transcript-port
    (begin
      (##close-port ##transcript-port)
      ##undef-object)
    (trap-no-transcript (transcript-off))))

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

; Multilisp procedures:

(define (touch x)
  (##touch x))

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