su.lsp
 Version 1.00
 Date 31 October 2004
 Authors:
 Steven Jones

 Contact jones57@swbell.net include the word "nyquist" in subject line

 The contents of this file are released under the terms of the GNU General
 Public License. See the file LICENSE.txt
>
 Implements a subset of the Python string module in XLISP.  Most of the
 standard python string functions are implemented with near identical
 behavior. The match between the python standard is not 100%. Besides the
 obvious difference between LISP and Python any other differences are noted
 in the embedded documentation.  A few additional functions have also been
 defined.
 
 Python string functions which have not been implemented.
 index
 rindex
 maketrans
 swapcase
 translate
 replace

function

 (->string n)
 Convert object to string

 n      - any
 return - string

function

 (su:expandtabs |tabsize|)
 Replace tab characters in string with spaces.

 str     - string. The string to be expanded
 tabsize - integer. Size of tab, default: 8
 return  - string.

function

 (su:reverse  str)
 Reverse characters of string

 str    - string. The string to be reversed
 return - string.

function

 (su:find  str sub [:start s][:end e])
 Locate index of substring within string.

 str    - string. The string to be searched.
 sub    - string. The sub-string to search for.
 :start - integer. The starting index of the search. default: 0
 :end   - integer. The ending search index. default: Length of str.
 return - integer. The index of the first occurrence of sub in str which is
          greater than start and less than end. If there is no such match 
          return NIL.

 NOTE:  Differences between this function and the python
 equivalent:
 1) The python version accepts negative indexing for start and stop.
 2) The python version returns -1 for a non-match.

function

 (su:find-any  str  sublst [:start s][:end e])
 Find occurrence of any string in sublst in string.
 This is similar to find but accepts a list of target strings instead of a
 single sub-string. If any string in the target list is located its
 position is returned.

 str    - string. The string to search.
 sublst - list of strings.   A list of sub-strings to search in str.
 :start - integer. Starting index of search.
 :end   - integer. Ending index of search.
 return - integer.  The index of the first element in sublst which is located
          in str. The result is greater than start and less than end. 
          If no match is found the result is NIL.

function

 (su:rfind  str sub [:start s][:end e])
 Search for substring starting from right side of string.
 su:rfind has the same argument set as find and the same python/lisp difference
 apply.  See su:find.

function

 (su:count  str sub [:start s][:end e])
 Return number of non-overlapping copies of substring in string.
 str    - string. The string to be searched.
 sub    - string. The search string to be counted.
 :start - integer. The starting index of search.
 :end   - integer. The ending index of the search.
 return - integer  .
 NOTE: Python version accepts negative indexes.

function

 (su:lower str)
 Convert string to lower case. Exactly equivalent to string-downcase.

 str    - string.
 return - string. 

function

 (su:left-trim-all  str [chrs])
 Remove all left most characters of string which are also characters in chrs
 str    - string. The string to be trimmed.
 chrs   - string. Characters to be removed. default: su:*whitespace*
 return - string. 

function

 (su:find-first-non-matching-char  str  [chrs])
 Locate index of the left-most character of str which is not also
 a character of chrs. Hows that for clarity?
 
 str    - string. The string to be searched.
 chrs   - string. The characters search for.
 return - integer. The index of the first character in str which is not also
          a character in chrs. If all characters of str are also characters 
          of chrs return NIL.

function

 (su:string-to-char-list  str)
 Convert string to list of single character strings.

 str    - string. The string to be converted.
 return - list. 

function

 (su:split-first  str  [chars])
 Split string at first "word"
 A word is defined as any continuous sequence of characters which are not in
 the string chars. The default is to delineate words by whitespace.

 str    - string. The string to be split.

 chars  - string. Characters to be used as deliminators.
          default su:*whitespace*

 return - list. The result is a list, the car which is the first word
          (trimmed of leading and trailing deliminators) in str.  If 
          there are more than on word in the original string the cdr 
          of the result is a string containing the original text without 
          the first word.

function

 (su:split  str [chars])
 Convert string into list of words. A word is any continuous sequence of
 characters not containing a deliminator. By default words are separated by
 any white character.

 str    - string. The string to be split.

 chars  - string. The delineation characters.

 return - list
 
 NOTE: There are several difference between the XLISP and Python version of
 split:
 1) In XLISP version the deliminators are only 1 character. The Python
 version allows for arbitrary string 
 2) The XLISP version allows for multiple deliminators.
 3) The python version takes an optional maxsplit argument.

function

 (su:join lst [sep])
 Concatenate list elements to string.

 lst    - list. 
 sep    - string. The string to be inserted between adjacent elements of lst
 return - string 

function

 (su:lstrip  str [chars])
 Remove all left most characters of string which are also characters in
 chars

 str    - string. The string to be stripped.
 chars  - string. List of characters to strip, default su:*whitespace*
 return - string. 

function

 (su:rstrip str [chars])
 Right hand version of su:lstrip.

function

 (su:strip str [chars])
 Bilateral version of su:lstrip.

function

 (su:upper str)
 Convert string to upper case.

function

 (su:ljust str width [pad])
 Left justify string.

 str    - string. The text to be justified.

 width  - integer. The minimum length of the result.

 pad    - string. Character(s) to be inserted to fill out result to required
          length. default: space
 
 return - string. The result is always at least width characters and source
          string is never truncated.

 NOTE: The XLISP version allows pad character to be set as an option, the
 python version does not.

function

 (su:rjust  str  width [pad])
 The right hand version of su:ljust.

function

 (su:center  str width [rpad [lpad]])
 Center text in field of width characters.

 str    - string. The string to be centered.

 width  - integer. The minimum length of result.

 rpad   - string. The right hand pad character. default space

 lpad   - string. The left hand pad character. default space

 return - string. The result is always at least width characters. 
          The source string is never truncated.

 NOTE: XLISP version allows the pad characters to be something other than a
 space. Further the left and right pad characters may be set separately.

function

 (su:zfill str width)
 Pad string with zeros on left to at least width characters.
 Strings with leading sign characters are handled properly.

 str    - string. The string to be padded.
 width  - integer. The minimum number of characters.
 return - string.

function

 (su:capitalize  str)
 Capitalize first character in string.

function

 (su:capwords str)
 Capitalize each word in str

 str    - string. The string to be capitalized.
 return - string .

 NOTE Embedded white space which spans more than one character is replaced
 by a single space.

function

 (su:starts-with   str pat [nocase])
 Test if string starts with pattern.
 
 str    - string. The string to be tested.
 pat    - string. The pattern 
 nocase - bool. If true the test is case insensitive. Default: NIL
 return - bool. True iff str starts with pat.

function

 (su:ends-with str pat [nocase])
 Test if string ends with pattern

 str    - string. The string to be tested

 pat    - string. The pattern

 nocase - bool. If true the test is case insensitive: Default: NIL

 return - bool. True iff str ends with pat.

function

 (su:but-first  (str [n]))
 Return all but first character of string.

 str    - string. The string to be processed

 n      - integer. The number of characters to be skipped. Default: 1

 return - string. All but the first n characters of str.
          If str is NIL or "" return and empty string.
          If n > length of str, return ""

function

 (su:but-last  str [n])
 Return all but last n characters of string.

 str    - string. The string to be processed.

 n      - integer. The number of characters to strip from end. Default: 1

 return - string   All but the last n characters of str.
          If str is NIL or "" return ""
          If n > length of str return ""

function

 (su:-but-last  str pat [nocase])
 Conditional version of su:but-last

 str    - string. The string to be processed.

 pat    - string. The pattern.

 nocase - bool. If true the test is case insensitive.

 return - string. If string str ends with the sub-string pat, strip pat 
          from the end of str and return. 
          If string str does not end with pat, return str.

