;;; -*- Mode:LISP; -*-î
î
;;; FAKE-STRING: Package for manipulating fake strings as real stringsî
î
;;; `fake' string definitions for:î
;;;î
;;; (STRINGP obj)		- Returns T if obj is a fake string.î
;;; (CHARACTER s)		- Coerces a string to a character.î
;;; (CHAR-UPCASE c)		- Uppercases a character.î
;;; (CHAR-DOWNCASE c)		- Lowercases a character.î
;;; (STRING-UPCASE s)		- Uppercases a string.î
;;; (STRING-DOWNCASE s)		- Lowercases a string.î
;;; (STRING-APPEND s1 s2 ...)	- Appends any number of strings together.î
î
;;; *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON*      - T or NIL global flag.î
;;; (STRING symbol)                                  - Creates a string.î
;;; (STRING-LENGTH s)                                - Returns number of chars.î
;;; (SUBSTRING s start &optional end)                - Takes substrings.î
;;; (STRING-SEARCH key s1 &optional start end)       - Searches for strings.î
î
;;; Package created and maintained by KMP@MC.î
;;; Kludgey enhancements courtesy of CSTACY@MC.î
î
(SSTATUS FEATURE FAKE-S)î
î
(EVAL-WHEN (EVAL COMPILE)î
  (IF (NOT (GET 'UMLMAC 'VERSION))î
      (LOAD '((DSK LISP)   UMLMAC FASL))))î
î
î
;;; Gloabl variable for users to control case sensitivity during comparisons. î
î
(DECLARE (SPECIAL *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON*))î
î
î
(SETQ *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON* NIL)î
î
î
;;; (STRINGP x)î
;;;î
;;; Predicate returns true iff x is a fake string, otherwise returns false.î
;;;î
;;; Note: Because of the way Maclisp implements fake strings, SYMBOLP willî
;;;       also return true for fake strings. Hence, in any case where î
;;;	  dispatching is being done on type, do the STRINGP check before theî
;;;	  SYMBOLP check as in:î
;;;î
;;;	(COND ...î
;;;           ((STRINGP x) ...) ;Check strings firstî
;;;	      ((SYMBOLP x) ...) ;Things that aren't STRINGP are `real' symbolsî
;;;	      ...)î
î
(DEFUN STRINGP (X)î
  (AND (SYMBOLP X) (GET X '+INTERNAL-STRING-MARKER)))î
î
;;; (STRING-EQUAL string1 string2)î
;;;î
;;; Predicate compares string1 and string2 returning true iff string1 î
;;; and string2 represent the same string. Case is not significant in î
;;; comparisons.î
î
(DEFUN STRING-EQUAL (S1 S2)î
  (IF (FIXP S1) (SETQ S1 (CHAR-UPCASE S1)))î
  (IF (FIXP S2) (SETQ S2 (CHAR-UPCASE S2)))î
  (COND ((FIXP S1)î
	 (COND ((FIXP S2) (= S1 S2))î
	       ((SYMBOLP S2)î
		(LET ((PNAME (PNGET S2 7.)))î
		  (AND (NULL (CDR PNAME))î
		       (= (CAR PNAME) (LSH S1 #o35)))))î
	       (T (ERROR "Not a string -- STRING-EQUAL" S2))))î
	((SYMBOLP S1)î
	 (COND ((FIXP S2)î
		(LET ((PNAME (PNGET S1 7.)))î
		  (AND (NULL (CDR PNAME))î
		       (= (CAR PNAME) (LSH S2 #o35)))))î
	       ((SYMBOLP S2)î
		(DO ((L1 (PNGET S1 7.) (CDR L1))î
		     (L2 (PNGET S2 7.) (CDR L2))î
		     (CHAR1 0.) (CHAR2 0.))î
		    ((NULL L1) (NULL L2))î
		  (DECLARE (FIXNUM CHAR1 CHAR2))î
		  (IF (NULL L2) (RETURN NIL))î
		  (LET ((W1 (FIXNUM-IDENTITY (CAR L1)))î
			(W2 (FIXNUM-IDENTITY (CAR L2))))î
		    (DECLARE (FIXNUM W1 W2))î
		    (IF (AND (NOT (= W1 W2))î
			     (DO ((BP #o3507 (- BP #o700)))î
				 ((MINUSP BP) NIL)î
			       (DECLARE (FIXNUM BP))î
			       (SETQ CHAR1 (LDB BP W1)î
				     CHAR2 (LDB BP W2))î
			       (COND ((NOT *ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON*)î
				      (IF (NOT (OR (< CHAR1 #/a)î
						   (> CHAR1 #/z)))î
					  (SETQ CHAR1 (+ CHAR1 #.(- #/A #/a))))î
				      (IF (NOT (OR (< CHAR2 #/a)î
						   (> CHAR2 #/z)))î
					  (SETQ CHAR2 (+ CHAR2 #.(- #/A #/a))))))î
			       (IF (NOT (= CHAR1 CHAR2))î
				   (RETURN T))))î
			(RETURN NIL)))))î
	       (T (ERROR "Not a string -- STRING-EQUAL" S2))))î
	(T (ERROR "Not a string -- STRING-EQUAL" S1))))î
î
î
î
î
;;; (CHARACTER x)î
;;;î
;;; Coerces x to be a character in fixnum representation.î
;;; If x is a fixnum, it is returned.î
;;; If x is a symbol, the first character of its pname is returned.î
;;; If x is a fake string, its first character is returned.î
î
(DEFUN CHARACTER (X)î
  (COND ((SYMBOLP X) (GETCHARN X 1.))î
	((FIXP X) X)î
	(T (ERROR "Not a string -- CHARACTER" X))))î
î
;;; (STRING-APPEND string1 string2 string3 ...)î
;;;î
;;; Returns a string which is the concatenation of the given strings.î
î
(DEFUN STRING-APPEND NARGSî
  (DECLARE (FIXNUM NARGS))î
  (DO ((STRING "" (COND ((FIXP (ARG I)) (FORMAT NIL "~A~C" STRING (ARG I)))î
			((SYMBOLP (ARG I)) (FORMAT NIL "~A~A" STRING (ARG I)))î
			(T (ERROR "Not a string -- STRING-APPEND" (ARG I)))))î
       (I 1 (1+ I)))î
      ((> I NARGS) STRING)î
    (DECLARE (FIXNUM I))))î
î
;;; (STRING-UPCASE string)î
;;;î
;;; Returns an uppercased copy of string.î
î
(DEFUN STRING-UPCASE (STRING)î
  (DO ((L (+INTERNAL-GET-PNAME STRING 'STRING-UPCASE) (CDR L))î
       (NEW-L NIL))î
      ((NULL L) (+INTERNAL-MAKE-STRING (NREVERSE NEW-L)))î
    (DO ((WORD (FIXNUM-IDENTITY (CAR L)))î
	 (BP   #o3507	        (- BP #o700))î
	 (NEW  0.	        (DPB CHAR BP NEW))î
	 (CHAR 0.))î
	((MINUSP BP) (PUSH NEW NEW-L))î
      (DECLARE (FIXNUM WORD BP NEW CHAR))î
      (COND ((NOT (OR (< (SETQ CHAR (LDB BP WORD)) #/a) (> CHAR #/z)))î
	     (SETQ CHAR (+ CHAR #.(- #/A #/a))))))))î
î
;;; (STRING-DOWNCASE string)î
;;;î
;;; Returns a lowercased copy of string.î
î
(DEFUN STRING-DOWNCASE (STRING)î
  (DO ((L (+INTERNAL-GET-PNAME STRING 'STRING-DOWNCASE) (CDR L))î
       (NEW-L NIL))î
      ((NULL L) (+INTERNAL-MAKE-STRING (NREVERSE NEW-L)))î
    (DO ((WORD (FIXNUM-IDENTITY (CAR L)))î
	 (BP   #o3507	        (- BP #o700))î
	 (NEW  0.	        (DPB CHAR BP NEW))î
	 (CHAR 0.))î
	((MINUSP BP) (PUSH NEW NEW-L))î
      (DECLARE (FIXNUM WORD BP NEW CHAR))î
      (COND ((NOT (OR (< (SETQ CHAR (LDB BP WORD)) #/A) (> CHAR #/Z)))î
	     (SETQ CHAR (+ CHAR #.(- #/a #/A))))))))î
î
î
;;; (CHAR-UPCASE C)î
;;;î
;;; Returns the character C in uppercase.î
î
(DEFUN CHAR-UPCASE (C)î
  (COND ((NOT (FIXP C)) (ERROR "Not a character -- CHAR-UPCASE"))î
	((OR (< C #/a) (> C #/z)) C)î
	(T (+ C #.(- #/A #/a)))))î
î
;;; (CHAR-DOWNCASE C)î
;;;î
;;; Returns the character C in lowercase.î
î
(DEFUN CHAR-DOWNCASE (C)î
  (COND ((NOT (FIXP C)) (ERROR "Not a character -- CHAR-DOWNCASE"))î
	((OR (< C #/A) (> C #/Z)) C)î
	(T (+ C #.(- #/a #/A)))))î
î
î
;;;; Kludgey enhancements.î
î
;;; (STRING Symbol)î
î
(DEFUN STRING (SYMBOL)î
  (IF (NOT (SYMBOLP SYMBOL))î
      (ERROR "Not a symbol -- ~A" SYMBOL 'STRING))î
  (LET ((FOO (COPYSYMBOL SYMBOL T)))î
    (PUTPROP FOO T '+INTERNAL-STRING-MARKER)î
    FOO))î
î
î
;;; (STRING-LENGTH String)î
;;;î
;;; Returns the number of characters in String.î
î
(DEFUN STRING-LENGTH (STRING)î
  (- (FLATSIZE STRING) 2))    ;; FLATC doesn't work right for strings, sigh.î
î
î
;;; (SUBSTRING String Start &optional End)î
;;; î
;;; Extracts a substring of String, from Start up to End,î
;;; not including End.  Origins are zero based.î
;;; If End is not specified, get the rest of the string from Start.î
î
(DEFUN SUBSTRING (STRING START &OPTIONAL END)î
  (SETQ STRING (STRING STRING)) ;Coerce so symbols work.î
  (IF (NULL END)î
      (SETQ END (STRING-LENGTH STRING)))î
  (LET ((N 0)î
	(RESULT-BP #O3507)î
	(NEW-WORD 0)î
	(NEW-WORDS))î
    (DO ((WORDS (+INTERNAL-GET-PNAME STRING 'SUBSTRING) (CDR WORDS)))î
	((NULL WORDS) (STRING-APPEND (+INTERNAL-MAKE-STRING (NREVERSE NEW-WORDS))))î
      (DO ((WORD (CAR WORDS) (CAR WORDS))î
	   (BP   #O3507      (- BP #O700))î
	   (CHAR 0.))î
	  ((MINUSP BP))î
	(SETQ CHAR (LDB BP WORD))î
	(WHEN (AND (NOT (ZEROP CHAR)) ;;FLUSH NULS.î
		   (>= N START)î
		   (< N  END))î
	  (SETQ NEW-WORD (DPB CHAR RESULT-BP NEW-WORD))î
	  (SETQ RESULT-BP (- RESULT-BP #O700))î
	  (WHEN (OR (MINUSP RESULT-BP)î
		    (<= N (STRING-LENGTH STRING)))î
	    (PUSH NEW-WORD NEW-WORDS)î
	    (SETQ NEW-WORD 0)î
	    (SETQ RESULT-BP #O3507)))î
	(SETQ N (1+ N))))))î
î
î
;;; This version will probably CONS a lot of list structure insideî
;;; SUBSTRING, but it was the easiest way to write it.î
î
(DEFUN STRING-SEARCH  (KEY STRING &OPTIONAL (START 0) END)î
  (IF (NULL END)î
      (SETQ END (STRING-LENGTH STRING)))î
  (COND ((ZEROP (+ (STRING-LENGTH STRING) (STRING-LENGTH KEY)))î
	 0)î
	(T (*CATCH 'FOUND-ITî
	 (DO ((N START (1+ N)))î
	     ((OR (= N (STRING-LENGTH STRING))î
		  (> (STRING-LENGTH KEY) (- (STRING-LENGTH STRING) N))î
		  (= N END))î
	      NIL)î
	   (IF (STRING-EQUAL KEY (SUBSTRING STRING Nî
					    (+ N (STRING-LENGTH KEY))))î
	       (*THROW 'FOUND-IT N)))))))î
î
î
î
î
î
;;; Utility functions. Not for use by users.î
î
;;; Takes a symbol, fake string, or fixnum and returns its pname.î
î
(DEFUN +INTERNAL-GET-PNAME (STRING FN)î
  (COND ((SYMBOLP STRING) (PNGET STRING 7.))î
	((FIXP STRING) (NCONS (LSH STRING #o35)))î
	(T (ERROR "Not a string -- ~A" STRING FN))))î
î
;;; Takes a pname and returns a fake string.î
î
(DEFUN +INTERNAL-MAKE-STRING (PNAME)î
  (SETQ PNAME (PNPUT PNAME NIL))î
  (PUTPROP PNAME T '+INTERNAL-STRING-MARKER)î
  PNAME)î
î
î
;;; Local Modes:;î
;;; Mode:LISP;î
;;; Lisp IF Indent:2;î
;;; End:;î
