From 8646b9afb9979064c3b0b79990c064dce7cb12b7 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Sat, 12 Oct 2002 06:10:17 +0000
Subject: [PATCH] r2976: *** empty log message ***

---
 debian/changelog |   6 ++
 equal.lisp       | 113 ++++++++++++++++++++
 genutils.lisp    | 262 ++---------------------------------------------
 kmrcl.asd        |   4 +-
 strings.lisp     | 150 +++++++++++++++++++++++++++
 5 files changed, 278 insertions(+), 257 deletions(-)
 create mode 100644 equal.lisp
 create mode 100644 strings.lisp

diff --git a/debian/changelog b/debian/changelog
index f8fb5db..ea6b675 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-kmrcl (1.2-1) unstable; urgency=low
+
+  * Seperate string and equal functions into their own files
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Sat, 12 Oct 2002 00:03:18 -0600
+
 cl-kmrcl (1.1-1) unstable; urgency=low
 
   * Re-arrange defclass order in ml-classes.lisp for cmucl compatibility
diff --git a/equal.lisp b/equal.lisp
new file mode 100644
index 0000000..b773db0
--- /dev/null
+++ b/equal.lisp
@@ -0,0 +1,113 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          equal.lisp
+;;;; Purpose:       Generalized equal function for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: equal.lisp,v 1.1 2002/10/12 06:10:17 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package :kmrcl)
+(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+
+  
+(defun generalized-equal (obj1 obj2)
+  (if (not (equal (type-of obj1) (type-of obj2)))
+      (progn
+	(terpri)
+	(describe obj1)
+	(describe obj2)
+	nil)
+    (typecase obj1
+      (double-float
+       (let ((diff (abs (/ (- obj1 obj2) obj1))))
+	 (if (> diff (* 10 double-float-epsilon))
+	     nil
+	   t)))
+      (complex
+       (and (generalized-equal (realpart obj1) (realpart obj2))
+	    (generalized-equal (imagpart obj1) (imagpart obj2))))
+      (standard-xstructure
+       (generalized-equal-fielded-object obj1 obj2))
+      (standard-object
+       (generalized-equal-fielded-object obj1 obj2))
+      (hash-table
+       (generalized-equal-hash-table obj1 obj2)
+       )
+      (function
+       (generalized-equal-function obj1 obj2))
+      (string
+       (string= obj1 obj2))
+      (array
+       (generalized-equal-array obj1 obj2))
+      (t
+       (equal obj1 obj2)))))
+
+
+(defun generalized-equal-function (obj1 obj2)
+  (string= (function-to-string obj1) (function-to-string obj2)))
+
+(defun generalized-equal-array (obj1 obj2)
+  (block test
+    (when (not (= (array-total-size obj1) (array-total-size obj2)))
+      (return-from test nil))
+    (dotimes (i (array-total-size obj1))
+      (unless (generalized-equal (aref obj1 i) (aref obj2 i))
+	(return-from test nil)))
+    (return-from test t)))
+
+(defun generalized-equal-hash-table (obj1 obj2)
+  (block test
+    (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
+      (return-from test nil))
+    (maphash
+     #'(lambda (k v)
+	 (multiple-value-bind (value found) (gethash k obj2)
+	   (unless (and found (generalized-equal v value))
+	     (return-from test nil))))
+     obj1)
+    (return-from test t)))
+
+(defun generalized-equal-fielded-object (obj1 obj2)
+  (block test
+    (when (not (equal (class-of obj1) (class-of obj2)))
+      (return-from test nil))
+    (dolist (field (class-slot-names (class-name (class-of obj1))))
+      (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
+	(return-from test nil)))
+    (return-from test t)))
+
+#+(or allegro lispworks)
+(defun class-slot-names (class-name)
+  "Given a CLASS-NAME, returns a list of the slots in the class."
+  (mapcar #'clos:slot-definition-name
+	  (clos:class-slots (find-class class-name))))
+
+#-(or allegro lispworks)
+(defun class-slot-names (class-name)
+  (warn "class-slot-names not supported on this platform"))
+
+
+(defun function-to-string (obj)
+  "Returns the lambda code for a function. Relies on
+Allegro implementation-dependent features."
+  (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
+    (declare (ignore closurep))
+    (if lambda
+	  (format nil "#'~s" lambda)
+      (if name
+	  (format nil "#'~s" name)
+	(progn
+	  (print obj)
+	  (break))))))
+
diff --git a/genutils.lisp b/genutils.lisp
index e753e62..09b14fa 100644
--- a/genutils.lisp
+++ b/genutils.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: genutils.lisp,v 1.4 2002/10/11 00:27:01 kevin Exp $
+;;;; $Id: genutils.lisp,v 1.5 2002/10/12 06:10:17 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -18,8 +18,7 @@
 
 
 (in-package :kmrcl)
