;;;
;;; STRINGS.LSP - Common Lisp string operations
;;;
;;; Author: Eric Benson
;;; Symbolic Computation Group
;;; Computer Science Dept.
;;; University of Utah
;;; Date: 7 April 1982
;;; Copyright (c) 1982 University of Utah
;;;
(eval-when (load)
(imports '(chars))) ; Uses the CHARS module
(eval-when (compile) ; Local functions
(localf string-equal-aux string<-aux string<=-aux string<>-aux
string-lessp-aux string-not-greaterp-aux string-not-equal-aux
string-trim-left-index string-trim-right-index
bag-element bag-element-aux
string-concat-aux))
;;;; CHAR - fetch a character in a string
;(defun char (s i) ; not defined because CHAR means something else in PSL
; (elt (stringify s) i))
;;;; RPLACHAR - store a character in a string
(defun rplachar (s i x)
(setelt s i x))
;;;; STRING= - compare two strings (substring options not implemented)
(fset 'string= (fsymeval 'eqstr)) ; Same function in PSL
;;;; STRING-EQUAL - compare two strings, ignoring case, bits and font
(defun string-equal (s1 s2)
(setq s1 (stringify s1))
(setq s2 (stringify s2))
(or (eq s1 s2)
(let ((len1 (string-length s1)) (len2 (string-length s2)))
(and (eql len1 len2) (string-equal-aux s1 s2 len1 0)))))
(defun string-equal-aux (s1 s2 len i)
(or (eql len i)
(and (char-equal (char s1 i) (char s2 i))
(string-equal-aux s1 s2 len (add1 i)))))
;;;; STRING< - lexicographic comparison of strings
(defun string< (s1 s2)
(setq s1 (stringify s1))
(setq s2 (stringify s2))
(string<-aux s1
s2
(string-length s1)
(string-length s2)
0))
(defun string<-aux (s1 s2 len1 len2 i)
(cond ((eql i len1) (if (eql i len2) () i))
((eql i len2) ())
((char= (char s1 i) (char s2 i))
(string<-aux s1 s2 len1 len2 (add1 i)))
((char< (char s1 i) (char s2 i)) i)
(t ())))
;;;; STRING> - lexicographic comparison of strings
(defun string> (s1 s2)
(string< s2 s1))
;;;; STRING<= - lexicographic comparison of strings
(defun string<= (s1 s2)
(setq s1 (stringify s1))
(setq s2 (stringify s2))
(string<=-aux s1 s2 (string-length s1) (string-length s2) 0))
(defun string<=-aux (s1 s2 len1 len2 i)
(cond ((eql i len1) i)
((eql i len2) ())
((char= (char s1 i) (char s2 i))
(string<=-aux s1 s2 len1 len2 (add1 i)))
((char< (char s1 i) (char s2 i)) i)
(t ())))
;;;; STRING>= - lexicographic comparison of strings
(defun string>= (s1 s2)
(string<= s2 s1))
;;;; STRING<> - lexicographic comparison of strings
(defun string<> (s1 s2)
(setq s1 (stringify s1))
(setq s2 (stringify s2))
(let ((len1 (string-length s1)) (len2 (string-length s2)))
(if (<= len1 len2)
(string<>-aux s1 s2 len1 len2 0)
(string<>-aux s2 s1 len2 len1 0))))
(defun string<>-aux (s1 s2 len1 len2 i)
(cond ((eql i len1)
(if (eql i len2) () i))
((char= (char s1 i) (char s2 i))
(string<>-aux s1 s2 len1 len2 (add1 i)))
(t i)))
;;;; STRING-LESSP - lexicographic comparison of strings
(defun string-lessp (s1 s2)
(setq s1 (stringify s1))
(setq s2 (stringify s2))
(string-lessp-aux s1 s2 (string-length s1) (string-length s2) 0))
(defun string-lessp-aux (s1 s2 len1 len2 i)
(cond ((eql i len1) (if (eql i len2) () i))
((eql i len2) ())
((char-equal (char s1 i) (char s2 i))
(string-lessp-aux s1 s2 len1 len2 (add1 i)))
((char-lessp (char s1 i) (char s2 i)) i)
(t ())))
;;;; STRING-GREATERP - lexicographic comparison of strings
(defun string-greaterp (s1 s2)
(string-lessp s2 s1))
;;;; STRING-NOT-GREATERP - lexicographic comparison of strings
(defun string-not-greaterp (s1 s2)
(setq s1 (stringify s1))
(setq s2 (stringify s2))
(string-not-greaterp-aux s1 s2 (string-length s1) (string-length s2) 0))
(defun string-not-greaterp-aux (s1 s2 len1 len2 i)
(cond ((eql i len1) i)
((eql i len2) ())
((char-equal (char s1 i) (char s2 i))
(string-not-greaterp-aux s1 s2 len1 len2 (add1 i)))
((char-lessp (char s1 i) (char s2 i))
i)
(t ())))
;;;; STRING-NOT-LESSP - lexicographic comparison of strings
(defun string-not-lessp (s1 s2)
(string-lessp= s2 s1))
;;;; STRING-NOT-EQUAL - lexicographic comparison of strings
(defun string-not-equal (s1 s2)
(setq s1 (stringify s1))
(setq s2 (stringify s2))
(let ((len1 (string-length s1)) (len2 (string-length s2)))
(if (<= len1 len2)
(string-not-equal-aux s1 s2 len1 len2 0)
(string-not-equal-aux s2 s1 len2 len1 0))))
(defun string-not-equal-aux (s1 s2 len1 len2 i)
(cond ((eql i len1)
(if (eql i len2) () i))
((char-equal (char s1 i) (char s2 i))
(string-not-equal-aux s1 s2 len1 len2 (add1 i)))
(t i)))
;;;; MAKE-STRING - construct a string
(defun make-string (count fill-character)
(mkstring (sub1 count) fill-character))
;;;; STRING-REPEAT - concat together copies of a string
(defun string-repeat (s i)
(setq s (stringify s))
(cond ((eql i 0) "")
((eql i 1) (copystring s))
(t (let ((len (string-length s)))
(let ((s1 (make-string (* i len) #\Space)))
(do ((j 1 (+ j 1)) (i1 -1))
((> j i))
(do ((k 0 (+ k 1)))
((eql k len))
(setq i1 (add1 i1))
(rplachar s1 i1 (char s k))))
s1)))))
;;;; STRING-TRIM - remove leading and trailing characters from a string
(defun string-trim (c-bag s)
(setq s (stringify s))
(let ((len (string-length s)))
(let ((i1 (string-trim-left-index c-bag s 0 len))
(i2 (string-trim-right-index c-bag s len)))
(if (<= i2 i1) "" (substring s i1 i2)))))
(defun string-trim-left-index (c-bag s i uplim)
(if (or (eql i uplim) (not (bag-element (char s i) c-bag)))
i
(string-trim-left-index c-bag s (add1 i) uplim)))
(defun string-trim-right-index (c-bag s i)
(if (or (eql i 0) (not (bag-element (char s (sub1 i)) c-bag)))
i
(string-trim-right-index c-bag s (sub1 i))))
(defun bag-element (elem c-bag)
(cond ((consp c-bag) (memq elem c-bag))
((stringp c-bag)
(bag-element-aux elem c-bag 0 (string-length c-bag)))
(t ())))
(defun bag-element-aux (elem c-bag i uplim)
(and (< i uplim)
(or (char= elem (char c-bag i))
(bag-element-aux elem c-bag (add1 i) uplim))))
;;;; STRING-LEFT-TRIM - remove leading characters from string
(defun string-left-trim (c-bag s)
(setq s (stringify s))
(let ((len (string-length s)))
(let ((i1 (string-trim-left-index c-bag s 0 len)))
(if (<= len i1) "" (substring s i1 len)))))
;;;; STRING-RIGHT-TRIM - remove trailing characters from string
(defun string-right-trim (c-bag s)
(setq s (stringify s))
(let ((i2 (string-trim-right-index c-bag s (string-length s))))
(if (<= i2 0) "" (substring s 0 i2))))
;;;; STRING-UPCASE - copy and raise all alphabetic characters in string
(defun string-upcase (s)
(setq s (stringify s))
(nstring-upcase (copystring s)))
;;;; NSTRING-UPCASE - destructively raise all alphabetic characters in string
(defun nstring-upcase (s)
(let ((len (string-length s)))
(do ((i 0 (+ i 1)))
((eql i len))
(let ((c (char s i)))
(when (lowercasep c) (rplachar s i (char-upcase c)))))
s))
;;;; STRING-DOWNCASE - copy and lower all alphabetic characters in string
(defun string-downcase (s)
(setq s (stringify s))
(nstring-downcase (copystring s)))
;;;; NSTRING-DOWNCASE - destructively raise all alphabetic characters in string
(defun nstring-downcase (s)
(let ((len (string-length s)))
(do ((i 0 (+ i 1)))
((eql i len))
(let ((c (char s i)))
(when (uppercasep c) (rplachar s i (char-downcase c)))))
s))
;;;; STRING-CAPITALIZE - copy and raise first letter of all words in string
(defun string-capitalize (s)
(setq s (stringify s))
(nstring-capitalize (copystring s)))
;;;; NSTRING-CAPITALIZE - destructively raise first letter of all words
(defun nstring-capitalize (s)
(let ((len (string-length s)) (in-word-flag ()))
(do ((i 0 (+ i 1)))
((eql i len))
(let ((c (char s i)))
(cond ((uppercasep c)
(if in-word-flag
(rplachar s i (char-downcase c))
(setq in-word-flag t)))
((lowercasep c)
(when (not in-word-flag)
(rplachar s i (char-upcase c))
(setq in-word-flag t)))
(t (setq in-word-flag ())))))
s))
;;;; STRING - coercion to a string, named STRINGIFY in PSL
(defun stringify (x)
(cond ((stringp x) x)
((symbolp x) (get-pname x))
(t (stderror (bldmsg "%r cannot be coerced to a string" x)))))
;;;; STRING-TO-LIST - unpack string characters into a list
(defun string-to-list (s)
(string2list s)) ; PSL function
;;;; STRING-TO-VECTOR - unpack string characters into a vector
(defun string-to-vector (s)
(string2vector s)) ; PSL function
;;;; SUBSTRING - subsequence restricted to strings
(defun substring (string start end)
(subseq (stringify string) start end))
;;;; STRING-LENGTH - last index of a string, plus one
(defun string-length (s)
(add1 (size s)))
;;;; STRING-CONCAT - concatenate strings
(defmacro string-concat args
(let ((len (length args)))
(cond ((eql len 0) "")
((eql len 1) `(copystring (stringify ,(first args))))
(t (string-concat-aux args len)))))
(defun string-concat-aux (args len)
(if (eql len 2)
`(concat (stringify ,(first args))
(stringify ,(second args)))
`(concat (stringify ,(first args))
,(string-concat-aux (rest args) (sub1 len)))))