;;;-*- Mode:LISP; Package:TIGER; Readtable:CL; Base:10; Fonts:(CPTFONT TR12I) -*-

; Copyright LISP Machine, Inc. 1984
;   See filename "Copyright" for
; licensing and release information.

;;; in the interest of software modularity (e.g. not having minor utility packages
;;; defining new read syntax) the readmacros in this file have been punted in favor of
;;; functions with compile-time optimization. 2/04/85 11:40:21 -gjc
;;;
;;; These replace # for ascii printing characters, and 1 *# for control characters.
;;;


(defconst *special-control-character-names*
	  '((#\control-@ :NUL :NULL)
	    (#\control-A :SOH :START-OF-HEADING)
	    (#\control-B :STX :START-OF-TEXT)
	    (#\control-C :ETX :END-OF-TEXT)
	    (#\control-D :EOT :END-OF-TRANSMISSION)
	    (#\control-E :ENQ :ENQUIRY)
	    (#\control-F :ACK :ACKNOWLEDGE)
	    (#\control-G :BEL :BELL)
	    (#\control-H :BS :OVERSTRIKE :BACKSPACE)
	    (#\control-I :HT :HORIZONTAL-TABULATION :TAB)
	    (#\control-J :LF :LINE :LINEFEED :LINE-FEED)
	    (#\control-K :VT :VERTICAL-TABULATION)
	    (#\control-L :FF :CLEAR-SCREEN :FORM :FORMFEED :FORM-FEED)
	    (#\control-M :CR :CARRIAGE-RETURN :RETURN)
	    (#\control-N :SO :SHIFT-OUT)
	    (#\control-O :SI :SHIFT-IN)
	    (#\control-P :DLE :DATA-LINK-ESCAPE)
	    (#\control-Q :DC1 :DEVICE-CONTROL-1)
	    (#\control-R :DC2 :DEVICE-CONTROL-2)
	    (#\control-S :DC3 :DEVICE-CONTROL-3)
	    (#\control-T :DC4 :DEVICE-CONTROL-4)
	    (#\control-U :NAK :NEGATIVE-ACKNOWLEDGE)
	    (#\control-V :SYN :SYNCHRONOUS-IDLE)
	    (#\control-W :ETB :END-OF-TRANSMISSION-BLOCK)
	    (#\control-X :CAN :CANCEL)
	    (#\control-Y :EM :END-OF-MEDIUM)
	    (#\control-Z :SUB :SUBSTITUTE)
	    (#\control-[ :ESC :ALT :ESCAPE :ALTMODE)
	    (#\control-\\ :FS :FILE-SEPARATOR)
	    (#\control-] :GS :GROUP-SEPARATOR)
	    (#\control-^ :RS :RECORD-SEPARATOR)
	    (#\control-_ :US :UNIT-SEPARATOR)
	    (#\control-\` :SP :SPACE)
	    (#\control-? :DEL :DELETE :RUBOUT))
  "Gives special ASCII names such as :EOT for #\control-D")

(defun ascii-code (lispm-character-or-symbol &aux lispm-character)
  "Given a lispm-character returns an acceptable translation into 7-bit ascii.
The domain of the function is not the set of all lispm-characters, nor is
the mapping one-to-one. The Lispm-Character may also be a keyword name of an
ascii character code"
  (setq lispm-character (or (and (symbolp lispm-character-or-symbol)
				 (keywordp lispm-character-or-symbol)
				 (car (rass #'memq lispm-character-or-symbol
					    *special-control-character-names*)))
			    lispm-character-or-symbol))
  
  (cond ((mem #'char= lispm-character '(#\return #\line #\tab #\form))
	 (- (char-code lispm-character) #o200))
	((mem #'char= lispm-character '(#\rubout #\delete))
	 #o177)
	((graphic-char-p lispm-character)
	 (check-ascii-char (char-code lispm-character) lispm-character))
	((char-bit lispm-character :meta)
	 (ferror nil "Meta-bit not handled: ~S" lispm-character))
	((char-bit lispm-character :super)
	 (ferror nil "Super-bit not handled: ~S" lispm-character))
	((char-bit lispm-character :hyper)
	 (ferror nil "Hyper-bit not handled: ~S" lispm-character))
	((char-bit lispm-character :control)
	 (check-ascii-char (logxor #o100 (char-code (char-upcase (set-char-bit lispm-character
									       :control
									       nil))))
			   lispm-character))
	('else
	 ;; some characters which fall through here are #\escape and #\network
	 ;; #\hand-down #\system.
	 (ferror nil "Unhandled character: ~S" lispm-character))))


(defun check-ascii-char (code from-lispm-char)
  (cond ((zerop (logand (lognot #o177) code))
	 code)
	('else
	 (ferror nil "Character had some unhandled high bits: ~S" from-lispm-char))))

(compiler:defoptimizer ascii-code-of-constant ascii-code (ascii-code) (form)
  ;; in fact this is simply the simplification of a call to constant
  ;; arguments, which is handled by other optimizers as well.
  ;; so a more specific declaration to that effect would be applicable.
  (cond ((and (= (length form) 2)
	      (or (typep (cadr form) '(or :number :character))
		  (and (symbolp (cadr form)) (keywordp (cadr form)))
		  (and (not (atom (cadr form)))
		       (eq (caadr form) 'quote))))
	 (eval form))
	('else
	 form)))