From: Kevin M. Rosenberg Date: Fri, 6 Jun 2003 21:59:30 +0000 (+0000) Subject: r5062: return from san diego X-Git-Tag: v1.96~195 X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=4a5b626f01db51b02f969adb33ddad6aa9ee303a r5062: return from san diego --- diff --git a/io.lisp b/io.lisp index 2dcf795..69bcb64 100644 --- a/io.lisp +++ b/io.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: io.lisp,v 1.6 2003/05/09 09:35:04 kevin Exp $ +;;;; $Id: io.lisp,v 1.7 2003/06/06 21:59:29 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) (defun print-file-contents (file &optional (strm *standard-output*)) "Opens a reads a file. Returns the contents as a single string" @@ -55,11 +55,13 @@ :if-exists :supersede) (stream-subst old new in out)))) -(defmacro print-n-chars (char n stream) - (let ((i (gensym))) - `(dotimes (,i ,n) - (declare (fixnum ,i)) - (write-char ,char ,stream)))) +(defun print-n-chars (char n stream) + (declare (fixnum n) + (optimize (speed 3) (safety 0) (space 0))) + (do ((i 0 (1+ i))) + ((= i n) char) + (declare (fixnum i)) + (write-char char stream))) (defun indent-spaces (n &optional (stream *standard-output*)) "Indent n*2 spaces to output stream" diff --git a/kmrcl-tests.asd b/kmrcl-tests.asd index 0f486ba..2999c26 100644 --- a/kmrcl-tests.asd +++ b/kmrcl-tests.asd @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: kmrcl-tests.asd,v 1.2 2003/05/08 19:19:08 kevin Exp $ +;;;; $Id: kmrcl-tests.asd,v 1.3 2003/06/06 21:59:29 kevin Exp $ ;;;; ************************************************************************* (defpackage #:kmrcl-tests-system @@ -19,7 +19,7 @@ :components ((:file "tests"))) -(defmethod perform ((o test-op) (c (eql (find-system :kmrcl-tests)))) +(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl-tests)))) (or (funcall (intern (symbol-name '#:do-tests) (find-package '#:regression-test))) (error "test-op failed"))) diff --git a/kmrcl.asd b/kmrcl.asd index 947b33a..b866b39 100644 --- a/kmrcl.asd +++ b/kmrcl.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: kmrcl.asd,v 1.29 2003/04/29 04:56:58 kevin Exp $ +;;;; $Id: kmrcl.asd,v 1.30 2003/06/06 21:59:29 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,6 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* +(in-package #:cl-user) (defpackage #:kmrcl-system (:use #:asdf #:cl)) (in-package #:kmrcl-system) @@ -53,6 +54,6 @@ #+(or allegro lispworks sbcl cmu scl) (defmethod perform ((o test-op) (c (eql (find-system :kmrcl)))) - (oos 'load-op 'kmrcl-tests) - (oos 'test-op 'kmrcl-tests)) + (operate 'load-op 'kmrcl-tests) + (operate 'test-op 'kmrcl-tests)) diff --git a/lists.lisp b/lists.lisp index 6b0edb2..a1fd55c 100644 --- a/lists.lisp +++ b/lists.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: lists.lisp,v 1.4 2003/05/11 21:51:43 kevin Exp $ +;;;; $Id: lists.lisp,v 1.5 2003/06/06 21:59:29 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,8 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) - +(in-package #:kmrcl) (defun mklist (obj) "Make into list if atom" @@ -28,7 +27,7 @@ (let ((acc nil)) (dolist (x lst (nreverse acc)) (let ((val (funcall fn x))) - (if val (push val acc)))))) + (when val (push val acc)))))) (defun appendnew (l1 l2) "Append two lists, filtering out elem from second list that are already in first list" @@ -127,4 +126,3 @@ (let ((results (car list))) (dolist (elem (cdr list) results) (setq results (append results elem))))) - diff --git a/macros.lisp b/macros.lisp index 74ea24b..03e3a9f 100644 --- a/macros.lisp +++ b/macros.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: macros.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $ +;;;; $Id: macros.lisp,v 1.2 2003/06/06 21:59:29 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) (defmacro let-when ((var test-form) &body body) `(let ((,var ,test-form)) @@ -60,7 +60,6 @@ `(labels ((self ,parms ,@body)) #'self)) - (defmacro aif2 (test &optional then else) (let ((win (gensym))) `(multiple-value-bind (it ,win) ,test diff --git a/math.lisp b/math.lisp index 6e585ba..682cd74 100644 --- a/math.lisp +++ b/math.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Nov 2002 ;;;; -;;;; $Id: math.lisp,v 1.3 2003/04/28 23:51:59 kevin Exp $ +;;;; $Id: math.lisp,v 1.4 2003/06/06 21:59:29 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -17,7 +17,7 @@ ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) (defun deriv (f dx) #'(lambda (x) diff --git a/package.lisp b/package.lisp index 3eb7b1d..c6f2ad9 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.33 2003/05/26 21:43:05 kevin Exp $ +;;;; $Id: package.lisp,v 1.34 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,13 +16,11 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - -(in-package :cl-user) +(in-package #:cl-user) (defpackage #:kmrcl - (:nicknames :kl) - (:use :common-lisp) + (:nicknames #:kl) + (:use #:cl) (:export #:ensure-integer #:mklist diff --git a/random.lisp b/random.lisp index 273817a..115c404 100644 --- a/random.lisp +++ b/random.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: random.lisp,v 1.3 2002/10/10 16:23:48 kevin Exp $ +;;;; $Id: random.lisp,v 1.4 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) (defun seed-random-generator () "Evaluate a random number of items" diff --git a/run-tests.lisp b/run-tests.lisp index 09c996b..bec0dba 100644 --- a/run-tests.lisp +++ b/run-tests.lisp @@ -1,3 +1,4 @@ +(in-package #:cl-user) (defpackage #:run-tests (:use #:cl)) (in-package #:run-tests) diff --git a/strings.lisp b/strings.lisp index 9d8620e..f933fe8 100644 --- a/strings.lisp +++ b/strings.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: strings.lisp,v 1.34 2003/05/26 21:43:05 kevin Exp $ +;;;; $Id: strings.lisp,v 1.35 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -17,7 +17,7 @@ ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) ;;; Strings @@ -76,8 +76,8 @@ (setq pos (1+ end)))) -(defun list-to-delimited-string (list &optional (separator #\space)) - (format nil (format nil "~~{~~A~~^~A~~}" separator) list)) +(defun list-to-delimited-string (list &optional (separator " ")) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list)) (defun string-invert (str) "Invert case of a string" @@ -231,7 +231,8 @@ list of characters and replacement strings." vec)) (defun concat-separated-strings (separator &rest lists) - (format nil (format nil "~~{~~A~~^~A~~}" separator) (append-sublists lists))) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") + (append-sublists lists))) (defun only-null-list-elements-p (lst) (or (null lst) (every #'null lst))) diff --git a/symbols.lisp b/symbols.lisp index f2af14b..7ec505f 100644 --- a/symbols.lisp +++ b/symbols.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: symbols.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $ +;;;; $Id: symbols.lisp,v 1.2 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) (defun cl-symbols () (append (cl-variables) (cl-functions))) diff --git a/tests.lisp b/tests.lisp index bdeaa27..f9df703 100644 --- a/tests.lisp +++ b/tests.lisp @@ -7,12 +7,13 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: tests.lisp,v 1.14 2003/05/11 21:51:44 kevin Exp $ +;;;; $Id: tests.lisp,v 1.15 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* +(in-package #:cl) (defpackage #:kmrcl-tests (:use #:kmrcl #:cl #:rtest)) (in-package #:kmrcl-tests) @@ -20,7 +21,6 @@ (rem-all-tests) - (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") @@ -37,7 +37,6 @@ (deftest str.8 (escape-xml-string "abcd") "abcd") (deftest str.9 (escape-xml-string "ab&cd") "ab&cd") (deftest str.10 (escape-xml-string "ab&cd<") "ab&cd<") -(deftest str.11 (escape-xml-string "ab&c><") "ab&c><") (deftest str.12 (string-trim-last-character "") "") (deftest str.13 (string-trim-last-character "a") "") (deftest str.14 (string-trim-last-character "ab") "a") @@ -94,10 +93,21 @@ (deftest css.4 (concat-separated-strings "|" '("ab" "cd") nil) "ab|cd") (deftest css.5 (concat-separated-strings "|" '("ab" "cd") nil '("ef")) "ab|cd|ef") -(deftest f.1 (filter #'(lambda (x) (when (oddp x) x)) - '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9)) +(deftest f.1 (filter #'(lambda (x) (when (oddp x) (* x x))) + '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81)) (deftest an.1 (appendnew '(a b c d) '(c c e f)) (a b c d e f)) + +(deftest pxml.1 + (xml-tag-contents "tag1" "Test") + nil nil) + +(deftest pxml.1o + (kmrcl::xml-tag-contents-old "tag1" "Test") + nil nil) + +;;; MOP Testing + (eval-when (:compile-toplevel :load-toplevel :execute) (when (find-package '#:kmr-mop) (pushnew :kmrtest-mop cl:*features*))) diff --git a/web-utils.lisp b/web-utils.lisp index 0f41c12..1614fe4 100644 --- a/web-utils.lisp +++ b/web-utils.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: web-utils.lisp,v 1.9 2002/10/18 05:14:49 kevin Exp $ +;;;; $Id: web-utils.lisp,v 1.10 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,8 +16,7 @@ ;;;; (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))) +(in-package #:kmrcl) ;;; HTML/XML constants @@ -65,3 +64,22 @@ amp (car var) "=" (cadr var)))) (rest vars)))) "")))) + +(defun make-url-new (page-name &key (base-dir *base-url*) (format :html) + (vars nil)) + (let ((amp (ecase format + (:html "&") + ((:xml :ie-xml) "&")))) + (concatenate 'string + base-dir page-name + (if vars + (let ((first-var (first vars))) + (concatenate 'string + "?" (car first-var) "=" (cadr first-var) + (mapcar-append-string + #'(lambda (var) + (when (and (car var) (cadr var)) + (concatenate 'string + amp (car var) "=" (cadr var)))) + (rest vars)))) + "")))) diff --git a/xml-utils.lisp b/xml-utils.lisp index be7952b..acbf5b3 100644 --- a/xml-utils.lisp +++ b/xml-utils.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: xml-utils.lisp,v 1.7 2003/05/26 21:43:05 kevin Exp $ +;;;; $Id: xml-utils.lisp,v 1.8 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,8 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) -(declaim (optimize (speed 3) (safety 2) (compilation-speed 0) (debug 3))) +(in-package #:kmrcl) (defun wrap-with-xml (str entity) @@ -36,7 +35,7 @@ (remove-tree-if #'string-ws? (parse-xml str))) |# -(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil)) +(defun positions-xml-tag-contents-old (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil)) "Returns three values: the start and end positions of contents between the xml tags and the position following the close of the end tag." (let ((done nil) @@ -77,6 +76,75 @@ (setq done t)))) (values startpos endpos nextpos))) +(defun find-start-tag (tag taglen xmlstr start-pos end-xmlstr) + (let ((bracketpos (position-char #\< xmlstr start-pos end-xmlstr))) + (when bracketpos + (let* ((starttag (1+ bracketpos)) + (endtag (+ starttag taglen))) + (if (and (< endtag end-xmlstr) + (string= tag xmlstr :start2 starttag :end2 endtag)) + (let* ((char-after-tag (char xmlstr endtag))) + (declare (character char-after-tag)) + (if (or (char= #\> char-after-tag) + (char= #\space char-after-tag)) + (progn + (if (char= #\> char-after-tag) + (setq startpos (1+ endtag)) + (setq startpos (1+ (position-char #\> xmlstr (1+ endtag) end-xmlstr)))) + )))))))) + +(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) + (end-xmlstr (length xmlstr))) + "Returns three values: the start and end positions of contents between + the xml tags and the position following the close of the end tag." + (let ((done nil) + (pos start-xmlstr) + (taglen (length tag)) + (startpos nil) + (endpos nil) + (nextpos nil)) + (while (not done) + (let ((bracketpos (position-char #\< xmlstr pos end-xmlstr))) + (unless bracketpos + (return-from positions-xml-tag-contents + (values nil nil nil))) + (let* ((starttag (1+ bracketpos)) + (endtag (+ starttag taglen))) + (if (and (< endtag end-xmlstr) + (string= tag xmlstr :start2 starttag :end2 endtag)) + (let* ((char-after-tag (char xmlstr endtag))) + (declare (character char-after-tag)) + (if (or (char= #\> char-after-tag) + (char= #\space char-after-tag)) + (progn + (if (char= #\> char-after-tag) + (setq startpos (1+ endtag)) + (setq startpos (1+ (position-char #\> xmlstr (1+ endtag) end-xmlstr)))) + (setq endpos (search (format nil "" tag) xmlstr + :start2 startpos :end2 end-xmlstr)) + (if (and startpos endpos) + (progn + (setq nextpos (+ endpos taglen 3)) + (setq pos nextpos)) + (setf startpos nil + endpos nil)) + (setq done t)) + (setq pos (1+ endtag)))) + (setq pos (1+ starttag))) + (when (> pos end-xmlstr) + (setq done t)))))) + (values startpos endpos nextpos))) + + +(defun xml-tag-contents-old (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil)) + "Returns two values: the string between XML start and end tag +and position of character following end tag." + (multiple-value-bind + (startpos endpos nextpos) + (positions-xml-tag-contents-old tag xmlstr start-xmlstr end-xmlstr) + (if (and startpos endpos) + (values (subseq xmlstr startpos endpos) nextpos) + (values nil nil)))) (defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil)) "Returns two values: the string between XML start and end tag @@ -92,10 +160,10 @@ and position of character following end tag." (concatenate 'string "")) (defun write-xml-cdata (str s) - (declare (simple-string str) (optimize (speed 3) (safety 0))) - (do* ((len (length str)) - (i 0 (1+ i))) - ((= i len) str) + (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0))) + (do ((len (length str)) + (i 0 (1+ i))) + ((= i len) str) (declare (fixnum i len)) (let ((c (schar str i))) (case c