;;;; 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
;;;;
(: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 "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")))
)
--- /dev/null
+;;;; -*- 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)))
+
+
--- /dev/null
+;;;; -*- 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*)))
+
;;;; 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
;;;;
#: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
--- /dev/null
+;;;; -*- 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))
;;;; 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
;;;;
(in-package :kmrcl)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
;;; Strings
(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 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)))
(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))
(defun escape-xml-string (string)
"Escape invalid XML characters"
- (string-replace-chars-strings
+ (substitute-chars-strings
string '((#\& . "&") (#\> . ">") (#\< . "<"))))
-(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
;;;; 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
;;;;
(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 "") "")