X-Git-Url: http://git.kpe.io/?p=puri.git;a=blobdiff_plain;f=src.lisp;h=ff4cd44b7c8dd9153f9d9d6a0909cd51cfd7c7f7;hp=22e34f1bee2dbd68c6c333a0f703a679db97f53a;hb=bfb444f6454719a1f312b17a45eeb7e38f94767a;hpb=a3cc7bca5ac50360113b3a51aa45926a28f4d4d3 diff --git a/src.lisp b/src.lisp index 22e34f1..ff4cd44 100644 --- a/src.lisp +++ b/src.lisp @@ -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.2 2003/07/18 20:51:37 kevin Exp $ +;; $Id: src.lisp,v 1.10 2003/07/20 21:03:54 kevin Exp $ (defpackage #:puri (:use #:cl) @@ -55,37 +55,76 @@ #:uri= #:intern-uri #:unintern-uri - #:do-all-uris)) + #:do-all-uris + + #:uri-parse-error ;; Added by KMR + )) (in-package #:puri) -(eval-when (compile) (declaim (optimize (speed 3)))) +(eval-when (:compile-toplevel) (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) - () - ) +(defun parse-body (forms &optional env) + "Parses a body, returns (VALUES docstring declarations forms)" + (declare (ignore env)) + ;; fixme -- need to add parsing of multiple declarations + (let (docstring declarations) + (when (stringp (car forms)) + (setq docstring (car forms)) + (setq forms (cdr forms))) + (when (and (listp (car forms)) + (symbolp (caar forms)) + (string-equal (symbol-name '#:declare) + (symbol-name (caar forms)))) + (setq declarations (car forms)) + (setq forms (cdr forms))) + (values docstring declarations forms))) + +(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) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) + + +;; KMR: Added new condition to handle cross-implementation variances +;; in the parse-error condition many implementations define + +(define-condition uri-parse-error (parse-error) + ((fmt-control :initarg :fmt-control :accessor fmt-control) + (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments )) + (:report (lambda (c stream) + (format stream "Parse error:") + (apply #'format stream (fmt-control c) (fmt-arguments c))))) (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 'uri-parse-error :fmt-control fmt :fmt-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-toplevel :load-toplevel :execute) + (import '(excl:*current-case-mode* + excl:delimited-string-to-list + excl::parse-body + 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 +133,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 +155,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 +209,7 @@ ((eq state :compl) (cond ((not (string-equal lookat "elseif")) (error "if*: missing elseif clause "))) - (setq state :init))))) + (setq state :init)))))) (defclass uri () @@ -207,7 +247,7 @@ ((nid :initarg :nid :initform nil :accessor urn-nid) (nss :initarg :nss :initform nil :accessor urn-nss))) -(eval-when (compile eval) +(eval-when (:compile-toplevel :execute) (defmacro clear-caching-on-slot-change (name) `(defmethod (setf ,name) :around (new-value (self uri)) (declare (ignore new-value)) @@ -358,7 +398,7 @@ (defparameter *reserved-fragment-characters* (reserved-char-vector (remove #\# *excluded-characters*))) -(eval-when (compile eval) +(eval-when (:compile-toplevel :execute) (defun gen-char-range-list (start end) (do* ((res '()) (endcode (1+ (char-int end))) @@ -753,13 +793,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 @@ -808,13 +842,9 @@ URI ~s contains illegal character ~s at position ~d." host *reserved-authority-characters* escape)) (when port ":") (when port -;;;; too slow until ACL 6.0: -;;; (format nil "~d" port) -;;; (princ-to-string port) - #-allegro (princ-to-string port) - #+allegro - (with-output-to-string (s) - (excl::maybe-print-fast s port)) + #-allegro (format nil "~D" port) + #+allegro (with-output-to-string (s) + (excl::maybe-print-fast s port)) ) (when path (encode-escaped-encoding path @@ -879,13 +909,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) @@ -1181,6 +1205,7 @@ URI ~s contains illegal character ~s at position ~d." ;; bootstrapping (uri= changed from function to method): (when (fboundp 'uri=) (fmakunbound 'uri=)) +(defgeneric uri= (uri1 uri2)) (defmethod uri= ((uri1 uri) (uri2 uri)) (when (not (eq (uri-scheme uri1) (uri-scheme uri2))) (return-from uri= nil)) @@ -1257,8 +1282,7 @@ Executes the forms once for each uri with var bound to the current uri" (let ((f (gensym)) (g-ignore (gensym)) (g-uri-space (gensym)) - (body #+allegro (third (excl::parse-body forms env)) - #-allegro forms)) + (body (third (parse-body forms env)))) `(let ((,g-uri-space (or ,uri-space *uris*))) (prog nil (flet ((,f (,var &optional ,g-ignore) @@ -1280,6 +1304,7 @@ 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 @@ -1297,7 +1322,17 @@ excl:: ;; timings ;; (don't run under emacs with M-x fi:common-lisp) -#+ignore +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'excl::gc)) + +#-allegro +(defun gc (&rest options) + (declare (ignore options)) + #+sbcl (sb-ext::gc) + #+cmu (ext::gc) + ) + (defun time-uri-module () (declare (optimize (speed 3) (safety 0) (debug 0))) (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo")