+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
--- /dev/null
+;;;; -*- 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))))))
+
;;;; 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
;;;;
(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))
(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)
(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
;;;; 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
;;;;
: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"))
--- /dev/null
+;;;; -*- 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))))
+
projects / kmrcl.git / commitdiff