r4668: *** empty log message ***

diff --git a/kmrcl.asd b/kmrcl.asd
index eb47c3f772ea1dd14d448e8c30199f79cfcad89c..af360d8d7eb61cab6501b525fc24e09a11652324 100644 (file)
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; 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
 ;;;;
 ;;;;
 ;;;; 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 "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"))
      (: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"))
      (: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")))
     )
      (:file "web-utils" :depends-on ("macros"))
      (:file "xml-utils" :depends-on ("macros")))
     )

diff --git a/lists.lisp b/lists.lisp
new file mode 100644 (file)
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 (file)
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 7b7238bdcf488eaf264b0ed27e3ffd6db3351f70..d53fa615590d9ac4be346c25c6d7b7368ab9de07 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; 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
 ;;;;
 ;;;;
 ;;;; 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-ws?
    #:string-invert
    #:escape-xml-string

-   #:string-replace-char-string

    #:make-usb8-array
    #:usb8-array-to-string
    #:string-to-usb8-array
    #:make-usb8-array
    #:usb8-array-to-string
    #:string-to-usb8-array

-   #:string-replace-chars-strings
+   #:substitute-chars-strings

    #:add-sql-quotes
    #:escape-backslashes
    
    #:add-sql-quotes
    #:escape-backslashes
    

diff --git a/seqs.lisp b/seqs.lisp
new file mode 100644 (file)
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 45c2d7a54ba27e5414a4b458de3990f4d6863a4e..a348ed5211af5fb91491d624f1798f3a343b71bf 100644 (file)
--- a/strings.lisp
+++ b/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; 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
 ;;;;
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -18,7 +18,6 @@
 
 
 (in-package :kmrcl)
 
 
 (in-package :kmrcl)

-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))

 
 ;;; Strings
 
 
 ;;; 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"
 
 (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"
 
 (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))
   
 (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)))
 
 (defun not-whitespace? (c)
   (not (whitespace? c)))


@@ -154,7 +154,7 @@
          (incf new-len (1- (length (cdr match)))))))
     new-len))
 
          (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))
   "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"
 
 (defun escape-xml-string (string)
   "Escape invalid XML characters"

-  (string-replace-chars-strings 
+  (substitute-chars-strings 

    string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;"))))
 
    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
 
 (defun make-usb8-array (len)
   (make-array len :adjustable nil

diff --git a/tests.lisp b/tests.lisp
index 467a02da24c42556513db07366d10db5da3b84e8..f4b3ce079f78f95517061dcd8c4f715cdc046ec9 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2003
 ;;;;
 ;;;; 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
 ;;;;
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;


@@ -25,16 +25,16 @@
 
 (deftest p1 t t)
 
 
 (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
 (deftest str.5

-    (string-replace-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi")))
+    (substitute-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi")))

   "efbcd")
 (deftest str.6
   "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 "") "")
   "efbcghi")
 
 (deftest str.7 (escape-xml-string "") "")