1;-*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Fonts:(CPTFONT CPTFONTB) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;*
;1;; Copyright (C) 1985-1989 Texas Instruments Incorporated.  All rights reserved.*


;;;
;;; 1Change history:*
;;;
;;;  1Date      Author*	1Description*
;;; 1-------------------------------------------------------------------------------------
;;;  06/24/87  AB   * 1 Changed CODE-CHAR to use the keypad bit specified in BITS by default.
;;;                   Also cleaned up all the empty (proclaim (compiler:try-inline))s.*
;1;;  02/26/87  HW    * 1Changed initial value of *country-code* to nil.
;;;* 1 11/25/86  LGO*    1Changed the character predicates to lookup char-code in bit vectors
;;; * 111/20/86  HW   *  1Change character code functions to take ISO characters into account:
;;;                   GRAPHIC-CHAR-P,ALPHA-CHAR-P, UPPER-CASE-P, LOWER-CASE-P*
;1;;  11/19/86 LGO+TWE*	1Changed GRAPHIC-CHAR-P to execute much faster.*
;1;;  10/08/86  TWE*	1Changed GRAPHIC-CHAR-P to return NIL for mouse and keypad characters.*
;1;;*			1This makes PRINT-OBJECT (used by PRINT, PRIN1, etc) work for mouse*
;1;;*			1and keypad characters.*
;1;;  10/07/86  TWE*	1Changed CODE-CHAR  to understand the keypad bit.  Also added the*
;1;;*			1defsubst CHAR-KEYPAD to follow the pattern of the other CHAR-...*
;1;;*			1DEFSUBSTs.
;;;;;;;;;;;;;;
;; accessing characters from strings*

(defconstant ISO-EXTENDED-UPPER-CASE-START 192.)
(defconstant ISO-EXTENDED-UPPER-CASE-END 222.)
(defconstant ISO-EXTENDED-LOWER-CASE-START 223.)
(defconstant ISO-EXTENDED-LOWER-CASE-END 255.)
(defconstant ISO-MULTIPLY 215.)	 ;this should be changed to #\multiply eventually
(defconstant ISO-DIVIDE 247.)	 ;this should be changed to #\divide eventually

(defparameter *country-code* nil
  "2Denotes natural language to be used. * 2This is not used by Explorer system software, but is available for developers.*")

(DEFSUBST CHAR (string index)
  1"Accesses the character at index INDEX in STRING.  Really the same as AREF."*
  (The character (COMMON-LISP-AR-1 string index)))

