;-*- LISP -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **
(DECLARE (COND ((STATUS FEATURE LISPM))   ;DO NOTHING ON LISP MACHINE.
	       ((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
		(BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
	       ((NULL (GET 'IF-FOR-MACLISP 'MACRO))
		(LOAD '(MACROS > DSK LISPM2))
		(LOAD '(DEFMAC FASL DSK LISPM2))
		(LOAD '(LMMAC > DSK LISPM2))
		(MACROS T))))	;SEND OVER THE REST OF THE MACROS IN THIS FILE

(IF-FOR-LISPM
(DEFUN USER:CC ()
  (CADR:CC)) )

(DECLARE (SPECIAL CC-GETSYL-UNRCH CC-GETSYL-UNRCH-TOKEN CC-LOW-LEVEL-FLAG))
(DECLARE (FIXNUM CH))
(DECLARE (EXPR-HASH T))
(SETQ DEFUN T)

(SETQ CC-GETSYL-UNRCH NIL)
(SETQ CC-GETSYL-UNRCH-TOKEN NIL)
(DECLARE (SPECIAL OLD-STREAM CC-INPUT-STREAM CC-OUTPUT-STREAM))

(DEFUN CC-GETSYL-RCH NIL 
 (PROG (CH)
	(COND (CC-GETSYL-UNRCH 
		(SETQ CH CC-GETSYL-UNRCH)
		(SETQ CC-GETSYL-UNRCH NIL))
	      (T (COND (CC-LOW-LEVEL-FLAG (CC-REPLACE-STATE)))
		 (SETQ CH (TYI CC-INPUT-STREAM '3))))
     X	(RETURN CH)))

(DEFUN CC-GETSYL-READ-TOKEN NIL 
  (PROG (TOK CH TERM-TOKEN)
	(COND (CC-GETSYL-UNRCH-TOKEN
		(SETQ TOK CC-GETSYL-UNRCH-TOKEN)
		(SETQ CC-GETSYL-UNRCH-TOKEN NIL)
		(RETURN TOK)))
   L	(SETQ CH (CC-GETSYL-RCH))
	(COND ((= CH 3)
		(SETQ TERM-TOKEN '*EOF*)
		(GO X))			;EOF
	      ((= CH 177)
		(OR TOK (RETURN '*RUB*)) ;OVER-RUBOUT
		(SETQ TOK (CDR TOK))
		(CURSORPOS 'X)
		(GO L))
	      ((OR (AND (< 100 CH)
			(< CH 133))
		   (AND (< 57 CH)
			(< CH 72))
		   (= CH 56))
	       (GO ALPHA-NUM))
	      ((AND (< 140 CH) (< CH 173))
	       (SETQ CH (- CH 40))
	       (GO ALPHA-NUM))
	      ((= CH 55)		;-
		(GO ALPHA-NUM))
;	      ((OR (= CH 40)
;		   (= CH 15)
;		   (= CH 12)
;		   (= CH 11)
;		   (= CH 14))
;		(GO SEP))
	      ((= CH 73)
		(GO SEMI)))
;DROP THRU ON "SCO"
	(SETQ TERM-TOKEN (ASCII CH))
  SEP 
  X	(COND (TOK 
	       (SETQ TOK (NREVERSE TOK))
	       (SETQ TOK
		     (COND ((DO L TOK (CDR L) (NULL L)
			      (OR (AND (< 57 (CAR L)) (< (CAR L) 72))
				  (= (CAR L) 55)
				  (= (CAR L) 53)
				  (RETURN T)))
			    (IMPLODE TOK))	;HAS LETTERS OR DOTS IN IT
			   (T (READLIST TOK))))	;A NUMBER (DIGITS, PLUS, MINUS)
		(SETQ CC-GETSYL-UNRCH-TOKEN TERM-TOKEN)
		(RETURN TOK))
	      (TERM-TOKEN
		(RETURN TERM-TOKEN))
	      (T (GO L)))
  SEMI	(COND ((= (CC-GETSYL-RCH) 15)
		(SETQ CC-GETSYL-UNRCH 15)
		(GO L)))
	(GO SEMI)
  ALPHA-NUM
	(SETQ TOK (CONS CH TOK))
	(GO L)))

(IF-FOR-LISPM
(DEFUN CC-STREAM (OP &REST ARGS)
  (SELECTQ OP
           (:TYI (LET ((CHAR (FUNCALL STANDARD-INPUT ':TYI)))
                      (COND ((AND (ZEROP (LDB %%KBD-CONTROL-META CHAR))
				  (< CHAR 200))	;Printing
			     CHAR)
                            ((OR (= CHAR #/L) (= CHAR #/l) (= CHAR #\FORM))
                             (FUNCALL STANDARD-INPUT ':CLEAR-SCREEN)
			     14)
                            ((= CHAR #\RUBOUT) 177) ;Map rubout
                            (T (LOGAND CHAR 37))))) ;Map CR, LF, etc.
           (:TYO (LET ((CHAR (CAR ARGS)))
		   (COND ((= CHAR 177) )
			 ;; Ascii printing and new-type format effectors go through
			 ((>= CHAR 40) (FUNCALL OLD-STREAM ':TYO CHAR))
			 ((MEMQ CHAR '(10 11 15))
			  (FUNCALL OLD-STREAM ':TYO (+ 200 CHAR)))
			 ((MEMQ CHAR '(33))
			  (FUNCALL OLD-STREAM ':TYO CHAR))
			 ((MEMQ CHAR '(12 14)) )
			 (T (FUNCALL OLD-STREAM ':TYO #/)
			    (FUNCALL OLD-STREAM ':TYO (+ CHAR 100))))))
           (OTHERWISE (LEXPR-FUNCALL OLD-STREAM OP ARGS)))))

(IF-FOR-LISPM
(DEFUN MAKE-CC-STREAM (&AUX (OLD-STREAM STANDARD-INPUT))
  (SETQ CC-INPUT-STREAM (CLOSURE '(OLD-STREAM) 'CC-STREAM))
  (LET ((OLD-STREAM STANDARD-OUTPUT))
       (SETQ CC-OUTPUT-STREAM (CLOSURE '(OLD-STREAM) 'CC-STREAM)))))

(IF-FOR-MACLISP
(DEFUN MAKE-CC-STREAM () (SETQ CC-OUTPUT-STREAM T CC-INPUT-STREAM T))
)