r5167: *** empty log message ***

diff --git a/ifstar.lisp b/ifstar.lisp
new file mode 100644 (file)
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 d652176188e618cb52232c0bc658032026ed1bf4..b6778246c3f67f2717dd0e79e0667ecce09cf31e 100644 (file)
--- 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 40ab8118ef6b00336922c0ea1a8aef217aa22c32..4351f112507f9b7f4b866d29b636bd701036c677 100644 (file)
--- 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 ed2148ee347cba703e88b21cd44a1f400df42288..8bc548d829f924dabe8bf4b11b56618987e589ad 100644 (file)
--- 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 50fafd73f74e4867a0ec01d9558b88f7f3db7777..bd4d11d197d22bcdd97fa2ed27d5fe6c7080d4b9 100644 (file)
--- 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 48a29107a419dc110a0e71176b4d690a20672c32..66c587b6969e0ab5b24a6bec843e3ecff37ef24e 100644 (file)
--- 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))))