;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; 
;;;; bivalent-tty.lisp: Make SBCL's initial streams bivalent.
;;;; 
;;;; Copyright 2008, Richard M Kreuter <kreuter@progn.net>
;;;; 
;;;; Time-stamp: <2008-09-28 15:50:59 rkreuter>

(in-package "SB-IMPL")

(defun pick-output-routine (type buffering &optional external-format)
  (when (subtypep type 'character)
    (let ((entry (get-external-format external-format)))
      (when entry
        (return-from pick-output-routine
          (values (symbol-function (nth (ecase buffering
                                          (:none 4)
                                          (:line 5)
                                          (:full 6))
                                        entry))
                  'character
                  1
                  (symbol-function (fourth entry))
                  (first (first entry)))))))
  (dolist (entry *output-routines*)
    (when (and (subtypep type (first entry))
               (eq buffering (second entry))
               (or (not (fifth entry))
                   (eq external-format (fifth entry))))
      (return-from pick-output-routine
        (values (symbol-function (third entry))
                (first entry)
                (fourth entry)))))
  ;; KLUDGE: dealing with the buffering here leads to excessive code
  ;; explosion.
  ;;
  ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
        if (subtypep type `(unsigned-byte ,i))
        do (return-from pick-output-routine
             (values
              (ecase buffering
                ;; FIXME-OR-DELETE-THIS-COMMENT: these 3 cases are
                ;; identical.
                (:none
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:none) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:line
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:line) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:full) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
              `(unsigned-byte ,i)
              (/ i 8))))
  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
        if (subtypep type `(signed-byte ,i))
        do (return-from pick-output-routine
             (values
              (ecase buffering
                (:none
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:none) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:full) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
              `(signed-byte ,i)
              (/ i 8)))))


(defun stream-reinit (&optional init-buffers-p)
  (when init-buffers-p
    (with-available-buffers-lock ()
      (aver (not (boundp '*available-buffers*)))
      (setf *available-buffers* nil)))
  (with-output-to-string (*error-output*)
    (setf *stdin*
          (make-fd-stream 0 :name "standard input" :input t :buffering :line
                          :element-type :default
                          #+win32 :external-format #+win32 (sb-win32::console-input-codepage)))
    (setf *stdout*
          (make-fd-stream 1 :name "standard output" :output t :buffering :line
                          :element-type :default
                          #+win32 :external-format #+win32 (sb-win32::console-output-codepage)))
    (setf *stderr*
          (make-fd-stream 2 :name "standard error" :output t :buffering :line
                          :element-type :default
                          #+win32 :external-format #+win32 (sb-win32::console-output-codepage)))
    (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
           (tty (sb-unix:unix-open ttyname sb-unix:o_rdwr #o666)))
      (if tty
          (setf *tty*
                (make-fd-stream tty
                                :element-type :default
                                :name "the terminal"
                                :input t
                                :output t
                                :buffering :line
                                :auto-close t))
          (setf *tty* (make-two-way-stream *stdin* *stdout*))))
    (princ (get-output-stream-string *error-output*) *stderr*))
  (values))

(save-lisp-and-die "sbcl.core")