;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; 
;;;$Header: /ct/ctlisp/ctio.l,v 1.20 84/09/05 10:45:57 alex Exp $
;;; 
;;;$Log:	/ct/ctlisp/ctio.l,v $
;;;Revision 1.20  84/09/05  10:45:57  alex
;;;fix the ct_readline2 in rel 5.
;;;
;;;Revision 1.19  84/06/26  17:13:21  alex
;;;handle the return immediately in ct_readline2, don't
;;;ignore them.
;;;
;;;Revision 1.18  84/06/26  01:01:20  alex
;;;append the #\return ad the end of the string returned by ct_readline2.This is important because the finite state machine use it to stop reading more num.
;;;
;;;Revision 1.17  84/06/25  14:08:36  alex
;;;add the ct_readline2 function.
;;;
;;;Revision 1.16  84/01/06  13:10:25  penny
;;;removed the localf declare for test-stream alex uses it
;;;
;;;Revision 1.15  83/12/09  14:01:17  john
;;;Added localf declarations
;;;
;;;Revision 1.14  83/10/18  12:06:10  john
;;;added ct_readline function.
;;;
;;;Revision 1.13  83/10/05  10:52:39  susan
;;;Added ct_tyipeeks that know about db%windows and extesting_streams
;;;
;;;Revision 1.12  83/09/24  23:22:06  mark
;;; Fixed underscore bug from VMS filename conversion and cleaned
;;; up commentary.  Also tested each function a little.  NB: these
;;; functions currently return different values on franz vs. zeta!
;;;
;;;Revision 1.11  83/09/20  22:56:11  penny
;;; Convert to new filename convention
;;;
;;;Revision 1.10  83/09/08  15:29:53  john
;;; Added freshline, skipline, and moved some of mark's
;;; private functions here to use ct_io.
;;;
;;;Revision 1.9  83/09/01  10:50:16  john
;;; Added ':' to 'ct_format
;;;
;;;Revision 1.8  83/09/01  10:43:32  john
;;; 2nd try to fix ct_format
;;;
;;;Revision 1.7  83/09/01  10:34:44  john
;;; Repaired ct_format to use "<-" with franz and "send" with lispm
;;;
;;;Revision 1.6  83/08/31  08:50:09  john
;;; Checked out for compilation only.
;;;
;;;Revision 1.5  83/08/31  08:47:10  john
;;; Improved ct_format to not double-evaluate some of its args.
;;;
;;;Revision 1.4  83/08/30  17:04:46  john
;;; Fix ct_tyi to allow eof option in Franz.
;;;
;;;Revision 1.3  83/08/30  15:38:55  john
;;; Allow use of EOF option for ct_tyi and ct_read.
;;;
;;;Revision 1.2  83/08/30  14:15:21  penny
;;; Fixed ct_format to not evaluate the stream
;;;
;;;Revision 1.1  83/08/30  00:44:36  penny
;;; Initial revision
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				 CTIO                                ;;;
;;; John Shelton                                         August 1983 ;;;
;;;                                                                  ;;;
;;; Computer Thought Improved IO Package                             ;;;
;;;                                                                  ;;;
;;;  This file includes most of the standard io functions (tyi,      ;;;
;;; princ, etc.) in ct format.  If the object that is supplied for a ;;;
;;; stream is one of some selected flavors, it will be sent a        ;;;
;;; message corresponding to the function name.                      ;;;
;;;                                                                  ;;;
;;;  These functions are defined as (quasi-) exprs (not macros) to   ;;;
;;; allow for easy recompilation of everything else.                 ;;;
;;;                                                                  ;;;
;;;  So far, have done:                                              ;;;
;;;                                                                  ;;;
;;; princ print prin1 tyo format terpri read tyi freshline skipline. ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   AJPO, Feb 1983.  ANSI/MIL-STD-1815A  Ada Reference Manual.     ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;  ****************************************************************
;;;  Ensure presence of needed files. 
;;;  ****************************************************************