function

 (su:strcat [a1 [a2 [a3 ... [an]]]])
 The su version of strcat. 
 The standard strcat function may only take string arguments. su:strcat may
 take any object as an argument. Non-string arguments are converted to their
 string representation and then concatenated to the result. NIL arguments
 are converted to an empty string "".

 a1 a2 a3 ...-  any.  Arbitrary number of arguments to be converted
                 to string and concatenated.

 return - string.

function

 (su:quote  str  [q])
 Add quotation characters around string.

 str    - string.  The string to be quoted.

 q      -  char.  The quote character. Default #\"

 return - string

macro

 (su:cat str frmt [args ...])
 Destructive string concatenation with format.
 su:cat is an alias for 
 (setq str (strcat str (format nil frmt args....)))
 
 str    - Symbol. A variable containing a string. The value of str is 
          changed as a side effect

 frmt   - String. The string formating template. See standard XLISP format 
          statement.

 return - String. The new value of str.

;; su.lsp
;; Version 1.00
;; Date 31 October 2004
;; Authors:
;; Steven Jones
;;
;; Contact jones57@swbell.net include the word "nyquist" in subject line
;;
;; The contents of this file are released under the terms of the GNU General
;; Public License. See the file LICENSE.txt
;;
;; Implements a subset of the Python string module in XLISP.  Most of the
;; standard python string functions are implemented with near identical
;; behavior. The match between the python standard is not 100%. Besides the
;; obvious difference between LISP and Python any other differences are noted
;; in the embedded documentation.  A few additional functions have also been
;; defined.
;; 
;; Python string functions which have not been implemented.
;; index
;; rindex
;; maketrans
;; swapcase
;; translate
;; replace
;; 

(current-file "su")
(provide 'su)

(setf su:*ascii-lowercase*   "abcdefghijklmnopqrstuvwxyz")
(setf su:*ascii-uppercase*   "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(setf su:*digits*            "0123456789")
(setf su:*hexdigits*         "0123456789abcdefABCDEF")
(setf su:*octdigits*         "01234567")
(setf su:*punctuation*       "~!@#$%^&*()_+`-={}|\\:;'\"<>?,./")
(setf su:*whitespace*        "\t\n ")
(setf su:*null*              "")


;; @doc function ->string
;; (->string n)
;; Convert object to string
;;
;; n      - any
;; return - string
;;

(defun ->string (n)
  (if (stringp n) n
    (format nil "~a" n)))


;; @doc function  su:expandtabs
;; (su:expandtabs |tabsize|)
;; Replace tab characters in string with spaces.
;;
;; str     - string. The string to be expanded
;; tabsize - integer. Size of tab, default: 8
;; return  - string.
;;

(defun su:expandtabs (str &optional (tabsize 8))
  (let ((sp (do ((index 0 (+ 1 index))(rs su:*null*)) ;tab replacement string
		((>= index tabsize) rs)
	      (setf rs (strcat rs " "))))
	(acc su:*null*))			       ;Result 
    (do ((index 0 (+ index 1)))
	((>= index (length str)))
      (let ((test (subseq str index (+ index 1))))
	(if (string= test "\t")
	    (setf acc (strcat acc sp))
	  (setf acc (strcat acc test)))))
    acc))


;; @doc function  su:reverse
;; (su:reverse  str)
;; Reverse characters of string
;;
;; str    - string. The string to be reversed
;; return - string.
;;

(defun su:reverse (str)
  (let ((rs su:*null*))
    (dotimes (i (length str))
      (let ((j (- (length str) 1 i)))
	(setf rs (strcat rs (subseq str j (+ j 1))))))
    rs))


;; @doc function  su:find
;; (su:find  str sub [:start s][:end e])
;; Locate index of substring within string.
;;
;; str    - string. The string to be searched.
;; sub    - string. The sub-string to search for.
;; :start - integer. The starting index of the search. default: 0
;; :end   - integer. The ending search index. default: Length of str.
;; return - integer. The index of the first occurrence of sub in str which is
;;          greater than start and less than end. If there is no such match 
;;          return NIL.
;;
;; NOTE:  Differences between this function and the python
;; equivalent:
;; 1) The python version accepts negative indexing for start and stop.
;; 2) The python version returns -1 for a non-match.
;;

(defun su:find (str sub &key start end)
  (if (null sub)
      nil
    (let ((start (or start 0))
	  (end (or end (length str))))
      (string-search sub str :start start :end end))))


;; @doc function su:find-any
;; (su:find-any  str  sublst [:start s][:end e])
;; Find occurrence of any string in sublst in string.
;; This is similar to find but accepts a list of target strings instead of a
;; single sub-string. If any string in the target list is located its
;; position is returned.
;;
;; str    - string. The string to search.
;; sublst - list of strings.   A list of sub-strings to search in str.
;; :start - integer. Starting index of search.
;; :end   - integer. Ending index of search.
;; return - integer.  The index of the first element in sublst which is located
;;          in str. The result is greater than start and less than end. 
;;          If no match is found the result is NIL.
;;

(defun su:find-any (str sublst &key start end)
  (let ((index (su:find str (car sublst) :start start :end end)))
    (or index (if sublst
		  (su:find-any str (cdr sublst) :start start :end end)
		nil))))


;; @doc function  su:rfind
;; (su:rfind  str sub [:start s][:end e])
;; Search for substring starting from right side of string.
;; su:rfind has the same argument set as find and the same python/lisp difference
;; apply.  See su:find.
;;

(defun su:rfind (str sub &key start end)
  (let ((index (su:find (su:reverse str) (su:reverse sub) :start start :end end)))
    (if index
	(- (length str) index 1)
      NIL)))


;; @doc function  su:count
;; (su:count  str sub [:start s][:end e])
;; Return number of non-overlapping copies of substring in string.
;; str    - string. The string to be searched.
;; sub    - string. The search string to be counted.
;; :start - integer. The starting index of search.
;; :end   - integer. The ending index of the search.
;; return - integer  .
;; NOTE: Python version accepts negative indexes.
;;

(defun su:count (str sub &key start end)
  (let* ((rs 0)
	 (start (or start 0))
	 (end (or end (length str)))
	 (index (su:find str sub :start start :end end)))
    (if index
	(+ 1 (su:count str sub :start (+ index (length sub)) :end))
      0)))


;; @doc function  su:lower
;; (su:lower str)
;; Convert string to lower case. Exactly equivalent to string-downcase.
;;
;; str    - string.
;; return - string. 
;;

(setfn su:lower string-downcase)


;; @doc function   su:left-trim-all
;; (su:left-trim-all  str [chrs])
;; Remove all left most characters of string which are also characters in chrs
;; str    - string. The string to be trimmed.
;; chrs   - string. Characters to be removed. default: su:*whitespace*
;; return - string. 
;;

(defun su:left-trim-all (str &optional (chrs su:*whitespace*))
  (if (not (zerop (length str)))
      (let ((first (subseq str 0 1)))
	  ;(format t "STR=~a \t FIRST=~a  CHRS=~a~%"  str first chrs)
	(if (string-search first chrs)
	    (su:left-trim-all (subseq str 1) chrs )
	  str))))


;; @doc function  su:find-first-non-matching-char
;; (su:find-first-non-matching-char  str  [chrs])
;; Locate index of the left-most character of str which is not also
;; a character of chrs. Hows that for clarity?
;; 
;; str    - string. The string to be searched.
;; chrs   - string. The characters search for.
;; return - integer. The index of the first character in str which is not also
;;          a character in chrs. If all characters of str are also characters 
;;          of chrs return NIL.
;;

(defun su:find-first-non-matching-char (str &optional (chrs su:*whitespace*))
  (do ((index 0 (+ index 1))(stop nil))
      ((or (>= index (length str)) stop)(if stop (- index 1) nil))
    (let ((test (subseq str index (+ index 1))))
      (if (not (string-search test chrs))
	  (setf  stop t)))))


;; @doc function   su:string-to-char-list
;; (su:string-to-char-list  str)
;; Convert string to list of single character strings.
;;
;; str    - string. The string to be converted.
;; return - list. 
;;

(defun su:string-to-char-list (str)
  (if (not (zerop (length str)))
      (cons (subseq str 0 1)(su:string-to-char-list (subseq str 1)))
    nil))


;; @doc function  su:split-first
;; (su:split-first  str  [chars])
;; Split string at first "word"
;; A word is defined as any continuous sequence of characters which are not in
;; the string chars. The default is to delineate words by whitespace.
;;
;; str    - string. The string to be split.
;;
;; chars  - string. Characters to be used as deliminators.
;;          default su:*whitespace*
;;
;; return - list. The result is a list, the car which is the first word
;;          (trimmed of leading and trailing deliminators) in str.  If 
;;          there are more than on word in the original string the cdr 
;;          of the result is a string containing the original text without 
;;          the first word.
;;

(defun su:split-first (str &optional (chars su:*whitespace*))
  (let ((str (su:left-trim-all str chars)))
    (let ((index (su:find-any str (su:string-to-char-list chars))))
      (if index
	  (list (subseq str 0 index)(subseq str index))
	(cons str nil)))))


;; @doc function   su:split
;; (su:split  str [chars])
;; Convert string into list of words. A word is any continuous sequence of
;; characters not containing a deliminator. By default words are separated by
;; any white character.
;;
;; str    - string. The string to be split.
;;
;; chars  - string. The delineation characters.
;;
;; return - list
;; 
;; NOTE: There are several difference between the XLISP and Python version of
;; split:
;; 1) In XLISP version the deliminators are only 1 character. The Python
;; version allows for arbitrary string 
;; 2) The XLISP version allows for multiple deliminators.
;; 3) The python version takes an optional maxsplit argument.
;;

(defun su:split (str &optional (chars su:*whitespace*))
  (if (not (su:find-first-non-matching-char str chars))
      nil
    (let ((lst (su:split-first str chars)))
      (if (cdr lst)
	  (cons (car lst)(su:split (car (cdr lst)) chars))
	lst))))


;; Used as part of su:join
;;

(defun su:__join (lst &optional (sep " "))
  (if lst
      (strcat (format nil (strcat "~a" sep)(car lst))(su:__join (cdr lst) sep))
    su:*null*))


;; @doc function  su:join
;; (su:join lst [sep])
;; Concatenate list elements to string.
;;
;; lst    - list. 
;; sep    - string. The string to be inserted between adjacent elements of lst
;; return - string 
;;

(defun su:join (lst &optional (sep " "))
  (let ((rs (su:__join lst sep)))
    (subseq rs 0 (- (length rs)(length sep)))))


;; @doc function  su:lstrip
;; (su:lstrip  str [chars])
;; Remove all left most characters of string which are also characters in
;; chars
;;
;; str    - string. The string to be stripped.
;; chars  - string. List of characters to strip, default su:*whitespace*
;; return - string. 
;;

(defun su:lstrip (str &optional (chars su:*whitespace*))
  (string-left-trim chars str))


;; @doc function  su:rstrip
;; (su:rstrip str [chars])
;; Right hand version of su:lstrip.
;;

(defun su:rstrip (str &optional (chars su:*whitespace*))
  (string-right-trim chars str))


;; @doc function  su:strip
;; (su:strip str [chars])
;; Bilateral version of su:lstrip.
;;

(defun su:strip (str &optional (chars su:*whitespace*))
  (su:lstrip (su:rstrip str chars) chars))


;; @doc function  su:upper
;; (su:upper str)
;; Convert string to upper case.
;;

(setfn su:upper string-upcase)


;; @doc function  su:ljust
;; (su:ljust str width [pad])
;; Left justify string.
;;
;; str    - string. The text to be justified.
;;
;; width  - integer. The minimum length of the result.
;;
;; pad    - string. Character(s) to be inserted to fill out result to required
;;          length. default: space
;; 
;; return - string. The result is always at least width characters and source
;;          string is never truncated.
;;
;; NOTE: The XLISP version allows pad character to be set as an option, the
;; python version does not.
;;

