X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src.lisp;h=4c3b66aa9571f3303297b0dde646a6f5b50da290;hb=617fff595006d80199b235d2d15f6b5a05be97c1;hp=8d98c1909b77474fceaa707eee489d0b48b35b46;hpb=9e5b1ca169d5d26c7195643f02325655eec515e2;p=puri.git

diff --git a/src.lisp b/src.lisp
index 8d98c19..4c3b66a 100644
--- a/src.lisp
+++ b/src.lisp
@@ -1,4 +1,4 @@
-;; -*- mode: common-lisp; package: net.uri -*-
+;; -*- mode: common-lisp; package: puri -*-
 ;; Support for URIs in Allegro.
 ;; For general URI information see RFC2396.
 ;;
@@ -22,7 +22,7 @@
 ;; Original version from ACL 6.1:
 ;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer
 ;;
-;; $Id: src.lisp,v 1.1 2003/07/18 20:34:23 kevin Exp $
+;; $Id: src.lisp,v 1.6 2003/07/19 18:21:43 kevin Exp $
 
 (defpackage #:puri
   (:use #:cl)
@@ -57,35 +57,48 @@
    #:unintern-uri
    #:do-all-uris))
 
-(in-package :net.uri)
+(in-package #:puri)
 
 (eval-when (compile) (declaim (optimize (speed 3))))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
 
-#-allegro
-(define-condition parse-error (error)
-  ()
-  )
 
+#-(or allegro lispworks)
+(define-condition parse-error (error)  ())
+
+(defun shrink-vector (str size)
+  #+allegro
+  (excl::.primcall 'sys::shrink-svector str size)
+  #+sbcl
+  (sb-kernel:shrink-vector str size)
+  #+cmu
+  (lisp::shrink-vector str size)
+  #+lispworks
+  (system::shrink-vector$vector str size)
+  #+(or allegro cmu sbcl lispworks)
+  str
+  #-(or allegro cmu sbcl lispworks)
+  (subseq str 0 size))
 
+
+#-allegro
 (defun .parse-error (fmt &rest args)
-  #+allegro (apply #'excl::.parse-error fmt args)
-  #-allegro (error 
-	     (make-condition 'parse-error :format-control fmt
-			     :format-arguments args)))
+  (error (make-condition 'parse-error :format-control fmt
+			 :format-arguments args)))
 
+#-allegro
 (defun internal-reader-error (stream fmt &rest args)
-  #+allegro
-  (apply #'excl::internal-reader-error stream fmt args)
-  #-allegro
-  (apply #'format stream
-	 "#u takes a string or list argument: ~s" args))
+  (apply #'format stream fmt args))
 
 #-allegro (defvar *current-case-mode* :case-insensitive-upper)
+#+allegro (eval-when (compile load eval)
+	    (import '(excl:*current-case-mode*
+		      excl:delimited-string-to-list
+		      excl::.parse-error
+		      excl::internal-reader-error
+		      excl:if*)))
 
-;; From Larry Hunter with modifications
+#-allegro
 (defun position-char (char string start max)
   (declare (optimize (speed 3) (safety 0) (space 0))
 	   (fixnum start max) (simple-string string))
@@ -94,10 +107,7 @@
     (declare (fixnum i))
     (when (char= char (schar string i)) (return i))))
 
-#+allegro 
-(defun delimited-string-to-list (string &optional (separator #\space)) 
-  (excl:delimited-string-to-list string))
-
+#-allegro 
 (defun delimited-string-to-list (string &optional (separator #\space) 
 				 skip-terminal)
   (declare (optimize (speed 3) (safety 0) (space 0)
@@ -119,23 +129,27 @@
 	     (type (or null fixnum) end))
     (push (subseq string pos end) output)
     (setq pos (1+ end))))
-  
-(defmacro if* (&rest args)
-   (do ((xx (reverse args) (cdr xx))
-	(state :init)
-	(elseseen nil)
-	(totalcol nil)
+
+#-allegro
+(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)))))
+	 (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")
@@ -169,7 +183,7 @@
 	     ((eq state :compl)
 	      (cond ((not (string-equal lookat "elseif"))
 		     (error "if*: missing elseif clause ")))
-	      (setq state :init)))))
+	      (setq state :init))))))
 
 
 (defclass uri ()
@@ -753,13 +767,7 @@ URI ~s contains illegal character ~s at position ~d."
 	(new-i 0 (1+ new-i))
 	ch ch2 chc chc2)
       ((= i max)
-       #+allegro
-       (excl::.primcall 'sys::shrink-svector new-string new-i)
-       #+sbcl
-       (sb-kernel:shrink-vector new-string new-i)
-       #-(or allegro sbcl)
-       (subseq new-string 0 new-i)
-       new-string)
+       (shrink-vector new-string new-i))
     (if* (char= #\% (setq ch (schar string i)))
        then (when (> (+ i 3) max)
 	      (.parse-error
@@ -879,13 +887,7 @@ URI ~s contains illegal character ~s at position ~d."
 	(new-i -1)
 	c ci)
       ((= i max)
-       #+allegro
-       (excl::.primcall 'sys::shrink-svector new-string (incf new-i))
-       #+sbcl
-       (sb-kernel:shrink-vector new-string (incf new-i))
-       #-(or allegro sbcl)
-       (subseq new-string 0 (incf new-i))
-       new-string)
+       (shrink-vector new-string (incf new-i)))
     (setq ci (char-int (setq c (schar string i))))
     (if* (or (null reserved-chars)
 	     (> ci 127)
@@ -1280,14 +1282,15 @@ Executes the forms once for each uri with var bound to the current uri"
 	  stream
 	  "#u takes a string or list argument: ~s" arg)))))
 
+
 #+allegro
 excl::
 #+allegro
 (locally (declare (special std-lisp-readtable))
   (let ((*readtable* std-lisp-readtable))
-    (set-dispatch-macro-character #\# #\u #'net.uri::sharp-u)))
+    (set-dispatch-macro-character #\# #\u #'puri::sharp-u)))
 #-allegro
-(set-dispatch-macro-character #\# #\u #'net.uri::sharp-u)
+(set-dispatch-macro-character #\# #\u #'puri::sharp-u)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;