[armedbear-cvs] r12617 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl
Mark Evenson
mevenson at common-lisp.net
Thu Apr 15 14:54:56 UTC 2010
Author: mevenson
Date: Thu Apr 15 10:54:55 2010
New Revision: 12617
Log:
Move pathname functions to EXT; implement DEFSETF for URL pathnames.
Implemented DEFSETF functions for HOST, AUTHORITY, QUERY, and FRAGMENT
sections of URL pathname.
Moved PATHNAME-JAR-P and PATHNAME-URL-P to EXT.
EXT::%INVALIDATE-NAMESTRING resets the namestring after changing the
internal structure. Having to monkey around with the internal
structure of Pathname is just wrong: we should implement the get/set
accessor pattern in Java even though it would make the code more
verbose.
Modified:
trunk/abcl/src/org/armedbear/lisp/Pathname.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp
trunk/abcl/src/org/armedbear/lisp/pathnames.lisp
trunk/abcl/test/lisp/abcl/jar-pathname.lisp
trunk/abcl/test/lisp/abcl/url-pathname.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu Apr 15 10:54:55 2010
@@ -74,6 +74,19 @@
public void invalidateNamestring() {
namestring = null;
}
+
+ // ### %invalidate-namestring
+ private static final Primitive _INVALIDATE_NAMESTRING = new pf_invalidate_namestring();
+ private static class pf_invalidate_namestring extends Primitive {
+ pf_invalidate_namestring() {
+ super("%invalidate-namestring", PACKAGE_EXT, false);
+ }
+ @Override
+ public LispObject execute(LispObject first) {
+ ((Pathname)coerceToPathname(first)).invalidateNamestring();
+ return first;
+ }
+ }
protected Pathname() {}
@@ -1610,7 +1623,7 @@
private static final Primitive PATHNAME_JAR_P = new pf_pathname_jar_p();
private static class pf_pathname_jar_p extends Primitive {
pf_pathname_jar_p() {
- super("pathname-jar-p", PACKAGE_SYS, true, "pathname",
+ super("pathname-jar-p", PACKAGE_EXT, true, "pathname",
"Predicate for whether PATHNAME references a JAR.");
}
@Override
@@ -1628,7 +1641,7 @@
private static final Primitive PATHNAME_URL_P = new pf_pathname_url_p();
private static class pf_pathname_url_p extends Primitive {
pf_pathname_url_p() {
- super("pathname-url-p", PACKAGE_SYS, true, "pathname",
+ super("pathname-url-p", PACKAGE_EXT, true, "pathname",
"Predicate for whether PATHNAME references a URL.");
}
@Override
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Thu Apr 15 10:54:55 2010
@@ -2920,6 +2920,10 @@
PACKAGE_EXT.addExternalSymbol("SLIME-INPUT-STREAM");
public static final Symbol SLIME_OUTPUT_STREAM =
PACKAGE_EXT.addExternalSymbol("SLIME-OUTPUT-STREAM");
+ public static final Symbol JAR_PATHNAME =
+ PACKAGE_EXT.addExternalSymbol("JAR-PATHNAME");
+ public static final Symbol URL_PATHNAME =
+ PACKAGE_EXT.addExternalSymbol("URL-PATHNAME");
// MOP.
public static final Symbol CLASS_LAYOUT =
@@ -3065,10 +3069,6 @@
PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME");
public static final Symbol JAVA_STACK_FRAME =
PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME");
- public static final Symbol JAR_PATHNAME =
- PACKAGE_SYS.addExternalSymbol("JAR-PATHNAME");
- public static final Symbol URL_PATHNAME =
- PACKAGE_SYS.addExternalSymbol("URL-PATHNAME");
// CDR6
public static final Symbol _INSPECTOR_HOOK_ =
Modified: trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/asdf-abcl.lisp Thu Apr 15 10:54:55 2010
@@ -41,7 +41,7 @@
(defmethod operation-done-p :around ((o compile-op)
(c cl-source-file))
(let ((files (output-files o c)))
- (if (every #'sys:pathname-jar-p files)
+ (if (every #'ext:pathname-jar-p files)
t
(call-next-method))))
Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/pathnames.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/pathnames.lisp Thu Apr 15 10:54:55 2010
@@ -433,3 +433,70 @@
(error 'type-error
:format-control "~S cannot be converted to a pathname."
:format-arguments (list thing)))))
+
+
+;;; Functions for dealing with URL Pathnames
+
+(in-package :extensions)
+
+(defun url-pathname-scheme (p)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (getf (pathname-host p) :scheme))
+
+(defun set-url-pathname-scheme (p v)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (let ((host (pathname-host p)))
+ (setf (getf host :scheme) v))
+ (%invalidate-namestring p))
+
+(defsetf url-pathname-scheme set-url-pathname-scheme)
+
+(defun url-pathname-authority (p)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (getf (pathname-host p) :authority))
+
+(defun set-url-pathname-authority (p v)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (let ((host (pathname-host p)))
+ (setf (getf host :authority) v))
+ (%invalidate-namestring p))
+
+(defsetf url-pathname-authority set-url-pathname-authority)
+
+(defun url-pathname-query (p)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (getf (pathname-host p) :query))
+
+(defun set-url-pathname-query (p v)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (let ((host (pathname-host p)))
+ (setf (getf host :query) v))
+ (%invalidate-namestring p))
+
+(defsetf url-pathname-query set-url-pathname-query)
+
+(defun url-pathname-fragment (p)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (getf (pathname-host p) :fragment))
+
+(defun set-url-pathname-fragment (p v)
+ (unless (pathname-url-p p)
+ (error "~A is not a URL pathname." p))
+ (let ((host (pathname-host p)))
+ (setf (getf host :fragment) v))
+ (%invalidate-namestring p))
+
+(defsetf url-pathname-query set-url-pathname-fragment)
+
+(export '(url-pathname-scheme
+ url-pathname-authority
+ url-pathname-query
+ url-pathname-fragment)
+ 'ext)
Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/jar-pathname.lisp (original)
+++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Thu Apr 15 10:54:55 2010
@@ -278,7 +278,7 @@
(let* ((p #p"jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class")
(d (first (pathname-device p))))
(values
- (system:pathname-url-p d)
+ (ext:pathname-url-p d)
(namestring d)
(pathname-directory p) (pathname-name p) (pathname-type p)))
t
@@ -291,7 +291,7 @@
(d0 (first d))
(d1 (second d)))
(values
- (system:pathname-url-p d0)
+ (ext:pathname-url-p d0)
(namestring d0)
(pathname-name d1) (pathname-type d1)
(pathname-name p) (pathname-type p)))
Modified: trunk/abcl/test/lisp/abcl/url-pathname.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/url-pathname.lisp (original)
+++ trunk/abcl/test/lisp/abcl/url-pathname.lisp Thu Apr 15 10:54:55 2010
@@ -28,4 +28,17 @@
"http"
"example.org"
"query=this"
- "that-fragment")
\ No newline at end of file
+ "that-fragment")
+
+(deftest url-pathname.3
+ (let* ((p (pathname
+ "http://example.org/a/b/foo.lisp?query=this#that-fragment")))
+ (values
+ (ext:url-pathname-scheme p)
+ (ext:url-pathname-authority p)
+ (ext:url-pathname-query p)
+ (ext:url-pathname-fragment p)))
+ "http"
+ "example.org"
+ "query=this"
+ "that-fragment")
More information about the armedbear-cvs
mailing list