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.
;Common Lisp character functions and variables.*

;;;
;;; 1Change history:*
;;;
;;;  1Date      Author*	1Description*
;;; 1-------------------------------------------------------------------------------------
;;;  06/24/87  AB*	1Declare CODE-CHAR INLINE for DIGIT-CHAR.*
;1;;  11/24/86  LGO*	1Declare INLINE those functions with no compiler optimization*
;1;;  11/20/86  HW*	1Modify functions to allow for ISO characters. *
;1;;  10/07/86  TWE*	1Changed  SET-CHAR-BIT and CHAR-BIT to understand the keypad bit.  Also*
;1;;*			1updated their documentation strings to tell about the mouse bit.

;;;;;;;;;;;;;;
;; coercion to a character object*

(DEFUN CHARACTER (x)
  1"Convert X to a character if possible."*
  (declare (inline character))
  (COND
    ((CHARACTERP x) x)
    ((NUMBERP x) (INT-CHAR x))
    ((AND (STRINGP x) (= (LENGTH x) 1)) (INT-CHAR (AREF x 0)))
    ((AND (SYMBOLP x) (= (LENGTH (SYMBOL-NAME x)) 1)) (INT-CHAR (AREF (SYMBOL-NAME x) 0)))
    (t (FERROR () "Cannot coerce ~S into a character" x))))


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


