;;; -*- Mode:LISP; Package:USER; Base:10 -*-
;;; $Header: /ct/ctlisp/ctstrl.l,v 1.5 84/02/10 11:03:34 bill Exp $
;;; $Log:	/ct/ctlisp/ctstrl.l,v $
;;;Revision 1.5  84/02/10  11:03:34  bill
;;;Fixed ct_string_article and ct_string_words to accept the null string.
;;;Fixed ct_character to detect the null string on Franz.
;;;
;;;Revision 1.4  83/11/22  17:31:20  bill
;;;Removed cons'ing involved in uses of substringn to get a single character.
;;;
;;;Revision 1.3  83/10/21  15:08:21  bill
;;;Fixed ct_nthchar to understand null strings better. Touched up ct_character.
;;;
;;;Revision 1.2  83/10/18  10:37:17  bill
;;;Changed the loading of the c code to be done with an interface file. Cleaned
;;;up ct_character and ct_nthchar.
;;;
;;;Revision 1.1  83/10/06  10:46:25  bill
;;;Initial revision
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                            ctstrl.l 			     ;;;
;;;                                                                  ;;;
;;; William Brew                                          9-15-83    ;;;
;;;                                                                  ;;;
;;; Compatable string package for ct lisp dialects. The string	     ;;;
;;; functions are based very closely on the LM-2 string functions.   ;;;
;;; The reader is refered to the LM-2 manual for details of the	     ;;;
;;; use of the functions.	       				     ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer Thought Corporation.      ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;                                                                  ;;;
;;;   The following code assumes familiarity with these materials.   ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(comment Assumes ct_load and some suitable file_map are present)