-
-(declaim (optimize (speed 3) (safety 1)))
+(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
 
 (defmacro bind-when ((bind-var boundForm) &body body)
   `(let ((,bind-var ,boundForm))
@@ -291,171 +290,14 @@
 	 (concatenate 'string accum (funcall func a b)))
       accum)))
   
-;;; Strings
-
-(defmacro string-append (outputstr &rest args)
-  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
-
-(defmacro string-field-append (outputstr &rest args)
-  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
-
-(defun list-to-string (lst)
-  "Converts a list to a string, doesn't include any delimiters between elements"
-  (format nil "~{~A~}" lst))
-
-(defun count-string-words (str)
-  (declare (simple-string str)
-	   (optimize (speed 3) (safety 0)))
-  (let ((n-words 0)
-	(in-word nil))
-    (declare (fixnum n-words))
-    (dotimes (i (length str))
-      (let ((ch (char str i)))
-	(declare (character ch))
-	(if (alphanumericp ch)
-	    (unless in-word
-	      (incf n-words)
-	      (setq in-word t))
-	  (setq in-word nil))))
-    n-words))
-
-#+excl
-(defun delimited-string-to-list (string &optional (separator #\space))
-  (excl:delimited-string-to-list string separator))
-
-#-excl
-(defun delimited-string-to-list (sequence &optional (separator #\space))
-"Split a string by a delimitor"
-  (loop
-      with start = 0
-      for end = (position separator sequence :start start)
-      collect (subseq sequence start end)
-      until (null end)
-      do
-    (setf start (1+ end))))
-
-#+excl
-(defun list-to-delimited-string (list &optional (separator #\space))
-  (excl:list-to-delimited-string list separator))
-
-#-excl
-(defun list-to-delimited-string (list &optional (separator #\space))
-  (let ((output (when list (format nil "~A" (car list)))))
-    (dolist (obj (rest list))
-      (setq output (concatenate 'string output
-				(format nil "~A" separator)
-				(format nil "~A" obj))))
-    output))
-
-(defun string-invert (str)
-  "Invert case of a string"
-  (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
-           (simple-string str))
-  (let ((up nil) (down nil))
-    (block skip
-      (loop for char of-type character across str do
-	    (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
-		  ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
-      (if up (string-downcase str) (string-upcase str)))))
-
-(defun add-sql-quotes (s)
-  (substitute-string-for-char s #\' "''"))
-
-(defun escape-backslashes (s)
-  (substitute-string-for-char s #\\ "\\\\"))
-
-(defun substitute-string-for-char (procstr match-char subst-str) 
-"Substitutes a string for a single matching character of a string"
-  (let ((pos (position match-char procstr)))
-    (if pos
-	(concatenate 'string
-	  (subseq procstr 0 pos) subst-str
-	  (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
-      procstr)))
-
-(defun string-substitute (string substring replacement-string)
-  "String substitute by Larry Hunter. Obtained from Google"
-  (let ((substring-length (length substring))
-	(last-end 0)
-	(new-string ""))
-    (do ((next-start
-	  (search substring string)
-	  (search substring string :start2 last-end)))
-	((null next-start)
-	 (concatenate 'string new-string (subseq string last-end)))
-      (setq new-string
-	(concatenate 'string
-	  new-string
-	  (subseq string last-end next-start)
-	  replacement-string))
-      (setq last-end (+ next-start substring-length)))))
-
-
-(defun string-trim-last-character (s)
-"Return the string less the last character"
-  (subseq s 0 (1- (length s))))
-
-(defun string-hash (str &optional (bitmask 65535))
-  (let ((hash 0))
-    (declare (fixnum hash)
-	     (simple-string str))
-    (dotimes (i (length str))
-      (declare (fixnum i))
-      (setq hash (+ hash (char-code (char str i)))))
-    (logand hash bitmask)))
-
-(defun string-not-null? (str)
-  (and str (not (zerop (length str)))))
-  
-(defun whitespace? (c) 
-  (declare (character c))
-  (declare (optimize (speed 3) (safety 0)))
-  (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
-
-(defun not-whitespace? (c)
-  (not (whitespace? c)))
-
-(defun string-ws? (str)
-  "Return t if string is all whitespace"
-  (when (stringp str)
-    (null (find-if #'not-whitespace? str))))
-
 
 ;;; Output
 
-(unless (boundp '+indent-vector+)
-  (defconstant +indent-vector+ 
-      (make-array 15 :fill-pointer nil :adjustable nil
-		  :initial-contents
-		  '("" 
-		    "  "
-		    "    "
-		    "      "
-		    "        "
-		    "          "
-		    "            "
-		    "              "
-		    "                "
-		    "                  "
-		    "                    "
-		    "                      "
-		    "                        "
-		    "                          "
-		    "                            "))))
-
-(defmacro indent-spaces (n &optional stream)
+(defun indent-spaces (n &optional (stream *standard-output*))
   "Indent n*2 spaces to output stream"
-  (let ((st (gensym)))
-    `(let ((,st ,stream))
-       (unless ,st
-	 (setq ,st *standard-output*))
-       (when (plusp ,n)
-	 (if (< ,n 10)
-	     (princ (aref +indent-vector+ ,n) ,st)
-	   (dotimes (i ,n)
-	     (declare (fixnum i))
-	     (format ,st "  ")))))))
-  
+  (let ((fmt (format nil "~~~DT" (+ n n))))
+    (format stream fmt)))
+
 (defun print-list (l &optional (output *standard-output*))
 "Print a list to a stream"
   (if (consp l)
@@ -627,98 +469,6 @@
     (nreverse lines)))
 
 
