OSCL/PURI
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

r5333: Auto commit for Debian build

Browse Source
This commit is contained in:
Kevin M. Rosenberg
2003-07-19 13:34:12 +00:00
parent e04389443a
commit 55a5a47351
2 changed files with 51 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
debian/changelog vendored
View File

@ -1,3 +1,9 @@
cl-puri (1.2.5-1) unstable; urgency=low
* add shrink vector, AllegroCL fixes
-- Kevin M. Rosenberg <kmr@debian.org> Sat, 19 Jul 2003 07:33:57 -0600
cl-puri (1.2.4-1) unstable; urgency=low cl-puri (1.2.4-1) unstable; urgency=low
* Fix typo for non-Allegro / non-SBCL platforms * Fix typo for non-Allegro / non-SBCL platforms

83
src.lisp
View File

@ -22,7 +22,7 @@
;; Original version from ACL 6.1: ;; Original version from ACL 6.1:
;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer ;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer
;; ;;
;; $Id: src.lisp,v 1.4 2003/07/19 03:12:18 kevin Exp $ ;; $Id: src.lisp,v 1.5 2003/07/19 13:34:12 kevin Exp $
(defpackage #:puri (defpackage #:puri
(:use #:cl) (:use #:cl)
@ -62,12 +62,25 @@
(eval-when (compile) (declaim (optimize (speed 3)))) (eval-when (compile) (declaim (optimize (speed 3))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
#-(or allegro lispworks) #-(or allegro lispworks)
(define-condition parse-error (error) ()) (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 new-string 0 (incf new-i)))
(defun .parse-error (fmt &rest args) (defun .parse-error (fmt &rest args)
#+allegro (apply #'excl::.parse-error fmt args) #+allegro (apply #'excl::.parse-error fmt args)
#-allegro (error #-allegro (error
@ -82,7 +95,12 @@
"#u takes a string or list argument: ~s" args)) "#u takes a string or list argument: ~s" args))
#-allegro (defvar *current-case-mode* :case-insensitive-upper) #-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:if*)))
#-allegro
(defun position-char (char string start max) (defun position-char (char string start max)
(declare (optimize (speed 3) (safety 0) (space 0)) (declare (optimize (speed 3) (safety 0) (space 0))
(fixnum start max) (simple-string string)) (fixnum start max) (simple-string string))
@ -91,10 +109,7 @@
(declare (fixnum i)) (declare (fixnum i))
(when (char= char (schar string i)) (return i)))) (when (char= char (schar string i)) (return i))))
#+allegro #-allegro
(defun delimited-string-to-list (string &optional (separator #\space))
(excl:delimited-string-to-list string))
(defun delimited-string-to-list (string &optional (separator #\space) (defun delimited-string-to-list (string &optional (separator #\space)
skip-terminal) skip-terminal)
(declare (optimize (speed 3) (safety 0) (space 0) (declare (optimize (speed 3) (safety 0) (space 0)
@ -117,22 +132,26 @@
(push (subseq string pos end) output) (push (subseq string pos end) output)
(setq pos (1+ end)))) (setq pos (1+ end))))
(defmacro if* (&rest args) #-allegro
(do ((xx (reverse args) (cdr xx)) (eval-when (:compile-toplevel :load-toplevel :execute)
(state :init) (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
(elseseen nil)
(totalcol nil) (defmacro if* (&rest args)
(do ((xx (reverse args) (cdr xx))
(state :init)
(elseseen nil)
(totalcol nil)
(lookat nil nil) (lookat nil nil)
(col nil)) (col nil))
((null xx) ((null xx)
(cond ((eq state :compl) (cond ((eq state :compl)
`(cond ,@totalcol)) `(cond ,@totalcol))
(t (error "if*: illegal form ~s" args)))) (t (error "if*: illegal form ~s" args))))
(cond ((and (symbolp (car xx)) (cond ((and (symbolp (car xx))
(member (symbol-name (car xx)) (member (symbol-name (car xx))
if*-keyword-list if*-keyword-list
:test #'string-equal)) :test #'string-equal))
(setq lookat (symbol-name (car xx))))) (setq lookat (symbol-name (car xx)))))
(cond ((eq state :init) (cond ((eq state :init)
(cond (lookat (cond ((string-equal lookat "thenret") (cond (lookat (cond ((string-equal lookat "thenret")
@ -166,7 +185,7 @@
((eq state :compl) ((eq state :compl)
(cond ((not (string-equal lookat "elseif")) (cond ((not (string-equal lookat "elseif"))
(error "if*: missing elseif clause "))) (error "if*: missing elseif clause ")))
(setq state :init))))) (setq state :init))))))
(defclass uri () (defclass uri ()
@ -750,14 +769,7 @@ URI ~s contains illegal character ~s at position ~d."
(new-i 0 (1+ new-i)) (new-i 0 (1+ new-i))
ch ch2 chc chc2) ch ch2 chc chc2)
((= i max) ((= i max)
#+allegro (shrink-vector new-string new-i))
(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)
#+(or allegro sbcl)
new-string)
(if* (char= #\% (setq ch (schar string i))) (if* (char= #\% (setq ch (schar string i)))
then (when (> (+ i 3) max) then (when (> (+ i 3) max)
(.parse-error (.parse-error
@ -877,14 +889,7 @@ URI ~s contains illegal character ~s at position ~d."
(new-i -1) (new-i -1)
c ci) c ci)
((= i max) ((= i max)
#+allegro (shrink-vector new-string (incf new-i)))
(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))
#+(or allegro sbcl)
new-string)
(setq ci (char-int (setq c (schar string i)))) (setq ci (char-int (setq c (schar string i))))
(if* (or (null reserved-chars) (if* (or (null reserved-chars)
(> ci 127) (> ci 127)