;;;-*- Mode:LISP; Package:USER; Fonts:(CPTFONT TR12I); Base:8; Readtable:ZL -*-

;1;;This defines new reader syntax for ASCII hacking.*

;1;; *#1 allows entry of ASCII printing characters, like *#/1 does for Lisp Machine characters.*
;1;; *#1 allows entry of ASCII control, etc. characters, like *#\1 does for Lisp Machine characters.*
;1;; All the usual names for ASCII characters are accepted, both in long form and in the standard*
;1;; two and three letter abbreviations.*
;1;; The form *Control-X1 is also accepted, where the *X1 is any letter or the characters @[\]^_ .*

(set-syntax-/#-macro-char #/ 'ascii-char-fixnum)
(set-syntax-/#-macro-char #/ 'ascii-control-char-fixnum)

(defvar ascii-sail-translation-table (make-array 32.)
  "Each element is the ASCII character corresponding to a Lisp Machine character.")

(fillarray ascii-sail-translation-table
	   '(nil				;1center-dot*
	     nil				;1down arrow*
	     nil				;1alpha*
	     nil				;1beta*
	     nil				;1and-sign*
	     nil				;1not-sign*
	     nil				;1epsilon*
	     nil				;1pi*
	     nil				;1lambda*
	     nil				;1gamma*
	     nil				;1delta*
	     nil				;1uparrow*
	     nil				;1plus-minus*
	     nil				;1circle-plus*
	     nil				;1infinity*
	     nil				;1partial delta*
	     nil				;1left horseshoe*
	     nil				;1right horseshoe*
	     nil				;1up horseshoe*
	     nil				;1down horseshoe*
	     nil				;1universal quantifier*
	     nil				;1existential quantifier*
	     nil				;1circle-X*
	     nil				;1double-arrow*
	     nil				;1left arrow*
	     nil				;1right arrow*
	     nil				;1not-equals*
	     33					;1diamond (altmode)*
	     nil				;1less-or-equal*
	     nil				;1greater-or-equal*
	     nil				;1equivalence*
	     nil				;1or*
	     ))

(defvar ascii-named-char-list
	'((:Null . 0)				;1NUL (Control-@)*
	  (:NUL . 0)
	  (:Start-of-Heading . 1)		;1SOH (Control-A)*
	  (:SOH . 1)
	  (:Start-of-Text . 2)			;1STX (Control-B)*
	  (:STX . 2)
	  (:End-of-Text . 3)			;1ETX (Control-C)*
	  (:ETX . 3)
	  (:End-of-Transmission . 4)		;1EOT (Control-D)*
	  (:EOT . 4)
	  (:Enquiry . 5)			;1ENQ (Control-E)*
	  (:ENQ . 5)
	  (:Acknowledge . 6)			;1ACK` (Control-F)*
	  (:ACK . 6)
	  (:Bell . 7)				;1BEL (Control-G)*
	  (:BEL . 7)
	  (:Backspace . 10)			;1BS (Control-H)*
	  (:Overstrike . 10)
	  (:BS . 10)
	  (:Tab . 11)				;1HT (Control-I)*
	  (:Horizontal-Tabulation . 11)
	  (:HT . 11)
	  (:Line-Feed . 12)			;1LF (Control-J)*
	  (:Linefeed . 12)
	  (:Line . 12)
	  (:LF . 12)
	  (:Vertical-Tabulation . 13)		;1VT (Control-K)*
 	  (:VT . 13)
	  (:Form-Feed . 14)			;1FF (Control-L)*
	  (:Formfeed . 14)
	  (:Form . 14)
	  (:Clear-Screen . 14)
	  (:FF . 14)
	  (:Return . 15)			;1CR (Control-M)*
	  (:Carriage-Return . 15)
	  (:CR . 15)
	  (:Shift-Out . 16)			;1SO (Control-N)*
	  (:SO . 16)
	  (:Shift-In . 17)			;1SI (Control-O)*
	  (:SI . 17)
	  (:Data-Link-Escape . 20)		;1DLE (Control-P)*
	  (:DLE . 20)
	  (:Device-Control-1 . 21)		;1DC1 (Control-Q)*
	  (:DC1 . 21)
	  (:Device-Control-2 . 22)		;1DC2 (Control-R)*
	  (:DC2 . 22)
	  (:Device-Control-3 . 23)		;1DC3 (Control-S)*
	  (:DC3 . 23)
	  (:Device-Control-4 . 24)		;1DC4 (Control-T)*
	  (:DC4 . 24)
	  (:Negative-Acknowledge . 25)		;1NAK (Control-U)*
	  (:NAK . 25)
	  (:Synchronous-Idle . 26)		;1SYN (Control-V)*
	  (:SYN . 26)
	  (:End-of-Transmission-Block . 27)	;1ETB (Control-W)*
	  (:ETB . 27)
	  (:Cancel . 30)			;1CAN (Control-X)*
	  (:CAN . 30)
	  (:End-of-Medium . 31)			;1EM (Control-Y)*
	  (:EM . 31)
	  (:Substitute . 32)			;1SUB (Control-Z)*
	  (:SUB . 32)
	  (:Altmode . 33)			;1ESC (Control-[)*
	  (:Escape . 33)
	  (:ALT . 33)
	  (:ESC . 33)
	  (:File-Separator . 34)		;1FS (Control-\)*
	  (:FS . 34)
	  (:Group-Separator . 35)		;1GS (Control-])*
	  (:GS . 35)
	  (:Record-Separator . 36)		;1RS (Control-^)*
	  (:RS . 36)
	  (:Unit-Separator . 37)		;1US (Control-_)*
	  (:US . 37)
	  (:Rubout . 177)			;1DEL (Rubout)*
	  (:Delete . 177)
	  (:DEL . 177)))

;1;; Note -- this is a modified version of this function for use in Systems 94 (with patches) and later.*
;1;; It uses SI:XR-XRTYI where appropriate so everything in the reader will work correctly.*
;1;; Since this won't work in earlier systems, it just uses the TYI message in old software.*
(defun ascii-char-fixnum (ignore stream)
  (let* ((char (cond ((< (si:get-system-version) 94.) (send stream ':tyi))
		     (t (si:xr-xrtyi stream nil t))))
	 (ascii-char (cond ((< 37 char 200) char)
			   ((< char 40) (aref ascii-sail-translation-table char))
			   (t nil))))
    (when (null ascii-char)
      (cerror ':no-action nil 'sys:read-error-1 "~C is not a valid ASCII character." char))
    ascii-char))

(defun ascii-control-char-fixnum (ignore stream)
  (pkg-bind "USER"
    (let ((name (read stream)))
      (unless (typep name ':SYMBOL)
	(cerror ':no-action nil 'sys:read-error-1
		"# followed by ~A, which is not a symbol." name))
      (cond ((string-equal name "CONTROL-" :start1 0 :start2 0 :end1 8 :end2 8)
	     (when ( (string-length name) 9.)
	       (cerror ':no-action nil 'sys:read-error-1
		       "#Control- followed by ~A, which is not a single character."
		       (substring name 8.)))
	     (let ((control-char (char-upcase (aref (string name) 8.))))
	       (unless (< 77 control-char 140)
		 (cerror ':no-action nil 'sys:read-error-1
		    "#Control- followed by ~C, which is not an ASCII control character."
		    control-char))
	       (- control-char 100)))
	    (t (cdr (cond ((assq (intern-soft name "KEYWORD") ascii-named-char-list))
			  (t (cerror ':no-action nil 'sys:read-error-1
				     "#~A is not an ASCII character." name)))))))))