(eval-when (compile load eval) (ct_load 'ctstrl))

#+franz (eval-when (compile load eval) (ct_load 'format))

#+franz(eval-when (compile load eval) (ct_load 'readline))

;;;  ****************************************************************
;;;  Compiler Declarations and Global Variables -- 
;;;  ****************************************************************

#+franz (declare (macros t))


;;;  Constant definitions, etc.

;;;  The list of possible flavors for the stream argument that should
;;; be handled separately.
(defconst *ct-redefined-io-function-flavors*
	  '(db%debug_window extesting_stream))




;;;  ****************************************************************
;;;  Functions, etc.
;;;  ****************************************************************

;;;  Tests to see if the "stream" argument should be sent a message
;;; or not.
(defun test-stream (stream)
  (and stream
       #+lispm (memq (typep stream) *ct-redefined-io-function-flavors*)
       #+franz (and (instancep stream)
		    (memq (flavor stream) *ct-redefined-io-function-flavors*))))

(defun ct_princ (thing &optional (stream ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_princ thing))
    ((eq stream ':not-supplied)  (princ thing))
    (t                           (princ thing stream))))

(defun ct_print (thing &optional (stream ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_print thing))
    ((eq stream ':not-supplied)  (print thing))
    (t                           (print thing stream))))

(defun ct_prin1 (thing &optional (stream ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_prin1 thing))
    ((eq stream ':not-supplied)  (prin1 thing))
    (t                           (prin1 thing stream))))

(defun ct_tyo (thing &optional (stream ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_tyo thing))
    ((eq stream ':not-supplied)  (tyo thing))
    (t                           (tyo thing stream))))

(defun ct_terpri (&optional (stream ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_terpri))
    ((eq stream ':not-supplied)  (terpri))
    (t                           (terpri stream))))

(defun freshline (&optional (stream ':not-supplied))
    (cond
       ((test-stream stream)     (ct_send stream ':ct_terpri))
       ((eq stream ':not-supplied) (terpri))
       (t                        (terpri stream))))

(defun skipline (&optional (stream ':not-supplied))
    (cond
       ((test-stream stream)     (ct_send stream ':ct_terpri)
	                         (ct_send stream ':ct_terpri))
       ((eq stream ':not-supplied) (terpri) (terpri))
       (t                        (terpri stream)
	                         (terpri stream))))

(defun ct_format (stream ctl-string &rest args)
  (cond
    ((test-stream stream)
     #+franz
     (apply #'<- (cons stream (cons ':ct_format (cons ctl-string args))))
     #+lispm
     (lexpr-send stream :ct_format ctl-string args))
    (t (apply #'format (cons stream (cons ctl-string args))))))

(defun ct_read (&optional (stream ':not-supplied) (eof-option ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_read))
    ((eq stream ':not-supplied)  (read))
    ((eq eof-option ':not-supplied) (read stream))
    (t                           (read stream eof-option))))

(defun ct_tyi (&optional (stream ':not-supplied) (eof-option ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_tyi))
    ((eq stream ':not-supplied)  (tyi))
    ((eq eof-option ':not-supplied) (tyi stream))
    (t                            (tyi stream eof-option))))

;;;  A basic incompatibility between LM and Franz peeking
#+franz
(defun ct_tyipeek (&optional (stream ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_tyipeek))
    ((eq stream ':not-supplied)  (tyipeek))
    (t                            (tyipeek stream))))

;;;  Force the lispm version to return -1 at end of file.  Franz does
;;; this automagically.
#+lispm
(defun ct_tyipeek (&optional (stream ':not-supplied))
  (cond
    ((test-stream stream)        (ct_send stream ':ct_tyipeek))
    ((eq stream ':not-supplied)  (tyipeek nil nil -1))
    (t                            (tyipeek nil stream -1 ))))

;;;  Allows reading up to next line separator in file.
#+lispm
(defun ct_readline3 (stream)
  (let (firstch)
    (setq firstch (ct_send stream 'any-tyi))
    (cond ((listp firstch) (ct_readline3 stream)) ;;ignore the mouse click
	  (t (ct_tyo firstch stream)
	     (ct_string_append (implode (cons firstch (read_rest stream)))))
	  )
    ))

#|
;;; the following code is for rel 4.5 only
#+lispm
(defun ct_readline2 (stream)
  (cond ((and (not rubout-handler)
	      (memq ':rubout-handler
		    (funcall stream ':which-operations)))
	 (funcall stream
		  ':rubout-handler
		  '((:pass-through m-l-1) (:do-not-echo #\end))
		  #'ct_readline2 stream))
	(t (do ((ch nil)
		(quit nil)
		(len 80)
		(string (make-array 80 ':type 'art-string))
		(idx 0)
		(first_return t)
		(end_key nil))
	       (quit (adjust-array-size string idx)
		     (ct_string_append string #\return))
	     (setq ch (errset (send stream ':tyi) nil))
	     (cond ((null ch))
		   (t
		    (setq ch (car ch))
		    (ct_if (eq ch #\end) (setq end_key t))
		    (cond ((or (= ch #\return) (listp ch)))
			  (t (ct_if (= idx len)
				    (adjust-array-size string
						       (setq len (+ len 40))))
			     (setq first_return nil)
			     (aset ch string idx)
			     (setq idx (1+ idx)))
			  )
		    (ct_if (or (null ch) end_key (= ch #\cr))
			   (setq quit t))
		    ))
	))))
|#

;;; rel 5 version
(defun ct_readline2 (&optional (stream standard-input))
  (with-input-editing (stream '((:pass-through m-l-1) (:do-not-echo #\end)))
       (do ((ch nil)
		(quit nil)
		(len 80)
		(string (make-array 80 ':type 'art-string))
		(idx 0)
		(first_return t)
		(end_key nil))
	       (quit (adjust-array-size string idx)
		     (ct_string_append string #\return))
	     (setq ch (errset (send stream ':tyi) nil))
	     (cond ((null ch))
		   (t
		    (setq ch (car ch))
		    (ct_if (eq ch #\end) (setq end_key t))
		    (cond ((or (= ch #\return) (listp ch)))
			  (t (ct_if (= idx len)
				    (adjust-array-size string
						       (setq len (+ len 40))))
			     (setq first_return nil)
			     (aset ch string idx)
			     (setq idx (1+ idx)))
			  )
		    (ct_if (or (null ch) end_key (= ch #\cr))
			   (setq quit t))
		    ))
	     )
       ))

#+lispm
(defun read_rest (stream)
  (do ((ans nil) (fini nil) (ch nil))
      (fini (nreverse ans))
    (setq ch (ct_send stream 'any-tyi))
    (cond ((listp ch)) ;; ignore the mouse click
	  ((eq ch #\return) (setq fini t))
	  (t (setq ans (cons ch ans))
	     (ct_tyo ch stream))
	  )
    ))
  
#+lispm
(deff ct_readline 'readline)

#+franz
(defun ct_readline (&optional (stream ':not-supplied) (eof -1))
    (cond
       ((test-stream stream)  (ct_send stream ':ct_readline))
       ((memq stream '(:not-supplied t nil)) (int_ct_readline))
       (t (readline stream eof))))

;;;  Reads a line from the terminal.
#+franz
(defun int_ct_readline ()
    (loop with string = ""
	  for char = (tyi)
	  until (memq char '(#\linefeed #\return))
	  do (cond
		((memq char '(#\rubout #\backspace))
		 (cond ((not (equal string ""))
			(setq string (ct_substring
					string 0
					(- (string-length string) 2))))))
		((and (< 31. char) (< char 127.))
		 (setq string (ct_string_append string char)))
		(t (beep)))
	  finally (return string)))




;;;  ****************************************************************
;;;  Other functions, etc.
;;;  ****************************************************************

;;;  Identical to LM version called prin1-then-space.
(defun prin1_sp macro (form)		  ;(thing stream)
       (selfinsertmacro form
	`(progn (ct_prin1 ,@(cdr form))
		(ct_princ " " ,@(cddr form)))))

(defun sp_princ macro (form)
       (selfinsertmacro form
	`(progn (ct_princ " " ,@(cddr form))
		(ct_princ ,@(cdr form)))))

(defun princ_sp macro (form)
       (selfinsertmacro form
	`(progn (ct_princ ,@(cdr form))
		(ct_princ " " ,@(cddr form)))))

(defun nl_indent macro (form)
       (selfinsertmacro form
			`(let ((x ,(cadr form)))
			   (declare (fixnum x))
			   (ct_terpri)
			   (do ((i 1 (1+ i)))
			       ((= i x))
			     (ct_princ " ")))))