From 7c7e6a18fd67e5370fd78690da2642cbe79e4113 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 20 Jun 2003 08:35:22 +0000
Subject: [PATCH] r5167: *** empty log message ***

---
 ifstar.lisp  | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 io.lisp      |  7 +++++-
 kmrcl.asd    |  3 ++-
 lists.lisp   | 16 +++++++++++++-
 package.lisp |  6 +++++-
 strings.lisp | 52 ++++++++++++++++++++++++++++++++++++++++----
 6 files changed, 137 insertions(+), 8 deletions(-)
 create mode 100644 ifstar.lisp

diff --git a/ifstar.lisp b/ifstar.lisp
new file mode 100644
index 0000000..b0c85cd
--- /dev/null
+++ b/ifstar.lisp
@@ -0,0 +1,61 @@
+;; the if* macro used in Allegro:
+;;
+;; This is in the public domain... please feel free to put this definition
+;; in your code or distribute it with your version of lisp.
+
+(in-package #:kmrcl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
+
+(defmacro if* (&rest args)
+   (do ((xx (reverse args) (cdr xx))
+	(state :init)
+	(elseseen nil)
+	(totalcol nil)
+	(lookat nil nil)
+	(col nil))
+       ((null xx)
+	(cond ((eq state :compl)
+	       `(cond ,@totalcol))
+	      (t (error "if*: illegal form ~s" args))))
+       (cond ((and (symbolp (car xx))
+		   (member (symbol-name (car xx))
+			   if*-keyword-list
+			   :test #'string-equal))
+	      (setq lookat (symbol-name (car xx)))))
+
+       (cond ((eq state :init)
+	      (cond (lookat (cond ((string-equal lookat "thenret")
+				   (setq col nil
+					 state :then))
+				  (t (error
+				      "if*: bad keyword ~a" lookat))))
+		    (t (setq state :col
+			     col nil)
+		       (push (car xx) col))))
+	     ((eq state :col)
+	      (cond (lookat
+		     (cond ((string-equal lookat "else")
+			    (cond (elseseen
+				   (error
+				    "if*: multiples elses")))
+			    (setq elseseen t)
+			    (setq state :init)
+			    (push `(t ,@col) totalcol))
+			   ((string-equal lookat "then")
+			    (setq state :then))
+			   (t (error "if*: bad keyword ~s"
+					      lookat))))
+		    (t (push (car xx) col))))
+	     ((eq state :then)
+	      (cond (lookat
+		     (error
+		      "if*: keyword ~s at the wrong place " (car xx)))
+		    (t (setq state :compl)
+		       (push `(,(car xx) ,@col) totalcol))))
+	     ((eq state :compl)
+	      (cond ((not (string-equal lookat "elseif"))
+		     (error "if*: missing elseif clause ")))
+	      (setq state :init)))))
+
diff --git a/io.lisp b/io.lisp
index d652176..b677824 100644
--- a/io.lisp
+++ b/io.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: io.lisp,v 1.8 2003/06/17 17:50:45 kevin Exp $
+;;;; $Id: io.lisp,v 1.9 2003/06/20 08:35:21 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -163,3 +163,8 @@
              (setf pos 0))))
     (buf-flush buf out)))
 
+(defun write-fixnum (n s)
+  #+allegro (excl::print-fixnum s 10 n)
+  (write-string (write-to-string n) s))
+
+
diff --git a/kmrcl.asd b/kmrcl.asd
index 40ab811..4351f11 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: kmrcl.asd,v 1.34 2003/06/18 17:12:29 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.35 2003/06/20 08:35:21 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -32,6 +32,7 @@
 
     :components 
     ((:file "package")
+     (:file "ifstar" :depends-on ("package"))
      (:file "macros" :depends-on ("package"))
      (:file "functions" :depends-on ("macros"))
      (:file "lists" :depends-on ("macros"))
diff --git a/lists.lisp b/lists.lisp
index ed2148e..8bc548d 100644
--- a/lists.lisp
+++ b/lists.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: lists.lisp,v 1.6 2003/06/18 17:12:29 kevin Exp $
+;;;; $Id: lists.lisp,v 1.7 2003/06/20 08:35:22 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -166,7 +166,21 @@
       ((null pl) alist)
     (setq alist (acons (car pl) (cadr pl) alist))))
 
+(defmacro update-plist (pkey value plist &key (test '#'eql))
+  "Macro to support below (setf get-alist)"
+  (let ((pos (gensym)))
+    `(let ((,pos (member ,pkey ,plist :test ,test)))
+       (if ,pos
+	   (progn
+	     (setf (cadr ,pos) ,value)
+	     ,plist)
+	 (setf ,plist (append ,plist (list ,pkey ,value)))))))
+
 (defun get-plist (key plist &key (test 'eql) (missing nil))
   (let-if (pos (member key plist :test test))
 	  (cadr pos)
 	  missing))
+
+(defun (setf get-plist) (value key plist &key (test #'eql))
+  (update-plist key value plist :test test)
+  value)
diff --git a/package.lisp b/package.lisp
index 50fafd7..bd4d11d 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.43 2003/06/18 17:12:29 kevin Exp $
+;;;; $Id: package.lisp,v 1.44 2003/06/20 08:35:22 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -53,10 +53,12 @@
    #:count-string-char-if
    #:hexchar
    #:escape-uri-field
+   #:unescape-uri-field
    #:non-alphanumericp
    #:random-string
    #:first-char
    #:last-char
+   #:ensure-string
    
    #:flatten
 
@@ -67,6 +69,7 @@
    #:print-n-strings
    #:print-list
    #:print-rows
+   #:write-fixnum
    #:file-subst
    #:stream-subst
 
@@ -84,6 +87,7 @@
    #:update-alist
    #:alist-plist
    #:plist-alist
+   #:update-plist
    #:get-plist
 
    ;; seq.lisp
diff --git a/strings.lisp b/strings.lisp
index 48a2910..66c587b 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: strings.lisp,v 1.44 2003/06/17 13:56:38 kevin Exp $
+;;;; $Id: strings.lisp,v 1.45 2003/06/20 08:35:22 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -403,6 +403,18 @@ for characters in a string"
   (declare (type (integer 0 15) n))
   (schar +hex-chars+ n))
 
+(defconstant +char-code-0+ (char-code #\0))
+(defconstant +char-code-upper-a+ (char-code #\A))
+(declaim (type fixnum +char-code-0+ +char-code-upper-a+))
+
+(defun charhex (ch)
+  "convert hex character to decimal"
+  (let ((code (char-code (char-upcase ch))))
+    (declare (fixnum ch)) 
+    (if (>= code +char-code-upper-a+)
+	(+ 10 (- code +char-code-upper-a+))
+	(- code +char-code-0+))))
+
 (defun escape-uri-field (query)
   "Escape non-alphanumeric characters for URI fields"
   (declare (simple-string query)
@@ -426,15 +438,40 @@ for characters in a string"
 	    (setf (schar str dpos) (hexchar (logand c 15))))
 	(setf (schar str dpos) ch)))))
 
+(defun unescape-uri-field (query)
+  "Unescape non-alphanumeric characters for URI fields"
+  (declare (simple-string query)
+	   (optimize (speed 3) (safety 0) (space 0)))
+  (do* ((count (count-string-char query #\%))
+	(len (length query))
+	(new-len (- len (* 2 count)))
+	(str (make-string new-len))
+	(spos 0 (1+ spos))
+	(dpos 0 (1+ dpos)))
+      ((= spos len) str)
+    (declare (fixnum count len new-len spos dpos)
+	     (simple-string str))
+    (let ((ch (schar query spos)))
+      (if (char= #\% ch)
+	  (let ((c1 (charhex (schar query (1+ spos))))
+		(c2 (charhex (schar query (+ spos 2)))))
+	    (declare (fixnum c1 c2))
+	    (setf (schar str dpos)
+		  (code-char (logior c2 (ash c1 4))))
+	    (incf spos 2))
+	(setf (schar str dpos) ch)))))
+
+
 (defconstant +char-code-a+ (char-code #\a))
 
 (defun random-string (&optional (len 10))
   "Returns a random lower-case string."
   (declare (optimize (speed 3)))
   (let ((s (make-string len)))
-    (declare (simple-string s)
-    (dotimes  (i len s)
-      (setf (schar s i) (code-char (+ +code-char-a+ (random 26))))))))
+    (declare (simple-string s))
+    (dotimes (i len s)
+      (setf (schar s i)
+	    (code-char (+ +char-code-a+ (random 26)))))))
 
 
 (defun first-char (s)
@@ -448,3 +485,10 @@ for characters in a string"
     (let ((len (length s)))
       (when (plusp len))
       (schar s (1- len)))))
+
+(defun ensure-string (v)
+  (typecase v
+    (string v)
+    (character (string v))
+    (symbol (symbol-name v))
+    (otherwise (write-to-string v))))
-- 
2.34.1