From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Tue, 29 Apr 2003 00:26:21 +0000 (+0000)
Subject: r4668: *** empty log message ***
X-Git-Tag: v1.96~261
X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=b7af043786744aaf0b67a5ee6f4d42a647dc738d

r4668: *** empty log message ***
---

diff --git a/kmrcl.asd b/kmrcl.asd
index eb47c3f..af360d8 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: kmrcl.asd,v 1.25 2003/04/28 23:51:59 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.26 2003/04/29 00:23:21 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -36,7 +36,7 @@
      (:file "seqs" :depends-on ("macros"))
      (:file "io" :depends-on ("macros"))
      (:file "console" :depends-on ("macros"))
-     (:file "strings" :depends-on ("genutils"))
+     (:file "strings" :depends-on ("macros"))
      (:file "equal" :depends-on ("macros"))
      (:file "buff-input" :depends-on ("macros"))
      (:file "telnet-server" :depends-on ("macros"))
@@ -45,7 +45,7 @@
      (:file "datetime" :depends-on ("macros"))
      (:file "math" :depends-on ("macros"))
      #+kmr-mop (:file "mop" :depends-on ("macros"))
-     #+kmr-mop (:file "attrib-class" :depends-on ("genutils" "mop"))
+     #+kmr-mop (:file "attrib-class" :depends-on ("seqs" "mop"))
      (:file "web-utils" :depends-on ("macros"))
      (:file "xml-utils" :depends-on ("macros")))
     )