(DEFUN STANDARD-CHAR-P (char)
  1"T if CHAR is one of the ASCII printing characters or the Return character."*
  (declare (inline STANDARD-CHAR-P))
  (OR (= char #\return)
      (<= #\space char #o176)))


1;;;;;;;;;;;
;; comparing characters -- case-sensitive char<symbol>
;;                         case-insensitive char-<name>*

(DEFSUBST CHAR= (char &REST chars)
  1"Returns T if all the characters are equal, considering bits,font and case."*

  (DO ((rest chars (CDR rest)))
      ((ATOM rest) t)
    (OR (= char (CAR rest)) (RETURN nil))))

(DEFUN CHAR-EQUAL (char &REST characters)
  1"Returns T if all the characters are equal, ignoring bits,font and case."*
  (LET ((ch (CHAR-CODE (char-upcase char))))	;simplified for iso characters PMH
    (DO ((tail characters (CDR tail))
	 ch1)
	((ATOM tail) t)
      (SETQ ch1 (CHAR-CODE (char-upcase (CAR tail))))
      (OR (= ch ch1) (RETURN-FROM CHAR-EQUAL nil)))))

(DEFUN CHAR< (char &rest chars)
 1"T if all the characters are monotonically increasing, considering bits,fonts and case."*
 (DO ((i char k)
      (rest chars (CDR rest))
      (k))
     ((ATOM rest) t)
   (SETQ k (CAR rest))
   (OR (< i k) (RETURN nil))))

(DEFUN CHAR-GREATERP (CHAR &rest chars)
  1"T if all the characters are monotonically decreasing, ignoring bits, font and case."*
;;Modified 9/15/86 by HW to support ISO characters
  (declare (inline char-greaterp))
  (LET ((ch (CHAR-CODE (CHAR-UPCASE char))))
    (DO ((tail chars (CDR tail))
	 ch1)
	((ATOM tail) t)
      (SETF ch1 (CHAR-CODE (CHAR-UPCASE (CAR tail))))
      (IF (> ch ch1)
	  (SETF ch ch1)
	  (RETURN-FROM char-greaterp nil)))))

1;; certainly a better name than ,say CHAR-INCREASING*
(DEFUN CHAR-LESSP (char &REST chars)
  1"T if all the characters are monotonically increasing, ignoring bits, font and case."*
;;Modified 9/15/86 by HW to support ISO characters
  (declare (inline char-lessp char-upcase))
  (LET ((ch (CHAR-CODE (CHAR-UPCASE char))))
    (DO ((tail chars (CDR tail))
	 ch1)
	((ATOM tail) t)
      (SETF ch1 (CHAR-CODE (CHAR-UPCASE (CAR tail))))
      (IF (< ch ch1)
	  (SETF ch ch1)
	  (RETURN-FROM char-lessp nil)))))

(DEFUN CHAR> (char &REST chars)
 1"T if all the characters are monotonically decreasing, considering bits,fonts and case."*
 (DO ((i char k)
      (rest chars (CDR rest))
      (k))
     ((ATOM rest) t)
   (SETQ k (CAR rest))
   (OR (> i k) (RETURN nil))))

(DEFUN CHAR<= (char &REST chars)
 1"T if all the characters are monotonically nondecreasing, considering bits,fonts and case."*
 (DO ((i char k)
      (rest chars (CDR rest))
      (k))
     ((ATOM rest) t)
   (SETQ k (CAR rest))
   (OR (<= i k) (RETURN nil))))

(DEFF ZLC:CHAR #'CHAR<=)

(DEFUN CHAR-NOT-GREATERP (char &rest chars)
  1"T if all the characters are monotonically nondecreasing, ignoring bits, font and case."*
;;Modified 9/15/86 by HW to support ISO characters
  (declare (inline char-not-greaterp))
  (LET ((ch (CHAR-CODE (CHAR-UPCASE char))))
    (DO ((tail chars (CDR tail))
	 ch1)
	((ATOM tail) t)
      (SETF ch1 (CHAR-CODE (CHAR-UPCASE (CAR tail))))
      (IF (<= ch ch1)
	  (SETF ch ch1)
	  (RETURN-FROM char-not-greaterp nil)))))

(DEFUN CHAR>= (char &REST chars)
 1"T if all the characters are monotonically nonincreasing, considering bits,fonts and case."*
 (DO ((i char k)
      (rest chars (CDR rest))
      (k))
     ((ATOM rest) t)
   (SETQ k (CAR rest))
   (OR (>= i k) (RETURN nil))))

(DEFF ZLC:CHAR #'CHAR>=)

(DEFUN CHAR-NOT-LESSP (char &REST chars)
  1"T if all the characters are monotonically nonincreasing, ignoring bits, font and case."*
;;Modified 9/15/86 by HW to support ISO characters
  (declare (inline char-not-lessp))
  (LET ((ch (CHAR-CODE (char-UPCASE char))))
    (DO ((tail chars (CDR tail))
	 ch1)
	((ATOM tail) t)
      (SETF ch1 (CHAR-CODE (CHAR-UPCASE (CAR tail))))
      (IF (>= ch ch1)
	  (SETF ch ch1)
	  (RETURN-FROM char-not-lessp nil)))))

(DEFSUBST CHAR/= (&REST chars)
  1"T if all the characters are distinct (no two equal), considering bits, font and case."*
  (APPLY '/= chars))

(DEFF ZLC:CHAR #'CHAR/=)

(DEFUN CHAR-NOT-EQUAL (&rest chars)
  1"T if all the characters are distinct, ignoring bits, font and case."*

    (DO ((tail chars (CDR tail)))
	((ATOM (CDR tail)) t)
      (LET ((char1 (CAR tail)))
	(DOLIST (char2 (CDR tail))
	  (IF (CHAR-EQUAL char1 char2)
	      (RETURN-FROM char-not-equal nil))))))

1;;;;;;;;;;;
;;  character names*

(DEFUN CHAR-NAME (char)
  1"Returns the standard name of CHAR, as a string; or NIL if there is none.
For example, \"NEWLINE\" for the character NEWLINE."*
  (CASE char
	(#\newline "NEWLINE")
	(#\page "PAGE")
	(#\BACKSPACE "BACKSPACE")
	(t (LET ((elt (RASSOC (CHAR-INT char) xr-special-character-names :TEST #'EQ)))
	     (IF elt (SYMBOL-NAME (CAR elt)))))))

(DEFUN NAME-CHAR (name)
  1"Returns the meaning of NAME as a character name, or NIL if it has none."*
  (LET ((found (CDR (ASSOC  name xr-special-character-names :TEST #'STRING-EQUAL))))
    (AND found (INT-CHAR found))))

1;; NOTE: the following is required in the cold load where it is needed for printing character objects*
(DEFUN OCHAR-GET-CHARACTER-NAME (char)
  (declare (special tv:NonP))
  (UNLESS (AND (GRAPHIC-CHAR-P char)
	       (/= char #\sp)
	       (/= char #\altmode)
	       (or (not (si:addin-p))
		   (not (boundp 'tv:*explorer-to-mac-char-code-map*))
		   (not (eql (aref tv:*explorer-to-mac-char-code-map*
				    (char-int char))
			     tv:NonP))))
    (CHAR-NAME char)))

1;;;;;;;;;;;;;;
;;  control bit functions*

;;2/9/87 Fixed backquotes to quotes.
(DEFSUBST CHAR-BIT (char bit-name)
  1"T if the bit spec'd by BIT-NAME (a keyword) is on in CHAR.
BIT-NAME can be :CONTROL, :META, :SUPER, :HYPER, :KEYPAD or :MOUSE."*
  (%LOGLDB-TEST (CDR (ASSOC bit-name
			    '((:control . #.%%kbd-control)
			      (:meta    . #.%%kbd-meta)
			      (:super   . #.%%kbd-super)
			      (:hyper   . #.%%kbd-hyper)
			      (:keypad  . #.%%kbd-keypad)
			      (:mouse   . #.%%kbd-mouse))
			    :TEST #'EQ))
		char))

;;;PHD 4/3/87 Fixed (setf (char-bit ch bit) value) SPR4196
(defmacro setf-char-bit (place bit-name value)
  (let ((vl (gensym)))
    (if (symbolp (parse-the-in-place place))
	;; Special case this to speed up the expansion process and make better code.
	(once-only (value)
	  `(prog1 ,value
		  (setq ,(parse-the-in-place place) (set-char-bit ,place ,bit-name ,value))))
	(multiple-value-bind (tempvars tempargs storevars storeform refform)
	    (get-setf-method place)
	  (sublis-eval-once (cons `(,vl . ,value) (pairlis tempvars tempargs))
			    (sublis-eval-once (list (cons (car storevars)
							  `(set-char-bit ,refform ,bit-name ,vl)))
					      `(prog1 ,vl ,storeform))
			    t t)))))

(defsetf char-bit setf-char-bit)

;;2/9/87 Fixed backquotes to quotes.
(DEFUN SET-CHAR-BIT (char bit-name new-value)
  1"Returns a character like CHAR except that the bit BIT-NAME has value NEW-VALUE in it.
BIT-NAME can be :CONTROL, :META, :SUPER, :HYPER, :KEYPAD or :MOUSE.
NEW-VALUE should be T or NIL."*
  (LET* ((new-char (%LOGDPB (IF new-value 1 0)
			    (CDR (ASSOC bit-name
					'((:control . #.%%kbd-control)
					  (:meta    . #.%%kbd-meta)
					  (:super   . #.%%kbd-super)
					  (:hyper   . #.%%kbd-hyper)
					  (:keypad  . #.%%kbd-keypad)
					  (:mouse   . #.%%kbd-mouse))
					:TEST #'EQ))
			    char)))
    (IF (TYPEP char 'character)
	(INT-CHAR new-char)
      new-char)))

;;AB 6/24/87.  DECLARE code-char INLINE here.
(DEFUN DIGIT-CHAR (weight &optional (radix 10.) (font 0))
  1"Return a character which signifies WEIGHT in radix RADIX, with FONT as specified.
This is always NIL if WEIGHT is  RADIX.
Otherwise, for WEIGHT between 0 and 9, you get characters 0 through 9;
for higher weights, you get digits."*
  (DECLARE (inline code-char))
  (IF (>= weight radix) nil	;Could the user ever have trouble checking this himself?
    (CODE-CHAR (IF (< weight 10.)
		   (+ #\0 weight)
		 (+ #\A weight -10.))
	       0 font)))