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

;; "_ports.scm"

(##include "header.scm")

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

; I/O stuff

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

(define (##input-port? x)
  (and (##subtyped? x)
       (##fixnum.= (##subtype x) (subtype-port))
       (##fixnum.< (##fixnum.modulo (port-kind x) 4) 2)))

(define (##output-port? x)
  (and (##subtyped? x)
       (##fixnum.= (##subtype x) (subtype-port))
       (##fixnum.< 0 (##fixnum.modulo (port-kind x) 4))))

(define (##closed-port? x)
  (and (##subtyped? x)
       (##fixnum.= (##subtype x) (subtype-port))
       (##fixnum.< 3 (port-kind x))))

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

; File I/O

(define (##make-port descr name kind read-proc write-proc ready-proc close-proc rbuf wbuf)
  (let ((port (port-make)))
    (port-kind-set!  port kind)
    (port-name-set!  port name)
    (port-read-set!  port (lambda (port)
                            (let ((rbuf (port-rbuf port)))
                              (let ((len (read-proc (port-misc port)
                                                    rbuf
                                                    0
                                                    (##string-length rbuf))))
                                (if len
                                  (begin
                                    (port-pos-set! port 0)
                                    (port-len-set! port len)
                                    (##fixnum.= len 0))
                                  (begin
                                    (##signal '##SIGNAL.IO-ERROR "Read error on" port)
                                    (port-pos-set! port 0)
                                    (port-len-set! port 0)
                                    #t))))))
    (port-write-set! port (lambda (s i j port)
                            (let loop ((i i))
                              (let ((len (write-proc (port-misc port) s i j)))
                                (if len
                                  (if (##fixnum.< 0 len)
                                    (let ((i (##fixnum.+ len i)))
                                      (if (##fixnum.< i j)
                                        (loop i)))
                                    (loop i))
                                  (##signal '##SIGNAL.IO-ERROR "Write error on" port))))))
    (port-ready-set! port (lambda (port) (ready-proc (port-misc port))))
    (port-close-set! port (lambda (port)
                            (if (##not (close-proc (port-misc port)))
                              (##signal '##SIGNAL.IO-ERROR "Close error on" port))
                            #t))
    (port-pos-set!   port 0)
    (port-len-set!   port 0)
    (port-rbuf-set!  port rbuf)
    (port-wbuf-set!  port wbuf)
    (port-misc-set!  port descr)
    port))

(define (##open-input-file s)
  (let ((descr (##os-file-open-input s)))
    (if descr
      (##make-port descr s 0
        ##os-file-read
        #f
        ##os-file-read-ready
        ##os-file-close
        (##make-string 64 #\space)
        #f)
      #f)))

(define (##open-output-file s)
  (let ((descr (##os-file-open-output s)))
    (if descr
      (##make-port descr s 2
        #f
        ##os-file-write
        #f
        ##os-file-close
        #f
        (##make-string 1 #\space))
      #f)))

(define (##open-input-output-file s)
  (let ((descr (##os-file-open-input-output s)))
    (if descr
      (##make-port descr s 1
        ##os-file-read
        ##os-file-write
        ##os-file-read-ready
        ##os-file-close
        (##make-string 64 #\space)
        (##make-string 1 #\space))
      #f)))

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

; String I/O

(define (##open-input-string str)
  (let ((port (port-make)))
    (port-kind-set!  port 0)
    (port-name-set!  port 'STRING)
    (port-read-set!  port (lambda (port) #t))
    (port-write-set! port #f)
    (port-ready-set! port (lambda (port) #t))
    (port-close-set! port (lambda (port) #t))
    (port-pos-set!   port 0)
    (port-len-set!   port (##string-length str))
    (port-rbuf-set!  port str)
    (port-wbuf-set!  port #f)
    port))

(define (##open-output-string)
  (let ((port (port-make)))
    (port-kind-set!  port 2)
    (port-name-set!  port 'STRING)
    (port-read-set!  port #f)
    (port-write-set! port ##output-string-write)
    (port-ready-set! port #f)
    (port-close-set! port (lambda (port) #t))
    (port-pos-set!   port 0)
    (port-rbuf-set!  port #f)
    (port-wbuf-set!  port (##make-string 1 #\space))
    (port-misc-set!  port (##make-string 36 #\space)) ; 4 + 8*n
    port))

(define (##output-string-write s i j port)
  (let* ((str (port-misc port))
         (pos (port-pos port))
         (len (##string-length str))
         (l (##fixnum.- j i))
         (new-pos (##fixnum.+ pos l))
         (overflow (##fixnum.- new-pos len)))
    (if (##fixnum.< 0 overflow)
      (let ((new-str (##make-string (##fixnum.+
                                      (##fixnum.*
                                        (##fixnum.quotient
                                          (##fixnum.+ overflow 71)
                                          8)
                                        8)
                                      len)
                                    #\space)))
        (let loop1 ((i (##fixnum.- pos 1)))
          (if (##not (##fixnum.< i 0))
            (begin
              (##string-set! new-str i (##string-ref str i))
              (loop1 (##fixnum.- i 1)))))
        (port-misc-set! port new-str)))
    (port-pos-set! port new-pos)
    (let ((str (port-misc port)))
      (let loop2 ((k (##fixnum.- l 1)))
        (if (##not (##fixnum.< k 0))
          (begin
            (##string-set! str
                           (##fixnum.+ pos k)
                           (##string-ref s (##fixnum.+ i k)))
            (loop2 (##fixnum.- k 1))))))
    #f))

(define (##get-output-string port)
  (let ((str (##substring (port-misc port) 0 (port-pos port))))
    (port-pos-set! port 0)
    str))

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

(define (##close-port port)
  (if (and (##not (##fixnum.< 3 (port-kind port)))
           ((port-close port) port))
    (port-kind-set! port (##fixnum.+ (##fixnum.modulo (port-kind port) 4) 4)))
  #f)

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

(define (##read-char port)
  (let ((c (##peek-char port)))
    (port-pos-set! port (##fixnum.+ (port-pos port) 1))
    c))

(define (##peek-char port)
  (let ((pos  (port-pos port))
        (len  (port-len port))
        (rbuf (port-rbuf port)))
    (if (##fixnum.< pos len)
      (##string-ref rbuf pos)
      (if ((port-read port) port)
        ##eof-object
        (##peek-char port)))))

(define (##eof-object? x)
  (##eq? x ##eof-object))

(define (##char-ready? port)
  (let ((pos (port-pos port))
        (len (port-len port)))
    (if (##fixnum.< pos len)
      #t
      ((port-ready port) port))))

(define (##write-char c port)
  (let ((wbuf (port-wbuf port)))
    (##string-set! wbuf 0 c)
    ((port-write port) wbuf 0 1 port)
    #f))

(define (##write-string s port)
  ((port-write port) s 0 (##string-length s) port)
  #f)

(define (##write-substring s i j port)
  (if (##fixnum.< i j) ((port-write port) s i j port))
  #f)

(define (##newline port)
  (##write-char #\newline port))

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

(define (##read port)

  (##define-macro (+ . args)                `(##fixnum.+ ,@args))
  (##define-macro (= . args)                `(##fixnum.= ,@args))
  (##define-macro (< . args)                `(##fixnum.< ,@args))
  (##define-macro (assq . args)             `(##assq ,@args))
  (##define-macro (cdr . args)              `(##cdr ,@args))
  (##define-macro (char->integer . args)    `(##char->integer ,@args))
  (##define-macro (char-alphabetic? . args) `(##char-alphabetic? ,@args))
  (##define-macro (char-downcase . args)    `(##char-downcase ,@args))
  (##define-macro (char=? . args)           `(##char=? ,@args))
  (##define-macro (cons . args)             `(##cons ,@args))
  (##define-macro (set-cdr! . args)         `(##set-cdr! ,@args))
  (##define-macro (eof-object? . args)      `(##eof-object? ,@args))
  (##define-macro (list . args)             `(##list ,@args))
  (##define-macro (make-string . args)      `(##make-string ,@args))
  (##define-macro (make-vector . args)      `(##make-vector ,@args))
  (##define-macro (not . args)              `(##not ,@args))
  (##define-macro (string->number . args)   `(##string->number ,@args))
  (##define-macro (string-set! . args)      `(##string-set! ,@args))
  (##define-macro (vector-ref . args)       `(##vector-ref ,@args))
  (##define-macro (vector-set! . args)      `(##vector-set! ,@args))

  (##define-macro (sf->locat sf)                #f)
  (##define-macro (sf-peek-char sf)             `(##peek-char ,sf))
  (##define-macro (sf-read-char sf)             `(##read-char ,sf))
  (##define-macro (sf-read-error sf msg . args) `(##signal '##SIGNAL.READ-ERROR ,msg ,@args))
  (##define-macro (make-source x locat)         x)
  (##define-macro (source-code-set! source x)   x)
  (##define-macro (string->canonical-symbol s)  `(##string->symbol ,s))

  (define QUOTE-sym            'quote)
  (define QUASIQUOTE-sym       'quasiquote)
  (define UNQUOTE-sym          'unquote)
  (define UNQUOTE-SPLICING-sym 'unquote-splicing)

  (define char-newline #\newline)
  (define false-object #f)

  (define named-char-table ##named-char-table)
  (define read-table       ##read-table)

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

; For compatibility, `read-source' is the same reader as the one used in the
; compiler.  It has been copied from the file "gambit/compiler/source.scm".

(define (read-source sf)

  (define (read-char*)
    (let ((c (sf-read-char sf)))
      (if (eof-object? c)
        (sf-read-error sf "Premature end of file encountered")
        c)))

  (define (read-non-whitespace-char)
    (let ((c (read-char*)))
      (cond ((< 0 (vector-ref read-table (char->integer c)))
             (read-non-whitespace-char))
            ((char=? c #\;)
             (let loop ()
               (if (not (char=? (read-char*) char-newline))
                 (loop)
                 (read-non-whitespace-char))))
            (else
             c))))

  (define (delimiter? c)
    (or (eof-object? c)
        (not (= (vector-ref read-table (char->integer c)) 0))))

  (define (read-list first)
    (let ((result (cons first '())))
      (let loop ((end result))
        (let ((c (read-non-whitespace-char)))
          (cond ((char=? c #\)))
                ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
                 (let ((x (read-source sf)))
                   (if (char=? (read-non-whitespace-char) #\))
                     (set-cdr! end x)
                     (sf-read-error sf "')' expected"))))
                (else
                 (let ((tail (cons (rd* c) '())))
                   (set-cdr! end tail)
                   (loop tail))))))
      result))

  (define (read-vector)
    (define (loop i)
      (let ((c (read-non-whitespace-char)))
        (if (char=? c #\))
          (make-vector i '())
          (let* ((x (rd* c))
                 (v (loop (+ i 1))))
            (vector-set! v i x)
            v))))
    (loop 0))

  (define (read-string)
    (define (loop i)
      (let ((c (read-char*)))
        (cond ((char=? c #\")
               (make-string i #\space))
              ((char=? c #\\)
               (let* ((c (read-char*))
                      (s (loop (+ i 1))))
                 (string-set! s i c)
                 s))
              (else
               (let ((s (loop (+ i 1))))
                 (string-set! s i c)
                 s)))))
    (loop 0))

  (define (read-symbol/number-string i)
    (if (delimiter? (sf-peek-char sf))
      (make-string i #\space)
      (let* ((c (sf-read-char sf))
             (s (read-symbol/number-string (+ i 1))))
        (string-set! s i (char-downcase c))
        s)))

  (define (read-symbol/number c)
    (let ((s (read-symbol/number-string 1)))
      (string-set! s 0 (char-downcase c))
      (or (string->number s 10)
          (string->canonical-symbol s))))

  (define (read-prefixed-number c)
    (let ((s (read-symbol/number-string 2)))
      (string-set! s 0 #\#)
      (string-set! s 1 c)
      (string->number s 10)))

  (define (read-special-symbol)
    (let ((s (read-symbol/number-string 2)))
      (string-set! s 0 #\#)
      (string-set! s 1 #\#)
      (string->canonical-symbol s)))

  (define (rd c)
    (cond ((eof-object? c)
           c)
          ((< 0 (vector-ref read-table (char->integer c)))
           (rd (sf-read-char sf)))
          ((char=? c #\;)
           (let loop ()
             (let ((c (sf-read-char sf)))
               (cond ((eof-object? c)
                      c)
                     ((char=? c char-newline)
                      (rd (sf-read-char sf)))
                     (else
                      (loop))))))
          (else
           (rd* c))))

  (define (rd* c)
    (let ((source (make-source #f (sf->locat sf))))
      (source-code-set!
        source
        (cond ((char=? c #\()
               (let ((x (read-non-whitespace-char)))
                 (if (char=? x #\))
                   '()
                   (read-list (rd* x)))))
              ((char=? c #\#)
               (let ((c (char-downcase (sf-read-char sf))))
                 (cond ((char=? c #\() (read-vector))
                       ((char=? c #\f) false-object)
                       ((char=? c #\t) #t)
                       ((char=? c #\\)
                        (let ((c (read-char*)))
                          (if (or (not (char-alphabetic? c))
                                  (delimiter? (sf-peek-char sf)))
                            c
                            (let ((name (read-symbol/number c)))
                              (let ((x (assq name named-char-table)))
                                (if x
                                  (cdr x)
                                  (sf-read-error sf "Unknown character name:" name)))))))

                       ((char=? c #\#)
                        (read-special-symbol))
                       (else
                        (let ((num (read-prefixed-number c)))
                          (or num
                              (sf-read-error sf "Unknown '#' read macro:" c)))))))
              ((char=? c #\")
               (read-string))
              ((char=? c #\')
               (list (make-source QUOTE-sym (sf->locat sf))
                     (read-source sf)))
              ((char=? c #\`)
               (list (make-source QUASIQUOTE-sym (sf->locat sf))
                     (read-source sf)))
              ((char=? c #\,)
               (if (char=? (sf-peek-char sf) #\@)
                 (let ((x (make-source UNQUOTE-SPLICING-sym (sf->locat sf))))
                   (sf-read-char sf)
                   (list x (read-source sf)))
                 (list (make-source UNQUOTE-sym (sf->locat sf))
                       (read-source sf))))
              ((char=? c #\))
               (sf-read-error sf "Misplaced ')'"))
              (else
               (if (char=? c #\.)
                 (if (delimiter? (sf-peek-char sf))
                   (sf-read-error sf "Misplaced '.'")))
               (read-symbol/number c))))))

  (rd (sf-read-char sf)))

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

  (read-source port))

(define ##named-char-table
  '((space   . #\space)
    (newline . #\newline)))

(define ##read-table
  (let ((rt (##make-vector 256 0)))

    ; setup whitespace chars

    (let loop ((i 32))
      (if (##not (##fixnum.< i 0))
        (begin (##vector-set! rt i 1) (loop (##fixnum.- i 1)))))

    ; setup other delimiters

    (##vector-set! rt (##char->integer #\;) -1)
    (##vector-set! rt (##char->integer #\() -1)
    (##vector-set! rt (##char->integer #\)) -1)
    (##vector-set! rt (##char->integer #\") -1)
    (##vector-set! rt (##char->integer #\') -1)
    (##vector-set! rt (##char->integer #\`) -1)

    rt))

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

(define (##wr-unlimited obj port display? touch?)
  (##fixnum.- (max-fixnum)
              (##wr obj port display? touch? (max-fixnum))))

(define (##wr-limited obj port display? touch? limit)
  (##fixnum.- limit
              (##wr obj port display? touch? limit)))

(define (##wr obj port display? touch? limit)
  (if (##fixnum.< 0 limit)
    ((##vector-ref ##wr-type-table (##type obj))
     obj
     port
     display?
     touch?
     limit)
    0))

(define (##wr-str s port limit)
  (##wr-substr s 0 (##string-length s) port limit))

(define (##wr-substr s i j port limit)
  (let ((len (##fixnum.- j i)))
    (if (##fixnum.< limit len)
      (begin
        (##write-substring s i (##fixnum.+ i limit) port)
        0)
      (begin
        (##write-substring s i j port)
        (##fixnum.- limit len)))))

(define (##wr-ch c port limit)
  (if (##fixnum.< 0 limit)
    (begin
      (##write-char c port)
      (##fixnum.- limit 1))
    0))

(define (##wr-adr type obj port limit)
  (##wr-str "]" port
            (##wr-str (##number->string (##type-cast obj (type-fixnum)) 16) port
                      (##wr-str " #x" port
                                (##wr-str type port
                                          (##wr-str "#[" port limit))))))

(define (##wr-tag-in type tag name port limit)
  (##wr-str "]" port
            (##wr name port #f #f
                  (##wr-str " in " port
                            (##wr-str tag port
                                      (##wr-str " " port
                                                (##wr-str type port
                                                          (##wr-str "#[" port limit))))))))

(define (##wr-named type name port limit)
  (##wr-str "]" port
            (##wr name port #f #f
                  (##wr-str " " port
                            (##wr-str type port
                                      (##wr-str "#[" port limit))))))

(define ##wr-type-table
  (##make-vector (type-range)
    (lambda (obj port display? touch? limit)
      (##wr-adr (##string-append "type-"
                                 (##number->string (##type obj) 10))
                obj
                port
                limit))))

(define ##wr-subtype-table
  (##make-vector (subtype-range)
    (lambda (obj port display? touch? limit)
      (##wr-adr (##string-append "subtype-"
                                 (##number->string (##subtype obj) 10))
                obj
                port
                limit))))

; Setup type dispatch table

(##vector-set! ##wr-type-table (type-fixnum)
  (lambda (obj port display? touch? limit)
    (##wr-str (##number->string obj 10) port limit)))

(##vector-set! ##wr-type-table (type-special)
  (lambda (obj port display? touch? limit)

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

    (if (##char? obj)

      (if display?
        (##wr-ch obj port limit)
        (let ((x (assq-cdr obj ##named-char-table)))
          (if x
           (##wr-str (symbol-string (##car x)) port
                     (##wr-str "#\\" port limit))
           (##wr-ch obj port
                    (##wr-str "#\\" port limit)))))

      (cond ((##eq? obj #t)
             (##wr-str "#t" port limit))
            ((##eq? obj #f)
             (##wr-str "#f" port limit))
            ((##eq? obj '())
             (##wr-str "()" port limit))
            ((##eq? obj ##undef-object)
             (##wr-str "#[undefined]" port limit))
            ((##eq? obj ##unass-object)
             (##wr-str "#[unassigned]" port limit))
            ((##eq? obj ##unbound-object)
             (##wr-str "#[unbound]" port limit))
            ((##eq? obj ##eof-object)
             (##wr-str "#[eof]" port limit))
            (else
             (##wr-adr "special" obj port limit))))))

(##vector-set! ##wr-type-table (type-pair)
  (lambda (obj port display? touch? limit)

    (define (wr-tail l limit)
      (if (##fixnum.< 0 limit)
        (let ((l (if touch? (touch-vars (l) l) l)))
          (cond ((##pair? l)
                 (wr-tail (##cdr l)
                          (##wr (##car l) port display? touch?
                                (##wr-str " " port limit))))
                ((##null? l)
                 (##wr-str ")" port limit))
                (else
                 (##wr-str ")" port
                           (##wr l port display? touch?
                                 (##wr-str " . " port limit))))))
        0))

    (define (wr-list x y limit)
      (wr-tail y
               (##wr x port display? touch?
                     (##wr-str "(" port limit))))

    (let ((x (##car obj))
          (y (##cdr obj)))
      (if (and (##pair? y) (##null? (##cdr y)))
        (let ((z (##car y)))
          (case x
            ((QUOTE)
             (##wr z port display? touch?
                   (##wr-str "'" port limit)))
            ((QUASIQUOTE)
             (##wr z port display? touch?
                   (##wr-str "`" port limit)))
            ((UNQUOTE)
             (##wr z port display? touch?
                   (##wr-str "," port limit)))
            ((UNQUOTE-SPLICING)
             (##wr z port display? touch?
                   (##wr-str ",@" port limit)))
            (else
             (wr-list x y limit))))
        (wr-list x y limit)))))

(##vector-set! ##wr-type-table (type-weak-pair)
  (lambda (obj port display? touch? limit)
    (##wr-adr "weak-pair" obj port limit)))

(##vector-set! ##wr-type-table (type-subtyped)
  (lambda (obj port display? touch? limit)
    ((##vector-ref ##wr-subtype-table (##subtype obj))
     obj
     port
     display?
     touch?
     limit)))

(##vector-set! ##wr-type-table (type-procedure)
  (lambda (obj port display? touch? limit)
    (let ((name (##object->global-var-name obj)))
      (if name
        (##wr-named "procedure" name port limit)
        (cond ((##proc-closure? obj)
               (##wr-adr "procedure" obj port limit))
              ((##proc-subproc? obj)
               (let ((parent (##object->global-var-name (##proc-subproc-parent obj))))
                 (if parent
                   (##wr-tag-in "subprocedure" (##number->string (##proc-subproc-tag obj) 10) parent port limit)
                   (##wr-adr "procedure" obj port limit))))
              (else
               (##wr-adr "procedure" obj port limit)))))))

(##vector-set! ##wr-type-table (type-placeholder)
  (lambda (obj port display? touch? limit)
    (if touch?
      (touch-vars (obj)
        (##wr obj port display? touch? limit))
      (##wr-adr "placeholder" obj port limit))))

; Setup subtype dispatch table

(##vector-set! ##wr-subtype-table (subtype-vector)
  (lambda (obj port display? touch? limit)
    (##wr (##vector->list obj) port display? touch?
          (##wr-str "#" port limit))))

(##vector-set! ##wr-subtype-table (subtype-symbol)
  (lambda (obj port display? touch? limit)
    (##wr-str (symbol-string obj) port limit)))

(##vector-set! ##wr-subtype-table (subtype-port)
  (lambda (obj port display? touch? limit)
    (##wr-named (if (##input-port? obj)
                  (if (##output-port? obj) "input-output-port" "input-port")
                  "output-port")
                (port-name obj)
                port
                limit)))

(##vector-set! ##wr-subtype-table (subtype-ratnum)
  (lambda (obj port display? touch? limit)
    (##wr-str (##number->string obj 10) port limit)))
    
(##vector-set! ##wr-subtype-table (subtype-cpxnum)
  (lambda (obj port display? touch? limit)
    (##wr-str (##number->string obj 10) port limit)))

(##vector-set! ##wr-subtype-table (subtype-frame)
  (lambda (obj port display? touch? limit)
    (##wr-adr "frame" obj port limit)))

(##vector-set! ##wr-subtype-table (subtype-task)
  (lambda (obj port display? touch? limit)
    (##wr-adr "task" obj port limit)))

(##vector-set! ##wr-subtype-table (subtype-string)
  (lambda (obj port display? touch? limit)

    (define (wr-str-quoted s port limit)
      (let loop ((i 0) (j 0) (limit limit))
        (if (##fixnum.< j (##string-length s))
          (let ((c (##string-ref s j)))
            (if (or (##char=? c #\") (##char=? c #\\))
              (loop j
                    (##fixnum.+ j 1)
                    (##wr-str "\\" port
                              (##wr-substr s i j port limit)))
              (loop i (##fixnum.+ j 1) limit)))
          (##wr-substr s i j port limit))))

    (if display?
      (##wr-str obj port limit)
      (##wr-str "\"" port
                (wr-str-quoted obj port
                               (##wr-str "\"" port limit))))))

(##vector-set! ##wr-subtype-table (subtype-bignum)
  (lambda (obj port display? touch? limit)
    (##wr-str (##number->string obj 10) port limit)))

(##vector-set! ##wr-subtype-table (subtype-flonum)
  (lambda (obj port display? touch? limit)
    (##wr-str (##number->string obj 10) port limit)))

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

(define (##write obj port touch?)
  (##wr-unlimited obj port #f touch?))

(define (##display obj port touch?)
  (##wr-unlimited obj port #t touch?))

(define (##pretty obj port touch? col width)

  (define (spaces n port)
    (if (##fixnum.< 0 n)
      (let ((m (if (##fixnum.< 40 n) 40 n)))
        (##write-substring "                                        " 0 m port)
        (spaces (##fixnum.- n m) port))))

  (define (indent to from port)
    (if (##fixnum.< to from)
      (begin
        (##newline port)
        (spaces to port))
      (spaces (##fixnum.- to from) port)))

  (define (obj->string obj width touch?)
    (let ((port (##open-output-string)))
      (##wr-limited obj port #f touch? (##fixnum.+ width 1))
      (let* ((str (##get-output-string port))
             (len (##string-length str)))
        (##close-port port)
        (if (##fixnum.< width len) #f str))))

  (define (p obj port touch? col width extra pp-pair)
    (let ((obj (if touch? (touch-vars (obj) obj))))
      (if (or (##pair? obj) (##vector? obj))
        (let ((str (obj->string obj (##fixnum.- (##fixnum.- width col) extra) touch?)))
          (if str
            (begin
              (##write-string str port)
              (##fixnum.+ col (##string-length str)))
            (if (##pair? obj)
              (pp-pair obj port touch? col width extra)
              (let ((col* (##fixnum.+ col 1))
                    (elems (##vector->list obj)))
                (##write-string "#" port)
                (pp-list elems port touch? col* width extra pp-expr)))))
        (##fixnum.+ col (##write obj port touch?)))))

  (define (pp-expr expr port touch? col width extra)
    (let ((head (##car expr)))
      (let* ((head (if touch? (touch-vars (head) head) head))
             (style (pp-style head)))
        (if style
          (style expr port touch? col width extra)
          (if (##symbol? head)
            (if (##fixnum.< (##string-length (symbol-string head)) 8)
              (pp-call expr port touch? col width extra pp-expr)
              (pp-general expr port touch? col width extra #f #f #f pp-expr))
            (pp-list expr port touch? col width extra pp-expr))))))

  ; (head item1
  ;       item2
  ;       item3)
  (define (pp-call expr port touch? col width extra pp-item)
    (##write-string "(" port)
    (let* ((head (##car expr))
           (rest (##cdr expr))
           (col* (##fixnum.+ (##fixnum.+ col 1) (##write head port touch?))))
      (pp-down rest port touch? col* (##fixnum.+ col* 1) width extra pp-item)))

  ; (item1
  ;  item2
  ;  item3)
  (define (pp-list l port touch? col width extra pp-item)
    (##write-string "(" port)
    (let ((col* (##fixnum.+ col 1)))
      (pp-down l port touch? col* col* width extra pp-item)))

  (define (pp-down l port touch? col1 col2 width extra pp-item)
    (let loop ((l l) (col* col1))
      (if (##pair? l)
        (let ((rest (##cdr l)))
          (let* ((rest (if touch? (touch-vars (rest) rest) rest))
                 (extra* (if (##null? rest) (##fixnum.+ extra 1) 0)))
            (indent col2 col* port)
            (loop rest (p (##car l) port touch? col2 width extra* pp-item))))
        (if (##null? l)
          (begin
            (##write-string ")" port)
            (##fixnum.+ col* 1))
          (begin
            (indent col2 col* port)
            (##write-string "." port)
            (indent col2 col* port)
            (let* ((extra* (##fixnum.+ extra 1))
                   (col** (p l port touch? col2 width extra* pp-item)))
              (##write-string ")" port)
              (##fixnum.+ col** 1)))))))

  (define (pp-expr-list l port touch? col width extra)
    (pp-list l port touch? col width extra pp-expr))

  (define (pp-abbrev expr port touch? col width extra prefix)
    (let* ((rest (##cdr expr))
           (rest (if touch? (touch-vars (rest) rest) rest)))
      (if (and (##pair? rest) (##null? (##cdr rest)))
        (let ((col* (##fixnum.+ col (##string-length prefix))))
          (##write-string prefix port)
          (p (##car rest) port touch? col* width extra pp-expr))
        (pp-call expr port touch? col width extra pp-expr))))

  (define (pp-general expr port touch? col width extra named? pp-1 pp-2 pp-3)

    (define (tail1 rest col1 col2 col3)
      (if (and pp-1 (##pair? rest))
        (begin
          (indent col3 col2 port)
          (let* ((val1 (##car rest))
                 (rest (##cdr rest))
                 (rest (if touch? (touch-vars (rest) rest) rest))
                 (extra* (if (##null? rest) (##fixnum.+ extra 1) 0))
                 (col* (p val1 port touch? col3 width extra* pp-1)))
            (tail2 rest col1 col* col3)))
        (tail2 rest col1 col2 col3)))

    (define (tail2 rest col1 col2 col3)
      (if (and pp-2 (##pair? rest))
        (begin
          (indent col3 col2 port)
          (let* ((val1 (##car rest))
                 (rest (##cdr rest))
                 (rest (if touch? (touch-vars (rest) rest) rest))
                 (extra* (if (##null? rest) (##fixnum.+ extra 1) 0))
                 (col* (p val1 port touch? col3 width extra* pp-2)))
            (tail3 rest col1 col*)))
        (tail3 rest col1 col2)))

    (define (tail3 rest col1 col2)
      (pp-down rest port touch? col2 col1 width extra pp-3))

    (##write-string "(" port)
    (let* ((head (##car expr))
           (rest (##cdr expr))
           (rest (if touch? (touch-vars (rest) rest) rest))
           (col* (##fixnum.+ (##fixnum.+ col 1) (##write head port touch?))))
      (if (and named? (##pair? rest))
        (begin
          (##write-string " " port)
          (let* ((name (##car rest))
                 (rest (##cdr rest))
                 (rest (if touch? (touch-vars (rest) rest) rest))
                 (col** (##fixnum.+ (##fixnum.+ col* 1) (##write name port touch?))))
            (tail1 rest (##fixnum.+ col 2) col** (##fixnum.+ col** 1))))
        (tail1 rest (##fixnum.+ col 2) col* (##fixnum.+ col* 1)))))

  (define (pp-quote expr port touch? col width extra)
    (pp-abbrev expr port touch? col width extra "'"))

  (define (pp-quasiquote expr port touch? col width extra)
    (pp-abbrev expr port touch? col width extra "`"))

  (define (pp-unquote expr port touch? col width extra)
    (pp-abbrev expr port touch? col width extra ","))

  (define (pp-unquote-splicing expr port touch? col width extra)
    (pp-abbrev expr port touch? col width extra ",@"))

  (define (pp-lambda expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))

  (define (pp-if expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr #f pp-expr))

  (define (pp-set! expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr #f pp-expr))

  (define (pp-cond expr port touch? col width extra)
    (pp-call expr port touch? col width extra pp-expr-list))

  (define (pp-case expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr #f pp-expr-list))

  (define (pp-and expr port touch? col width extra)
    (pp-call expr port touch? col width extra pp-expr))

  (define (pp-or expr port touch? col width extra)
    (pp-call expr port touch? col width extra pp-expr))

  (define (pp-let expr port touch? col width extra)
    (let* ((rest (##cdr expr))
           (rest (if touch? (touch-vars (rest) rest) rest))
           (named? (and (##pair? rest) (##symbol? (##car rest)))))
      (pp-general expr port touch? col width extra named? pp-expr-list #f pp-expr)))

  (define (pp-let* expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))

  (define (pp-letrec expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))

  (define (pp-begin expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f #f #f pp-expr))

  (define (pp-do expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr-list pp-expr-list pp-expr))

  (define (pp-define expr port touch? col width extra)
    (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))

  (define (pp-style x)
    (case x
      ((quote) pp-quote)
      ((quasiquote) pp-quasiquote)
      ((unquote) pp-unquote)
      ((unquote-splicing) pp-unquote-splicing)
      ((lambda) pp-lambda)
      ((if) pp-if)
      ((set!) pp-set!)
      ((cond) pp-cond)
      ((case) pp-case)
      ((and) pp-and)
      ((or) pp-or)
      ((let) pp-let)
      ((let*) pp-let*)
      ((letrec) pp-letrec)
      ((begin) pp-begin)
      ((do) pp-do)
      ((define) pp-define)
      (else #f)))

  (p obj port touch? col width 0 pp-expr))

(define (##pretty-print obj port width)
  (##pretty obj port (if-touches #t #f) 0 width)
  (##newline port))

(define (##object->string obj width touch?)
  (let ((port (##open-output-string)))
    (##wr-limited obj port #f touch? (##fixnum.+ width 1))
    (let* ((str (##get-output-string port))
           (len (##string-length str)))
      (##close-port port)
      (if (##fixnum.< width len)
        (begin
          (##string-set! str (##fixnum.- width 1) #\.)
          (##string-set! str (##fixnum.- width 2) #\.)
          (##string-set! str (##fixnum.- width 3) #\.)
          (##string-shrink! str width)
          str)
        str))))

(define (##format port str . args)
  (let ((len (##string-length str)))
    (let loop ((i 0) (j 0) (args args))
      (if (##not (##fixnum.< j len))
        (##write-substring str i j port)
        (let ((c (##string-ref str j)))
          (if (##char=? c #\~)
            (let ((c (##string-ref str (##fixnum.+ j 1))))
              (##write-substring str i j port)
              (if (##memq c '(#\A #\S #\V #\D #\B #\O #\X))
                (let ((arg (##car args))
                      (rest (##cdr args)))
                  (cond ((##char=? c #\A)
                         (##display arg port #t))
                        ((##char=? c #\S)
                         (##write arg port #t))
                        ((##char=? c #\V)
                         (##wr-unlimited arg port #f #f))
                        ((##char=? c #\D)
                         (##write-string (##number->string arg 10) port))
                        ((##char=? c #\B)
                         (##write-string (##number->string arg 2) port))
                        ((##char=? c #\O)
                         (##write-string (##number->string arg 8) port))
                        ((##char=? c #\X)
                         (##write-string (##number->string arg 16) port)))
                  (loop (##fixnum.+ j 2) (##fixnum.+ j 2) rest))
                (cond ((##char=? c #\%)
                       (##newline port)
                       (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args))
                      ((##char=? c #\~)
                       (##write-string "~" port)
                       (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args))
                      ((##char=? c #\newline)
                       (let ((k (let skip ((j (##fixnum.+ j 2)))
                                  (cond ((##not (##fixnum.< j len))
                                         j)
                                        ((##char-whitespace? c)
                                         (skip (##fixnum.+ j 1)))
                                        (else
                                         j)))))
                         (loop k k args)))
                      (else
                       (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args)))))
            (loop i (##fixnum.+ j 1) args)))))))

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

(define (##stdin-read descr rbuf i j)
  (let ((len (##os-file-read descr rbuf i j)))
    (if len
      (let ((p ##transcript-port))
        (if (and (##fixnum.< 0 len)
                 (##output-port? p)
                 (##not (##closed-port? p)))
          (##write-substring rbuf i j p))))
    len))

(define ##stdin
  (let ((port
          (##make-port 0 'STDIN 0
            ##stdin-read
            #f
            ##os-file-read-ready
            #f
            (##make-string 1 #\space)
            #f)))
    (port-close-set! port (lambda (descr) #f))
    port))

(define (##stdout-write descr s i j)
  (let ((len (##os-file-write descr s i j)))
    (if len
      (let ((p ##transcript-port))
        (if (and (##fixnum.< 0 len)
                 (##output-port? p)
                 (##not (##closed-port? p)))
          (##write-substring s i j p))))
    len))

(define ##stdout
  (let ((port
          (##make-port 1 'STDOUT 2
            #f
            ##stdout-write
            #f
            #f
            #f
            (##make-string 1 #\space))))
    (port-close-set! port (lambda (descr) #f))
    port))

(define ##stderr
  (let ((port
          (##make-port 2 'STDERR 2
            #f
            ##stdout-write
            #f
            #f
            #f
            (##make-string 1 #\space))))
    (port-close-set! port (lambda (descr) #f))
    port))

(define (##transcript-on port)
  (set! ##transcript-port port)
  #f)

(define (##transcript-off port)
  (set! ##transcript-port #f)
  #f)

(define ##transcript-port #f)

(define (##current-input-port)
  (##dynamic-ref '##CURRENT-INPUT-PORT ##stdin))

(define (##current-output-port)
  (##dynamic-ref '##CURRENT-OUTPUT-PORT ##stdout))

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

(define (##load s trace-port)

  (define (load-from-port port)
    (let loop ()
      (let ((expr (##read port)))
        (if (##not (##eof-object? expr))
          (let ((val (##eval-global expr)))
            (if trace-port
              (begin
                (##write val trace-port (if-touches #t #f))
                (##newline trace-port)))
            (loop))
          (##close-port port)))))

  (define (remove-extension str ext)
    (let ((lstr (##string-length str))
          (lext (##string-length ext)))
      (cond ((##fixnum.< lstr lext)
             str)
            ((##string=? (##substring str (##fixnum.- lstr lext) lstr) ext)
             (##substring str 0 (##fixnum.- lstr lext)))
            (else
             str))))

  (let* ((name (remove-extension s ".O"))
         (name* (##string-append name ".O"))
         (port (##open-input-file name*)))
    (if port
      (begin
        (##close-port port)
        (let ((msg (##load-object-file name)))
          (if (##procedure? msg)
            (begin (msg) name*)
            (trap-load (load name*) msg))))
      (let* ((name (remove-extension s ".scm"))
             (name* (##string-append name ".scm"))
             (port (##open-input-file name*)))
        (if port
          (begin (load-from-port port) name*)
          (let ((port (##open-input-file s)))
            (if port
              (begin (load-from-port port) s)
              (trap-open-file (load s)))))))))

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