-;; Generalized equal system
-  
-(defun generalized-equal (obj1 obj2)
-  (if (not (equal (type-of obj1) (type-of obj2)))
-      (progn
-	(terpri)
-	(describe obj1)
-	(describe obj2)
-	nil)
-    (typecase obj1
-      (double-float
-       (let ((diff (abs (/ (- obj1 obj2) obj1))))
-	 (if (> diff (* 10 double-float-epsilon))
-	     nil
-	   t)))
-      (complex
-       (and (generalized-equal (realpart obj1) (realpart obj2))
-	    (generalized-equal (imagpart obj1) (imagpart obj2))))
-      (structure
-       (generalized-equal-fielded-object obj1 obj2))
-      (standard-object
-       (generalized-equal-fielded-object obj1 obj2))
-      (hash-table
-       (generalized-equal-hash-table obj1 obj2)
-       )
-      (function
-       (generalized-equal-function obj1 obj2))
-      (string
-       (string= obj1 obj2))
-      (array
-       (generalized-equal-array obj1 obj2))
-      (t
-       (equal obj1 obj2)))))
-
-
-(defun generalized-equal-function (obj1 obj2)
-  (string= (function-to-string obj1) (function-to-string obj2)))
-
-(defun generalized-equal-array (obj1 obj2)
-  (block test
-    (when (not (= (array-total-size obj1) (array-total-size obj2)))
-      (return-from test nil))
-    (dotimes (i (array-total-size obj1))
-      (unless (generalized-equal (aref obj1 i) (aref obj2 i))
-	(return-from test nil)))
-    (return-from test t)))
-
-(defun generalized-equal-hash-table (obj1 obj2)
-  (block test
-    (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
-      (return-from test nil))
-    (maphash
-     #'(lambda (k v)
-	 (multiple-value-bind (value found) (gethash k obj2)
-	   (unless (and found (generalized-equal v value))
-	     (return-from test nil))))
-     obj1)
-    (return-from test t)))
-
-(defun generalized-equal-fielded-object (obj1 obj2)
-  (block test
-    (when (not (equal (class-of obj1) (class-of obj2)))
-      (return-from test nil))
-    (dolist (field (class-slot-names (class-name (class-of obj1))))
-      (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
-	(return-from test nil)))
-    (return-from test t)))
-
-#+(or allegro lispworks)
-(defun class-slot-names (class-name)
-  "Given a CLASS-NAME, returns a list of the slots in the class."
-  (mapcar #'clos:slot-definition-name
-	  (clos:class-slots (find-class class-name))))
-
-#-(or allegro lispworks)
-(defun class-slot-names (class-name)
-  (warn "class-slot-names not supported on this platform"))
-
-
-(defun function-to-string (obj)
-  "Returns the lambda code for a function. Relies on
-Allegro implementation-dependent features."
-  (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
-    (declare (ignore closurep))
-    (if lambda
-	  (format nil "#'~s" lambda)
-      (if name
-	  (format nil "#'~s" name)
-	(progn
-	  (print obj)
-	  (break))))))
-
 
 ;;; Formatting functions
 