(DEFF SCHAR #'CHAR)

1;;;;;;;;;;;;;;
;; accessing fields within a character*

(Defsubst CHAR-CODE (char)
  1"Returns the character code of the character object CHAR.
This is sans the font number and meta bits."*
  (LDB %%ch-char char))

(Defsubst CHAR-FONT (char)
  1"Returns the font number of character object CHAR."*
  (LDB %%ch-font char))

;;PAD 2/6/87 Use all-control-bits rather than control-meta-bits
(Defsubst CHAR-BITS (char)
  "Returns the special bits of the character object CHAR."
  (LDB %%kbd-all-control-bits char))

(Defsubst CHAR-KEYPAD (char)
  1"returns the value of the keypad flag."*
  (LDB %%kbd-keypad char))

(Defsubst CHAR-MOUSE-BUTTON (char)
  1"returns the value of the mouse-button"*
  (LDB %%kbd-mouse-button char))

(Defsubst CHAR-MOUSE-CLICKS (char)
  1"returns the number of times the mouse button was clicked"*
   (LDB %%kbd-mouse-n-clicks char))

1;;;;;;;;;;;;;;
;; predicates*

(proclaim '(compiler:try-inline string-char-p))
(Defun STRING-CHAR-P (char)
  1"T if CHAR is a character which ordinary strings can contain.
Note that ART-FAT-STRING arrays can contain additional characters,
for which this function nevertheless returns NIL."*
;;  (<= 0 char 255)
  (zerop (logand char #x-100)))

(proclaim '(compiler:try-inline fat-string-char-p))
(Defun FAT-STRING-CHAR-P (char)
  1"T if CHAR is a character which a fat string can contain."*
;;  (<= 0 char #xffff)
  (zerop (logand char #x-10000))
  )

(eval-when (compile load)
(defparameter graphic-char-p-vector
	     (flet ((GRAPHIC-CHAR-P (char)
		      (AND (ZEROP (LOGAND char (DPB -1 %%kbd-control-meta
						    (DPB -1 %%kbd-keypad
							 (DPB -1 %%kbd-mouse 0)))))
			   (NOT (<= #x80 (CHAR-CODE char) #x9F)))))
	       (loop with vector = (make-array char-code-limit :element-type 'bit)
		     for i below char-code-limit
		     do (setf (aref vector i) (if (graphic-char-p i) 1 0))
		     finally (return vector)))) )

(Defun GRAPHIC-CHAR-P (char)
  1"Returns T if CHAR is a graphic character, one which prints as a 
  single glyph. Fonts are permitted but the bits-field of char must
  be zero.  Mouse and keypad characters do not print as single glyph
  either."*
  (AND (ZEROP (LOGAND char '#.(%logDPB -1 %%kbd-control-meta
				      (%logDPB -1 %%kbd-keypad
					       (%logDPB -1 %%kbd-mouse 0)))))
       (plusp (aref graphic-char-p-vector (char-code char)))))

(eval-when (compile load)
(defparameter alpha-char-p-vector
	     (flet ((ALPHA-CHAR-P (char)
		     1"T if CHAR is alphabetic with no meta bits."*
		     (AND (ZEROP (CHAR-BITS char))
			  (let ((char-code (char-code char)))
			    (or (<= #\a (LOGIOR #x20 char-code) #\z)
				(and (<= #xC0 CHAR-CODE #xFF)	;check for ISO range PMH
				     (/= CHAR-CODE ISO-multiply ISO-divide)))))))
	       (loop with vector = (make-array char-code-limit :element-type 'bit)
		     for i below char-code-limit
		     do (setf (aref vector i) (if (alpha-char-p i) 1 0))
		     finally (return vector)))) )

(proclaim '(compiler:try-inline alpha-char-p))
(Defun ALPHA-CHAR-P (char)
  1"T if CHAR is alphabetic with no meta bits."*
  (AND (ZEROP (CHAR-BITS char))
       (plusp (aref alpha-char-p-vector (char-code char)))))

(eval-when (compile load)
(defparameter upper-case-p-vector
	     (flet ((UPPER-CASE-P (char)
		      1"T if CHAR is an upper case letter with no meta bits."*
		      (AND (ZEROP (CHAR-BITS char))
			   (let ((char-code (char-code char)))
			     (or (<= #\A CHAR-CODE #\Z)
				 (and (<= ISO-EXTENDED-UPPER-CASE-START	;check for ISO range PMH
					  CHAR-CODE
					  ISO-EXTENDED-UPPER-CASE-END)
				      (/= CHAR-CODE iso-multiply)))))))
	       (loop with vector = (make-array char-code-limit :element-type 'bit)
		     for i below char-code-limit
		     do (setf (aref vector i) (if (upper-case-p i) 1 0))
		     finally (return vector))))  )

(proclaim '(compiler:try-inline upper-case-p))
(Defun UPPER-CASE-P (char)
  1"T if CHAR is an upper case letter with no meta bits."*
  (AND (ZEROP (CHAR-BITS char))
       (plusp (aref upper-case-p-vector (char-code char)))))

(defparameter lower-case-p-vector
	     (flet ((LOWER-CASE-P (char)
		      1"T if CHAR is a lower case letter with no meta bits."*
		      (AND (ZEROP (CHAR-BITS char))
			   (let ((char-code (char-code char)))
			     (or (<= #\a CHAR-CODE #\z)
				 (and (<= ISO-EXTENDED-LOWER-CASE-START	;check for ISO range PMH
					  CHAR-CODE
					  ISO-EXTENDED-LOWER-CASE-END)
				      (/= char-code iso-divide)))))))
	       (loop with vector = (make-array char-code-limit :element-type 'bit)
		     for i below char-code-limit
		     do (setf (aref vector i) (if (lower-case-p i) 1 0))
		     finally (return vector))))

(proclaim '(compiler:try-inline lower-case-p))
(Defun LOWER-CASE-P (char)
  1"T if CHAR is a lower case letter with no meta bits."*
  (AND (ZEROP (CHAR-BITS char))
       (plusp (aref lower-case-p-vector (char-code char)))))

(defparameter both-case-p-vector
	     (flet ((BOTH-CASE-P (char)
		      1"T if CHAR is a character which has upper and lower case forms, with no meta bits."*
		      (AND (ZEROP (CHAR-BITS char))
			   (let ((char-code (char-code char)))
			     (or (<= #\a (LOGIOR #x20 CHAR-CODE) #\z)
				 (and (<= iso-extended-upper-case-start	;check for ISO range PMH
					  (logandc1 #x20 char-code)
					  iso-extended-upper-case-end )
				      (/= char-code iso-multiply iso-divide)))))))
	       (loop with vector = (make-array char-code-limit :element-type 'bit)
		     for i below char-code-limit
		     do (setf (aref vector i) (if (both-case-p i) 1 0))
		     finally (return vector))))

(proclaim '(compiler:try-inline both-case-p))
(Defun BOTH-CASE-P (char)
  1"T if CHAR is a character which has upper and lower case forms, with no meta bits."*
  (AND (ZEROP (CHAR-BITS char))
       (plusp (aref both-case-p-vector (char-code char)))))

(defparameter alphanumeric-p-vector
	     (flet ((ALPHANUMERICP (char)
		      1"T if CHAR is a letter or digit, with no meta bits."*
		      (AND (ZEROP (CHAR-BITS char))
			   (let ((char-code (char-code char)))
			     (OR (<= #\0 CHAR-CODE #\9)
				 (<= #\a (LOGIOR #x20 CHAR-CODE) #\z)
				 (and (<= #xC0 CHAR-CODE #xFF)	;check for ISO range PMH
				      (/= iso-multiply iso-divide (CHAR-CODE char))))))))
	       (loop with vector = (make-array char-code-limit :element-type 'bit)
		     for i below char-code-limit
		     do (setf (aref vector i) (if (alphanumericp i) 1 0))
		     finally (return vector))))

(proclaim '(compiler:try-inline alphanumericp))
(Defun ALPHANUMERICP (char)
  1"T if CHAR is a letter or digit, with no meta bits."*
  (AND (ZEROP (CHAR-BITS char))
       (plusp (aref alphanumeric-p-vector (char-code char)))))

;;(proclaim '(compiler:try-inline))
(Defun DIGIT-CHAR-P (char &optional (radix 10.))
  1"Weight of CHAR as a digit, if it is a digit in radix RADIX; else NIL.
The weights of #\0 through #\9 are 0 through 9;
the weights of letters start at ten for A.
RADIX does not affect the weight of any digit,
but it affects whether NIL is returned."*
  (DECLARE (inline char-upcase))
  (AND (ZEROP (CHAR-BITS char))
       (LET ((basic (CHAR-UPCASE (CHAR-CODE char))))
	 (AND (COND ((= radix 10.) (<= #\0 basic #\9))
		    ((< radix 10.) (<= #\0 basic (+ #\0 radix -1)))
		    (t
		     (OR (<= #\0 basic #\9)
			 (<= #\A  basic (+ #\A radix -11.)))))
	      (IF (<= basic #\9) (- basic #\0) (+ 10. (- basic #\A)))))))

1;;;;;;;;;;; 
;; making character objects*

;;AB 6/24/87.  Change CODE-CHAR to use the keypad bit from BITS unless the optional
;;             KEYPAD arg is supplied.  Also made it a DEFUN instead of a DEFSUBST.
;;             with a TRY-INLINE.
(proclaim '(compiler:try-inline code-char))
(DEFUN CODE-CHAR (code &optional (bits 0) (font 0) keypad)
  1"Returns a character whose code comes from CODE, bits from BITS and font from FONT.
CODE can be a number or a character.
KEYPAD, if supplied, should be 1 for a keypad character, 0 otherwise.  
This will override* 1the keypad bit supplied in BITS.
NIL is returned if it is not possible to have a character object
with the specified FONT and BITS."*
  (AND (<= 0 bits (1- CHAR-BITS-LIMIT))
       (<= 0 font (1- CHAR-FONT-LIMIT))
       (<= 0 code (1- CHAR-CODE-LIMIT))
       (IF keypad
	   (AND (<= 0 keypad 1)
		(INT-CHAR (%logdpb keypad %%kbd-keypad
				   (%LOGDPB bits %%kbd-all-control-bits
					    (DPB font %%ch-font code)))))
	   (INT-CHAR (%LOGDPB bits %%kbd-all-control-bits
			      (DPB font %%ch-font code))))))

(Defconstant *MAX-MOUSE-CLICKS* (EXPT 2 (LDB #o0004 %%kbd-mouse-n-clicks))  ;; a fancy way of expressing 8.
  1"Maxinum number of mouse clicks."*)

(Defsubst CODE-MOUSE-CHAR (button &optional (bits 0) (clicks 1))
  1"Returns a character whose code comes from <button>, bits from <bits> and clicks from <clicks>.
<button> can be a number 0,  1, or  2 
           or a Keyword :L, :M, or :R.
<bits> is the bits attribute - (hyper,super,meta,control) must be 0-15
<clicks> is the number of times the button was clicked 
NIL is returned if it is not possible to have a character object
with the specified FONT and BITS."*
  (let ((but
	  (CASE button 
		((:L 0) 0)
		((:M 1) 1)
		((:R 2) 2)
		(t nil))))
    (WHEN (AND but
	       (<= 0 bits (1- CHAR-BITS-LIMIT))
	       (<= 1 clicks *max-mouse-clicks*))
      (INT-CHAR
	(%LOGDPB bits %%kbd-control-meta
		 (DPB (1- clicks) %%kbd-mouse-n-clicks 
		      (DPB 1 %%kbd-mouse but)))))))

(proclaim '(compiler:inline make-char))
(Defun MAKE-CHAR (char &optional (bits 0) (font 0))
  1"Returns a character with the same character code as CHAR,
but with the BITS and FONT fields as specified."*
  (DECLARE (inline code-char))
  (CODE-CHAR (char-code char) bits font))

1;;;;;;;;;;;
;; case-conversion*

(defparameter char-upcase-vector
	     (loop with vector = (make-array char-code-limit :element-type 'bit)
		   for char below char-code-limit
		   do (setf (aref vector char) (if (and (both-case-p char)(lower-case-p char)) 1 0))
		   finally (return vector)))

(proclaim '(compiler:try-inline char-upcase))
(Defun CHAR-UPCASE (char) 
  1"If CHAR is a lowercase alphabetic character , then an 
  upper case version with the same font attributes is
  returned.  Otherwise, CHAR is returned. Note: the 
  bits-field of the character must be zero."*
  (IF (AND (ZEROP (CHAR-BITS char))
	   (plusp (aref char-upcase-vector (char-code char))))
      (INT-CHAR (LOGXOR #x20 char))
      char))

(defparameter char-downcase-vector
	     (loop with vector = (make-array char-code-limit :element-type 'bit)
		   for char below char-code-limit
		   do (setf (aref vector char) (if (and (both-case-p char)(upper-case-p char)) 1 0))
		   finally (return vector)))

(proclaim '(compiler:try-inline char-downcase))
(Defun CHAR-DOWNCASE (char)
  1"If CHAR is a uppercase alphabetic character,then a lower
  case version with the same font attributes is returned.
  Otherwise CHAR is returned.Note: the bits-field of the 
 character must be zero."*
  
  (IF (AND (ZEROP (CHAR-BITS char))
	   (plusp (aref char-downcase-vector (char-code char))))
      (INT-CHAR (LOGIOR #x20 char))
      char))