1;-*- *cold-load:t; 1Mode:Common-Lisp; Package:SI; 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 ;;; ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;* 1** (c) Copyright 1980 Massachusetts Institute of Technology *** ;SUBSTRING and NSUBSTRING take an optional area argument. ;Note that most of the functions in this package will consider a number ;to be a string one character long. However, they will never return ;a number instead of a string one character long. ;Symbols given as arguments will be converted into their pnames. ;; This macro is used by string-searching functions to coerce the string args. (defmacro coerce-string-search-arg (arg-name) `(or (fixnum-arrayp ,arg-name) (setq ,arg-name (zlc:string ,arg-name)))) (defsubst fixnum-arrayp (object) "T if OBJECT is an array whose type requires all elements to be fixnums." (and (arrayp object) (array-bits-per-element (%p-ldb %%array-type-field object)))) (defmacro coerce-string-arg (arg-name) "Convert ARG-NAME to a string if it isn't one already. Sets the value of ARG-NAME." `(or (stringp ,arg-name) (setq ,arg-name (zlc:string ,arg-name)))) (defun string-append (&rest strings &aux (length 0) string coerced (i 0)) "Append any number of strings (or arrays). The value is always a newly constructed array. The value will be the same type of array as the first argument. Symbols and numbers are coerced into strings." (dolist (s strings) (incf length (typecase s (array (length s)) ((or fixnum character) 1) (t (ZLC:string-length s))))) (setq string (make-array length :type (if (arrayp (car strings)) (array-type (car strings)) 'art-string))) (dolist (s strings) (typecase s ((or number character) (setf (aref string i) s) (incf i 1)) (t (setq coerced (if (arrayp s) s (string s))) (copy-array-portion coerced 0 (setq length (array-active-length coerced)) string i (incf i length))))) string) (defun string-nconc (mung &rest strings &aux len final-len s2len) "STRING-NCONC extends the first string and tacks on any number of additional strings. The first argument must be a string with a fill-pointer. Returns the first argument, which may have been moved and forwarded, just like ADJUST-ARRAY-SIZE." (setq final-len (setq len (fill-pointer mung))) (dolist (str2 strings) (setq final-len (+ final-len (ZLC:string-length str2)))) (and (> final-len (array-total-size mung)) (adjust-array mung final-len)) (dolist (str2 strings) (typecase str2 ((or fixnum character) (vector-push str2 mung) (incf len 1)) (t (setq str2 (if (arrayp str2) str2 (string str2)) s2len (array-active-length str2)) (copy-array-portion str2 0 s2len mung len (incf len s2len)) (setf (fill-pointer mung) len)))) mung) ;;;PHD 3/20/87 Changed nsubstring to an open call. (defun nsubstring (string from &optional to (area nil) &aux length ) "Return a displaced array whose data is part of STRING, from FROM to TO. If you modify the contents of the displaced array, the original string changes. If TO is omitted or NIL, the substring runs up to the end of the string. If AREA is specified, the displaced array is made in that area." (coerce-string-arg string) (or to (setq to (array-active-length string))) (setq length (- to from)) (or (and (>= length 0) (>= from 0) (<= to (array-active-length string))) (ferror () "Args ~S and ~S out of range for ~S." from to string)) (let ((the-array (%ALLOCATE-AND-INITIALIZE-ARRAY (+ (%LOGDPB 1 %%array-displaced-bit (%LOGDPB 1 %%array-number-dimensions (%LOGDPB (%P-LDB-OFFSET %%ARRAY-TYPE-FIELD string 0) %%array-type-field 0))) 3) length 0 area 4)) (idx 1) (indexed-p (array-indexed-p string))) (%P-STORE-CONTENTS-OFFSET (if indexed-p (array-indirect-to string) string) the-array idx) (%P-STORE-CONTENTS-OFFSET length the-array (1+ idx)) (%P-STORE-CONTENTS-OFFSET (+ from (if indexed-p (array-index-offset string) 0)) the-array (+ idx 2)) the-array)) ;;;(defun nsubstring (string from &optional to (area nil) &aux length arraytype) ;;; "Return a displaced array whose data is part of STRING, from FROM to TO. ;;;If you modify the contents of the displaced array, the original string changes. ;;;If TO is omitted or NIL, the substring runs up to the end of the string. ;;;If AREA is specified, the displaced array is made in that area." ;;; (coerce-string-arg string) ;;; (or to (setq to (array-active-length string))) ;;; (setq length (- to from)) ;;; (or (and (>= length 0) (>= from 0) (<= to (array-active-length string))) ;;; (ferror () "Args ~S and ~S out of range for ~S." from to string)) ;;; (setq arraytype (array-type string)) ;;; (cond ;;; ((not (array-indexed-p string)) ;;; (make-array length :area area :type arraytype :displaced-to string;DISPLACED ;;; :displaced-index-offset from));INDEX OFFSET ;;; ;; OTHERWISE, PROBABLY A SUBSTRING OF A SUBSTRING ;;; (t ;;; (make-array length :area area :type arraytype :displaced-to (array-indirect-to string) ;;; ;;POINT TO ARRAY POINTED TO ORIGINALLY ;;; :displaced-index-offset (+ from (array-index-offset string)))))) (defun zlc:substring (string from &optional to (area nil)) "Return a copy of part of STRING, from FROM to TO. If TO is omitted, the copied part is up to the end of the string. If AREA is specified, the new string is made in that area.";Nice and modular but conses up the wazoo ;(STRING-APPEND (NSUBSTRING STRING FROM TO)) ;What's wrong with consing up wazoos? Do they take up lots of space? ;No, but they make a lot of noise. (coerce-string-arg string) (or to (setq to (array-active-length string))) (or (and (>= to from) (>= from 0) (<= to (array-active-length string))) (ferror () "Args ~S and ~S out of range for ~S." from to string)) (let ((res (make-array (- to from) :type (%p-ldb-offset %%array-type-field string 0) :area area))) (copy-array-portion string from to res 0 (array-total-size res)) res)) (defun substring-after-char (char string &optional (start 0) (end (ZLC:STRING-LENGTH string)) area) "Return the part of STRING that follows the first occurrence of CHAR after START. Only the part of STRING up to END is searched, and the substring stops there too. The value is a newly created string, in area AREA (or the default area)." (let ((idx (ZLC:STRING-SEARCH-CHAR char string start end ))) (cond ((null idx) "") (t (ZLC:SUBSTRING string (1+ idx) end area) )))) (defun ZLC:STRING-LENGTH (string) "Return the length of STRING, in characters." (cond ((arrayp string) (array-active-length string)) ((or (integerp string) (characterp string)) 1) ((symbolp string) (array-active-length (symbol-name string))) ((and (typep string 'instance) (let ((s (send string :send-if-handles :string-for-printing))) (and s (length s))))) (t (ferror () "Cannot convert ~S into a string." string)))) (defun zlc:string-equal (string1 string2 &rest args) "Return T if the specified portions of STRING1 and STRING2 are the same. Case is not significant in comparing characters unless ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON is non-NIL. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (declare (arglist string1 string2 &key (start1 0) end1 (start2 0) end2)) (if args (let (idx1 idx2 lim1 lim2) (if (and (car args) (symbolp (car args)) (keywordp (car args))) (setq idx1 (getf args :start1) idx2 (getf args :start2) lim1 (getf args :end1) lim2 (getf args :end2)) (list-match-p args `(,idx1 ,idx2 ,lim1 ,lim2))) (or idx1 (setq idx1 0)) (or idx2 (setq idx2 0)) (coerce-string-arg string1) (coerce-string-arg string2) (cond ((or lim1 lim2) (or lim1 (setq lim1 (array-active-length string1))) (or lim2 (setq lim2 (array-active-length string2))) (and (= (setq lim1 (- lim1 idx1)) (- lim2 idx2)) (%string-equal string1 idx1 string2 idx2 lim1))) (t (%string-equal string1 idx1 string2 idx2 ())))) (%string-equal (if (stringp string1) string1 (string string1)) 0 (if (stringp string2) string2 (string string2)) 0 ()))) (defun zlc:string= (string1 string2 &rest args) "Returns T if the specified portions of STRING1 and STRING2 are the same. Case is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (declare (arglist string1 string2 &key (start1 0) end1 (start2 0) end2)) (let (idx1 idx2 lim1 lim2 (alphabetic-case-affects-string-comparison t)) (if (and (car args) (symbolp (car args)) (keywordp (car args))) (setq idx1 (getf args :start1) idx2 (getf args :start2) lim1 (getf args :end1) lim2 (getf args :end2)) (list-match-p args `(,idx1 ,idx2 ,lim1 ,lim2))) (or idx1 (setq idx1 0)) (or idx2 (setq idx2 0)) (coerce-string-arg string1) (coerce-string-arg string2) (cond ((or lim1 lim2) (or lim1 (setq lim1 (array-active-length string1))) (or lim2 (setq lim2 (array-active-length string2))) (and (= (setq lim1 (- lim1 idx1)) (- lim2 idx2)) (%string-equal string1 idx1 string2 idx2 lim1))) (t (%string-equal string1 idx1 string2 idx2 ()))))) ;;; Common Lisp only versions ;;;Optimized version (defun string=* (string1 string2 &optional (start1 0) end1 (start2 0) end2 &aux (alphabetic-case-affects-string-comparison t)) (coerce-string-arg string1) (coerce-string-arg string2) (cond ((or end1 end2) (or end1 (setq end1 (array-active-length string1))) (or end2 (setq end2 (array-active-length string2))) (and (= (setq end1 (- end1 start1)) (- end2 start2)) (%string-equal string1 start1 string2 start2 end1))) (t (%string-equal string1 start1 string2 start2 ())))) (defun cli:string= (string1 string2 &rest args) "Returns T if the specified portions of STRING1 and STRING2 are the same. Case is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (declare (arglist string1 string2 &key (start1 0) end1 (start2 0) end2)) (let (idx1 idx2 lim1 lim2 (alphabetic-case-affects-string-comparison t)) (if (and (car args) (symbolp (car args)) (keywordp (car args))) (setq idx1 (getf args :start1) idx2 (getf args :start2) lim1 (getf args :end1) lim2 (getf args :end2)) (list-match-p args `(,idx1 ,idx2 ,lim1 ,lim2))) (or idx1 (setq idx1 0)) (or idx2 (setq idx2 0)) (coerce-string-arg string1) (coerce-string-arg string2) (cond ((or lim1 lim2) (or lim1 (setq lim1 (array-active-length string1))) (or lim2 (setq lim2 (array-active-length string2))) (and (= (setq lim1 (- lim1 idx1)) (- lim2 idx2)) (%string-equal string1 idx1 string2 idx2 lim1))) (t (%string-equal string1 idx1 string2 idx2 ()))))) ;;;(defun cli:string= (string1 string2 &key (start1 0) end1 (start2 0) end2 &aux ;;; (alphabetic-case-affects-string-comparison t)) ;;; "Returns T if the specified portions of STRING1 and STRING2 ;;; are the same. Case is significant in comparing characters. ;;; START1, START2 - integers indicating where comparison should begin ;;; in STRING1 and STRING2 respectively. ;;; END1, END2 - integers indicating where comparison should stop ;;; in STRING1 and STRING2 respectively. Comparison ;;; stops just before this index. A NIL value for either ;;; END keyword implies the active length of the string. ;;; Note the default case is to use the entirety of both strings." ;;; (string=* string1 string2 start1 end1 start2 end2)) (defun string-equal* (string1 string2 &optional (start1 0) end1 (start2 0) end2 &aux (alphabetic-case-affects-string-comparison nil)) (coerce-string-arg string1) (coerce-string-arg string2) (cond ((or end1 end2) (or end1 (setq end1 (array-active-length string1))) (or end2 (setq end2 (array-active-length string2))) (and (= (setq end1 (- end1 start1)) (- end2 start2)) (%string-equal string1 start1 string2 start2 end1))) (t (%string-equal string1 start1 string2 start2 ())))) ;;;(defun cli:string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2 ;;; &aux (alphabetic-case-affects-string-comparison nil)) ;;; "Returns T if the specified portions of STRING1 and STRING2 ;;; are the same. Case is not significant in comparing characters. ;;; START1, START2 - integers indicating where comparison should begin ;;; in STRING1 and STRING2 respectively. ;;; END1, END2 - integers indicating where comparison should stop ;;; in STRING1 and STRING2 respectively. Comparison ;;; stops just before this index. A NIL value for either ;;; END keyword implies the active length of the string. ;;; Note the default case is to use the entirety of both strings." ;;; (string-equal* string1 string2 start1 end1 start2 end2)) ;; 5/02/89 DNG - Use ZLC:STRING instead of LISP:STRING for consistency. [SPR 8816] (defun cli:string-equal (string1 string2 &rest args) "Return T if the specified portions of STRING1 and STRING2 are the same. Case is not significant in comparing characters unless ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON is non-NIL. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (declare (arglist string1 string2 &key (start1 0) end1 (start2 0) end2)) (if args (let (idx1 idx2 lim1 lim2) (if (and (car args) (symbolp (car args)) (keywordp (car args))) (setq idx1 (getf args :start1) idx2 (getf args :start2) lim1 (getf args :end1) lim2 (getf args :end2)) (list-match-p args `(,idx1 ,idx2 ,lim1 ,lim2))) (or idx1 (setq idx1 0)) (or idx2 (setq idx2 0)) (coerce-string-arg string1) (coerce-string-arg string2) (cond ((or lim1 lim2) (or lim1 (setq lim1 (array-active-length string1))) (or lim2 (setq lim2 (array-active-length string2))) (and (= (setq lim1 (- lim1 idx1)) (- lim2 idx2)) (%string-equal string1 idx1 string2 idx2 lim1))) (t (%string-equal string1 idx1 string2 idx2 ())))) (%string-equal (if (stringp string1) string1 (zlc:string string1)) 0 (if (stringp string2) string2 (zlc:string string2)) 0 ()))) (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns T if the specified portions of STRING1 and STRING2 are not the same. Case is not significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare string1 string2 start1 start2 end1 end2))) (unless (zerop v) (1- (abs v))))) (proclaim '(inline make-string)) (defun make-string (length &key (initial-element nil provided-p)) "Creates and returns a string of LENGTH elements, all set to INITIAL-ELEMENT. If INITIAL-ELEMENT is not supplied, the elements contain the character with code 0." (declare (arglist length &key initial-element )) (values (if provided-p (make-array length :element-type 'string-char :initial-element initial-element ) (make-array length :element-type 'string-char)))) (defun ZLC:STRING-SEARCH-CHAR (char string &optional (from 0) to consider-case) "Returns the index in STRING of the first occurrence of CHAR past FROM, or NIL if none. If TO is non-NIL, the search stops there, and the value is NIL if CHAR is not found before there. Case matters during character comparison if CONSIDER-CASE is non-NIL." (let ((alphabetic-case-affects-string-comparison consider-case)) (coerce-string-search-arg string) (or to (setq to (array-active-length string))) (%string-search-char char string from to))) (defun ZLC:STRING-REVERSE-SEARCH-CHAR (char string &optional from (to 0) consider-case) "Returns the index in STRING of the last occurrence of CHAR before FROM, or NIL if none. If TO is non-zero, the search stops there, and the value is NIL if CHAR does not appear after there. TO should normally be less than FROM. If FROM is omitted or NIL, the default is the end of the string. Case matters during character comparison if CONSIDER-CASE is non-NIL." (coerce-string-search-arg string) (or from (setq from (array-active-length string))) (if consider-case (do ((i (1- from) (1- i))) ((< i to) nil) (and (= char (aref string i)) (return i))) (do ((i (1- from) (1- i))) ((< i to) nil) (and (char-equal char (aref string i)) (return i))))) (defun ZLC:STRING-SEARCH-NOT-CHAR (char string &optional (from 0) to consider-case) "Returns the index in STRING of the first character past FROM not equal to CHAR, or NIL. If TO is non-NIL, the search stops there, and the value is NIL if a character different from CHAR is not found before there. Case matters during character comparison if CONSIDER-CASE is non-NIL." (coerce-string-search-arg string) (or to (setq to (array-active-length string))) (if consider-case (do ((i from (1+ i))) ((>= i to) nil) (or (= char (aref string i)) (return i))) (do ((i from (1+ i))) ((>= i to) nil) (or (char-equal char (aref string i)) (return i))))) (defun ZLC:STRING-REVERSE-SEARCH-NOT-CHAR (char string &optional from (to 0) consider-case) "Returns the index in STRING of the last character before FROM not equal to CHAR, or NIL. If TO is non-zero, the search stops there, and the value is NIL if no character different from CHAR appears after there. TO should normally be less than FROM. If FROM is omitted or NIL, the default is the end of the string. Case matters during character comparison if CONSIDER-CASE is non-NIL." (coerce-string-search-arg string) (or from (setq from (array-active-length string))) (if consider-case (do ((i (1- from) (1- i))) ((< i to) nil) (or (= char (aref string i)) (return i))) (do ((i (1- from) (1- i))) ((< i to) nil) (or (char-equal char (aref string i)) (return i))))) (defun ZLC:STRING-SEARCH (key string &optional (from 0) to (key-from 0) key-to consider-case &aux (alphabetic-case-affects-string-comparison consider-case) key-len) "Returns the index in STRING of the first occurrence of KEY past FROM, or NIL. If TO is non-NIL, the search stops there, and the value is NIL if no occurrence of KEY is found before there. KEY-FROM and KEY-TO may be used to specify searching for just a substring of KEY. CONSIDER-CASE if non-NIL means we distinguish letters by case." (coerce-string-search-arg string) (coerce-string-arg key);?? (unless key-to (setq key-to (array-active-length key))) (setq key-len (- key-to key-from)) (or to (setq to (array-active-length string))) (cond ((= key-from key-to) (and (<= from to) from)) (t (setq to (1+ (- to key-len)));Last position at which key may start +1 (prog (ch1) (cond ((minusp to) (return ()))) (setq ch1 (aref key key-from)) loop ;Find next place key might start (or (setq from (%string-search-char ch1 string from to)) (return ())) (and (%string-equal key key-from string from key-len) (return from)) (setq from (1+ from));Avoid infinite loop. %STRING-SEARCH-CHAR does right (go loop))))) ; thing if from  to. (defun ZLC:STRING-REVERSE-SEARCH (key string &optional from (to 0) (key-from 0) key-to consider-case &aux (alphabetic-case-affects-string-comparison consider-case) key-len) "Returns the index in STRING of the last occurrence before FROM of KEY, or NIL. If TO is non-zero, the search stops there, and the value is NIL if no occurrence of KEY is found after there. TO should normally be less than FROM. If FROM is omitted or NIL, the default is the end of the string. KEY-FROM and KEY-TO may be used to specify searching for just a substring of KEY. CONSIDER-CASE if non-NIL means we distinguish letters by case." (coerce-string-search-arg string) (coerce-string-arg key);?? (unless key-to (setq key-to (array-active-length key))) (setq key-len (- key-to key-from)) (or from (setq from (array-active-length string))) (setq to (+ to (1- key-len)));First position at which last char of key may be (cond ((zerop key-len) from) (t (do ((n (1- from) (1- n)) (ch1 (aref key (1- key-to)))) ((< n to) nil) (and (if consider-case (char= (aref string n) ch1) (char-equal (aref string n) ch1)) (%string-equal key key-from string (1+ (- n key-len)) key-len) (return (1+ (- n key-len)))))))) (eval-when (compile) (DEFMACRO nstring-modify-case (string to-uppercase-p start end) "Destructively change case if appropriate STRING is the string to be modified. TO-UPPERCASE if T means lower->upper modification, else upper->lower. START is the position in the string to start modifying. END is the position in the string to stop modifying. NIL means the end." ;;Modified 10/14/86 to support ISO characters ;;Modified 12/17/86 to speedup slowdowns introduced by ISO changes `(DO ((len (OR ,end (ARRAY-ACTIVE-LENGTH ,string))) (CHAR) (i ,start (1+ i))) ((= i len) ,string) (SETQ char (AREF ,string i)) (WHEN (AND (PLUSP (AREF ,(if to-uppercase-p 'char-upcase-vector 'char-downcase-vector) (CHAR-CODE char))) (ZEROP (CHAR-BITS char))) (SETF (AREF ,string i) (LOGXOR 32 char))))) ) (defun string-upcase (string &key (start 0) end) "Return a copy of STRING changing the specified portion to upper case. START - integer indicating where the conversion to upper case should begin. END - integer indicating where conversion should stop. Conversion stops just before this index. A NIL value for the END keyword implies the active length of the string. Note the default case is to convert the entire string to upper case." (setq string (string-append string));Copy so we don't mung original string (nstring-modify-case string t start end)) (defun string-downcase (string &key (start 0) end) "Return a copy of STRING changing the specified portion to lower case. START - integer indicating where the conversion to lower case should begin. END - integer indicating where conversion should stop. Conversion stops just before this index. A NIL value for the END keyword implies the active length of the string. Note the default case is to convert the entire string to lower case." (setq string (string-append string));Copy so we don't mung original string (nstring-modify-case string nil start end)) (DEFUN string-capitalize (string &optional &key (start 0) end spaces) "Return a copy of STRING changing the specified portion so that the first letter of each word is upper case. START - integer indicating where the conversion should begin. This letter is always converted to uppercase. END - integer indicating where the conversion should stop. Conversion stops just before this index. A NIL value for the END keyword implies the active length of the string. SPACES - If non-NIL, hyphens are converted to spaces. Note the default case is to capitalize every word in the string." (DECLARE (inline char-upcase char-downcase upper-case-p lower-case-p)) (SETQ string (STRING-APPEND string)) (DO ((i start (1+ i)) (len (OR end (LENGTH string))) prev-letter ch) ((= i len)) (SETQ ch (AREF string i)) (COND ((AND spaces (= ch #\-)) (SETF (AREF string i) #\SPACE) (SETQ prev-letter ())) ((UPPER-CASE-P ch) (WHEN prev-letter (SETF (AREF string i) (CHAR-DOWNCASE ch))) (SETQ prev-letter t)) ((LOWER-CASE-P ch) (UNLESS prev-letter (SETF (AREF string i) (CHAR-UPCASE ch))) (SETQ prev-letter t)) ((<= #\0 (CHAR-CODE ch) #\9) (SETQ prev-letter t)) (t (SETQ prev-letter ())))) string) (defun nstring-upcase (string &key (start 0) end) "Destructively modify STRING changing the specified portion to upper case. START - integer indicating where conversion should begin. END - integer indicating where conversion should stop. Conversion stops just before this index. A NIL value for the END keyword implies the active length of the string. Note the default case is to change the entire string to upper case." (nstring-modify-case string t start end)) ;;AB for PHD 6/19/87 Fixed to-upcase-p arg in the call to nstring-modify-case. (defun nstring-downcase (string &key (start 0) end) "Destructively modify STRING changing the specified portion to lower case. START - integer indicating where conversion should begin. END - integer indicating where conversion should stop. Conversion stops just before this index. A NIL value for the END keyword implies the active length of the string. Note the default case is to change the entire string to lower case." (nstring-modify-case string nil start end)) (DEFUN nstring-capitalize (string &optional &key (start 0) end spaces) "Destructively modify STRING changing the specified portion so that the first letter of each word is upper case. START - integer indicating where the conversion should begins. This letter is always converted to uppercase. END - integer indicating where the conversion should stop. COnversion stops just before this index. A NIL value for the END keyword implies the active length of the string. SPACES - If non-NIL, hyphens are converted to spaces. Note the default case is to capitalize every word in the string." (DECLARE (inline char-upcase char-downcase upper-case-p lower-case-p)) (DO ((i start (1+ i)) (len (OR end (LENGTH string))) prev-letter ch) ((= i len)) (SETQ ch (AREF string i)) (COND ((AND spaces (= ch #\-)) (SETF (AREF string i) #\SPACE) (SETQ prev-letter ())) ((UPPER-CASE-P ch) (WHEN prev-letter (SETF (AREF string i) (CHAR-DOWNCASE ch))) (SETQ prev-letter t)) ((LOWER-CASE-P ch) (UNLESS prev-letter (SETF (AREF string i) (CHAR-UPCASE ch))) (SETQ prev-letter t)) ((<= #\0 (CHAR-CODE ch) #\9) (SETQ prev-letter t)) (t (SETQ prev-letter ())))) string) (defun string-capitalize-words (string &optional (copy-p t) (spaces t)) "In STRING, turn hyphens to spaces and make each word be capitalized. If SPACES is NIL, hyphens are not changed. Copies the original string unless COPY-P is NIL, meaning mung the original." (or (and (not copy-p) (stringp string)) (setq string (string-append string))) (nstring-capitalize string :spaces spaces)) (defun string-remove-fonts (string) "Return a copy of STRING, with all characters changed to font 0. If STRING already has all characters in font 0, it may not be copied." (if (and (stringp string) (eq (array-type string) 'art-string)) string (let ((newstring (make-array (array-active-length string) :type art-string))) (copy-array-contents string newstring) newstring))) (defun ZLC:STRING-NREVERSE (string &aux len) "Destructively modify string by reversing the order of its elements. Actually, this will work on any one-dimensional array." (typecase string ((or fixnum character)) (t (typecase string (array) (symbol ;; Special treatment to avoid munging symbols (when (symbol-package string) (ferror () "Illegal to mung the PNAME of an interned symbol.")) (setq string (symbol-name string))) (t (coerce-string-arg string))) (setq len (array-active-length string)) (do ((i 0 (1+ i)) (j (1- len) (1- j))) ((< j i)) (rotatef (aref string i) (aref string j))))) string) (defun zlc:string-reverse (string) "Return a string whose elements are those of STRING, in reverse order. Actually, this will work on any one-dimensional array." (ZLC:STRING-NREVERSE (string-append string)) ) ;Internal function. (defun array-mem (function item array) (dotimes (i (array-active-length array)) (if (funcall function item (aref array i)) (return t)))) ;;; a CHARACTER-SET may be either a vector or a list of characters (or fixnums) ;;; or a single character. (defun string-search-set (char-set string &optional (from 0) to consider-case) "Returns the index in STRING of the first char past FROM that's in CHAR-SET, or NIL. CHAR-SET can be a list of characters or a string. If TO is non-NIL, the search stops there, and the value is NIL if no occurrence of a char in CHAR-SET is found before there. Case matters during character comparison if CONSIDER-CASE is non-NIL." (if (null char-set) (return-from string-search-set ())) (coerce-string-search-arg string) (or to (setq to (array-active-length string))) (let ((alphabetic-case-affects-string-comparison consider-case)) (typecase char-set (list (let (best this) (dolist (char char-set best) (when (setq this (%string-search-char char string from to)) (when (= this from) (return from));fast return (setq best (if best (min best this) this) to best))))) (array (let ((set-len (array-active-length char-set))) (do ((i from (1+ i))) ((>= i to) nil) (when (%string-search-char (aref string i) char-set 0 set-len) (return i))))) ((or fixnum character) (%string-search-char char-set string from to)) (t (ferror () "CHAR-SET ~s must be a character, string, or list of characters" char-set))))) (defun string-reverse-search-set (char-set string &optional from (to 0) consider-case) "Returns the index in STRING of the last char before FROM that's in CHAR-SET, or NIL. CHAR-SET can be a list of characters or a string. If TO is non-NIL, the search stops there, and the value is NIL if no occurrence of a char in CHAR-SET is found after there. TO is normally less than FROM. Case matters during character comparison if CONSIDER-CASE is non-NIL." (if (null char-set) (return-from string-reverse-search-set ())) (coerce-string-search-arg string) (or from (setq from (array-active-length string))) (let ((alphabetic-case-affects-string-comparison consider-case)) (etypecase char-set (list (do ((i (1- from) (1- i))) ((< i to) nil) (if consider-case (when (member (aref string i) char-set :test #'eq) (return-from string-reverse-search-set i)) (dolist (e char-set) (when (char-equal (aref string i) e) (return-from string-reverse-search-set i)))))) (array (let ((set-len (array-active-length char-set))) (do ((i (1- from) (1- i))) ((< i to) nil) (if (%string-search-char (aref string i) char-set 0 set-len) (return-from string-reverse-search-set i))))) ((or fixnum character) (do ((i (1- from) (1- i))) ((< i to) nil) (when (if consider-case (char= char-set (aref string i)) (char-equal char-set (aref string i))) (return-from string-reverse-search-set i))))))) (defun string-search-not-set (char-set string &optional (from 0) to consider-case &aux (alphabetic-case-affects-string-comparison consider-case)) "Returns the index in STRING of the first char past FROM that's NOT in CHAR-SET, or NIL. CHAR-SET can be a list of characters or a string. If TO is non-NIL, the search stops there, and the value is NIL if no occurrence of a char not in CHAR-SET is found before there. Case matters during character comparison if CONSIDER-CASE is non-NIL." (if (null char-set) (return-from string-search-not-set ())) (coerce-string-search-arg string) (or to (setq to (array-active-length string))) (let ((compare-fct (if consider-case #'char= #'char-equal))) (etypecase char-set (array (do ((i from (1+ i))) ((>= i to) nil) (unless (%string-search-char (aref string i) char-set 0 (length char-set)) (return-from string-search-not-set i)))) (list (do ((i from (1+ i))) ((>= i to) nil) (unless (if consider-case (member (aref string i) char-set :test #'eq) (dolist (e char-set) (when (char-equal (aref string i) e) (return e)))) (return-from string-search-not-set i)))) ((or character fixnum) (do ((i from (1+ i))) ((>= i to) nil) (unless (funcall compare-fct char-set (aref string i)) (return-from string-search-not-set i))))))) (defun string-reverse-search-not-set (char-set string &optional from (to 0) consider-case &aux (alphabetic-case-affects-string-comparison consider-case)) "Returns the index in STRING of the last char before FROM that's NOT in CHAR-SET, or NIL. CHAR-SET can be a list of characters or a string. If TO is non-NIL, the search stops there, and the value is NIL if no occurrence of a char not in CHAR-SET is found after there. TO is normally less than FROM. Case matters during character comparison if CONSIDER-CASE is non-NIL." (if (null char-set) (return-from string-reverse-search-not-set ())) (coerce-string-search-arg string) (or from (setq from (array-active-length string))) (let ((compare-fct (if consider-case #'char= #'char-equal))) (etypecase char-set (list (do ((i (1- from) (1- i))) ((< i to) nil) (unless (if consider-case (member (aref string i) char-set :test #'eq) (dolist (e char-set) (when (char-equal (aref string i) e) (return e)))) (return-from string-reverse-search-not-set i)))) (array (do ((i (1- from) (1- i))) ((< i to) nil) (unless (%string-search-char (aref string i) char-set 0 (length char-set)) (return-from string-reverse-search-not-set i)))) ((or fixnum character) (do ((i (1- from) (1- i))) ((< i to) nil) (unless (funcall compare-fct char-set (aref string i)) (return-from string-reverse-search-not-set i))))))) (defun string-trim (char-set string &aux i j) "Return a copy of STRING with all characters in CHAR-SET removed at both ends. CHAR-SET can be a list of characters or a string." (coerce-string-arg string) (setq i (string-search-not-set char-set string 0 () t)) (cond ((null i) "") (t (setq j (string-reverse-search-not-set char-set string () 0 t)) (ZLC:SUBSTRING string i (1+ j))))) (defun string-left-trim (char-set string &aux i) "Return a copy of STRING with all characters in CHAR-SET removed at the beginning. CHAR-SET can be a list of characters or a string." (coerce-string-arg string) (setq i (string-search-not-set char-set string 0 () t)) (cond (i (ZLC:SUBSTRING string i (length string))) (t ""))) (defun string-right-trim (char-set string &aux i) "Return a copy of STRING with all characters in CHAR-SET removed at the end. CHAR-SET can be a list of characters or a string." (coerce-string-arg string) (setq i (string-reverse-search-not-set char-set string () 0 t)) (cond (i (ZLC:SUBSTRING string 0 (1+ i))) (t ""))) (defun string-subst-char (new old string &optional (copy-p t) (retain-font-p t)) "Substitute the NEW character at every occurence of OLD in STRING. Copies the original string unless COPY-P is NIL, meaning mung the original. If RETAIN-FONT-P is T, then the font of each repective OLD character is retained. As of now, case is ignored in comparisons." (or (and (not copy-p) (stringp string)) (setq string (string-append string))) (let ((end (ZLC:STRING-LENGTH string))) (do ((new (character new)) (old (character old)) (i (%string-search-char old string 0 end) (%string-search-char old string i end))) ((null i)) (setf (aref string i) (cond (retain-font-p (deposit-field new %%ch-char (aref string i))) (t new))))) string) ;;; T means case matters in string comparisons, NIL means it is ignored. ;;; This is bound to T by certain routines, such as INTERN, but I do not ;;; recommend changing its global value to T rather than NIL; many system ;;; functions, or at least their user interfaces, assume that string ;;; comparison is case-insensitive. (defvar alphabetic-case-affects-string-comparison :unbound "Microcode flag which controls whether %STRING-EQUAL and %STRING-SEARCH consider case.") (defun string-compare (str1 str2 &optional (idx1 0) (idx2 0) lim1 lim2) "Compares the two substrings in dictionary order, ignoring case. Returns a positive number if STR1>STR2. Returns zero if STR1=STR2. Returns a negative number if STR1= idx1 lim1) (return (if (< idx2 lim2) (- (1+ idx1)) 0))) (and (>= idx2 lim2) (return (1+ idx1))) (cond ((char-equal (aref str1 idx1) (aref str2 idx2)) (setq idx1 (1+ idx1) idx2 (1+ idx2)) (go l))) (and (char-lessp (aref str1 idx1) (aref str2 idx2)) (return (- (1+ idx1)))) (return (1+ idx1)))) (defun string-compare-case (str1 str2 &optional (idx1 0) (idx2 0) lim1 lim2) "Compares the two substrings in dictionary order, considering case. Returns a positive number if STR1>STR2. Returns zero if STR1=STR2. Returns a negative number if STR1= idx1 lim1) (return (if (< idx2 lim2) (- (1+ idx1)) 0))) (and (>= idx2 lim2) (return (1+ idx1))) (cond ((= (aref str1 idx1) (aref str2 idx2)) (setq idx1 (1+ idx1) idx2 (1+ idx2)) (go l))) (and (< (aref str1 idx1) (aref str2 idx2)) (return (- (1+ idx1)))) (return (1+ idx1)))) (defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is less than that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare-case string1 string2 start1 start2 end1 end2))) (if (minusp v) (1- (abs v))))) (defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is greater than that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare-case string1 string2 start1 start2 end1 end2))) (if (plusp v) (1- (abs v))))) (deff zlc:string 'string<=) (defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is less than or equal to that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare-case string1 string2 start1 start2 end1 end2))) (cond ((minusp v) (abs (1+ v))) ((zerop v) (- (or end1 (length string1)) start1))))) (deff zlc:string 'string>=) (defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is greater than or equal to that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare-case string1 string2 start1 start2 end1 end2))) (cond ((plusp v) (1- v)) ((zerop v) (- (or end1 (length string1)) start1))))) (deff zlc:string 'string/=) (defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portions of STRING1 and STRING2 are different. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare-case string1 string2 start1 start2 end1 end2))) (unless (zerop v) (1- (abs v))))) (defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is less than that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case is not significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare string1 string2 start1 start2 end1 end2))) (if (minusp v) (1- (abs v))))) (defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is greater than that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case not is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare string1 string2 start1 start2 end1 end2))) (if (plusp v) (1- (abs v))))) (defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is not greater than that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case not is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare string1 string2 start1 start2 end1 end2))) (cond ((minusp v) (abs (1+ v))) ((zerop v) (- (or end1 (length string1)) start1))))) (defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) "Returns a number if the specified portion of STRING1 is not less than that of STRING2, in dictionary order. The number returned is actually the index, relative to STRING1, of the first difference between the strings. Case not is significant in comparing characters. START1, START2 - integers indicating where comparison should begin in STRING1 and STRING2 respectively. END1, END2 - integers indicating where comparison should stop in STRING1 and STRING2 respectively. Comparison stops just before this index. A NIL value for either END keyword implies the active length of the string. Note the default case is to use the entirety of both strings." (let ((v (string-compare string1 string2 start1 start2 end1 end2))) (cond ((plusp v) (1- v)) ((zerop v) (- (or end1 (length string1)) start1))))) (defun alphalessp (x y) "T if printed representation of X is less than that of Y. Characters and numbers come before symbols/strings, before random objects, before lists. Characters and numbers are compared using CHAR<; symbols/strings with STRING-LESSP; random objecs by printing them(!); lists are compared recursively." (cond ((or (numberp x) (characterp x)) (or (not (or (numberp y) (characterp y))) (char< x y))) ((or (numberp y) (characterp y)) nil) ((or (symbolp x) (stringp x)) (or (not (or (symbolp y) (stringp y))) (string-lessp x y))) ((or (symbolp y) (stringp y)) nil) ((atom x) (or (consp y) (string-lessp (prin1-to-string x) (prin1-to-string y)))) ((atom y) nil) (t (do ((x1 x (cdr x1)) (y1 y (cdr y1))) ((null y1)) (or x1 (return t)) (and (alphalessp (car x1) (car y1)) (return t)) (and (alphalessp (car y1) (car x1)) (return ())))))) (defun alphaequal (x y) "T if X and Y print the same, or nearly so. Exceptions: numbers and characters are compared using CHAR= and a symbol and its pname compare as equal." (typecase x ((or number character) (and (or (numberp y) (characterp y)) (char= x y))) ((or symbol string) (and (or (symbolp y) (stringp y)) (string-equal x y))) (atom (and (atom y) (string-equal (prin1-to-string x) (prin1-to-string y)))) (t (do ((x1 x (cdr x1)) (y1 y (cdr y1))) ((null x1) (null y1)) (or y1 (return ())) (or (alphaequal (car x1) (car y1)) (return ())))))) (defun zlc:string (x) "Convert X to a string if possible." (typecase x (string x) (symbol (symbol-name x)) ;; this kludginess is due to the fact that (typep x 'string-char) loses on fixnums ;; and that string-char-p blows out on non-character non-fixnums ((or string-char (and fixnum (satisfies string-char-p))) (values (make-array 1 :element-type 'string-char :initial-value x))) (t (or (and (instancep x) (send x :send-if-handles :string-for-printing)) (ferror () "Cannot convert ~S into a string." x))))) (defun string-aux (x) (typecase x (string-char (values (make-array 1 :element-type 'string-char :initial-value x))) (t (or (and (instancep x) (send x :send-if-handles :string-for-printing)) (ferror () "Cannot convert ~S into a string." x))))) (proclaim '(inline cli:string)) (defun cli:string (x) "Convert X to a string if X is a symbol, a string or a string character." (typecase x (symbol (symbol-name x)) (string x) (T (string-aux x)))) ;; 4/14/89 DNG - Fixed for words ending in F, such as "leaf" -> "leaves", "half" -> "halves". (defun string-pluralize (string) "Return a plural form of STRING. Attempts to preserve the case-pattern in STRING." (DECLARE (inline char-upcase)) (coerce-string-arg string) (if (equal string "") "" (let* (flush add (last-char-raw (aref string (1- (length string)))) (last-char (char-upcase last-char-raw)) (last-char-lc-flag (/= last-char last-char-raw)) (penult-char (char-upcase (if (> (length string) 1) (aref string (- (length string) 2)) 0))) (last-3 (ZLC:SUBSTRING string (max 0 (- (length string) 3))))) (cond ((and (char-equal last-char #\Y) (not (member penult-char '(#\A #\E #\I #\O #\U) :test #'eq))) (setq flush 1 add "ies")) ((or (string-equal string "ox") (string-equal string "vax")) (setq add "en")) ((or (and (= last-char #\H) (member penult-char '(#\C #\S) :test #'eq)) (member last-char '(#\S #\Z #\X) :test #'eq)) (setq add "es")) ((string-equal last-3 "man") (setq flush 2 add "en")) ((string-equal last-3 "fan") (setq flush 2 add "en")) ((string-equal last-3 "ife") (setq flush 2 add "ves")) ((and (= last-char #\F) (member penult-char '(#\L #\A))) (setq flush 1 add "ves")) ; 4/14/89 DNG (t (setq add "s"))) (and flush (setq string (ZLC:SUBSTRING string 0 (- (length string) flush)))) (cond (add (string-append string (cond (last-char-lc-flag add) (t (string-upcase add))))) (t string))))) (defun string-append-a-or-an (noun-string &rest more-strings) "Appends the strings, with \"a \" or \"an \" added in front." (apply 'string-append (string-select-a-or-an noun-string) " " noun-string more-strings)) (defvar *alphabet* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" "A string containing all the upper case and all the lower case letters.") (defun string-select-a-or-an (string) "Returns \"a\" or \"an\", lowercase, according to contents of STRING." (setq string (string string)) (let ((len (length string)) (idx (string-search-not-set *alphabet* string))) (cond ((zerop len) "a");random ((= len 1) (cond ((member (char-upcase (aref string 0)) '(#\A #\E #\F #\H #\I #\L #\M #\N #\O #\R #\S #\X) :test #'eq) "an") (t "a"))) ((or (%string-equal "EU" 0 string 0 2) (and (> (or idx len) 4) (%string-equal "UNI" 0 string 0 3) (or (member (char-upcase (aref string 3)) '(#\A #\E #\I #\O #\U #\Y) :test #'eq) (member (char-upcase (aref string 4)) '(#\A #\E #\I #\O #\U #\Y) :test #'eq)))) "a") ((and (> (or idx len) 2) (= (char-upcase (aref string 0)) #\U) (= (char-upcase (aref string 2)) #\E)) "a") ((member (char-upcase (aref string 0)) '(#\A #\E #\I #\O #\U) :test #'eq) "an") (t "a")))) ;;PAD 2/3/87 Call parse-integer (defun parse-number (string &optional (from 0) to radix fail-if-not-whole-string) "Return a number parsed from the contents of STRING, or a part of it. FROM and TO specify the part of the string; TO = NIL means the end of it. RADIX defaults to decimal. If the string or part doesn't start with a number, NIL is returned. The second value is the index in STRING of the first non-digit, or NIL if none. FAIL-IF-NOT-WHOLE-STRING means return NIL and 0 unless the whole string or specified part can be parsed as a number." (let ((real-end (or to (length string)))) (multiple-value-bind (num index) (parse-integer string :start from :end real-end :radix (or radix 10.) :junk-allowed t ) (if fail-if-not-whole-string (if (= index real-end) (values num index) (values nil 0)) (values num (and num index)))))) (defun number-into-array (array n &optional (radix *print-base*) (at-index 0) (min-columns 0)) "Store a printed representation of the fixnum N into ARRAY starting at AT-INDEX. The index of the first element of ARRAY not stored into and the new value of ARRAY are returned. (ARRAY is munged) RADIX, which defaults to *PRINT-BASE*, is used for conversion. Leading spaces are used to fill up at least MIN-COLUMNS columns." (declare (values new-index array)) (multiple-value-bind (quot digit) (truncate n radix) (if (zerop quot) (dotimes (i (1- min-columns)) (setf (aref array at-index) #\SPACE) (setq at-index (1+ at-index))) (setq at-index (number-into-array array quot radix at-index (1- min-columns)))) (setf (aref array at-index) (if (< digit 10) (+ digit #\0) (+ digit #\A -10))) (values (1+ at-index) array))) ;;; Add an array to the end of another (defun append-to-array (to-array from-array &optional (from-start 0) from-end &aux old-length new-length) "Append the contents of FROM-ARRAY to TO-ARRAY, modifying the latter. FROM-START and FROM-END specify the part of FROM-ARRAY to use." (or from-end (setq from-end (array-active-length from-array))) (setq new-length (+ (setq old-length (array-leader to-array 0)) (- from-end from-start))) (and (< (array-total-size to-array) new-length) (adjust-array to-array new-length)) (copy-array-portion from-array from-start from-end to-array old-length new-length) (store-array-leader new-length to-array 0))