diff --git a/kmrcl.asd b/kmrcl.asd
index 5216a5e..f7d44a3 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: kmrcl.asd,v 1.4 2002/10/11 23:51:33 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.5 2002/10/12 06:10:17 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -25,6 +25,8 @@
     :components 
     ((:file "package")
      (:file "genutils" :depends-on ("package"))
+     (:file "strings" :depends-on ("package"))
+     #+(or allegro lispworks) (:file "equal" :depends-on ("package"))
      (:file "buff-input" :depends-on ("genutils"))
      (:file "telnet-server" :depends-on ("genutils"))
      (:file "pipes" :depends-on ("package"))
diff --git a/strings.lisp b/strings.lisp
new file mode 100644
index 0000000..ba34182
--- /dev/null
+++ b/strings.lisp
@@ -0,0 +1,150 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strings.lisp
+;;;; Purpose:       Strings utility functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: strings.lisp,v 1.1 2002/10/12 06:10:17 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package :kmrcl)
+(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+;;; Strings
+
+(defmacro string-append (outputstr &rest args)
+  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defmacro string-field-append (outputstr &rest args)
+  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defun list-to-string (lst)
+  "Converts a list to a string, doesn't include any delimiters between elements"
+  (format nil "~{~A~}" lst))
+
+(defun count-string-words (str)
+  (declare (simple-string str)
+	   (optimize (speed 3) (safety 0)))
+  (let ((n-words 0)
+	(in-word nil))
+    (declare (fixnum n-words))
+    (dotimes (i (length str))
+      (let ((ch (char str i)))
+	(declare (character ch))
+	(if (alphanumericp ch)
+	    (unless in-word
+	      (incf n-words)
+	      (setq in-word t))
+	  (setq in-word nil))))
+    n-words))
+
+#+excl
+(defun delimited-string-to-list (string &optional (separator #\space))
+  (excl:delimited-string-to-list string separator))
+
+#-excl
+(defun delimited-string-to-list (sequence &optional (separator #\space))
+"Split a string by a delimitor"
+  (loop
+      with start = 0
+      for end = (position separator sequence :start start)
+      collect (subseq sequence start end)
+      until (null end)
+      do
+    (setf start (1+ end))))
+
+#+excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+  (excl:list-to-delimited-string list separator))
+
+#-excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+  (let ((output (when list (format nil "~A" (car list)))))
+    (dolist (obj (rest list))
+      (setq output (concatenate 'string output
+				(format nil "~A" separator)
+				(format nil "~A" obj))))
+    output))
+
+(defun string-invert (str)
+  "Invert case of a string"
+  (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
+           (simple-string str))
+  (let ((up nil) (down nil))
+    (block skip
+      (loop for char of-type character across str do
+	    (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
+		  ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
+      (if up (string-downcase str) (string-upcase str)))))
+
+(defun add-sql-quotes (s)
+  (substitute-string-for-char s #\' "''"))
+
+(defun escape-backslashes (s)
+  (substitute-string-for-char s #\\ "\\\\"))
+
+(defun substitute-string-for-char (procstr match-char subst-str) 
+"Substitutes a string for a single matching character of a string"
+  (let ((pos (position match-char procstr)))
+    (if pos
+	(concatenate 'string
+	  (subseq procstr 0 pos) subst-str
+	  (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
+      procstr)))
+
+(defun string-substitute (string substring replacement-string)
+  "String substitute by Larry Hunter. Obtained from Google"
+  (let ((substring-length (length substring))
+	(last-end 0)
+	(new-string ""))
+    (do ((next-start
+	  (search substring string)
+	  (search substring string :start2 last-end)))
+	((null next-start)
+	 (concatenate 'string new-string (subseq string last-end)))
+      (setq new-string
+	(concatenate 'string
+	  new-string
+	  (subseq string last-end next-start)
+	  replacement-string))
+      (setq last-end (+ next-start substring-length)))))
+
+
+(defun string-trim-last-character (s)
+"Return the string less the last character"
+  (subseq s 0 (1- (length s))))
+
+(defun string-hash (str &optional (bitmask 65535))
+  (let ((hash 0))
+    (declare (fixnum hash)
+	     (simple-string str))
+    (dotimes (i (length str))
+      (declare (fixnum i))
+      (setq hash (+ hash (char-code (char str i)))))
+    (logand hash bitmask)))
+
+(defun string-not-null? (str)
+  (and str (not (zerop (length str)))))
+  
+(defun whitespace? (c) 
+  (declare (character c))
+  (declare (optimize (speed 3) (safety 0)))
+  (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
+
+(defun not-whitespace? (c)
+  (not (whitespace? c)))
+
+(defun string-ws? (str)
+  "Return t if string is all whitespace"
+  (when (stringp str)
+    (null (find-if #'not-whitespace? str))))
+
-- 
2.34.1