(defun su:ljust (str width &optional (pad " "))
  (if (< (length str) width)
      (su:ljust (strcat str pad) width pad)
    str))


;; @doc function  su:rjust
;; (su:rjust  str  width [pad])
;; The right hand version of su:ljust.
;;

(defun su:rjust (str width &optional (pad " "))
  (if (< (length str) width)
      (su:rjust (strcat pad str) width pad)
    str))


;; @doc function   su:center
;; (su:center  str width [rpad [lpad]])
;; Center text in field of width characters.
;;
;; str    - string. The string to be centered.
;;
;; width  - integer. The minimum length of result.
;;
;; rpad   - string. The right hand pad character. default space
;;
;; lpad   - string. The left hand pad character. default space
;;
;; return - string. The result is always at least width characters. 
;;          The source string is never truncated.
;;
;; NOTE: XLISP version allows the pad characters to be something other than a
;; space. Further the left and right pad characters may be set separately.
;;

(defun su:center (str width &optional (rpad " ")(lpad " "))
  (if (< (length str) width)
      (su:center (strcat rpad str lpad) width rpad lpad)
    str))


;; @doc function  su:zfill
;; (su:zfill str width)
;; Pad string with zeros on left to at least width characters.
;; Strings with leading sign characters are handled properly.
;;
;; str    - string. The string to be padded.
;; width  - integer. The minimum number of characters.
;; return - string.
;;

(defun su:zfill (str width)
  (if (numberp str)
      (setf str (string-trim " " (->string str))))
  (let ((sign (if (not (zerop (length str)))
		  (subseq str 0 1)
		su:*null*)))
    (if (or (string= sign "+")(string= sign "-"))
	(let ()
	  (setf str (su:rjust (subseq str 1)(- width 1) "0"))
	  (strcat sign str))
      (su:rjust str width "0"))))


;; @doc function  su:capitalize 
;; (su:capitalize  str)
;; Capitalize first character in string.
;;

(defun su:capitalize (str)
  (if (not (zerop (length str)))
      (strcat (su:upper (subseq str 0 1))(subseq str 1))
    str))


;; Used as part of su:capwords definition.
;;

(defun su:__capwords (lst)
  (if lst
      (cons (su:capitalize (format nil "~a" (car lst)))(su:__capwords (cdr lst)))
    nil))


;; @doc function  su:capwords
;; (su:capwords str)
;; Capitalize each word in str
;;
;; str    - string. The string to be capitalized.
;; return - string .
;;
;; NOTE Embedded white space which spans more than one character is replaced
;; by a single space.
;;

(defun su:capwords (str)
  (if (zerop (length str))
      str
    (let ((lst (su:__capwords (su:split str))))
      (su:join lst))))


;; function  su:list->string  DEPRECIATED
;; (su:list->string   lst [spacer])
;; Exactly equivalent to list->string defined in utilities.lsp
;;
;;(defun su:list->string (lst &optional (spacer " "))
;;  (if lst
;;      (strcat (car (format nil "~a~a" (car lst) spacer)
;;		   (su:list->string (cdr lst) spacer)))
;;    ""))


;; @doc function  su:starts-with
;; (su:starts-with   str pat [nocase])
;; Test if string starts with pattern.
;; 
;; str    - string. The string to be tested.
;; pat    - string. The pattern 
;; nocase - bool. If true the test is case insensitive. Default: NIL
;; return - bool. True iff str starts with pat.
;;

(defun su:starts-with  (str pat &optional (nocase nil))
  (let (tstr tpat index)
    (if nocase
	(setf tstr (su:lower str)
	      tpat (su:lower pat))
      (setf tstr str
	    tpat pat))
    (setf index (string-search tpat tstr))
    (and (numberp index) (zerop index))))