(eval-when (compile load eval) (ct_load 'aip))	   ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat))  ;Franz/LM compat pkg.

#+franz
(eval-when (load eval) (ct_load 'ctstrlc))         ;Lisp interface to c code

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))

#+franz
(defvar alphabetic_case_affects_string_comparison nil
    "Case flag for comparisons. Nil -> ignore case. T -> use case."
)

#+franz
(defconst *caseshift* (- #/a #/A)
    "The difference between a lower and upper case letter."
)

#+franz
(defconst *up_pattern* nil
    "A translate pattern for shifting to upper case (initialized later)."
)

#+franz
(defconst *down_pattern* nil
    "A translate pattern for shifting to lower case (initialized later)."
)

#+franz
(defconst *change_pattern* nil
    "A translate pattern for shifting to the other case (initialized later)."
)

(defconst *ms* 99999999
    "The maximum length strings."
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macro definitions --

; Case flag for the c functions

#+franz
(defmacro ccasef ()
    '(ct_if alphabetic_case_affects_string_comparison 1 0)
)

; Find the differance between two characters using the case flag.

#+franz
(defmacro chardiff (ch1 ch2 flag)
    `(ct_if ,flag
	 (- ,ch1 ,ch2)
	 (- ,ch1 (ct_char_samecase ,ch1 ,ch2))
     )
)

; Check if a character is lower case

#+franz
(defmacro char_lowerp (ch)
    `(and (< #/` ,ch) (< ,ch #/{))
)

#+lispm
(defmacro char_lowerp (ch)
    `(= ,ch (char-downcase ,ch))
)

; Check if a character is upper case

#+franz
(defmacro char_upperp (ch)
    `(and (< #/@ ,ch) (< ,ch #/[))
)

#+lispm
(defmacro char_upperp (ch)
    `(= ,ch (char-upcase ,ch))
)

; Check if a character is a vowel

(defmacro vowelp (ch)
    `(memq (ct_character ,ch) '(#/a #/e #/i #/o #/u #/y #/A #/E #/I #/O #/U #/Y))
)

; Return an index from a c function

#+franz
(defmacro return_index (form)
    `(let ((index ,form))
	 (ct_if (= index -1) nil index)
     )
)

; Get a fresh copy of a string. String coersion is applied.

#+franz
(defmacro fresh_string (thing)
    `(get_pname (uconcat (ct_string ,thing)))
)

#+lispm
(defmacro fresh_string (thing)
    `(string-append ,thing)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Flavor definitions --

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Callable Functions/Methods -- 

;;;;;;;;;;;;;; 
; Some basics
;;;;;;;;;;;;;; 

; 
; Make get pname work in both dialects with both an underscore and a hyphen
; 

#+franz
(eval-when (compile load eval) (putd 'get-pname (getd 'get_pname)))

#+lispm
(eval-when (compile load eval) (fset 'get_pname (fsymeval 'get-pname)))


;;;;;;;;;;;;; 
; Characters
;;;;;;;;;;;;; 


; 
; Check if a fixnum is a legal character
; 

#+franz
(defun ct_characterp (thing)
    (and (fixp thing) (< -1 thing) (< thing 128))
)

#+lispm
(defun ct_characterp (thing)
    (and (fixp thing) (< -1 thing) (< thing 256))
)

; 
; Coerce a thing to a single fixnum character
; 

#+franz
(defun ct_character (ch)
    (cond ((ct_characterp ch) ch)
	  ((symbolp ch) (substringn ch 1 0))
	  ((and (stringp ch) (substringn ch 1 0)))
	  (t (error ch "cannot be coerced to a character"))
    )
)

#+lispm-on-a-clear-day-you-can-see-forever-damnit
(eval-when (compile load eval) (fset 'ct_character (fsymeval 'character)))

#+Lispm
(defun ct_character (ch)
  (cond ((ct_characterp ch) ch)
	((symbolp ch) (aref (string ch) 0))
	((stringp ch) (aref ch 0))
	(t (ferror "Object cannot be coerced to a character: ~S" ch))))

; 
; Get the nth character of a string.
; 

#+franz
(defun ct_nthchar (string n)
    (substringn (ct_string string) (1+ n) 0)
)

#+lispm
(defun ct_nthchar (string n)
    (aref (string string) n)
)

; 
; Compare two characters for equality. Uses the case flag.
; 

#+franz
(defun ct_char_equal (ch1 ch2)
    (setq ch1 (ct_character ch1))
    (setq ch2 (ct_character ch2))
    (= (chardiff ch1 ch2 alphabetic_case_affects_string_comparison) 0)
)

#+lispm
(eval-when (compile load eval) (fset 'ct_char_equal (fsymeval 'char-equal)))

; 
; Compare two characters for less then. Uses the case flag.
; 

#+franz
(defun ct_char_lessp (ch1 ch2)
    (setq ch1 (ct_character ch1))
    (setq ch2 (ct_character ch2))
    (< (chardiff ch1 ch2 alphabetic_case_affects_string_comparison) 0)
)

#+lispm
(eval-when (compile load eval) (fset 'ct_char_lessp (fsymeval 'char-lessp)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
; Upper and lower case letters
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; 
; Convert a character to upper case.
; 

#+franz
(defun ct_char_upcase (ch)
    (setq ch (ct_character ch))
    (ct_if (char_lowerp ch)
	(- ch *caseshift*)
	ch
    )
)

#+lispm
(eval-when (compile load eval) (fset 'ct_char_upcase (fsymeval 'char-upcase)))

;
; Convert a character to lower case.
; 

#+franz
(defun ct_char_downcase (ch)
    (setq ch (ct_character ch))
    (ct_if (char_upperp ch)
	(+ ch *caseshift*)
	ch
    )
)

#+lispm
(eval-when (compile load eval) (fset 'ct_char_downcase (fsymeval 'char-downcase)))

; 
; Convert a character to the opposite case.
; 

(defun ct_char_changecase (ch)
    (setq ch (ct_character ch))
    (ct_if (char_lowerp ch)
	(ct_char_upcase ch)
	(ct_char_downcase ch)
    )
)

; 
; Convert ch2 to the same case as ch1.
; 

(defun ct_char_samecase (ch1 ch2)
    (setq ch1 (ct_character ch1))
    (cond ((char_lowerp ch1) (ct_char_downcase ch2))
	  ((char_upperp ch1) (ct_char_upcase ch2))
	  (t ch2)
    )
)

; 
; Convert a string to upper case via the string translate function. First
; we get a new string via substring.
; 

#+franz
(defun ct_string_upcase (string &optional (from 0) (to *ms*))
    (nstrtranslate (ct_substring string from to) *up_pattern* 0 *ms*)
)

#+lispm
(defun ct_string_upcase (string &optional (from 0) (to nil))
    (string-upcase (substring string from to))
)

; 
; Convert a string to lower case via the string translate function. First
; we get a new string via substring.
; 

#+franz
(defun ct_string_downcase (string &optional (from 0) (to *ms*))
    (nstrtranslate (ct_substring string from to) *down_pattern* 0 *ms*)
)

#+lispm
(defun ct_string_downcase (string &optional (from 0) (to nil))
    (string-downcase (substring string from to))
)
; 
; Convert a string to opposite case via the string translate function. First
; we get a new string via substring.
; 

#+franz
(defun ct_string_changecase (string &optional (from 0) (to *ms*))
    (nstrtranslate (ct_substring string from to) *change_pattern* 0 *ms*)
)

#+lispm
(defun ct_string_changecase (string &optional (from 0) (to nil))
    (ct_string_nchangecase (substring string from to))
)

; 
; Convert a string to the same case as ch. Substring it if necessary.
; 

(defun ct_string_samecase (ch string &optional (from 0)
			      (to #+franz *ms* #+lispm nil))
    (cond ((char_lowerp ch) (ct_string_downcase string from to))
	  ((char_upperp ch) (ct_string_upcase string from to))
	  (t (ct_substring string from to))
    )
)

; 
; Convert the string to upper case. Over write the affected portion of the string.
; 

#+franz
(defun ct_string_nupcase (string &optional (from 0) (to *ms*))
    (cond ((stringp string) (nstrtranslate string *up_pattern* from to))
	  ((ct_characterp string) (ct_char_upcase string))
	  (t (error string "cannot be up cased in place"))
    )
)

#+lispm
(defun ct_string_nupcase (string &optional (from 0) (to nil))
    (and (null to) (setq to *ms*))
    (cond ((stringp string)
	   (loop for i from from to (min to (1- (string-length string)))
	         do (aset (char-upcase (aref string i)) string i)
	   )
	   string
	  )
	  ((ct_characterp string) (string-upcase string))
	  (t (error "cannot string up case in place")
	  )
    )
)

; 
; Convert the string to lower case. Over write the affected portion of the string.
; 

#+franz
(defun ct_string_ndowncase (string &optional (from 0) (to *ms*))
    (cond ((stringp string) (nstrtranslate string *down_pattern* from to))
	  ((ct_characterp string) (ct_char_downcase string))
	  (t (error string "cannot be down cased in place"))
    )
)

#+lispm
(defun ct_string_ndowncase (string &optional (from 0) (to nil))
    (and (null to) (setq to *ms*))
    (cond ((stringp string)
	   (loop for i from from to (min to (1- (string-length string)))
	         do (aset (char-downcase (aref string i)) string i)
	   )
	   string
	  )
	  ((ct_characterp string) (string-downcase string))
	  (t (error "cannot string down case in place"))
    )
)

; 
; Convert the string to opposite case. Over write the affected portion of
; the string.
; 

#+franz
(defun ct_string_nchangecase (string &optional (from 0) (to *ms*))
    (cond ((stringp string) (nstrtranslate string *change_pattern* from to))
	  ((ct_characterp string) (ct_char_changecase string))
	  (t (error string "cannot be up cased in place"))
    )
)

#+lispm
(defun ct_string_nchangecase (string &optional (from 0) (to nil))
    (and (null to) (setq to *ms*))
    (cond ((stringp string)
	   (loop for i from from to (min to (1- (string-length string)))
	         do (aset (ct_char_changecase (aref string i)) string i)
	   )
	   string
	  )
	  ((ct_characterp string) (string (ct_char_changecase string)))
	  (t (error "cannot string change case in place"))
    )
)

; 
; Convert the string to the same case as ch. Overwrite the affected portion.
; 

(defun ct_string_nsamecase (ch string &optional (from 0)
			       (to #+franz *ms* #+lispm nil))
    (cond ((char_lowerp ch) (ct_string_ndowncase string from to))
	  ((char_upperp ch) (ct_string_nupcase string from to))
	  (t (ct_string string))
    )
)


;;;;;;;;;;;;;;;;;;;;;;;;;; 
; Basic string operations
;;;;;;;;;;;;;;;;;;;;;;;;;;


; 
; Define a ct version of stringp
; 

#+franz
(eval-when (compile load eval) (putd 'ct_stringp (getd 'stringp)))

#+lispm
(eval-when (compile load eval) (fset 'ct_stringp (fsymeval 'stringp)))

; 
; Coerce a thing to a string.
; 

#+franz
(defun ct_string (&optional (thing ""))
    (cond ((stringp thing) thing)
	  ((symbolp thing) (get_pname thing))
	  ((ct_characterp thing) (get_pname (ascii thing)))
	  (t (error thing "cannot be coerced to a string"))
    )
)

#+lispm
(eval-when (compile load eval) (fset 'ct_string (fsymeval 'string)))

; 
; Get the length of a string.
; 

#+franz
(defun ct_string_length (str)
    (flatc (ct_string str))
)

#+lispm
(eval-when (compile load eval) (fset 'ct_string_length (fsymeval 'string-length)))

; 
; Compare two strings for equality. Use the case flag. Substring if necessary.
; 

#+franz
(defun ct_string_equal (str1 str2 &optional (idx1 0) (idx2 0) (lim1 *ms*)
			   (lim2 *ms*))
    (= 0 (strdiff (ct_string str1) (ct_string str2) (fix idx1) (fix idx2)
	     (fix lim1) (fix lim2) (ccasef)
	 )
    )
)

#+lispm
(eval-when (compile load eval) (fset 'ct_string_equal (fsymeval 'string-equal)))

; 
; Compare two strings for less than. Use the case flag. Substring if necessary.
; 

#+franz
(defun ct_string_lessp (str1 str2 &optional (idx1 0) (idx2 0) (lim1 *ms*)
			   (lim2 *ms*))
    (> 0 (strdiff (ct_string str1) (ct_string str2) (fix idx1) (fix idx2)
	     (fix lim1) (fix lim2) (ccasef)
	 )
    )
)

#+lispm
(defun ct_string_lessp (str1 str2 &optional (idx1 0) (idx2 0) (lim1 nil)
			   (lim2 nil))
    (string-lessp (substring str1 idx1 lim1) (substring str2 idx2 lim2))
)

; 
; Get the portion of the string from from up to but not including to.
; Return the null string if out of range.
; 

#+franz
(defun ct_substring (string from &optional (to *ms*))
    (cond ((substring (ct_string string) (1+ from) (- to from)))
	  (t "")
    )
)

#+lispm
(eval-when (compile load eval) (fset 'ct_substring (fsymeval 'substring)))

; 
; Append a bunch of string coercable things into one big string.
; 

#+franz
(defun ct_string_append (&rest args)
    (get_pname (apply 'uconcat (mapcar 'ct_string args)))
)

#+lispm
(eval-when (compile load eval) (fset 'ct_string_append (fsymeval 'string-append)))

; 
; Trim the characters in char_set from both ends of string. Return a new
; substring.
; 

#+franz
(defun ct_string_trim (char_set string &optional (from 0) (to *ms*))
    (ct_string_right_trim char_set (ct_string_left_trim char_set string from to))
)

#+lispm
(defun ct_string_trim (char_set string &optional (from 0) (to nil))
    (string-trim char_set (substring string from to))
)

; 
; Trim the characters in char_set from the left end of string. Return a new 
; substring.
; 

#+franz
(defun ct_string_left_trim (char_set string &optional (from 0) (to *ms*))
    (setq string (ct_string string))
    (let ((index (ct_string_search_not_set char_set string from to)))
	(ct_if index
	    (substring string (1+ index) (- to index))
	    ""
	)
    )
)

#+lispm
(defun ct_string_left_trim (char_set string &optional (from 0) (to nil))
    (string-left-trim char_set (substring string from to))
)

; 
; Trim the characters in char_set from the right end of string. Return a 
; new substring. (note the reversed nature of from and to)
; 

#+franz
(defun ct_string_right_trim (char_set string &optional (from *ms*) (to 0))
    (setq string (ct_string string))
    (let ((index (ct_string_reverse_search_not_set char_set string from to)))
	(ct_if index
	    (substring string (1+ to)  (- index to -1))
	    ""
	)
    )
)

#+lispm
(defun ct_string_right_trim (char_set string &optional (from nil) (to 0))
    (string-right-trim char_set (substring string to from))
)

; 
; Return a new string which is the reverse of string.
; 

#+franz
(defun ct_string_reverse (string &optional (from 0) (to *ms*))
    (nstrreverse (fresh_string string) (fix from) (fix to))
)

#+lispm
(defun ct_string_reverse (string &optional (from 0) (to nil))
    (string-reverse (substring string from to))
)

; 
; Reverse a string in place.
; 

#+franz
(defun ct_string_nreverse (string &optional (from 0) (to *ms*))
    (cond ((stringp string) (nstrreverse string (fix from) (fix to)))
	  ((ct_characterp string) string)
	  (t (error string "cannot be reversed in place"))
    )
)

; --NB note, this does not limit the range of the reversal as does the franz
; version

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_nreverse (fsymeval 'string-nreverse))
)

; 
; Return a new string which is the pluaral of string.
; 

#+franz
(defun ct_string_pluralize (string)
    (setq string (ct_string string))
    (and (equal string "") (error "the null string cannot be pluralized"))
    (let* (flush add
	   (old_case_flag alphabetic_case_affects_string_comparison)
	   (last_char_raw (substringn string -1 0))
	   (last_char (ct_char_upcase last_char_raw))
	   (penult_char (and (> (ct_string_length string) 1)
			     (ct_char_upcase (substringn string -2 0))
			)
	   )
	   (last_3 (substring string -3 3))
	  )
	(unwind-protect
	    (progn
		(setq alphabetic_case_affects_string_comparison nil)
		(cond ((and (= last_char #/Y)
		            (not (memq penult_char '(#/A #/E #/I #/O #/U))))
		       (setq flush 1 add "ies"))
		    ((or (ct_string_equal string "ox")
		         (ct_string_equal string "vax")
		     )
		     (setq add "en"))
		    ((or (and (= last_char #/H) (memq penult_char '(#/C #/S)))
		         (memq last_char '(#/S #/Z #/X)))
	             (setq add "es"))
		    ((ct_string_equal last_3 "man")
                     (setq flush 2 add "en"))
		    ((ct_string_equal last_3 "ife")
	             (setq flush 2 add "ves"))
		    (t (setq add "s")))
		(and flush
		     (setq string
			 (substring string 1 (- (ct_string_length string) flush))
		     )
		)
		(ct_string_append string (ct_string_samecase last_char_raw add))
	    )
	    (setq alphabetic_case_affects_string_comparison old_case_flag)
	)
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_pluralize (fsymeval 'string-pluralize))
)

; 
; Return the article which is appropriate for putting in front of string. Special
; case for the null string.
; 

(defun ct_string_article (string)
    (cond ((equal string "") "")
	  ((vowelp string) "an")
	  (t "a")
    )
)

; 
; Return a new string like string but with the first letter upper case.
; 

(defun ct_string_capitalize (string)
    (ct_string_nupcase (fresh_string string) 0 1)
)

; 
; Put a bunch of words together into a string. Do the right thing with
; punctuation and spacing.
; 

(defun ct_string_words (&rest word_list)
    (apply 'ct_string_append (loop with squoted = nil
			           with dquoted = nil
				   for word in word_list
				   for wordstr = (ct_string word)
				   for this = (sp_type wordstr squoted dquoted)
				   and last = 'noafter then this
				   unless (or (eq this 'nobefore)
					      (eq this 'never)
					      (eq last 'noafter)
					      (eq last 'never)
					  )
				   collect " "
				   collect wordstr
			     )
    )
)


;;;;;;;;;;;;;;;;;;; 
; String searching
;;;;;;;;;;;;;;;;;;;


; 
; Return the index of the first occurence of char in string. Use the case flag.
; 

#+franz
(defun ct_string_search_char (char string &optional (from 0) (to *ms*))
    (return_index (charindexf (ct_character char) (ct_string string) (fix from)
		      (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_search_char (fsymeval 'string-search-char))
)

; 
; Return the index of the first non occurence of char in string. Use the caseflag.
; 

#+franz
(defun ct_string_search_not_char (char string &optional (from 0) (to *ms*))
    (return_index (charindexfn (ct_character char) (ct_string string) (fix from)
		      (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_search_not_char (fsymeval 'string-search-not-char))
)

; 
; Return the index of the first occurence of the key in string. Use the case
; flag.
; 

#+franz
(defun ct_string_search (key string &optional (from 0) (to *ms*))
    (return_index (strindexf (ct_string key) (ct_string string) (fix from) (fix to)
		      (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_search (fsymeval 'string-search))
)

; 
; Return the first occurence of any char in char set in the string string. Use the
; case flag.
; 

#+franz
(defun ct_string_search_set (char_set string &optional (from 0) (to *ms*))
    (and (listp char_set) (setq char_set (maknam (mapcar 'ct_character char_set))))
    (return_index (charsetindexf (ct_string char_set) (ct_string string) (fix from)
		      (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_search_set (fsymeval 'string-search-set))
)

; 
; Return the index of the first occurence of any character not in char set 
; in the string string. Use the case flag.
; 

#+franz
(defun ct_string_search_not_set (char_set string &optional (from 0) (to *ms*))
    (and (listp char_set) (setq char_set (maknam (mapcar 'ct_character char_set))))
    (return_index (charsetindexfn (ct_string char_set) (ct_string string)
		      (fix from) (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_search_not_set (fsymeval 'string-search-not-set))
)

; 
; Return the index of the last occurence of char in string. Use the case flag.
; Note the reversed nature of from and to.
; 

#+franz
(defun ct_string_reverse_search_char (char string &optional (from *ms*) (to 0))
    (return_index (charindexr (ct_character char) (ct_string string) (fix from)
		      (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_reverse_search_char
	         (fsymeval 'string-reverse-search-char)
	   )
)

; 
; Return the last non occurence of char in string. Use the case flag.
; Note the reversed nature of from and to.

#+franz
(defun ct_string_reverse_search_not_char (char string &optional (from *ms*) (to 0))
    (return_index (charindexrn (ct_character char) (ct_string string) (fix from)
		      (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_reverse_search_not_char
	         (fsymeval 'string-reverse-search-not-char)
	   )
)

; 
; Return the last occurence of key in string. Use the caseflag. Note the
; reversed nature of from and to.
; 

#+franz
(defun ct_string_reverse_search (key string &optional (from *ms*) (to 0))
    (return_index (strindexr (ct_string key) (ct_string string) (fix from) (fix to)
		      (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_reverse_search (fsymeval 'string-reverse-search))
)

; 
; Return the last occurence of any char in char set in string. Use the case flag.
; Note the reversed nature of from and to.
; 

#+franz
(defun ct_string_reverse_search_set (char_set string &optional (from *ms*) (to 0))
    (and (listp char_set) (setq char_set (maknam (mapcar 'ct_character char_set))))
    (return_index (charsetindexr (ct_string char_set) (ct_string string) (fix from)
		      (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_reverse_search_set
	         (fsymeval 'string-reverse-search-set)
	   )
)

; 
; Return the last occurence of any char not in char set in string. Use the case
; flag. Note the reversed nature of from and to.
; 

#+franz
(defun ct_string_reverse_search_not_set (char_set string &optional (from *ms*)
					    (to 0))
    (and (listp char_set) (setq char_set (maknam (mapcar 'ct_character char_set))))
    (return_index (charsetindexrn (ct_string char_set) (ct_string string)
		      (fix from) (fix to) (ccasef)
		  )
    )
)

#+lispm
(eval-when (compile load eval)
           (fset 'ct_string_reverse_search_not_set
	         (fsymeval 'string-reverse-search-not-set)
	   )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Methods -- 

; Put these here because they use the char_??? functions.

#+franz
(setq *up_pattern*
    (get_pname (maknam (cons 1 (loop for i from 1 to 127
				     collect (ct_char_upcase i)
			       )
		       )
	       )
    )
)
#+franz
(setq *down_pattern*
    (get_pname (maknam (cons 1 (loop for i from 1 to 127
				     collect (ct_char_downcase i)
			       )
		       )
	       )
    )
)
#+franz
(setq *change_pattern*
    (get_pname (maknam (cons 1 (loop for i from 1 to 127
				     collect (ct_char_changecase i)
			       )
		       )
	       )
    )
)

; Look for the type of spacing which is appropriate for a character. sq and
; dq are single and double quote counters respectively. (binary counters)

(defun sp_type (chstr sq dq)
    (setq chstr (and (not (equal chstr "")) (ct_character chstr)))
    (cond ((null chstr) 'never)
	  ((memq chstr '(#/. #/, #/; #/: #/? #/! #/% #/) #/] #/})) 'nobefore)
          ((memq chstr '(#/( #/[ #/{ #/$ #/` #/#)) 'noafter)
          ((= chstr #/_) 'never)
	  ((= chstr #/')
	   (setq sq (not sq))
	   (ct_if sq 'noafter 'nobefore)
	  )
	  ((= chstr #/")
	   (setq dq (not dq))
	   (ct_if dq 'noafter 'nobefore)
          )
    )
)

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;