diff --git a/lists.lisp b/lists.lisp
new file mode 100644
index 0000000..dee8317
--- /dev/null
+++ b/lists.lisp
@@ -0,0 +1,85 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          lists.lisp
+;;;; Purpose:       Functions for lists for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: lists.lisp,v 1.1 2003/04/29 00:26:21 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)
+
+
+(defun mklist (obj)
+  "Make into list if atom"
+  (if (listp obj) obj (list obj)))
+
+(defun filter (fn lst)
+  "Filter a list by function, eliminate elements where fn returns nil"
+  (let ((acc nil))
+    (dolist (x lst)
+      (let ((val (funcall fn x)))
+        (if val (push val acc))))
+    (nreverse acc)))
+
+(defun appendnew (l1 l2)
+  "Append two lists, filtering out elem from second list that are already in first list"
+  (dolist (elem l2)
+    (unless (find elem l1)
+      (setq l1 (append l1 (list elem)))))
+  l1)
+
+
+
+(defun remove-tree-if (pred tree)
+  "Strip from tree of atoms that satistify predicate"
+  (if (atom tree)
+      (unless (funcall pred tree)
+	tree)
+    (let ((car-strip (remove-tree-if pred (car tree)))
+	  (cdr-strip (remove-tree-if pred (cdr tree))))
+      (cond
+       ((and car-strip (atom (cadr tree)) (null cdr-strip))
+	(list car-strip))
+       ((and car-strip cdr-strip)
+	(cons car-strip cdr-strip))
+       (car-strip
+	car-strip)
+       (cdr-strip
+	cdr-strip)))))
+
+(defun find-tree (sym tree)
+  "Finds an atom as a car in tree and returns cdr tree at that positions"
+  (if (or (null tree) (atom tree))
+      nil
+    (if (eql sym (car tree))
+	(cdr tree)
+      (aif (find-tree sym (car tree))
+	  it
+	(aif (find-tree sym (cdr tree))
+	    it
+	    nil)))))
+
+;;; Keyword functions
+
+(defun remove-keyword (key arglist)
+  (loop for sublist = arglist then rest until (null sublist)
+	for (elt arg . rest) = sublist
+	unless (eq key elt) append (list elt arg)))
+
+(defun remove-keywords (key-names args)
+  (loop for ( name val ) on args by #'cddr
+	unless (member (symbol-name name) key-names 
+		       :key #'symbol-name :test 'equal)
+	append (list name val)))
+
+
diff --git a/mop.lisp b/mop.lisp
new file mode 100644
index 0000000..5e4ba96
--- /dev/null
+++ b/mop.lisp
@@ -0,0 +1,120 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          mop.lisp
+;;;; Purpose:       Imports standard MOP symbols into KMRCL
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id: mop.lisp,v 1.1 2003/04/29 00:26:21 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.
+;;;; *************************************************************************
+
+;;; This file imports MOP symbols into KMR-MOP packages and then
+;;; re-exports them to hide differences in MOP implementations.
+
+(in-package #:cl-user)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (if (find-package 'sb-mop)
+      (pushnew :kmr-sbcl-mop cl:*features*)
+      (pushnew :kmr-sbcl-pcl cl:*features*)))
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (if (find-package 'mop)
+      (pushnew :kmr-cmucl-mop cl:*features*)
+      (pushnew :kmr-cmucl-pcl cl:*features*)))
+
+(defpackage #:kmr-mop
+  (:use
+   #:cl
+   #:kmrcl
+   #+kmr-sbcl-mop #:sb-mop
+   #+kmr-cmucl-mop #:mop
+   #+allegro #:mop
+   #+lispworks #:clos
+   #+scl #:clos)
+  (:export
+   #:class-of #:class-name #:class-slots #:find-class
+   #:standard-class
+   #:slot-definition-name #:finalize-inheritance
+   #:standard-direct-slot-definition
+   #:standard-effective-slot-definition #:validate-superclass
+   #:direct-slot-definition-class #:compute-effective-slot-definition
+   #:compute-effective-slot-definition-initargs
+   #:slot-value-using-class
+   #:class-prototype #:generic-function-method-class #:intern-eql-specializer
+   #:make-method-lambda #:generic-function-lambda-list
+   #:compute-slots)   
+   )
+
+(in-package #:kmr-mop)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadowing-import
+   #+allegro
+   '(excl::compute-effective-slot-definition-initargs)
+   #+lispworks
+   '(clos::compute-effective-slot-definition-initargs)
+   #+kmr-sbcl-mop 
+   '(sb-pcl::compute-effective-slot-definition-initargs)
+   #+kmr-sbcl-pcl
+   '(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl:find-class
+     sb-pcl::standard-class
+     sb-pcl:slot-definition-name sb-pcl::finalize-inheritance
+     sb-pcl::standard-direct-slot-definition
+     sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
+     sb-pcl::direct-slot-definition-class sb-pcl::compute-effective-slot-definition
+     sb-pcl::compute-effective-slot-definition-initargs
+     sb-pcl::slot-value-using-class
+     sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer
+     sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list
+     sb-pcl::compute-slots)
+   #+kmr-cmucl-mop 
+   '(pcl::compute-effective-slot-definition-initargs)
+   #+kmr-cmucl-pcl
+   '(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
+     pcl::slot-definition-name pcl:finalize-inheritance
+     pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
+     pcl::validate-superclass pcl:direct-slot-definition-class
+     pcl:compute-effective-slot-definition
+     pcl::compute-effective-slot-definition-initargs
+     pcl::slot-value-using-class
+     pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
+     pcl:make-method-lambda pcl:generic-function-lambda-list
+     pcl::compute-slots)
+   #+scl
+   '(clos::compute-effective-slot-definition-initargs
+     clos::class-prototype
+     ;; note: make-method-lambda is not fbound
+     )
+   '#:kmr-mop))
+
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (if (find-package 'sb-mop)
+      (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*))
+      (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*))))
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (if (find-package 'mop)
+      (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
+      (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (>= (length (generic-function-lambda-list
+		     (ensure-generic-function
+		      'compute-effective-slot-definition)))
+	    3)
+    (pushnew :kmr-named-cesd cl:*features*)))
+
diff --git a/package.lisp b/package.lisp
index 7b7238b..d53fa61 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.21 2003/04/28 23:51:59 kevin Exp $
+;;;; $Id: package.lisp,v 1.22 2003/04/29 00:23:21 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -87,11 +87,10 @@
    #:string-ws?
    #:string-invert
    #:escape-xml-string
-   #:string-replace-char-string
    #:make-usb8-array
    #:usb8-array-to-string
    #:string-to-usb8-array
-   #:string-replace-chars-strings
+   #:substitute-chars-strings
    #:add-sql-quotes
    #:escape-backslashes
    
diff --git a/seqs.lisp b/seqs.lisp
new file mode 100644
index 0000000..92a4aa0
--- /dev/null
+++ b/seqs.lisp
@@ -0,0 +1,70 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          seqs.lisp
+;;;; Purpose:       Sequence functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: seqs.lisp,v 1.1 2003/04/29 00:26:21 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)
+
+
+(defun mapappend (func seq)
+  (apply #'append (mapcar func seq)))
+
+(defun mapcar-append-string-nontailrec (func v)
+  "Concatenate results of mapcar lambda calls"  
+  (aif (car v)
+       (concatenate 'string (funcall func it)
+		    (mapcar-append-string-nontailrec func (cdr v)))
+       ""))
+
+
+(defun mapcar-append-string (func v &optional (accum ""))
+  "Concatenate results of mapcar lambda calls"  
+  (aif (car v)
+       (mapcar-append-string 
+	func 
+	(cdr v) 
+	(concatenate 'string accum (funcall func it)))
+       accum))
+
+(defun mapcar2-append-string-nontailrec (func la lb)
+  "Concatenate results of mapcar lambda call's over two lists"  
+  (let ((a (car la))
+	(b (car lb)))
+    (if (and a b)
+      (concatenate 'string (funcall func a b)
+		   (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
+      "")))
+  
+(defun mapcar2-append-string (func la lb &optional (accum ""))
+  "Concatenate results of mapcar lambda call's over two lists"  
+  (let ((a (car la))
+	(b (car lb)))
+    (if (and a b)
+	(mapcar2-append-string 
+	 func 
+	 (cdr la) 
+	 (cdr lb)
+	 (concatenate 'string accum (funcall func a b)))
+      accum)))
+  
+
+
+(defun nsubseq (sequence start &optional (end (length sequence)))
+  "Return a subsequence by pointing to location in original sequence"
+  (make-array (- end start)
+	      :element-type (array-element-type sequence)
+	      :displaced-to sequence
+	      :displaced-index-offset start))
diff --git a/strings.lisp b/strings.lisp
index 45c2d7a..a348ed5 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: strings.lisp,v 1.10 2003/04/28 23:51:59 kevin Exp $
+;;;; $Id: strings.lisp,v 1.11 2003/04/29 00:23:21 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -18,7 +18,6 @@
 
 
 (in-package :kmrcl)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
 
 ;;; Strings
 
@@ -90,7 +89,7 @@
 
 (defun substitute-string-for-char (procstr match-char subst-str) 
   "Substitutes a string for a single matching character of a string"
-  (replace-chars-strings procstr (list (cons match-char subst-str))))
+  (substitute-chars-strings procstr (list (cons match-char subst-str))))
 
 (defun string-substitute (string substring replacement-string)
   "String substitute by Larry Hunter. Obtained from Google"
@@ -129,8 +128,9 @@
   
 (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)))
+  (locally (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)))
@@ -154,7 +154,7 @@
 	  (incf new-len (1- (length (cdr match)))))))
     new-len))
 
-(defun string-replace-chars-strings (str repl-alist)
+(defun substitute-chars-strings (str repl-alist)
   "Replace all instances of a chars with a string. repl-alist is an assoc
 list of characters and replacement strings."
   (declare (simple-string str))
@@ -182,41 +182,9 @@ list of characters and replacement strings."
 
 (defun escape-xml-string (string)
   "Escape invalid XML characters"
-  (string-replace-chars-strings 
+  (substitute-chars-strings 
    string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;"))))
 
-(defun string-replace-char-string (string repl-char repl-str)
-  "Replace all occurances of repl-char with repl-str"
- (declare (simple-string string))
-  (let ((count (count repl-char string)))
-    (declare (fixnum count))
-    (if (zerop count)
-	string
-	(locally (declare (optimize (speed 3) (safety 0)))
-	  (let* ((old-length (length string))
-		 (repl-length (length repl-str))
-		 (new-string (make-string (the fixnum
-					    (+ old-length
-					       (the fixnum
-						 (* count
-						    (the fixnum (1- repl-length)))))))))
-	    (declare (fixnum old-length repl-length)
-		     (simple-string new-string))
-	    (let ((newpos 0))
-	      (declare (fixnum newpos))
-	      (dotimes (oldpos (length string))
-		(declare (fixnum oldpos))
-		(if (char= repl-char (schar string oldpos))
-		    (dotimes (repl-pos repl-length)
-		      (declare (fixnum repl-pos))
-		      (setf (schar new-string newpos) (schar repl-str repl-pos))
-		      (incf newpos))
-		    (progn
-		      (setf (schar new-string newpos) (schar string oldpos))
-		      (incf newpos)))))
-	    new-string)))))
-
-    
 
 (defun make-usb8-array (len)
   (make-array len :adjustable nil
diff --git a/tests.lisp b/tests.lisp
index 467a02d..f4b3ce0 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2003
 ;;;;
-;;;; $Id: tests.lisp,v 1.2 2003/04/28 23:51:59 kevin Exp $
+;;;; $Id: tests.lisp,v 1.3 2003/04/29 00:23:21 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -25,16 +25,16 @@
 
 (deftest p1 t t)
 
-(deftest str.0 (string-replace-chars-strings "" nil) "")
-(deftest str.1 (string-replace-chars-strings "abcd" nil) "abcd")
-(deftest str.2 (string-replace-chars-strings "abcd" nil) "abcd")
-(deftest str.3 (string-replace-chars-strings "abcd" '((#\j . "ef"))) "abcd")
-(deftest str.4 (string-replace-chars-strings "abcd" '((#\a . "ef"))) "efbcd")
+(deftest str.0 (substitute-chars-strings "" nil) "")
+(deftest str.1 (substitute-chars-strings "abcd" nil) "abcd")
+(deftest str.2 (substitute-chars-strings "abcd" nil) "abcd")
+(deftest str.3 (substitute-chars-strings "abcd" '((#\j . "ef"))) "abcd")
+(deftest str.4 (substitute-chars-strings "abcd" '((#\a . "ef"))) "efbcd")
 (deftest str.5
-    (string-replace-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi")))
+    (substitute-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi")))
   "efbcd")
 (deftest str.6
-    (string-replace-chars-strings "abcd" '((#\a . "ef") (#\d . "ghi")))
+    (substitute-chars-strings "abcd" '((#\a . "ef") (#\d . "ghi")))
   "efbcghi")
 
 (deftest str.7 (escape-xml-string "") "")