;; @doc function  su:ends-with 
;; (su:ends-with str pat [nocase])
;; Test if string ends with pattern
;;
;; str    - string. The string to be tested
;;
;; pat    - string. The pattern
;;
;; nocase - bool. If true the test is case insensitive: Default: NIL
;;
;; return - bool. True iff str ends with pat.
;;

(defun su:ends-with   (str pat &optional (nocase nil))
    (su:starts-with (su:reverse str) (su:reverse pat) nocase))


;; @doc function su:but-first
;; (su:but-first  (str [n]))
;; Return all but first character of string.
;;
;; str    - string. The string to be processed
;;
;; n      - integer. The number of characters to be skipped. Default: 1
;;
;; return - string. All but the first n characters of str.
;;          If str is NIL or "" return and empty string.
;;          If n > length of str, return ""
;;

(defun su:but-first (str &optional (n 1))
  (cond ((null str) su:*null*)
	((string= str su:*null*) su:*null*)
	((> n (length str)) su:*null*)
	(t (subseq str n))))


;; @doc function  su:but-last 
;; (su:but-last  str [n])
;; Return all but last n characters of string.
;;
;; str    - string. The string to be processed.
;;
;; n      - integer. The number of characters to strip from end. Default: 1
;;
;; return - string   All but the last n characters of str.
;;          If str is NIL or "" return ""
;;          If n > length of str return ""
;;

(defun su:but-last (str &optional (n 1))
  (cond ((null str) su:*null*)
	((string= str su:*null*) su:*null*)
	((> n (length str)) su:*null*)
	(t (subseq str 0 (- (length str) n)))))


;; @doc function  su:-but-last
;; (su:-but-last  str pat [nocase])
;; Conditional version of su:but-last
;;
;; str    - string. The string to be processed.
;;
;; pat    - string. The pattern.
;;
;; nocase - bool. If true the test is case insensitive.
;;
;; return - string. If string str ends with the sub-string pat, strip pat 
;;          from the end of str and return. 
;;          If string str does not end with pat, return str.
;; 

(defun su:-but-last (str pat &optional (nocase NIL))
    (if (su:ends-with str pat nocase)
	(su:but-last str (length pat))
      str))


;; @doc function   su:strcat 
;; (su:strcat [a1 [a2 [a3 ... [an]]]])
;; The su version of strcat. 
;; The standard strcat function may only take string arguments. su:strcat may
;; take any object as an argument. Non-string arguments are converted to their
;; string representation and then concatenated to the result. NIL arguments
;; are converted to an empty string "".
;;
;; a1 a2 a3 ...-  any.  Arbitrary number of arguments to be converted
;;                 to string and concatenated.
;;
;; return - string.
;;

(defun su:strcat  (&rest args)
  (do ((index 0 (+ index 1))(acc su:*null*))
      ((> index (- (length args) 1)) acc)
    (let ((tok (nth index args)))
      (setf tok (if (null tok) su:*null* (format nil "~a" tok)))
      (setf acc (strcat acc tok)))))


;; @doc function   su:quote
;; (su:quote  str  [q])
;; Add quotation characters around string.
;;
;; str    - string.  The string to be quoted.
;;
;; q      -  char.  The quote character. Default #\"
;;
;; return - string
;;

(defun su:quote (str &optional (q #\"))
  (let ((qchr (string-trim " " (->string q))))
    (strcat qchr str qchr)))


;; @doc macro su:cat
;; (su:cat str frmt [args ...])
;; Destructive string concatenation with format.
;; su:cat is an alias for 
;; (setq str (strcat str (format nil frmt args....)))
;; 
;; str    - Symbol. A variable containing a string. The value of str is 
;;          changed as a side effect
;;
;; frmt   - String. The string formating template. See standard XLISP format 
;;          statement.
;;
;; return - String. The new value of str.
;;

(defmacro su:cat (str frmt &rest args)
  `(setq ,str (strcat ,str (format nil ,frmt ,@args))))